TeX Live: tlpkg/TeXLive/TLPDB.pm

"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20231127/tlpkg/TeXLive/TLPDB.pm" (16 Oct 2023, 87924 Bytes) of package /linux/misc/install-tl-unx.tar.gz:

As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

1 # $Id: TLPDB.pm 68562 2023-10-16 17:17:01Z karl $ 2 # TeXLive::TLPDB.pm - tlpdb plain text database files. 3 # Copyright 2007-2023 Norbert Preining 4 # This file is licensed under the GNU General Public License version 2 5 # or any later version. 6 7 use strict; use warnings; 8 package TeXLive::TLPDB; 9 10 my $svnrev = '$Revision: 68562 $'; 11 my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown"; 12 sub module_revision { return $_modulerevision; } 13 14 =pod 15 16 =head1 NAME 17 18 C<TeXLive::TLPDB> -- TeX Live Package Database (C<texlive.tlpdb>) module 19 20 =head1 SYNOPSIS 21 22 use TeXLive::TLPDB; 23 24 TeXLive::TLPDB->new (); 25 TeXLive::TLPDB->new (root => "/path/to/texlive/installation/root"); 26 27 $tlpdb->root("/path/to/root/of/texlive/installation"); 28 $tlpdb->copy; 29 $tlpdb->from_file($filename); 30 $tlpdb->writeout; 31 $tlpdb->writeout(FILEHANDLE); 32 $tlpdb->as_json; 33 $tlpdb->save; 34 $tlpdb->media; 35 $tlpdb->available_architectures(); 36 $tlpdb->add_tlpobj($tlpobj); 37 $tlpdb->needed_by($pkg); 38 $tlpdb->remove_tlpobj($pkg); 39 $tlpdb->get_package("packagename"); 40 $tlpdb->list_packages ( [$tag] ); 41 $tlpdb->expand_dependencies(["-only-arch",] $totlpdb, @list); 42 $tlpdb->expand_dependencies(["-no-collections",] $totlpdb, @list); 43 $tlpdb->find_file("filename"); 44 $tlpdb->collections; 45 $tlpdb->schemes; 46 $tlpdb->updmap_cfg_lines; 47 $tlpdb->fmtutil_cnf_lines; 48 $tlpdb->language_dat_lines; 49 $tlpdb->language_def_lines; 50 $tlpdb->language_lua_lines; 51 $tlpdb->package_revision("packagename"); 52 $tlpdb->location; 53 $tlpdb->platform; 54 $tlpdb->is_verified; 55 $tlpdb->verification_status; 56 $tlpdb->config_src_container; 57 $tlpdb->config_doc_container; 58 $tlpdb->config_container_format; 59 $tlpdb->config_release; 60 $tlpdb->config_minrelease; 61 $tlpdb->config_revision; 62 $tlpdb->config_frozen; 63 $tlpdb->options; 64 $tlpdb->option($key, [$value]); 65 $tlpdb->reset_options(); 66 $tlpdb->add_default_options(); 67 $tlpdb->settings; 68 $tlpdb->setting($key, [$value]); 69 $tlpdb->setting([-clear], $key, [$value]); 70 $tlpdb->sizes_of_packages($opt_src, $opt_doc, $ref_arch_list [, @packs ]); 71 $tlpdb->sizes_of_packages_with_deps($opt_src, $opt_doc, $ref_arch_list [, @packs ]); 72 $tlpdb->install_package($pkg, $dest_tlpdb); 73 $tlpdb->remove_package($pkg, %options); 74 $tlpdb->install_package_files($file [, $file ]); 75 76 TeXLive::TLPDB->listdir([$dir]); 77 $tlpdb->generate_listfiles([$destdir]); 78 79 $tlpdb->make_virtual; 80 $tlpdb->is_virtual; 81 $tlpdb->virtual_add_tlpdb($tlpdb, $tag); 82 $tlpdb->virtual_remove_tlpdb($tag); 83 $tlpdb->virtual_get_tags(); 84 $tlpdb->virtual_get_tlpdb($tag); 85 $tlpdb->virtual_get_package($pkg, $tag); 86 $tlpdb->candidates($pkg); 87 $tlpdb->virtual_candidate($pkg); 88 $tlpdb->virtual_pinning( [ $pin_file_TLConfFile ] ); 89 90 =head1 DESCRIPTION 91 92 =cut 93 94 use TeXLive::TLConfig qw($CategoriesRegexp $DefaultCategory $InfraLocation 95 $DatabaseName $DatabaseLocation $MetaCategoriesRegexp $Archive 96 $DefaultCompressorFormat %Compressors $CompressorExtRegexp 97 %TLPDBOptions %TLPDBSettings $ChecksumExtension 98 $RelocPrefix $RelocTree); 99 use TeXLive::TLCrypto; 100 use TeXLive::TLPOBJ; 101 use TeXLive::TLUtils qw(dirname mkdirhier member wndws info log debug ddebug 102 tlwarn basename download_file merge_into tldie 103 system_pipe); 104 use TeXLive::TLWinGoo; 105 106 use Cwd 'abs_path'; 107 108 my $_listdir; 109 110 =pod 111 112 =over 4 113 114 =item C<< TeXLive::TLPDB->new >> 115 116 =item C<< TeXLive::TLPDB->new( [root => "$path"] ) >> 117 118 C<< TeXLive::TLPDB->new >> creates a new C<TLPDB> object. If the 119 argument C<root> is given it will be initialized from the respective 120 location starting at $path. If C<$path> begins with C<http://>, C<https://>, 121 C<ftp://>, C<scp://>, C<ssh://> or C<I<user>@I<host>:>, the respective file 122 is downloaded. The C<$path> can also start with C<file:/> in which case it 123 is treated as a file on the filesystem in the usual way. 124 125 Returns an object of type C<TeXLive::TLPDB>, or undef if the root was 126 given but no package could be read from that location. 127 128 =cut 129 130 sub new { 131 my $class = shift; 132 my %params = @_; 133 my $self = { 134 root => $params{'root'}, 135 tlps => $params{'tlps'}, 136 verified => 0 137 }; 138 my $verify = defined($params{'verify'}) ? $params{'verify'} : 0; 139 ddebug("TLPDB new: verify=$verify\n"); 140 $_listdir = $params{'listdir'} if defined($params{'listdir'}); 141 bless $self, $class; 142 if (defined($params{'tlpdbfile'})) { 143 my $nr_packages_read = $self->from_file($params{'tlpdbfile'}, 144 'from-file' => 1, 'verify' => $verify); 145 if ($nr_packages_read == 0) { 146 # that is bad, we didn't read anything, so return undef. 147 return undef; 148 } 149 return $self; 150 } 151 if (defined($self->{'root'})) { 152 my $nr_packages_read 153 = $self->from_file("$self->{'root'}/$DatabaseLocation", 154 'verify' => $verify); 155 if ($nr_packages_read == 0) { 156 # that is bad, we didn't read anything, so return undef. 157 return undef; 158 } 159 } 160 return $self; 161 } 162 163 164 sub copy { 165 my $self = shift; 166 my $bla = {}; 167 %$bla = %$self; 168 bless $bla, "TeXLive::TLPDB"; 169 return $bla; 170 } 171 172 =pod 173 174 =item C<< $tlpdb->add_tlpobj($tlpobj) >> 175 176 The C<add_tlpobj> adds an object of the type TLPOBJ to the TLPDB. 177 178 =cut 179 180 sub add_tlpobj { 181 my ($self,$tlp) = @_; 182 if ($self->is_virtual) { 183 tlwarn("TLPDB: cannot add tlpobj to a virtual tlpdb\n"); 184 return 0; 185 } 186 $self->{'tlps'}{$tlp->name} = $tlp; 187 } 188 189 =pod 190 191 =item C<< $tlpdb->needed_by($pkg) >> 192 193 Returns an array of package names depending on $pkg. 194 195 =cut 196 197 sub needed_by { 198 my ($self,$pkg) = @_; 199 my @ret; 200 for my $p ($self->list_packages) { 201 my $tlp = $self->get_package($p); 202 DEPENDS: for my $d ($tlp->depends) { 203 # exact match 204 if ($d eq $pkg) { 205 push @ret, $p; 206 last DEPENDS; # of the for loop on all depends 207 } 208 # 209 if ($d =~ m/^(.*)\.ARCH$/) { 210 my $parent = $1; 211 for my $a ($self->available_architectures) { 212 if ($pkg eq "$parent.$a") { 213 push @ret, $p; 214 last DEPENDS; 215 } 216 } 217 } 218 } 219 } 220 return @ret; 221 } 222 223 =pod 224 225 =item C<< $tlpdb->remove_tlpobj($pkg) >> 226 227 Remove the package named C<$pkg> from the tlpdb. Gives a warning if the 228 package is not present 229 230 =cut 231 232 sub remove_tlpobj { 233 my ($self,$pkg) = @_; 234 if ($self->is_virtual) { 235 tlwarn("TLPDB: cannot remove tlpobj from a virtual tlpdb\n"); 236 return 0; 237 } 238 if (defined($self->{'tlps'}{$pkg})) { 239 delete $self->{'tlps'}{$pkg}; 240 } else { 241 tlwarn("TLPDB: package to be removed not found: $pkg\n"); 242 } 243 } 244 245 =pod 246 247 =item C<< $tlpdb->from_file($filename, @args) >> 248 249 The C<from_file> function initializes the C<TLPDB> if the root was not 250 given at generation time. See L<TLPDB::new> for more information. 251 252 It returns the actual number of packages (TLPOBJs) read from 253 C<$filename>, and zero if there are problems (and gives warnings). 254 255 =cut 256 257 sub from_file { 258 my ($self, $path, @args) = @_; 259 my %params = @args; 260 if ($self->is_virtual) { 261 tlwarn("TLPDB: cannot initialize a virtual tlpdb from_file\n"); 262 return 0; 263 } 264 if (@_ < 2) { 265 die "$0: from_file needs filename for initialization"; 266 } 267 my $root_from_path = dirname(dirname($path)); 268 if (defined($self->{'root'})) { 269 if ($self->{'root'} ne $root_from_path) { 270 if (!$params{'from-file'}) { 271 tlwarn("TLPDB: initialization from different location than original;\n"); 272 tlwarn("TLPDB: hope you are sure!\n"); 273 tlwarn("TLPDB: root=$self->{'root'}, root_from_path=$root_from_path\n"); 274 } 275 } 276 } else { 277 $self->root($root_from_path); 278 } 279 $self->verification_status($VS_UNKNOWN); 280 my $retfh; 281 my $tlpdbfile; 282 my $is_verified = 0; 283 # do media detection 284 my $rootpath = $self->root; 285 my $media; 286 if ($rootpath =~ m,https?://|ftp://,) { 287 $media = 'NET'; 288 } elsif ($rootpath =~ m,$TeXLive::TLUtils::SshURIRegex,) { 289 $media = 'NET'; 290 } else { 291 if ($rootpath =~ m,file://*(.*)$,) { 292 $rootpath = "/$1"; 293 } 294 if ($params{'media'}) { 295 $media = $params{'media'}; 296 } elsif (! -d $rootpath) { 297 # no point in going on if we don't even have a directory. 298 tlwarn("TLPDB: not a directory, not loading: $rootpath\n"); 299 return 0; 300 } elsif (-d "$rootpath/texmf-dist/web2c") { 301 $media = 'local_uncompressed'; 302 } elsif (-d "$rootpath/texmf/web2c") { # older 303 $media = 'local_uncompressed'; 304 } elsif (-d "$rootpath/web2c") { 305 $media = 'local_uncompressed'; 306 } elsif (-d "$rootpath/$Archive") { 307 $media = 'local_compressed'; 308 } else { 309 # we cannot find the right type, return zero, hope people notice 310 tlwarn("TLPDB: Cannot determine type of tlpdb from $rootpath!\n"); 311 return 0; 312 } 313 } 314 $self->{'media'} = $media; 315 # 316 # actually load the TLPDB 317 if ($path =~ m;^((https?|ftp)://|file:\/\/*); || $path =~ m;$TeXLive::TLUtils::SshURIRegex;) { 318 debug("TLPDB.pm: trying to initialize from $path\n"); 319 # now $xzfh filehandle is open, the file created 320 # TLUtils::download_file will just overwrite what is there 321 # on windows that doesn't work, so we close the fh immediately 322 # this creates a short loophole, but much better than before anyway 323 my $tlpdbfh; 324 ($tlpdbfh, $tlpdbfile) = TeXLive::TLUtils::tl_tmpfile(); 325 # same as above 326 close($tlpdbfh); 327 # if we have xz available we try the xz file 328 my $xz_succeeded = 0 ; 329 my $compressorextension = "<UNSET>"; 330 if (defined($::progs{$DefaultCompressorFormat})) { 331 # we first try the xz compressed file 332 my ($xzfh, $xzfile) = TeXLive::TLUtils::tl_tmpfile(); 333 close($xzfh); 334 my $decompressor = $::progs{$DefaultCompressorFormat}; 335 $compressorextension = $Compressors{$DefaultCompressorFormat}{'extension'}; 336 my @decompressorArgs = @{$Compressors{$DefaultCompressorFormat}{'decompress_args'}}; 337 debug("trying to download $path.$compressorextension to $xzfile\n"); 338 my $ret = TeXLive::TLUtils::download_file("$path.$compressorextension", "$xzfile"); 339 # better to check both, the return value AND the existence of the file 340 if ($ret && (-r "$xzfile")) { 341 # ok, let the fun begin 342 debug("decompressing $xzfile to $tlpdbfile\n"); 343 # xz *hopefully* returns 0 on success and anything else on failure 344 # we don't have to negate since not zero means error in the shell 345 # and thus in perl true 346 if (!system_pipe($decompressor, $xzfile, $tlpdbfile, 1, @decompressorArgs)) { 347 debug("$decompressor $xzfile failed, trying plain file\n"); 348 unlink($xzfile); # the above command only removes in case of success 349 } else { 350 $xz_succeeded = 1; 351 debug("found the uncompressed $DefaultCompressorFormat file\n"); 352 } 353 } 354 } else { 355 debug("no $DefaultCompressorFormat defined ...\n"); 356 } 357 if (!$xz_succeeded) { 358 debug("TLPDB: downloading $path.$compressorextension didn't succeed, try $path\n"); 359 my $ret = TeXLive::TLUtils::download_file($path, $tlpdbfile); 360 # better to check both, the return value AND the existence of the file 361 if ($ret && (-r $tlpdbfile)) { 362 # do nothing 363 } else { 364 unlink($tlpdbfile); 365 tldie( "$0: TLPDB::from_file could not initialize from: $path\n" 366 . "$0: Maybe the repository setting should be changed.\n" 367 . "$0: More info: https://tug.org/texlive/acquire.html\n"); 368 } 369 } 370 # if we are still here, then either the xz version was downloaded 371 # and unpacked, or the non-xz version was downloaded, and in both 372 # cases the result, i.e., the unpackaged tlpdb, is in $tlpdbfile 373 # 374 # before we open and proceed, verify the downloaded file 375 if ($params{'verify'} && $media ne 'local_uncompressed') { 376 my ($verified, $status) = TeXLive::TLCrypto::verify_checksum_and_check_return($tlpdbfile, $path); 377 $is_verified = $verified; 378 $self->verification_status($status); 379 } 380 open($retfh, "<$tlpdbfile") || die "$0: open($tlpdbfile) failed: $!"; 381 } else { 382 if ($params{'verify'} && $media ne 'local_uncompressed') { 383 my ($verified, $status) = TeXLive::TLCrypto::verify_checksum_and_check_return($path, $path); 384 $is_verified = $verified; 385 $self->verification_status($status); 386 } 387 open(TMP, "<$path") || die "$0: open($path) failed: $!"; 388 $retfh = \*TMP; 389 } 390 my $found = 0; 391 my $ret = 0; 392 do { 393 my $tlp = TeXLive::TLPOBJ->new; 394 $ret = $tlp->from_fh($retfh,1); 395 if ($ret) { 396 $self->add_tlpobj($tlp); 397 $found++; 398 } 399 } until (!$ret); 400 if (! $found) { 401 debug("$0: Could not load packages from\n"); 402 debug(" $path\n"); 403 } 404 405 $self->{'verified'} = $is_verified; 406 407 close($retfh); 408 return($found); 409 } 410 411 =pod 412 413 =item C<< $tlpdb->writeout >> 414 415 =item C<< $tlpdb->writeout(FILEHANDLE) >> 416 417 The C<writeout> function writes the database to C<STDOUT>, or 418 the file handle given as argument. 419 420 =cut 421 422 sub writeout { 423 my $self = shift; 424 if ($self->is_virtual) { 425 tlwarn("TLPDB: cannot writeout a virtual tlpdb\n"); 426 return 0; 427 } 428 my $fd = (@_ ? $_[0] : *STDOUT); 429 foreach (sort keys %{$self->{'tlps'}}) { 430 TeXLive::TLUtils::dddebug("writeout: tlpname=$_ ", 431 $self->{'tlps'}{$_}->name, "\n"); 432 $self->{'tlps'}{$_}->writeout($fd); 433 print $fd "\n"; 434 } 435 } 436 437 =pod 438 439 =item C<< $tlpdb->as_json >> 440 441 The C<as_json> function returns a JSON UTF8 encoded representation of the 442 database, that is a JSON array of packages. If the database is virtual, 443 a JSON array where each element is a hash with two keys, C<tag> giving 444 the tag of the sub-database, and C<tlpdb> giving the JSON of the database. 445 446 =cut 447 448 sub as_json { 449 my $self = shift; 450 my $ret = "{"; 451 if ($self->is_virtual) { 452 my $firsttlpdb = 1; 453 for my $k (keys %{$self->{'tlpdbs'}}) { 454 $ret .= ",\n" if (!$firsttlpdb); 455 $ret .= "\"$k\":"; 456 $firsttlpdb = 0; 457 $ret .= $self->{'tlpdbs'}{$k}->_as_json; 458 } 459 } else { 460 $ret .= "\"main\":"; 461 $ret .= $self->_as_json; 462 } 463 $ret .= "}\n"; 464 return($ret); 465 } 466 467 sub options_as_json { 468 my $self = shift; 469 die("calling _as_json on virtual is not supported!") if ($self->is_virtual); 470 my $opts = $self->options; 471 my @opts; 472 for my $k (keys %TLPDBOptions) { 473 my %foo; 474 $foo{'name'} = $k; 475 $foo{'tlmgrname'} = $TLPDBOptions{$k}[2]; 476 $foo{'description'} = $TLPDBOptions{$k}[3]; 477 $foo{'format'} = $TLPDBOptions{$k}[0]; 478 $foo{'default'} = "$TLPDBOptions{$k}[1]"; 479 # if ($TLPDBOptions{$k}[0] =~ m/^n/) { 480 # if (exists($opts->{$k})) { 481 # $foo{'value'} = $opts->{$k}; 482 # $foo{'value'} += 0; 483 # } 484 # $foo{'default'} += 0; 485 # } elsif ($TLPDBOptions{$k}[0] eq "b") { 486 # if (exists($opts->{$k})) { 487 # $foo{'value'} = ($opts->{$k} ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False()); 488 # } 489 # $foo{'default'} = ($foo{'default'} ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False()); 490 # } elsif ($k eq "location") { 491 # my %def; 492 # $def{'main'} = $TLPDBOptions{$k}[1]; 493 # $foo{'default'} = \%def; 494 # if (exists($opts->{$k})) { 495 # my %repos = TeXLive::TLUtils::repository_to_array($opts->{$k}); 496 # $foo{'value'} = \%repos; 497 # } 498 # } elsif ($TLPDBOptions{$k}[0] eq "p") { 499 # # strings/path 500 # if (exists($opts->{$k})) { 501 # $foo{'value'} = $opts->{$k}; 502 # } 503 # } else { 504 505 # TREAT ALL VALUES AS STRINGS, otherwise not parsable JSON 506 # treat as strings 507 if (exists($opts->{$k})) { 508 $foo{'value'} = $opts->{$k}; 509 } 510 # } 511 push @opts, \%foo; 512 } 513 return(TeXLive::TLUtils::encode_json(\@opts)); 514 } 515 516 sub settings_as_json { 517 my $self = shift; 518 die("calling _as_json on virtual is not supported!") if ($self->is_virtual); 519 my $sets = $self->settings; 520 my @json; 521 for my $k (keys %TLPDBSettings) { 522 my %foo; 523 $foo{'name'} = $k; 524 $foo{'type'} = $TLPDBSettings{$k}[0]; 525 $foo{'description'} = $TLPDBSettings{$k}[1]; 526 # if ($TLPDBSettings{$k}[0] eq "b") { 527 # if (exists($sets->{$k})) { 528 # $foo{'value'} = ($sets->{$k} ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False()); 529 # } 530 # } elsif ($TLPDBSettings{$k} eq "available_architectures") { 531 # if (exists($sets->{$k})) { 532 # my @lof = $self->available_architectures; 533 # $foo{'value'} = \@lof; 534 # } 535 # } else { 536 if (exists($sets->{$k})) { 537 $foo{'value'} = "$sets->{$k}"; 538 } 539 # } 540 push @json, \%foo; 541 } 542 return(TeXLive::TLUtils::encode_json(\@json)); 543 } 544 545 sub configs_as_json { 546 my $self = shift; 547 die("calling _as_json on virtual is not supported!") if ($self->is_virtual); 548 my %cfgs; 549 $cfgs{'container_split_src_files'} = ($self->config_src_container ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False()); 550 $cfgs{'container_split_doc_files'} = ($self->config_doc_container ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False()); 551 $cfgs{'container_format'} = $self->config_container_format; 552 $cfgs{'release'} = $self->config_release; 553 $cfgs{'minrelease'} = $self->config_minrelease; 554 return(TeXLive::TLUtils::encode_json(\%cfgs)); 555 } 556 557 sub _as_json { 558 my $self = shift; 559 die("calling _as_json on virtual is not supported!") if ($self->is_virtual); 560 my $ret = "{"; 561 $ret .= '"options":'; 562 $ret .= $self->options_as_json(); 563 $ret .= ',"settings":'; 564 $ret .= $self->settings_as_json(); 565 $ret .= ',"configs":'; 566 $ret .= $self->configs_as_json(); 567 $ret .= ',"tlpkgs": ['; 568 my $first = 1; 569 foreach (keys %{$self->{'tlps'}}) { 570 $ret .= ",\n" if (!$first); 571 $first = 0; 572 $ret .= $self->{'tlps'}{$_}->as_json; 573 } 574 $ret .= "]}"; 575 return($ret); 576 } 577 578 =pod 579 580 =item C<< $tlpdb->save >> 581 582 The C<save> functions saves the C<TLPDB> to the file which has been set 583 as location. If the location is undefined, die. 584 585 =cut 586 587 sub save { 588 my $self = shift; 589 if ($self->is_virtual) { 590 tlwarn("TLPDB: cannot save a virtual tlpdb\n"); 591 return 0; 592 } 593 my $path = $self->location; 594 mkdirhier(dirname($path)); 595 my $tmppath = "$path.tmp"; 596 open(FOO, ">$tmppath") || die "$0: open(>$tmppath) failed: $!"; 597 $self->writeout(\*FOO); 598 close(FOO); 599 # on Windows the renaming sometimes fails, try to copy and unlink the 600 # .tmp file. This we do for all archs, cannot hurt. 601 # if we managed that one, we move it over 602 TeXLive::TLUtils::copy ("-f", $tmppath, $path); 603 unlink ($tmppath) or tlwarn ("TLPDB: cannot unlink $tmppath: $!\n"); 604 } 605 606 =pod 607 608 =item C<< $tlpdb->media >> 609 610 Returns the media code the respective installation resides on. 611 612 =cut 613 614 sub media { 615 my $self = shift ; 616 if ($self->is_virtual) { 617 return "virtual"; 618 } 619 return $self->{'media'}; 620 } 621 622 =pod 623 624 =item C<< $tlpdb->available_architectures >> 625 626 The C<available_architectures> functions returns the list of available 627 architectures as set in the options section 628 (i.e., using setting("available_architectures")) 629 630 =cut 631 632 sub available_architectures { 633 my $self = shift; 634 my @archs; 635 if ($self->is_virtual) { 636 for my $k (keys %{$self->{'tlpdbs'}}) { 637 TeXLive::TLUtils::push_uniq \@archs, $self->{'tlpdbs'}{$k}->available_architectures; 638 } 639 return sort @archs; 640 } else { 641 return $self->_available_architectures; 642 } 643 } 644 645 sub _available_architectures { 646 my $self = shift; 647 my @archs = $self->setting("available_architectures"); 648 if (! @archs) { 649 # fall back to the old method checking tex\.* 650 my @packs = $self->list_packages; 651 map { s/^tex\.// ; push @archs, $_ ; } grep(/^tex\.(.*)$/, @packs); 652 } 653 return @archs; 654 } 655 656 =pod 657 658 =item C<< $tlpdb->get_package("pkgname") >> 659 660 The C<get_package> function returns a reference to the C<TLPOBJ> object 661 corresponding to the I<pkgname>, or undef. 662 663 =cut 664 665 sub get_package { 666 my ($self,$pkg,$tag) = @_; 667 if ($self->is_virtual) { 668 if (defined($tag)) { 669 if (defined($self->{'packages'}{$pkg}{'tags'}{$tag})) { 670 return $self->{'packages'}{$pkg}{'tags'}{$tag}{'tlp'}; 671 } else { 672 debug("TLPDB::get_package: package $pkg not found in repository $tag\n"); 673 return; 674 } 675 } else { 676 $tag = $self->{'packages'}{$pkg}{'target'}; 677 if (defined($tag)) { 678 return $self->{'packages'}{$pkg}{'tags'}{$tag}{'tlp'}; 679 } else { 680 return; 681 } 682 } 683 } else { 684 return $self->_get_package($pkg); 685 } 686 } 687 688 sub _get_package { 689 my ($self,$pkg) = @_; 690 return undef if (!$pkg); 691 if (defined($self->{'tlps'}{$pkg})) { 692 my $ret = $self->{'tlps'}{$pkg}; 693 return $self->{'tlps'}{$pkg}; 694 } else { 695 return undef; 696 } 697 } 698 699 =pod 700 701 =item C<< $tlpdb->media_of_package($pkg [, $tag]) >> 702 703 returns the media type of the package. In the virtual case a tag can 704 be given and the media of that repository is used, otherwise the 705 media of the virtual candidate is given. 706 707 =cut 708 709 sub media_of_package { 710 my ($self, $pkg, $tag) = @_; 711 if ($self->is_virtual) { 712 if (defined($tag)) { 713 if (defined($self->{'tlpdbs'}{$tag})) { 714 return $self->{'tlpdbs'}{$tag}->media; 715 } else { 716 tlwarn("TLPDB::media_of_package: tag not known: $tag\n"); 717 return; 718 } 719 } else { 720 my (undef,undef,undef,$maxtlpdb) = $self->virtual_candidate($pkg); 721 return $maxtlpdb->media; 722 } 723 } else { 724 return $self->media; 725 } 726 } 727 728 =pod 729 730 =item C<< $tlpdb->list_packages >> 731 732 The C<list_packages> function returns the list of all included packages. 733 734 By default, for virtual tlpdbs only packages that are installable 735 are listed. That means, packages that are only in subsidiary repositories 736 but are not specifically pinned to it cannot be installed and are thus 737 not listed. Adding "-all" argument lists also these packages. 738 739 Finally, if there is another argument, the tlpdb must be virtual, 740 and the argument must specify a tag/name of a sub-tlpdb. In this 741 case all packages (without exceptions) from this repository are returned. 742 743 =cut 744 745 sub list_packages { 746 my $self = shift; 747 my $arg = shift; 748 my $tag; 749 my $showall = 0; 750 if (defined($arg)) { 751 if ($arg eq "-all") { 752 $showall = 1; 753 } else { 754 $tag = $arg; 755 } 756 } 757 if ($self->is_virtual) { 758 if ($showall) { 759 return (sort keys %{$self->{'packages'}}); 760 } 761 if ($tag) { 762 if (defined($self->{'tlpdbs'}{$tag})) { 763 return $self->{'tlpdbs'}{$tag}->list_packages; 764 } else { 765 tlwarn("TLPDB::list_packages: tag not defined: $tag\n"); 766 return 0; 767 } 768 } 769 # we have to be careful here: If a package 770 # is only present in a subsidiary repository 771 # and the package is *not* explicitly 772 # pinned to it, it will not be installable. 773 # This is what we want. But in this case 774 # we don't want it to be listed by default. 775 # 776 my @pps; 777 for my $p (keys %{$self->{'packages'}}) { 778 push @pps, $p if (defined($self->{'packages'}{$p}{'target'})); 779 } 780 return (sort @pps); 781 } else { 782 return $self->_list_packages; 783 } 784 } 785 786 sub _list_packages { 787 my $self = shift; 788 return (sort keys %{$self->{'tlps'}}); 789 } 790 791 =pod 792 793 =item C<< $tlpdb->expand_dependencies(["control",] $tlpdb, ($pkgs)) >> 794 795 If the first argument is the string C<"-only-arch">, expands only 796 dependencies of the form C<.>I<ARCH>. 797 798 If the first argument is C<"-no-collections">, then dependencies between 799 "same-level" packages (scheme onto scheme, collection onto collection, 800 package onto package) are ignored. 801 802 C<-only-arch> and C<-no-collections> cannot be specified together; has 803 to be one or the other. 804 805 The next (or first) argument is the target TLPDB, then a list of 806 packages. 807 808 In the virtual case, if a package name is tagged with C<@repository-tag> 809 then all the dependencies will still be expanded between all included 810 databases. Only in case of C<.>I<ARCH> dependencies the repository-tag 811 is sticky. 812 813 We return a list of package names, the closure of the package list with 814 respect to the depends operator. (Sorry, that was for mathematicians.) 815 816 =cut 817 818 sub expand_dependencies { 819 my $self = shift; 820 my $only_arch = 0; 821 my $no_collections = 0; 822 my $first = shift; 823 my $totlpdb; 824 if ($first eq "-only-arch") { 825 $only_arch = 1; 826 $totlpdb = shift; 827 } elsif ($first eq "-no-collections") { 828 $no_collections = 1; 829 $totlpdb = shift; 830 } else { 831 $totlpdb = $first; 832 } 833 my %install = (); 834 my @archs = $totlpdb->available_architectures; 835 for my $p (@_) { 836 next if ($p =~ m/^\s*$/); 837 my ($pp, $aa) = split('@', $p); 838 $install{$pp} = (defined($aa) ? $aa : 0);; 839 } 840 my $changed = 1; 841 while ($changed) { 842 $changed = 0; 843 my @pre_select = keys %install; 844 ddebug("pre_select = @pre_select\n"); 845 for my $p (@pre_select) { 846 next if ($p =~ m/^00texlive/); 847 my $pkg = $self->get_package($p, ($install{$p}?$install{$p}:undef)); 848 if (!defined($pkg)) { 849 ddebug("W: $p is mentioned somewhere but not available, disabling\n"); 850 $install{$p} = 0; 851 next; 852 } 853 for my $p_dep ($pkg->depends) { 854 ddebug("checking $p_dep in $p\n"); 855 my $tlpdd = $self->get_package($p_dep); 856 if (defined($tlpdd)) { 857 # before we ignored all deps of schemes and colls if -no-collections 858 # was given, but this prohibited auto-install of new collections 859 # even if the scheme is updated. 860 # Now we suppress only "same-level dependencies", so scheme -> scheme 861 # and collections -> collections and package -> package 862 # hoping that this works out better 863 # if ($tlpdd->category =~ m/$MetaCategoriesRegexp/) { 864 if ($tlpdd->category eq $pkg->category) { 865 # we ignore same-level dependencies if "-no-collections" is given 866 ddebug("expand_deps: skipping $p_dep in $p due to -no-collections\n"); 867 next if $no_collections; 868 } 869 } 870 if ($p_dep =~ m/^(.*)\.ARCH$/) { 871 my $foo = "$1"; 872 foreach $a (@archs) { 873 # install .ARCH packages from the same sub repository as the 874 # main packages 875 $install{"$foo.$a"} = $install{$foo} 876 if defined($self->get_package("$foo.$a")); 877 } 878 } elsif ($p_dep =~ m/^(.*)\.windows$/) { 879 # a windows package should *only* be installed if we are installing 880 # the windows arch 881 if (grep(/^windows$/,@archs)) { 882 $install{$p_dep} = 0; 883 } 884 } else { 885 $install{$p_dep} = 0 unless $only_arch; 886 } 887 } 888 } 889 890 # check for newly selected packages 891 my @post_select = keys %install; 892 ddebug("post_select = @post_select\n"); 893 if ($#pre_select != $#post_select) { 894 $changed = 1; 895 } 896 } 897 # create return list 898 return map { $install{$_} eq "0"?$_:"$_\@" . $install{$_} } keys %install; 899 #return(keys %install); 900 } 901 902 =pod 903 904 =item C<< $tlpdb->find_file("filename") >> 905 906 The C<find_file> returns a list of packages:filename 907 containing a file named C<filename>. 908 909 =cut 910 911 # TODO adapt for searching in *all* tags ??? 912 sub find_file { 913 my ($self,$fn) = @_; 914 my @ret = (); 915 for my $pkg ($self->list_packages) { 916 for my $f ($self->get_package($pkg)->contains_file($fn)) { 917 push (@ret, "$pkg:$f"); 918 } 919 } 920 return @ret; 921 } 922 923 =pod 924 925 =item C<< $tlpdb->collections >> 926 927 The C<collections> function returns a list of all collection names. 928 929 =cut 930 931 sub collections { 932 my $self = shift; 933 my @ret; 934 foreach my $p ($self->list_packages) { 935 if ($self->get_package($p)->category eq "Collection") { 936 push @ret, $p; 937 } 938 } 939 return @ret; 940 } 941 942 =pod 943 944 =item C<< $tlpdb->schemes >> 945 946 The C<schemes> function returns a list of all scheme names. 947 948 =cut 949 950 sub schemes { 951 my $self = shift; 952 my @ret; 953 foreach my $p ($self->list_packages) { 954 if ($self->get_package($p)->category eq "Scheme") { 955 push @ret, $p; 956 } 957 } 958 return @ret; 959 } 960 961 962 963 =pod 964 965 =item C<< $tlpdb->package_revision("packagename") >> 966 967 The C<package_revision> function returns the revision number of the 968 package named in the first argument. 969 970 =cut 971 972 sub package_revision { 973 my ($self,$pkg) = @_; 974 my $tlp = $self->get_package($pkg); 975 if (defined($tlp)) { 976 return $tlp->revision; 977 } else { 978 return; 979 } 980 } 981 982 =pod 983 984 =item C<< $tlpdb->generate_packagelist >> 985 986 The C<generate_packagelist> prints TeX Live package names in the object 987 database, together with their revisions, to the file handle given in the 988 first (optional) argument, or C<STDOUT> by default. It also outputs all 989 available architectures as packages with revision number -1. 990 991 =cut 992 993 sub generate_packagelist { 994 my $self = shift; 995 my $fd = (@_ ? $_[0] : *STDOUT); 996 foreach (sort $self->list_packages) { 997 print $fd $self->get_package($_)->name, " ", 998 $self->get_package($_)->revision, "\n"; 999 } 1000 foreach ($self->available_architectures) { 1001 print $fd "$_ -1\n"; 1002 } 1003 } 1004 1005 =pod 1006 1007 =item C<< $tlpdb->generate_listfiles >> 1008 1009 =item C<< $tlpdb->generate_listfiles($destdir) >> 1010 1011 The C<generate_listfiles> generates the list files for the old 1012 installers. This function will probably go away. 1013 1014 =cut 1015 1016 sub generate_listfiles { 1017 my ($self,$destdir) = @_; 1018 if (not(defined($destdir))) { 1019 $destdir = TeXLive::TLPDB->listdir; 1020 } 1021 foreach (sort $self->list_package) { 1022 my $tlp = $self->get_package($_); 1023 $self->_generate_listfile($tlp, $destdir); 1024 } 1025 } 1026 1027 sub _generate_listfile { 1028 my ($self,$tlp,$destdir) = @_; 1029 my $listname = $tlp->name; 1030 my @files = $tlp->all_files; 1031 @files = TeXLive::TLUtils::sort_uniq(@files); 1032 &mkpath("$destdir") if (! -d "$destdir"); 1033 my (@lop, @lot); 1034 foreach my $d ($tlp->depends) { 1035 my $subtlp = $self->get_package($d); 1036 if (defined($subtlp)) { 1037 if ($subtlp->is_meta_package) { 1038 push @lot, $d; 1039 } else { 1040 push @lop, $d; 1041 } 1042 } else { 1043 # pseudo-dependencies on $Package.ARCH can be ignored 1044 if ($d !~ m/\.ARCH$/) { 1045 tlwarn("TLPDB: package $tlp->name depends on $d, but this does not exist\n"); 1046 } 1047 } 1048 } 1049 open(TMP, ">$destdir/$listname") 1050 || die "$0: open(>$destdir/$listname) failed: $!"; 1051 1052 # title and size information for collections and schemes in the 1053 # first two lines, marked with * 1054 if ($tlp->category eq "Collection") { 1055 print TMP "*Title: ", $tlp->shortdesc, "\n"; 1056 # collections references Packages, we have to collect the sizes of 1057 # all the Package-tlps included 1058 # What is unclear for me is HOW the size is computed for bin-* 1059 # packages. The collection-basic contains quite a lot of 1060 # bin-files, but the sizes for the different archs differ. 1061 # I guess we have to take the maximum? 1062 my $s = 0; 1063 foreach my $p (@lop) { 1064 my $subtlp = $self->get_package($p); 1065 if (!defined($subtlp)) { 1066 tlwarn("TLPDB: $listname references $p, but this is not in tlpdb\n"); 1067 } 1068 $s += $subtlp->total_size; 1069 } 1070 # in case the collection itself ships files ... 1071 $s += $tlp->runsize + $tlp->srcsize + $tlp->docsize; 1072 print TMP "*Size: $s\n"; 1073 } elsif ($tlp->category eq "Scheme") { 1074 print TMP "*Title: ", $tlp->shortdesc, "\n"; 1075 my $s = 0; 1076 # schemes size includes ONLY those packages which are directly 1077 # included and directly included files, not the size of the 1078 # included collections. But if a package is included in one of 1079 # the called for collections AND listed directly, we don't want 1080 # to count its size two times 1081 my (@inccol,@incpkg,@collpkg); 1082 # first we add all the packages tlps that are directly included 1083 @incpkg = @lop; 1084 # now we select all collections, and for all collections we 1085 # again select all non-meta-packages 1086 foreach my $c (@lot) { 1087 my $coll = $self->get_package($c); 1088 foreach my $d ($coll->depends) { 1089 my $subtlp = $self->get_package($d); 1090 if (defined($subtlp)) { 1091 if (!($subtlp->is_meta_package)) { 1092 TeXLive::TLUtils::push_uniq(\@collpkg,$d); 1093 } 1094 } else { 1095 tlwarn("TLPDB: collection $coll->name depends on $d, but this does not exist\n"); 1096 } 1097 } 1098 } 1099 # finally go through all packages and add the ->total_size 1100 foreach my $p (@incpkg) { 1101 if (!TeXLive::TLUtils::member($p,@collpkg)) { 1102 $s += $self->get_package($p)->total_size; 1103 } 1104 } 1105 $s += $tlp->runsize + $tlp->srcsize + $tlp->docsize; 1106 print TMP "*Size: $s\n"; 1107 } 1108 # dependencies and inclusion of packages 1109 foreach my $t (@lot) { 1110 # strange, schemes mark included collections via -, while collections 1111 # themselves mark deps on other collections with +. collections are 1112 # never referenced in Packages. 1113 if ($listname =~ m/^scheme/) { 1114 print TMP "-"; 1115 } else { 1116 print TMP "+"; 1117 } 1118 print TMP "$t\n"; 1119 } 1120 foreach my $t (@lop) { print TMP "+$t\n"; } 1121 # included files 1122 foreach my $f (@files) { print TMP "$f\n"; } 1123 # also print the listfile itself 1124 print TMP "$destdir/$listname\n"; 1125 # execute statements 1126 foreach my $e ($tlp->executes) { 1127 print TMP "!$e\n"; 1128 } 1129 # finish 1130 close(TMP); 1131 } 1132 1133 =pod 1134 1135 =item C<< $tlpdb->root([ "/path/to/installation" ]) >> 1136 1137 The function C<root> allows to read and set the root of the 1138 installation. 1139 1140 =cut 1141 1142 sub root { 1143 my $self = shift; 1144 if ($self->is_virtual) { 1145 tlwarn("TLPDB: cannot set/edit root of a virtual tlpdb\n"); 1146 return 0; 1147 } 1148 if (@_) { $self->{'root'} = shift } 1149 return $self->{'root'}; 1150 } 1151 1152 =pod 1153 1154 =item C<< $tlpdb->location >> 1155 1156 Return the location of the actual C<texlive.tlpdb> file used. This is a 1157 read-only function; you cannot change the root of the TLPDB using this 1158 function. 1159 1160 See C<00texlive.installation.tlpsrc> for a description of the 1161 special value C<__MASTER>. 1162 1163 =cut 1164 1165 sub location { 1166 my $self = shift; 1167 if ($self->is_virtual) { 1168 tlwarn("TLPDB: cannot get location of a virtual tlpdb\n"); 1169 return 0; 1170 } 1171 return "$self->{'root'}/$DatabaseLocation"; 1172 } 1173 1174 =pod 1175 1176 =item C<< $tlpdb->platform >> 1177 1178 returns the platform of this installation. 1179 1180 =cut 1181 1182 # deduce the platform of the referenced media as follows: 1183 # - if the $tlpdb->setting("platform") is there it overrides the detected 1184 # setting 1185 # - if it is not there call TLUtils::platform() 1186 sub platform { 1187 # try to deduce the platform 1188 my $self = shift; 1189 my $ret = $self->setting("platform"); 1190 #print STDERR "platform $ret set in tlpdb\n" if defined $ret; 1191 return $ret if defined $ret; 1192 # the platform setting wasn't found in the tlpdb, try TLUtils::platform 1193 #print STDERR "Setting platform to ",TeXLive::TLUtils::platform(), "\n"; 1194 return TeXLive::TLUtils::platform(); 1195 } 1196 1197 =pod 1198 1199 =item C<< $tlpdb->is_verified >> 1200 1201 Returns 0/1 depending on whether the tlpdb was verified by checking 1202 the cryptographic signature. 1203 1204 =cut 1205 1206 sub is_verified { 1207 my $self = shift; 1208 if ($self->is_virtual) { 1209 tlwarn("TLPDB: cannot set/edit verified property of a virtual tlpdb\n"); 1210 return 0; 1211 } 1212 if (@_) { $self->{'verified'} = shift } 1213 return $self->{'verified'}; 1214 } 1215 =pod 1216 1217 =item C<< $tlpdb->verification_status >> 1218 1219 Returns the id of the verification status. To obtain a textual representation 1220 us %TLCrypto::VerificationStatusDescription. 1221 1222 =cut 1223 1224 sub verification_status { 1225 my $self = shift; 1226 if ($self->is_virtual) { 1227 tlwarn("TLPDB: cannot set/edit verification status of a virtual tlpdb\n"); 1228 return 0; 1229 } 1230 if (@_) { $self->{'verification_status'} = shift } 1231 return $self->{'verification_status'}; 1232 } 1233 1234 =pod 1235 1236 =item C<< $tlpdb->listdir >> 1237 1238 The function C<listdir> allows to read and set the packages variable 1239 specifying where generated list files are created. 1240 1241 =cut 1242 1243 sub listdir { 1244 my $self = shift; 1245 if (@_) { $_listdir = $_[0] } 1246 return $_listdir; 1247 } 1248 1249 =pod 1250 1251 =item C<< $tlpdb->config_src_container >> 1252 1253 Returns 1 if the texlive config option for src files splitting on 1254 container level is set. See Options below. 1255 1256 =cut 1257 1258 sub config_src_container { 1259 my $self = shift; 1260 my $tlp; 1261 if ($self->is_virtual) { 1262 $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); 1263 } else { 1264 $tlp = $self->{'tlps'}{'00texlive.config'}; 1265 } 1266 if (defined($tlp)) { 1267 foreach my $d ($tlp->depends) { 1268 if ($d =~ m!^container_split_src_files/(.*)$!) { 1269 return "$1"; 1270 } 1271 } 1272 } 1273 return 0; 1274 } 1275 1276 =pod 1277 1278 =item C<< $tlpdb->config_doc_container >> 1279 1280 Returns 1 if the texlive config option for doc files splitting on 1281 container level is set. See Options below. 1282 1283 =cut 1284 1285 sub config_doc_container { 1286 my $self = shift; 1287 my $tlp; 1288 if ($self->is_virtual) { 1289 $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); 1290 } else { 1291 $tlp = $self->{'tlps'}{'00texlive.config'}; 1292 } 1293 if (defined($tlp)) { 1294 foreach my $d ($tlp->depends) { 1295 if ($d =~ m!^container_split_doc_files/(.*)$!) { 1296 return "$1"; 1297 } 1298 } 1299 } 1300 return 0; 1301 } 1302 1303 =pod 1304 1305 =item C<< $tlpdb->config_container_format >> 1306 1307 Returns the currently set default container format. See Options below. 1308 1309 =cut 1310 1311 sub config_container_format { 1312 my $self = shift; 1313 my $tlp; 1314 if ($self->is_virtual) { 1315 $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); 1316 } else { 1317 $tlp = $self->{'tlps'}{'00texlive.config'}; 1318 } 1319 if (defined($tlp)) { 1320 foreach my $d ($tlp->depends) { 1321 if ($d =~ m!^container_format/(.*)$!) { 1322 return "$1"; 1323 } 1324 } 1325 } 1326 return ""; 1327 } 1328 1329 =pod 1330 1331 =item C<< $tlpdb->config_release >> 1332 1333 Returns the currently set release. See Options below. 1334 1335 =cut 1336 1337 sub config_release { 1338 my $self = shift; 1339 my $tlp; 1340 if ($self->is_virtual) { 1341 $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); 1342 } else { 1343 $tlp = $self->{'tlps'}{'00texlive.config'}; 1344 } 1345 if (defined($tlp)) { 1346 foreach my $d ($tlp->depends) { 1347 if ($d =~ m!^release/(.*)$!) { 1348 return "$1"; 1349 } 1350 } 1351 } 1352 return ""; 1353 } 1354 1355 =pod 1356 1357 =item C<< $tlpdb->config_minrelease >> 1358 1359 Returns the currently allowed minimal release. See Options below. 1360 1361 =cut 1362 1363 sub config_minrelease { 1364 my $self = shift; 1365 my $tlp; 1366 if ($self->is_virtual) { 1367 $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); 1368 } else { 1369 $tlp = $self->{'tlps'}{'00texlive.config'}; 1370 } 1371 if (defined($tlp)) { 1372 foreach my $d ($tlp->depends) { 1373 if ($d =~ m!^minrelease/(.*)$!) { 1374 return "$1"; 1375 } 1376 } 1377 } 1378 return; 1379 } 1380 1381 =pod 1382 1383 =item C<< $tlpdb->config_frozen >> 1384 1385 Returns true if the location is frozen. 1386 1387 =cut 1388 1389 sub config_frozen { 1390 my $self = shift; 1391 my $tlp; 1392 if ($self->is_virtual) { 1393 $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); 1394 } else { 1395 $tlp = $self->{'tlps'}{'00texlive.config'}; 1396 } 1397 if (defined($tlp)) { 1398 foreach my $d ($tlp->depends) { 1399 if ($d =~ m!^frozen/(.*)$!) { 1400 return "$1"; 1401 } 1402 } 1403 } 1404 return; 1405 } 1406 1407 1408 =pod 1409 1410 =item C<< $tlpdb->config_revision >> 1411 1412 Returns the currently set revision. See Options below. 1413 1414 =cut 1415 1416 sub config_revision { 1417 my $self = shift; 1418 my $tlp; 1419 if ($self->is_virtual) { 1420 $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); 1421 } else { 1422 $tlp = $self->{'tlps'}{'00texlive.config'}; 1423 } 1424 if (defined($tlp)) { 1425 foreach my $d ($tlp->depends) { 1426 if ($d =~ m!^revision/(.*)$!) { 1427 return "$1"; 1428 } 1429 } 1430 } 1431 return ""; 1432 } 1433 1434 =pod 1435 1436 =item C<< $tlpdb->sizes_of_packages_with_deps ( $opt_src, $opt_doc, $ref_arch_list, [ @packs ] ) >> 1437 1438 =item C<< $tlpdb->sizes_of_packages ( $opt_src, $opt_doc, $ref_arch_list, [ @packs ] ) >> 1439 1440 These functions return a reference to a hash with package names as keys 1441 and the sizes in bytes as values. The sizes are computed for the list of 1442 package names given as the fourth argument, or all packages if not 1443 specified. The difference between the two functions is that the C<_with_deps> 1444 gives the size of packages including the size of all depending sizes. 1445 1446 If anything has been computed one additional key is synthesized, 1447 C<__TOTAL__>, which contains the total size of all packages under 1448 consideration. In the case of C<_with_deps> this total computation 1449 does B<not> count packages multiple times, even if they appear 1450 multiple times as dependencies. 1451 1452 If the third argument is a reference to a list of architectures, then 1453 only the sizes for the binary packages for these architectures are used, 1454 otherwise all sizes for all architectures are summed. 1455 1456 =cut 1457 1458 sub sizes_of_packages { 1459 my ($self, $opt_src, $opt_doc, $arch_list_ref, @packs) = @_; 1460 return $self->_sizes_of_packages(0, $opt_src, $opt_doc, $arch_list_ref, @packs); 1461 } 1462 1463 sub sizes_of_packages_with_deps { 1464 my ($self, $opt_src, $opt_doc, $arch_list_ref, @packs) = @_; 1465 return $self->_sizes_of_packages(1, $opt_src, $opt_doc, $arch_list_ref, @packs); 1466 } 1467 1468 1469 sub _sizes_of_packages { 1470 my ($self, $with_deps, $opt_src, $opt_doc, $arch_list_ref, @packs) = @_; 1471 @packs || ( @packs = $self->list_packages() ); 1472 my @exppacks; 1473 if ($with_deps) { 1474 # don't expand collection->collection dependencies 1475 #@exppacks = $self->expand_dependencies('-no-collections', $self, @packs); 1476 @exppacks = $self->expand_dependencies($self, @packs); 1477 } else { 1478 @exppacks = @packs; 1479 } 1480 my @archs; 1481 if ($arch_list_ref) { 1482 @archs = @$arch_list_ref; 1483 } else { 1484 # if nothing is passed on, we use all available archs 1485 @archs = $self->available_architectures; 1486 } 1487 my %tlpsizes; 1488 my %tlpobjs; 1489 my $totalsize = 0; 1490 foreach my $p (@exppacks) { 1491 $tlpobjs{$p} = $self->get_package($p); 1492 my $media = $self->media_of_package($p); 1493 if (!defined($tlpobjs{$p})) { 1494 warn "STRANGE: $p not to be found in ", $self->root; 1495 next; 1496 } 1497 # 1498 # in case we are calling the _with_deps variant, we always 1499 # compute *UNCOMPRESSED* sizes (not the container sizes!!!) 1500 if ($with_deps) { 1501 $tlpsizes{$p} = $self->size_of_one_package('local_uncompressed' , $tlpobjs{$p}, 1502 $opt_src, $opt_doc, @archs); 1503 } else { 1504 $tlpsizes{$p} = $self->size_of_one_package($media, $tlpobjs{$p}, 1505 $opt_src, $opt_doc, @archs); 1506 } 1507 $totalsize += $tlpsizes{$p}; 1508 } 1509 my %realtlpsizes; 1510 if ($totalsize) { 1511 $realtlpsizes{'__TOTAL__'} = $totalsize; 1512 } 1513 if (!$with_deps) { 1514 for my $p (@packs) { 1515 $realtlpsizes{$p} = $tlpsizes{$p}; 1516 } 1517 } else { # the case with dependencies 1518 # make three rounds: for packages, collections, schemes 1519 # size computations include only those from lower-levels 1520 # that is, scheme-scheme, collection-collection 1521 # does not contribute to the size 1522 for my $p (@exppacks) { 1523 next if ($p =~ m/scheme-/); 1524 next if ($p =~ m/collection-/); 1525 $realtlpsizes{$p} = $tlpsizes{$p}; 1526 } 1527 for my $p (@exppacks) { 1528 # only collections 1529 next if ($p !~ m/collection-/); 1530 $realtlpsizes{$p} = $tlpsizes{$p}; 1531 ddebug("=== $p adding deps\n"); 1532 for my $d ($tlpobjs{$p}->depends) { 1533 next if ($d =~ m/^collection-/); 1534 next if ($d =~ m/^scheme-/); 1535 ddebug("=== going for $d\n"); 1536 if (defined($tlpsizes{$d})) { 1537 $realtlpsizes{$p} += $tlpsizes{$d}; 1538 ddebug("=== found $tlpsizes{$d} for $d\n"); 1539 } else { 1540 # silently ignore missing defined packages - they should have 1541 # been computed by expand-dependencies 1542 debug("TLPDB.pm: size with deps: sub package not found main=$d, dep=$p\n"); 1543 } 1544 } 1545 } 1546 for my $p (@exppacks) { 1547 # only schemes 1548 next if ($p !~ m/scheme-/); 1549 $realtlpsizes{$p} = $tlpsizes{$p}; 1550 ddebug("=== $p adding deps\n"); 1551 for my $d ($tlpobjs{$p}->depends) { 1552 # should not be necessary, we don't have collection -> scheme deps 1553 next if ($d =~ m/^scheme-/); 1554 ddebug("=== going for $d\n"); 1555 if (defined($realtlpsizes{$d})) { 1556 $realtlpsizes{$p} += $realtlpsizes{$d}; 1557 ddebug("=== found $realtlpsizes{$d} for $d\n"); 1558 } else { 1559 # silently ignore missing defined packages - they should have 1560 # been computed by expand-dependencies 1561 debug("TLPDB.pm: size with deps: sub package not found main=$d, dep=$p\n"); 1562 } 1563 } 1564 } 1565 } 1566 return \%realtlpsizes; 1567 } 1568 1569 sub size_of_one_package { 1570 my ($self, $media, $tlpobj, $opt_src, $opt_doc, @used_archs) = @_; 1571 my $size = 0; 1572 if ($media ne 'local_uncompressed') { 1573 # we use the container size as the measuring unit since probably 1574 # downloading will be the limiting factor 1575 $size = $tlpobj->containersize; 1576 $size += $tlpobj->srccontainersize if $opt_src; 1577 $size += $tlpobj->doccontainersize if $opt_doc; 1578 } else { 1579 # we have to add the respective sizes, that is checking for 1580 # installation of src and doc file 1581 $size = $tlpobj->runsize; 1582 $size += $tlpobj->srcsize if $opt_src; 1583 $size += $tlpobj->docsize if $opt_doc; 1584 my %foo = %{$tlpobj->binsize}; 1585 for my $k (keys %foo) { 1586 if (@used_archs && member($k, @used_archs)) { 1587 $size += $foo{$k}; 1588 } 1589 } 1590 # packages sizes are stored in blocks; transform that to bytes. 1591 $size *= $TeXLive::TLConfig::BlockSize; 1592 } 1593 return $size; 1594 } 1595 1596 =pod 1597 1598 =item C<< $tlpdb->install_package_files($f [, $f]) >> 1599 1600 Install a package from a package file, i.e. a .tar.xz. 1601 Returns the number of packages actually installed successfully. 1602 1603 =cut 1604 1605 sub install_package_files { 1606 my ($self, @files) = @_; 1607 1608 my $ret = 0; 1609 1610 my $opt_src = $self->option("install_srcfiles"); 1611 my $opt_doc = $self->option("install_docfiles"); 1612 1613 for my $f (@files) { 1614 1615 # - create a tmp directory 1616 my $tmpdir = TeXLive::TLUtils::tl_tmpdir(); 1617 # - unpack everything there 1618 { 1619 my ($ret, $msg) = TeXLive::TLUtils::unpack($f, $tmpdir); 1620 if (!$ret) { 1621 tlwarn("TLPDB::install_package_files: $msg\n"); 1622 next; 1623 } 1624 } 1625 # we are still here, so the files have been unpacked properly 1626 # we need now to find the tlpobj in $tmpdir/tlpkg/tlpobj/ 1627 my ($tlpobjfile, $anotherfile) = <$tmpdir/tlpkg/tlpobj/*.tlpobj>; 1628 if (defined($anotherfile)) { 1629 # we found several tlpobj files, that is not allowed, stop 1630 tlwarn("TLPDB::install_package_files: several tlpobj files " 1631 . "($tlpobjfile, $anotherfile) in tlpkg/tlpobj/, stopping!\n"); 1632 next; 1633 } 1634 # - read the tlpobj from there 1635 my $tlpobj = TeXLive::TLPOBJ->new; 1636 $tlpobj->from_file($tlpobjfile); 1637 # we didn't die in this process, so that seems to be a proper tlpobj 1638 # (btw, why didn't I work on proper return values!?!) 1639 1640 # 1641 # we are now ready for installation 1642 # if this package existed before, remove it from the tlpdb 1643 if ($self->get_package($tlpobj->name)) { 1644 $self->remove_package($tlpobj->name); 1645 } 1646 1647 # code partially from TLPDB->not_virtual_install_package!!! 1648 my @installfiles = (); 1649 my $reloc = 1 if $tlpobj->relocated; 1650 foreach ($tlpobj->runfiles) { push @installfiles, $_; }; 1651 foreach ($tlpobj->allbinfiles) { push @installfiles, $_; }; 1652 if ($opt_src) { foreach ($tlpobj->srcfiles) { push @installfiles, $_; } } 1653 if ($opt_doc) { foreach ($tlpobj->docfiles) { push @installfiles, $_; } } 1654 # 1655 # remove the RELOC prefix, but do NOT replace it with RelocTree 1656 @installfiles = map { s!^$RelocPrefix/!!; $_; } @installfiles; 1657 # if the first argument of _install_data is scalar, it is the 1658 # place from where files should be installed 1659 if (!_install_data ($tmpdir, \@installfiles, $reloc, \@installfiles, 1660 $self)) { 1661 tlwarn("TLPDB::install_package_files: couldn't install_data files: " 1662 . "@installfiles\n"); 1663 next; 1664 } 1665 if ($reloc) { 1666 if ($self->setting("usertree")) { 1667 $tlpobj->cancel_reloc_prefix; 1668 } else { 1669 $tlpobj->replace_reloc_prefix; 1670 } 1671 $tlpobj->relocated(0); 1672 } 1673 my $tlpod = $self->root . "/tlpkg/tlpobj"; 1674 mkdirhier( $tlpod ); 1675 open(TMP,">$tlpod/".$tlpobj->name.".tlpobj") or 1676 die("Cannot open tlpobj file for ".$tlpobj->name); 1677 $tlpobj->writeout(\*TMP); 1678 close(TMP); 1679 $self->add_tlpobj($tlpobj); 1680 $self->save; 1681 TeXLive::TLUtils::announce_execute_actions("enable", $tlpobj); 1682 # do the postinstallation actions 1683 # 1684 # Run the post installation code in the postaction tlpsrc entries 1685 # in case we are on w32 and the admin did install for himself only 1686 # we switch off admin mode 1687 if (wndws() && admin() && !$self->option("w32_multi_user")) { 1688 non_admin(); 1689 } 1690 # for now desktop_integration maps to both installation 1691 # of desktop shortcuts and menu items, but we can split them later 1692 &TeXLive::TLUtils::do_postaction("install", $tlpobj, 1693 $self->option("file_assocs"), 1694 $self->option("desktop_integration"), 1695 $self->option("desktop_integration"), 1696 $self->option("post_code")); 1697 1698 # remember that we installed this package correctly 1699 $ret++; 1700 } 1701 return $ret; 1702 } 1703 1704 1705 =pod 1706 1707 =item C<< $tlpdb->install_package($pkg, $dest_tlpdb [, $tag]) >> 1708 1709 Installs the package $pkg into $dest_tlpdb. 1710 If C<$tag> is present and the tlpdb is virtual, tries to install $pkg 1711 from the repository tagged with $tag. 1712 1713 =cut 1714 1715 sub install_package { 1716 my ($self, $pkg, $totlpdb, $tag) = @_; 1717 if ($self->is_virtual) { 1718 if (defined($tag)) { 1719 if (defined($self->{'packages'}{$pkg}{'tags'}{$tag})) { 1720 return $self->{'tlpdbs'}{$tag}->install_package($pkg, $totlpdb); 1721 } else { 1722 tlwarn("TLPDB::install_package: package $pkg not found" 1723 . " in repository $tag\n"); 1724 return; 1725 } 1726 } else { 1727 my ($maxtag, $maxrev, $maxtlp, $maxtlpdb) 1728 = $self->virtual_candidate($pkg); 1729 return $maxtlpdb->install_package($pkg, $totlpdb); 1730 } 1731 } else { 1732 if (defined($tag)) { 1733 tlwarn("TLPDB: not a virtual tlpdb, ignoring tag $tag" 1734 . " on installation of $pkg\n"); 1735 } 1736 return $self->not_virtual_install_package($pkg, $totlpdb); 1737 } 1738 return; 1739 } 1740 1741 sub not_virtual_install_package { 1742 my ($self, $pkg, $totlpdb) = @_; 1743 my $fromtlpdb = $self; 1744 my $ret; 1745 die("TLPDB not initialized, cannot find tlpdb!") 1746 unless (defined($fromtlpdb)); 1747 1748 my $tlpobj = $fromtlpdb->get_package($pkg); 1749 if (!defined($tlpobj)) { 1750 tlwarn("TLPDB::not_virtual_install_package: cannot find package: $pkg\n"); 1751 return 0; 1752 } else { 1753 my $container_src_split = $fromtlpdb->config_src_container; 1754 my $container_doc_split = $fromtlpdb->config_doc_container; 1755 # get options about src/doc splitting from $totlpdb 1756 my $opt_src = $totlpdb->option("install_srcfiles"); 1757 my $opt_doc = $totlpdb->option("install_docfiles"); 1758 my $real_opt_doc = $opt_doc; 1759 my $reloc = 1 if $tlpobj->relocated; 1760 my $container; 1761 my @installfiles; 1762 my $root = $self->root; 1763 # make sure that there is no terminal / in $root, otherwise we 1764 # will get double // somewhere 1765 $root =~ s!/$!!; 1766 foreach ($tlpobj->runfiles) { 1767 # s!^!$root/!; 1768 push @installfiles, $_; 1769 } 1770 foreach ($tlpobj->allbinfiles) { 1771 # s!^!$root/!; 1772 push @installfiles, $_; 1773 } 1774 if ($opt_src) { 1775 foreach ($tlpobj->srcfiles) { 1776 # s!^!$root/!; 1777 push @installfiles, $_; 1778 } 1779 } 1780 if ($real_opt_doc) { 1781 foreach ($tlpobj->docfiles) { 1782 # s!^!$root/!; 1783 push @installfiles, $_; 1784 } 1785 } 1786 my $media = $self->media; 1787 my $container_is_versioned = 0; 1788 if ($media eq 'local_uncompressed') { 1789 $container = \@installfiles; 1790 } elsif ($media eq 'local_compressed') { 1791 for my $ext (map { $Compressors{$_}{'extension'} } keys %Compressors) { 1792 # request versioned containers when local (i.e., ISO image), 1793 # since the unversioned symlinks cannot be dereferenced 1794 # on Windows. 1795 my $rev = $tlpobj->revision; 1796 if (-r "$root/$Archive/$pkg.r$rev.tar.$ext") { 1797 $container_is_versioned = 1; 1798 $container = "$root/$Archive/$pkg.r$rev.tar.$ext"; 1799 } elsif (-r "$root/$Archive/$pkg.tar.$ext") { 1800 $container_is_versioned = 0; 1801 $container = "$root/$Archive/$pkg.tar.$ext"; 1802 } 1803 } 1804 if (!$container) { 1805 tlwarn("TLPDB: cannot find package $pkg.tar.$CompressorExtRegexp" 1806 . " in $root/$Archive\n"); 1807 return(0); 1808 } 1809 } elsif (&media eq 'NET') { 1810 # Since the NET server cannot be a Windows machine, 1811 # ok to request the unversioned file. 1812 $container = "$root/$Archive/$pkg.tar." 1813 . $Compressors{$DefaultCompressorFormat}{'extension'}; 1814 $container_is_versioned = 0; 1815 } 1816 my $container_str = ref $container eq "ARRAY" 1817 ? "[" . join (" ", @$container) . "]" : $container; 1818 ddebug("TLPDB::not_virtual_install_package: installing container: ", 1819 $container_str, "\n"); 1820 $self->_install_data($container, $reloc, \@installfiles, $totlpdb, 1821 $tlpobj->containersize, $tlpobj->containerchecksum) 1822 || return(0); 1823 # if we are installing from local_compressed or NET we have to fetch 1824 # respective source and doc packages $pkg.source and $pkg.doc and 1825 # install them, too 1826 if (($media eq 'NET') || ($media eq 'local_compressed')) { 1827 # we install split containers under the following conditions: 1828 # - the container were split generated 1829 # - src/doc files should be installed 1830 # (- the package is not already a split one (like .i386-linux)) 1831 # the above test has been removed because it would mean that 1832 # texlive.infra.doc.tar.xz 1833 # will never be installed, and we do already check that there 1834 # are at all src/doc files, which in split packages of the form 1835 # foo.ARCH are not present. And if they are present, than that is fine, 1836 # too (bin-foobar.windows.doc.tar.xz) 1837 # - there are actually src/doc files present 1838 if ($container_src_split && $opt_src && $tlpobj->srcfiles) { 1839 my $srccontainer = $container; 1840 if ($container_is_versioned) { 1841 $srccontainer =~ s/\.(r[0-9]*)\.tar\.$CompressorExtRegexp$/.source.$1.tar.$2/; 1842 } else { 1843 $srccontainer =~ s/\.tar\.$CompressorExtRegexp$/.source.tar.$1/; 1844 } 1845 $self->_install_data($srccontainer, $reloc, \@installfiles, $totlpdb, 1846 $tlpobj->srccontainersize, $tlpobj->srccontainerchecksum) 1847 || return(0); 1848 } 1849 if ($container_doc_split && $real_opt_doc && $tlpobj->docfiles) { 1850 my $doccontainer = $container; 1851 if ($container_is_versioned) { 1852 $doccontainer =~ s/\.(r[0-9]*)\.tar\.$CompressorExtRegexp$/.doc.$1.tar.$2/; 1853 } else { 1854 $doccontainer =~ s/\.tar\.$CompressorExtRegexp$/.doc.tar.$1/; 1855 } 1856 $self->_install_data($doccontainer, $reloc, \@installfiles, 1857 $totlpdb, $tlpobj->doccontainersize, $tlpobj->doccontainerchecksum) 1858 || return(0); 1859 } 1860 # 1861 # if we installed from NET/local_compressed and we got a relocatable container 1862 # make sure that the stray texmf-dist/tlpkg directory is removed 1863 # in USER MODE that should NOT be done because we keep the information 1864 # there, but for now do it unconditionally 1865 if ($tlpobj->relocated) { 1866 my $reloctree = $totlpdb->root . "/" . $RelocTree; 1867 my $tlpkgdir = $reloctree . "/" . $InfraLocation; 1868 my $tlpod = $tlpkgdir . "/tlpobj"; 1869 TeXLive::TLUtils::rmtree($tlpod) if (-d $tlpod); 1870 # we try to remove the tlpkg directory, that will succeed only 1871 # if it is empty. So in normal installations it won't be, but 1872 # if we are installing a relocated package it is texmf-dist/tlpkg 1873 # which will be (hopefully) empty 1874 rmdir($tlpkgdir) if (-d "$tlpkgdir"); 1875 } 1876 } 1877 # we don't want to have wrong information in the tlpdb, so remove the 1878 # src/doc files if they are not installed ... 1879 if (!$opt_src) { 1880 $tlpobj->clear_srcfiles; 1881 } 1882 if (!$real_opt_doc) { 1883 $tlpobj->clear_docfiles; 1884 } 1885 # if a package is relocatable we have to cancel the reloc prefix 1886 # and unset the relocated setting 1887 # before we save it to the local tlpdb 1888 if ($tlpobj->relocated) { 1889 if ($totlpdb->setting("usertree")) { 1890 $tlpobj->cancel_reloc_prefix; 1891 } else { 1892 $tlpobj->replace_reloc_prefix; 1893 } 1894 $tlpobj->relocated(0); 1895 } 1896 # we have to write out the tlpobj file since it is contained in the 1897 # archives (.tar.xz) but at DVD install time we don't have them 1898 my $tlpod = $totlpdb->root . "/tlpkg/tlpobj"; 1899 mkdirhier($tlpod); 1900 my $count = 0; 1901 my $tlpobj_file = ">$tlpod/" . $tlpobj->name . ".tlpobj"; 1902 until (open(TMP, $tlpobj_file)) { 1903 # The open might fail for no good reason on Windows. 1904 # Try again for a while, but not forever. 1905 if ($count++ == 100) { die "$0: open($tlpobj_file) failed: $!"; } 1906 select (undef, undef, undef, .1); # sleep briefly 1907 } 1908 $tlpobj->writeout(\*TMP); 1909 close(TMP); 1910 $totlpdb->add_tlpobj($tlpobj); 1911 $totlpdb->save; 1912 # compute the return value 1913 TeXLive::TLUtils::announce_execute_actions("enable", $tlpobj); 1914 # do the postinstallation actions 1915 # 1916 # Run the post installation code in the postaction tlpsrc entries 1917 # in case we are on w32 and the admin did install for himself only 1918 # we switch off admin mode 1919 if (wndws() && admin() && !$totlpdb->option("w32_multi_user")) { 1920 non_admin(); 1921 } 1922 # for now desktop_integration maps to both installation 1923 # of desktop shortcuts and menu items, but we can split them later 1924 &TeXLive::TLUtils::do_postaction("install", $tlpobj, 1925 $totlpdb->option("file_assocs"), 1926 $totlpdb->option("desktop_integration"), 1927 $totlpdb->option("desktop_integration"), 1928 $totlpdb->option("post_code")); 1929 } 1930 return 1; 1931 } 1932 1933 # 1934 # _install_data 1935 # actually does the installation work 1936 # returns 1 on success and 0 on error 1937 # 1938 # if the first argument is a string, then files are taken from this directory 1939 # otherwise it is a tlpdb from where to install 1940 # 1941 sub _install_data { 1942 my ($self, $what, $reloc, $filelistref, $totlpdb, $whatsize, $whatcheck) = @_; 1943 1944 my $target = $totlpdb->root; 1945 my $tempdir = TeXLive::TLUtils::tl_tmpdir(); 1946 1947 my @filelist = @$filelistref; 1948 1949 if (ref $what) { 1950 # determine the root from where we install 1951 # if the first argument $self is a string, then it should be the 1952 # root from where to install the files, otherwise it should be 1953 # a TLPDB object (installation from DVD) 1954 my $root; 1955 if (!ref($self)) { 1956 $root = $self; 1957 } else { 1958 $root = $self->root; 1959 } 1960 # if we are installing a reloc, add the RelocTree to the target 1961 if ($reloc) { 1962 if (!$totlpdb->setting("usertree")) { 1963 $target .= "/$RelocTree"; 1964 } 1965 } 1966 1967 foreach my $file (@$what) { 1968 # @what is taken, not @filelist! 1969 # is this still needed? 1970 my $dn=dirname($file); 1971 mkdirhier("$target/$dn"); 1972 TeXLive::TLUtils::copy "$root/$file", "$target/$dn"; 1973 } 1974 # we always assume that copy will work 1975 return(1); 1976 } elsif ($what =~ m,\.tar\.$CompressorExtRegexp$,) { 1977 if ($reloc) { 1978 if (!$totlpdb->setting("usertree")) { 1979 $target .= "/$RelocTree"; 1980 } 1981 } 1982 my $ww = ($whatsize || "<unset>"); 1983 my $ss = ($whatcheck || "<unset>"); 1984 debug("TLPDB::_install_data: what=$what, target=$target, size=$ww, checksum=$ss, tmpdir=$tempdir\n"); 1985 my ($ret, $pkg) = TeXLive::TLUtils::unpack($what, $target, 'size' => $whatsize, 'checksum' => $whatcheck, 'tmpdir' => $tempdir); 1986 if (!$ret) { 1987 tlwarn("TLPDB::_install_data: $pkg for $what\n"); # $pkg is error msg 1988 return(0); 1989 } 1990 # remove the $pkg.tlpobj, we recreate it anyway again 1991 unlink ("$target/tlpkg/tlpobj/$pkg.tlpobj") 1992 if (-r "$target/tlpkg/tlpobj/$pkg.tlpobj"); 1993 return(1); 1994 } else { 1995 tlwarn("TLPDB::_install_data: don't know how to install $what\n"); 1996 return(0); 1997 } 1998 } 1999 2000 =pod 2001 2002 =item << $tlpdb->remove_package($pkg, %options) >> 2003 2004 Removes a single package with all the files and the entry in the db; 2005 warns if the package does not exist. 2006 2007 =cut 2008 2009 # remove_package removes a single package with all files (including the 2010 # tlpobj files) and the entry from the tlpdb. 2011 sub remove_package { 2012 my ($self, $pkg, %opts) = @_; 2013 my $localtlpdb = $self; 2014 my $tlp = $localtlpdb->get_package($pkg); 2015 my $usertree = $localtlpdb->setting("usertree"); 2016 if (!defined($tlp)) { 2017 # we should not be called. 2018 tlwarn ("TLPDB::remove_package: package not present, ", 2019 "so nothing to remove: $pkg\n"); 2020 } else { 2021 my $currentarch = $self->platform(); 2022 if ($pkg eq "texlive.infra" || $pkg eq "texlive.infra.$currentarch") { 2023 log ("Not removing $pkg, it is essential!\n"); 2024 return 0; 2025 } 2026 # we have to chdir to $localtlpdb->root 2027 my $Master = $localtlpdb->root; 2028 chdir ($Master) || die "chdir($Master) failed: $!"; 2029 my @files = $tlp->all_files; 2030 # 2031 # also remove the .tlpobj file 2032 push @files, "tlpkg/tlpobj/$pkg.tlpobj"; 2033 # 2034 # and the ones from src/doc splitting 2035 if (-r "tlpkg/tlpobj/$pkg.source.tlpobj") { 2036 push @files, "tlpkg/tlpobj/$pkg.source.tlpobj"; 2037 } 2038 if (-r "tlpkg/tlpobj/$pkg.doc.tlpobj") { 2039 push @files, "tlpkg/tlpobj/$pkg.doc.tlpobj"; 2040 } 2041 # 2042 # some packages might be relocated, thus having the RELOC prefix 2043 # in user mode we just remove the prefix, in normal mode we 2044 # replace it with texmf-dist 2045 # since we don't have user mode 2046 if ($tlp->relocated) { 2047 for (@files) { 2048 if (!$usertree) { 2049 s:^$RelocPrefix/:$RelocTree/:; 2050 } 2051 } 2052 } 2053 # 2054 # we want to check that a file is only listed in one package, so 2055 # in case that a file to be removed is listed in another package 2056 # we will warn and *not* remove it 2057 my %allfiles; 2058 for my $p ($localtlpdb->list_packages) { 2059 next if ($p eq $pkg); # we have to skip the to be removed package 2060 for my $f ($localtlpdb->get_package($p)->all_files) { 2061 $allfiles{$f} = $p; 2062 } 2063 } 2064 my @goodfiles = (); 2065 my @badfiles = (); 2066 my @debugfiles = (); 2067 for my $f (@files) { 2068 # in usermode we have to add texmf-dist again for comparison 2069 if (defined($allfiles{$f})) { 2070 # this file should be removed but is mentioned somewhere, too 2071 # take into account if we got a warn list 2072 if (defined($opts{'remove-warn-files'})) { 2073 my %a = %{$opts{'remove-warn-files'}}; 2074 if (defined($a{$f})) { 2075 push @badfiles, $f; 2076 } else { 2077 # NO NOTHING HERE!!! 2078 # DON'T PUSH IT ON @goodfiles, it will be removed, which we do 2079 # NOT want. We only want to suppress the warning! 2080 push @debugfiles, $f; 2081 } 2082 } else { 2083 push @badfiles, $f; 2084 } 2085 } else { 2086 push @goodfiles, $f; 2087 } 2088 } 2089 if ($#debugfiles >= 0) { 2090 debug("The following files will not be removed due to the removal of $pkg.\n"); 2091 debug("But we do not warn on it because they are moved to other packages.\n"); 2092 for my $f (@debugfiles) { 2093 debug(" $f - $allfiles{$f}\n"); 2094 } 2095 } 2096 if ($#badfiles >= 0) { 2097 # warn the user 2098 tlwarn("TLPDB: These files would have been removed due to removal of\n"); 2099 tlwarn("TLPDB: $pkg, but are part of another package:\n"); 2100 for my $f (@badfiles) { 2101 tlwarn(" $f - $allfiles{$f}\n"); 2102 } 2103 } 2104 # 2105 # Run only the postaction code thing now since afterwards the 2106 # files will be gone ... 2107 if (defined($opts{'nopostinstall'}) && $opts{'nopostinstall'}) { 2108 &TeXLive::TLUtils::do_postaction("remove", $tlp, 2109 0, # tlpdbopt_file_assocs, 2110 0, # tlpdbopt_desktop_integration, menu part 2111 0, # tlpdbopt_desktop_integration, desktop part 2112 $localtlpdb->option("post_code")); 2113 } 2114 # we want to check whether we can actually remove files 2115 # there might be various reasons that this fails, like texmf-dist 2116 # directory suddently becoming ro (for whatever definition of 2117 # suddenly). 2118 my (%by_dirs, %removed_dirs) = &TeXLive::TLUtils::all_dirs_and_removed_dirs (@goodfiles); 2119 my @removals = keys %removed_dirs; 2120 2121 # we have already check for the existence of the dirs returned 2122 for my $d (keys %by_dirs) { 2123 if (! &TeXLive::TLUtils::dir_writable($d)) { 2124 tlwarn("TLPDB::remove_package: directories are not writable, cannot remove files: $d\n"); 2125 return 0; 2126 } 2127 } 2128 2129 # now do the removal 2130 for my $entry (@goodfiles) { 2131 # sometimes the files might not be there: 1) we remove .tlpobj 2132 # explicitly above; 2) we're called from tl-update-containers 2133 # to update the network tlpdb, and that doesn't have an expanded 2134 # texmf-dist. 2135 next unless -e $entry; 2136 # 2137 unlink($entry) 2138 || tlwarn("TLPDB::remove_package: Could not unlink $entry: $!\n"); 2139 } 2140 for my $d (@removals) { 2141 rmdir($d) 2142 || tlwarn("TLPDB::remove_package: Could not rmdir $d: $!\n") 2143 } 2144 $localtlpdb->remove_tlpobj($pkg); 2145 TeXLive::TLUtils::announce_execute_actions("disable", $tlp); 2146 2147 # should we save at each removal??? 2148 # advantage: the tlpdb actually reflects what is installed 2149 # disadvantage: removing a collection calls the save routine several times 2150 # still I consider it better that the tlpdb is in a consistent state 2151 $localtlpdb->save; 2152 # 2153 # Run the post installation code in the postaction tlpsrc entries 2154 # in case we are on w32 and the admin did install for himself only 2155 # we switch off admin mode 2156 if (wndws() && admin() && !$localtlpdb->option("w32_multi_user")) { 2157 non_admin(); 2158 } 2159 # 2160 # Run the post installation code in the postaction tlpsrc entries 2161 # the postaction code part cannot be evaluated now since the 2162 # files are already removed. 2163 # Again, desktop integration maps to desktop and menu links 2164 if (!$opts{'nopostinstall'}) { 2165 debug(" TLPDB::remove_package: running remove postinstall"); 2166 &TeXLive::TLUtils::do_postaction("remove", $tlp, 2167 $localtlpdb->option("file_assocs"), 2168 $localtlpdb->option("desktop_integration"), 2169 $localtlpdb->option("desktop_integration"), 2170 0); 2171 } 2172 } 2173 return 1; 2174 } 2175 2176 2177 =pod 2178 2179 =item C<< $tlpdb->option($key [, $val]) >> 2180 =item C<< $tlpdb->setting($key [, $val]) >> 2181 2182 Need to be documented 2183 2184 =cut 2185 2186 sub _set_option_value { 2187 my $self = shift; 2188 $self->_set_value_pkg('00texlive.installation', 'opt_', @_); 2189 } 2190 sub _set_setting_value { 2191 my $self = shift; 2192 $self->_set_value_pkg('00texlive.installation', 'setting_', @_); 2193 } 2194 sub _set_value_pkg { 2195 my ($self,$pkgname,$pre,$key,$value) = @_; 2196 my $k = "$pre$key"; 2197 my $pkg; 2198 if ($self->is_virtual) { 2199 $pkg = $self->{'tlpdbs'}{'main'}->get_package($pkgname); 2200 } else { 2201 $pkg = $self->{'tlps'}{$pkgname}; 2202 } 2203 my @newdeps; 2204 if (!defined($pkg)) { 2205 $pkg = new TeXLive::TLPOBJ; 2206 $pkg->name($pkgname); 2207 $pkg->category("TLCore"); 2208 push @newdeps, "$k:$value"; 2209 } else { 2210 my $found = 0; 2211 foreach my $d ($pkg->depends) { 2212 if ($d =~ m!^$k:!) { 2213 $found = 1; 2214 push @newdeps, "$k:$value"; 2215 } else { 2216 push @newdeps, $d; 2217 } 2218 } 2219 if (!$found) { 2220 push @newdeps, "$k:$value"; 2221 } 2222 } 2223 $pkg->depends(@newdeps); 2224 $self->add_tlpobj($pkg); 2225 } 2226 2227 sub _clear_option { 2228 my $self = shift; 2229 $self->_clear_pkg('00texlive.installation', 'opt_', @_); 2230 } 2231 2232 sub _clear_setting { 2233 my $self = shift; 2234 $self->_clear_pkg('00texlive.installation', 'setting_', @_); 2235 } 2236 2237 sub _clear_pkg { 2238 my ($self,$pkgname,$pre,$key) = @_; 2239 my $k = "$pre$key"; 2240 my $pkg; 2241 if ($self->is_virtual) { 2242 $pkg = $self->{'tlpdbs'}{'main'}->get_package($pkgname); 2243 } else { 2244 $pkg = $self->{'tlps'}{$pkgname}; 2245 } 2246 my @newdeps; 2247 if (!defined($pkg)) { 2248 return; 2249 } else { 2250 foreach my $d ($pkg->depends) { 2251 if ($d =~ m!^$k:!) { 2252 # do nothing, we drop the value 2253 } else { 2254 push @newdeps, $d; 2255 } 2256 } 2257 } 2258 $pkg->depends(@newdeps); 2259 $self->add_tlpobj($pkg); 2260 } 2261 2262 2263 sub _get_option_value { 2264 my $self = shift; 2265 $self->_get_value_pkg('00texlive.installation', 'opt_', @_); 2266 } 2267 2268 sub _get_setting_value { 2269 my $self = shift; 2270 $self->_get_value_pkg('00texlive.installation', 'setting_', @_); 2271 } 2272 2273 sub _get_value_pkg { 2274 my ($self,$pkg,$pre,$key) = @_; 2275 my $k = "$pre$key"; 2276 my $tlp; 2277 if ($self->is_virtual) { 2278 $tlp = $self->{'tlpdbs'}{'main'}->get_package($pkg); 2279 } else { 2280 $tlp = $self->{'tlps'}{$pkg}; 2281 } 2282 if (defined($tlp)) { 2283 foreach my $d ($tlp->depends) { 2284 if ($d =~ m!^$k:(.*)$!) { 2285 return "$1"; 2286 } 2287 } 2288 return; 2289 } 2290 tlwarn("TLPDB: $pkg not found, cannot read option $key.\n"); 2291 return; 2292 } 2293 2294 sub option_pkg { 2295 my $self = shift; 2296 my $pkg = shift; 2297 my $key = shift; 2298 if (@_) { $self->_set_value_pkg($pkg, "opt_", $key, shift); } 2299 my $ret = $self->_get_value_pkg($pkg, "opt_", $key); 2300 # special case for location == __MASTER__ 2301 if (defined($ret) && $ret eq "__MASTER__" && $key eq "location") { 2302 return $self->root; 2303 } 2304 return $ret; 2305 } 2306 sub option { 2307 my $self = shift; 2308 my $key = shift; 2309 if (@_) { $self->_set_option_value($key, shift); } 2310 my $ret = $self->_get_option_value($key); 2311 # special case for location == __MASTER__ 2312 if (defined($ret) && $ret eq "__MASTER__" && $key eq "location") { 2313 return $self->root; 2314 } 2315 return $ret; 2316 } 2317 sub setting_pkg { 2318 my $self = shift; 2319 my $pkg = shift; 2320 my $key = shift; 2321 if (@_) { 2322 if ($TLPDBSettings{$key}->[0] eq "l") { 2323 $self->_set_value_pkg($pkg, "setting_", $key, "@_"); 2324 } else { 2325 $self->_set_value_pkg($pkg, "setting_", $key, shift); 2326 } 2327 } 2328 my $ret = $self->_get_value_pkg($pkg, "setting_", $key); 2329 # check the types of the settings, and if it is a "l" return a list 2330 if ($TLPDBSettings{$key}->[0] eq "l") { 2331 my @ret; 2332 if (defined $ret) { 2333 @ret = split(" ", $ret); 2334 } else { 2335 tlwarn "TLPDB::setting_pkg: no $key, returning empty list\n"; 2336 @ret = (); 2337 } 2338 return @ret; 2339 } 2340 return $ret; 2341 } 2342 sub setting { 2343 my $self = shift; 2344 my $key = shift; 2345 if ($key eq "-clear") { 2346 my $realkey = shift; 2347 $self->_clear_setting($realkey); 2348 return; 2349 } 2350 if (@_) { 2351 if ($TLPDBSettings{$key}->[0] eq "l") { 2352 $self->_set_setting_value($key, "@_"); 2353 } else { 2354 $self->_set_setting_value($key, shift); 2355 } 2356 } 2357 my $ret = $self->_get_setting_value($key); 2358 # check the types of the settings, and if it is a "l" return a list 2359 if ($TLPDBSettings{$key}->[0] eq "l") { 2360 my @ret; 2361 if (defined $ret) { 2362 @ret = split(" ", $ret); 2363 } else { 2364 tlwarn("TLPDB::setting: no $key, returning empty list\n"); 2365 @ret = (); 2366 } 2367 return @ret; 2368 } 2369 return $ret; 2370 } 2371 2372 sub reset_options { 2373 my $self = shift; 2374 for my $k (keys %TLPDBOptions) { 2375 $self->option($k, $TLPDBOptions{$k}->[1]); 2376 } 2377 } 2378 2379 sub add_default_options { 2380 my $self = shift; 2381 for my $k (sort keys %TLPDBOptions) { 2382 # if the option is not set already, do set it to defaults 2383 if (! $self->option($k) ) { 2384 $self->option($k, $TLPDBOptions{$k}->[1]); 2385 } 2386 } 2387 } 2388 2389 =pod 2390 2391 =item C<< $tlpdb->options >> 2392 2393 Returns a reference to a hash with option names. 2394 2395 =cut 2396 2397 sub _keyshash { 2398 my ($self, $pre, $hr) = @_; 2399 my @allowed = keys %$hr; 2400 my %ret; 2401 my $pkg; 2402 if ($self->is_virtual) { 2403 $pkg = $self->{'tlpdbs'}{'main'}->get_package('00texlive.installation'); 2404 } else { 2405 $pkg = $self->{'tlps'}{'00texlive.installation'}; 2406 } 2407 if (defined($pkg)) { 2408 foreach my $d ($pkg->depends) { 2409 if ($d =~ m!^$pre([^:]*):(.*)!) { 2410 if (member($1, @allowed)) { 2411 $ret{$1} = $2; 2412 } else { 2413 tlwarn("TLPDB::_keyshash: Unsupported option/setting $d\n"); 2414 } 2415 } 2416 } 2417 } 2418 return \%ret; 2419 } 2420 2421 sub options { 2422 my $self = shift; 2423 return ($self->_keyshash('opt_', \%TLPDBOptions)); 2424 } 2425 sub settings { 2426 my $self = shift; 2427 return ($self->_keyshash('setting_', \%TLPDBSettings)); 2428 } 2429 2430 =pod 2431 2432 =item C<< $tlpdb->format_definitions >> 2433 2434 This function returns a list of references to hashes where each hash 2435 represents a parsed AddFormat line. 2436 2437 =cut 2438 2439 sub format_definitions { 2440 my $self = shift; 2441 my @ret; 2442 foreach my $p ($self->list_packages) { 2443 my $obj = $self->get_package ($p); 2444 die "$0: No TeX Live package named $p, strange" if ! $obj; 2445 push @ret, $obj->format_definitions; 2446 } 2447 return(@ret); 2448 } 2449 2450 =item C<< $tlpdb->fmtutil_cnf_lines >> 2451 2452 The function C<fmtutil_cnf_lines> returns the list of a fmtutil.cnf file 2453 containing only those formats present in the installation. 2454 2455 Every format listed in the tlpdb but listed in the arguments 2456 will not be included in the list of lines returned. 2457 2458 =cut 2459 sub fmtutil_cnf_lines { 2460 my $self = shift; 2461 my @lines; 2462 foreach my $p ($self->list_packages) { 2463 my $obj = $self->get_package ($p); 2464 die "$0: No TeX Live package named $p, strange" if ! $obj; 2465 push @lines, $obj->fmtutil_cnf_lines(@_); 2466 } 2467 return(@lines); 2468 } 2469 2470 =item C<< $tlpdb->updmap_cfg_lines ( [@disabled_maps] ) >> 2471 2472 The function C<updmap_cfg_lines> returns the list of a updmap.cfg file 2473 containing only those maps present in the installation. 2474 2475 A map file mentioned in the tlpdb but listed in the arguments will not 2476 be included in the list of lines returned. 2477 2478 =cut 2479 sub updmap_cfg_lines { 2480 my $self = shift; 2481 my @lines; 2482 foreach my $p ($self->list_packages) { 2483 my $obj = $self->get_package ($p); 2484 die "$0: No TeX Live package named $p, strange" if ! $obj; 2485 push @lines, $obj->updmap_cfg_lines(@_); 2486 } 2487 return(@lines); 2488 } 2489 2490 =item C<< $tlpdb->language_dat_lines ( [@disabled_hyphen_names] ) >> 2491 2492 The function C<language_dat_lines> returns the list of all 2493 lines for language.dat that can be generated from the tlpdb. 2494 2495 Every hyphenation pattern listed in the tlpdb but listed in the arguments 2496 will not be included in the list of lines returned. 2497 2498 =cut 2499 2500 sub language_dat_lines { 2501 my $self = shift; 2502 my @lines; 2503 foreach my $p ($self->list_packages) { 2504 my $obj = $self->get_package ($p); 2505 die "$0: No TeX Live package named $p, strange" if ! $obj; 2506 push @lines, $obj->language_dat_lines(@_); 2507 } 2508 return(@lines); 2509 } 2510 2511 =item C<< $tlpdb->language_def_lines ( [@disabled_hyphen_names] ) >> 2512 2513 The function C<language_def_lines> returns the list of all 2514 lines for language.def that can be generated from the tlpdb. 2515 2516 Every hyphenation pattern listed in the tlpdb but listed in the arguments 2517 will not be included in the list of lines returned. 2518 2519 =cut 2520 2521 sub language_def_lines { 2522 my $self = shift; 2523 my @lines; 2524 foreach my $p ($self->list_packages) { 2525 my $obj = $self->get_package ($p); 2526 die "$0: No TeX Live package named $p, strange" if ! $obj; 2527 push @lines, $obj->language_def_lines(@_); 2528 } 2529 return(@lines); 2530 } 2531 2532 =item C<< $tlpdb->language_lua_lines ( [@disabled_hyphen_names] ) >> 2533 2534 The function C<language_lua_lines> returns the list of all 2535 lines for language.dat.lua that can be generated from the tlpdb. 2536 2537 Every hyphenation pattern listed in the tlpdb but listed in the arguments 2538 will not be included in the list of lines returned. 2539 2540 =cut 2541 2542 sub language_lua_lines { 2543 my $self = shift; 2544 my @lines; 2545 foreach my $p ($self->list_packages) { 2546 my $obj = $self->get_package ($p); 2547 die "$0: No TeX Live package named $p, strange" if ! $obj; 2548 push @lines, $obj->language_lua_lines(@_); 2549 } 2550 return(@lines); 2551 } 2552 2553 =back 2554 2555 =head1 VIRTUAL DATABASES 2556 2557 The purpose of virtual databases is to collect several data sources 2558 and present them in one way. The normal functions will always return 2559 the best candidate for the set of functions. 2560 2561 More docs to be written someday, maybe. 2562 2563 =over 4 2564 2565 =cut 2566 2567 # 2568 # packages are saved: 2569 # $self->{'packages'}{$pkgname}{'tags'}{$tag}{'revision'} = $rev 2570 # $self->{'packages'}{$pkgname}{'tags'}{$tag}{'tlp'} = $tlp 2571 # $self->{'packages'}{$pkgname}{'target'} = $target_tag 2572 # 2573 2574 sub is_virtual { 2575 my $self = shift; 2576 if (defined($self->{'virtual'}) && $self->{'virtual'}) { 2577 return 1; 2578 } 2579 return 0; 2580 } 2581 2582 sub make_virtual { 2583 my $self = shift; 2584 if (!$self->is_virtual) { 2585 if ($self->list_packages) { 2586 tlwarn("TLPDB: cannot convert initialized tlpdb to virtual\n"); 2587 return 0; 2588 } 2589 $self->{'virtual'} = 1; 2590 } 2591 return 1; 2592 } 2593 2594 sub virtual_get_tags { 2595 my $self = shift; 2596 return keys %{$self->{'tlpdbs'}}; 2597 } 2598 2599 sub virtual_get_tlpdb { 2600 my ($self, $tag) = @_; 2601 if (!$self->is_virtual) { 2602 tlwarn("TLPDB: cannot remove tlpdb from a non-virtual tlpdb!\n"); 2603 return 0; 2604 } 2605 if (!defined($self->{'tlpdbs'}{$tag})) { 2606 tlwarn("TLPDB::virtual_get_tlpdb: unknown tag: $tag\n"); 2607 return 0; 2608 } 2609 return $self->{'tlpdbs'}{$tag}; 2610 } 2611 2612 sub virtual_add_tlpdb { 2613 my ($self, $tlpdb, $tag) = @_; 2614 if (!$self->is_virtual) { 2615 tlwarn("TLPDB: cannot virtual_add_tlpdb to a non-virtual tlpdb!\n"); 2616 return 0; 2617 } 2618 $self->{'tlpdbs'}{$tag} = $tlpdb; 2619 for my $p ($tlpdb->list_packages) { 2620 my $tlp = $tlpdb->get_package($p); 2621 $self->{'packages'}{$p}{'tags'}{$tag}{'revision'} = $tlp->revision; 2622 $self->{'packages'}{$p}{'tags'}{$tag}{'tlp'} = $tlp; 2623 } 2624 $self->check_evaluate_pinning(); 2625 return 1; 2626 } 2627 2628 sub virtual_remove_tlpdb { 2629 my ($self, $tag) = @_; 2630 if (!$self->is_virtual) { 2631 tlwarn("TLPDB: Cannot remove tlpdb from a non-virtual tlpdb!\n"); 2632 return 0; 2633 } 2634 if (!defined($self->{'tlpdbs'}{$tag})) { 2635 tlwarn("TLPDB: virtual_remove_tlpdb: unknown tag $tag\n"); 2636 return 0; 2637 } 2638 for my $p ($self->{'tlpdbs'}{$tag}->list_packages) { 2639 delete $self->{'packages'}{$p}{'tags'}{$tag}; 2640 } 2641 delete $self->{'tlpdbs'}{$tag}; 2642 $self->check_evaluate_pinning(); 2643 return 1; 2644 } 2645 2646 sub virtual_get_package { 2647 my ($self, $pkg, $tag) = @_; 2648 if (defined($self->{'packages'}{$pkg}{'tags'}{$tag})) { 2649 return $self->{'packages'}{$pkg}{'tags'}{$tag}{'tlp'}; 2650 } else { 2651 tlwarn("TLPDB: virtual pkg $pkg not found in tag $tag\n"); 2652 return; 2653 } 2654 } 2655 2656 =item C<< $tlpdb->candidates ( $pkg ) >> 2657 2658 Returns the list of candidates for the given package in the 2659 format 2660 2661 tag/revision 2662 2663 If the returned list is empty, then the database was not virtual and 2664 no install candidate was found. 2665 2666 If the returned list contains undef as first element, the database 2667 is virtual, and no install candidate was found. 2668 2669 The remaining elements in the list are all repositories that provide 2670 that package. 2671 2672 Note that there might not be an install candidate, but still the 2673 package is provided by a sub-repository. This can happen if a package 2674 is present only in the sub-repository and there is no explicit pin 2675 for that package in the pinning file. 2676 2677 =cut 2678 2679 sub is_repository { 2680 my $self = shift; 2681 my $tag = shift; 2682 if (!$self->is_virtual) { 2683 return ( ($tag eq $self->{'root'}) ? 1 : 0 ); 2684 } 2685 return ( defined($self->{'tlpdbs'}{$tag}) ? 1 : 0 ); 2686 } 2687 2688 2689 # returns a list of tag/rev 2690 sub candidates { 2691 my $self = shift; 2692 my $pkg = shift; 2693 my @ret = (); 2694 if ($self->is_virtual) { 2695 if (defined($self->{'packages'}{$pkg})) { 2696 my $t = $self->{'packages'}{$pkg}{'target'}; 2697 if (defined($t)) { 2698 push @ret, "$t/" . $self->{'packages'}{$pkg}{'tags'}{$t}{'revision'}; 2699 } else { 2700 $t = ""; 2701 # no target found, but maybe available somewhere else, 2702 # we return undef as first one 2703 push @ret, undef; 2704 } 2705 # make sure that we always check for main as repo 2706 my @repos = keys %{$self->{'packages'}{$pkg}}; 2707 for my $r (sort keys %{$self->{'packages'}{$pkg}{'tags'}}) { 2708 push @ret, "$r/" . $self->{'packages'}{$pkg}{'tags'}{$r}{'revision'} 2709 if ($t ne $r); 2710 } 2711 } 2712 } else { 2713 my $tlp = $self->get_package($pkg); 2714 if (defined($tlp)) { 2715 push @ret, "main/" . $tlp->revision; 2716 } 2717 } 2718 return @ret; 2719 } 2720 2721 =item C<< $tlpdb->candidate ( ) >> 2722 2723 Returns either a list of four undef, if no install candidate is found, 2724 or the following information on the install candidate as list: the tag 2725 name of the repository, the revision number of the package in the 2726 candidate repository, the tlpobj of the package in the candidate 2727 repository, and the candidate repository's TLPDB itself. 2728 2729 =cut 2730 2731 # 2732 sub virtual_candidate { 2733 my ($self, $pkg) = @_; 2734 my $t = $self->{'packages'}{$pkg}{'target'}; 2735 if (defined($t)) { 2736 return ($t, $self->{'packages'}{$pkg}{'tags'}{$t}{'revision'}, 2737 $self->{'packages'}{$pkg}{'tags'}{$t}{'tlp'}, $self->{'tlpdbs'}{$t}); 2738 } 2739 return(undef,undef,undef,undef); 2740 } 2741 2742 =item C<< $tlpdb->virtual_pinning ( [ $pinfile_TLConfFile] ) >> 2743 2744 Sets or returns the C<TLConfFile> object for the pinning data. 2745 2746 =cut 2747 2748 sub virtual_pindata { 2749 my $self = shift; 2750 return ($self->{'pindata'}); 2751 } 2752 2753 sub virtual_update_pins { 2754 my $self = shift; 2755 if (!$self->is_virtual) { 2756 tlwarn("TLPDB::virtual_update_pins: Non-virtual tlpdb can't have pins.\n"); 2757 return 0; 2758 } 2759 my $pincf = $self->{'pinfile'}; 2760 my @pins; 2761 for my $k ($pincf->keys) { 2762 for my $v ($pincf->value($k)) { 2763 # we recompose the values into lines again, as we *might* have 2764 # options later, i.e., lines of the format 2765 # repo:pkg:opt 2766 push (@pins, $self->make_pin_data_from_line("$k:$v")); 2767 } 2768 } 2769 $self->{'pindata'} = \@pins; 2770 $self->check_evaluate_pinning(); 2771 return ($self->{'pindata'}); 2772 } 2773 sub virtual_pinning { 2774 my ($self, $pincf) = @_; 2775 if (!$self->is_virtual) { 2776 tlwarn("TLPDB::virtual_pinning: Non-virtual tlpdb can't have pins.\n"); 2777 return 0; 2778 } 2779 if (!defined($pincf)) { 2780 return ($self->{'pinfile'}); 2781 } 2782 $self->{'pinfile'} = $pincf; 2783 $self->virtual_update_pins(); 2784 return ($self->{'pinfile'}); 2785 } 2786 2787 # 2788 # current format: 2789 # <repo>:<pkg_glob>[,<pkg_glob>,...][:<options>] 2790 # only supported options for now is 2791 # revision 2792 # meaning that, if for the selected package there is no other 2793 # "non-revision" pinning, then all repo/package versions are compared 2794 # using normal revision comparison, and the biggest revision number wins. 2795 # That allows you to have the same package in several repos: 2796 # repo1:foo:revision 2797 # repo2:foo:revision 2798 # repo1:* 2799 # repo2:* 2800 # means that: 2801 # for package "foo" the revision numbers of "foo" in the repos "repo1", 2802 # "repo2", and "main" are numerically compared and biggest number wins. 2803 # for all other packages of "repo1" and "repo2", other repositories 2804 # are not considered. 2805 # 2806 # NOT IMPLEMENTED YET!!! 2807 # 2808 # $pin{'repo'} = $repo; 2809 # $pin{'glob'} = $glob; 2810 # $pin{'re'} = $re; 2811 # $pin{'line'} = $line; # for debug/warning purpose 2812 sub make_pin_data_from_line { 2813 my $self = shift; 2814 my $l = shift; 2815 my ($a, $b, $c) = split(/:/, $l); 2816 my @ret; 2817 my %m; 2818 $m{'repo'} = $a; 2819 $m{'line'} = $l; 2820 if (defined($c)) { 2821 $m{'options'} = $c; 2822 } 2823 # split the package globs 2824 for (split(/,/, $b)) { 2825 # remove leading and terminal white space 2826 s/^\s*//; 2827 s/\s*$//; 2828 my %mm = %m; 2829 $mm{'glob'} = $_; 2830 $mm{'re'} = glob_to_regex($_); 2831 push @ret, \%mm; 2832 } 2833 return @ret; 2834 } 2835 2836 sub check_evaluate_pinning { 2837 my $self = shift; 2838 my @pins = (defined($self->{'pindata'}) ? @{$self->{'pindata'}} : ()); 2839 # 2840 # run through the pin lines and make sure that all the conditions 2841 # and requirements are obeyed 2842 my %pkgs = %{$self->{'packages'}}; 2843 # main:* 2844 my ($mainpin) = $self->make_pin_data_from_line("main:*"); 2845 # the default main:* is always considered to be matched 2846 $mainpin->{'hit'} = 1; 2847 push @pins, $mainpin; 2848 # # sort pins so that we first check specific lines without occurrences of 2849 # # special characters, and then those with special characters. 2850 # # The definitions are based on glob style rules, saved in $pp->{'glob'} 2851 # # so we simply check whether there is * or ? in the string 2852 # @pins = sort { 2853 # my $ag = $a->{'glob'}; 2854 # my $bg = $b->{'glob'}; 2855 # my $cAs = () = $ag =~ /\*/g; # number of * in glob of $a 2856 # my $cBs = () = $bg =~ /\*/g; # number of * in glob of $b 2857 # my $cAq = () = $ag =~ /\?/g; # number of ? in glob of $a 2858 # my $cBq = () = $bg =~ /\?/g; # number of ? in glob of $b 2859 # my $aVal = 2 * $cAs + $cAq; 2860 # my $bVal = 2 * $cBs + $cBq; 2861 # $aVal <=> $bVal 2862 # } @pins; 2863 for my $pkg (keys %pkgs) { 2864 PINS: for my $pp (@pins) { 2865 my $pre = $pp->{'re'}; 2866 if (($pkg =~ m/$pre/) && 2867 (defined($self->{'packages'}{$pkg}{'tags'}{$pp->{'repo'}}))) { 2868 $self->{'packages'}{$pkg}{'target'} = $pp->{'repo'}; 2869 # register that this pin was hit 2870 $pp->{'hit'} = 1; 2871 last PINS; 2872 } 2873 } 2874 } 2875 # check that all pinning lines where hit 2876 # If a repository has a catch-all pin 2877 # foo:* 2878 # then we do not warn about any other pin (foo:abcde) not being hit. 2879 my %catchall; 2880 for my $p (@pins) { 2881 $catchall{$p->{'repo'}} = 1 if ($p->{'glob'} eq "*"); 2882 } 2883 for my $p (@pins) { 2884 next if defined($p->{'hit'}); 2885 next if defined($catchall{$p->{'repo'}}); 2886 tlwarn("tlmgr (TLPDB): pinning warning: the package pattern ", 2887 $p->{'glob'}, " on the line:\n ", $p->{'line'}, 2888 "\n does not match any package\n"); 2889 } 2890 } 2891 2892 2893 # implementation copied from Text/Glob.pm (copyright Richard Clamp). 2894 # changes made: 2895 # remove $strict_leading_dot and $strict_wildcard_slash if calls 2896 # and execute the code unconditionally, as we do not change the 2897 # default settings of 1 of these two variables. 2898 sub glob_to_regex { 2899 my $glob = shift; 2900 my $regex = glob_to_regex_string($glob); 2901 return qr/^$regex$/; 2902 } 2903 2904 sub glob_to_regex_string 2905 { 2906 my $glob = shift; 2907 my ($regex, $in_curlies, $escaping); 2908 local $_; 2909 my $first_byte = 1; 2910 for ($glob =~ m/(.)/gs) { 2911 if ($first_byte) { 2912 $regex .= '(?=[^\.])' unless $_ eq '.'; 2913 $first_byte = 0; 2914 } 2915 if ($_ eq '/') { 2916 $first_byte = 1; 2917 } 2918 if ($_ eq '.' || $_ eq '(' || $_ eq ')' || $_ eq '|' || 2919 $_ eq '+' || $_ eq '^' || $_ eq '$' || $_ eq '@' || $_ eq '%' ) { 2920 $regex .= "\\$_"; 2921 } 2922 elsif ($_ eq '*') { 2923 $regex .= $escaping ? "\\*" : "[^/]*"; 2924 } 2925 elsif ($_ eq '?') { 2926 $regex .= $escaping ? "\\?" : "[^/]"; 2927 } 2928 elsif ($_ eq '{') { 2929 $regex .= $escaping ? "\\{" : "("; 2930 ++$in_curlies unless $escaping; 2931 } 2932 elsif ($_ eq '}' && $in_curlies) { 2933 $regex .= $escaping ? "}" : ")"; 2934 --$in_curlies unless $escaping; 2935 } 2936 elsif ($_ eq ',' && $in_curlies) { 2937 $regex .= $escaping ? "," : "|"; 2938 } 2939 elsif ($_ eq "\\") { 2940 if ($escaping) { 2941 $regex .= "\\\\"; 2942 $escaping = 0; 2943 } 2944 else { 2945 $escaping = 1; 2946 } 2947 next; 2948 } 2949 else { 2950 $regex .= $_; 2951 $escaping = 0; 2952 } 2953 $escaping = 0; 2954 } 2955 print "# $glob $regex\n" if debug; 2956 2957 return $regex; 2958 } 2959 2960 sub match_glob { 2961 print "# ", join(', ', map { "'$_'" } @_), "\n" if debug; 2962 my $glob = shift; 2963 my $regex = glob_to_regex $glob; 2964 local $_; 2965 grep { $_ =~ $regex } @_; 2966 } 2967 2968 =pod 2969 2970 =back 2971 2972 =head1 OPTIONS 2973 2974 Options regarding the full TeX Live installation to be described are saved 2975 in a package C<00texlive.config> as values of C<depend> lines. This special 2976 package C<00texlive.config> does not contain any files, only depend lines 2977 which set one or more of the following options: 2978 2979 =over 4 2980 2981 =item C<container_split_src_files/[01]> 2982 2983 =item C<container_split_doc_files/[01]> 2984 2985 These options specify that at container generation time the source and 2986 documentation files for a package have been put into a separate container 2987 named C<package.source.extension> and C<package.doc.extension>. 2988 2989 =item C<container_format/I<format>> 2990 2991 This option specifies a format for containers. The currently supported 2992 formats are C<xz> and C<zip>. But note that C<zip> is untested. 2993 2994 =item C<release/I<relspec>> 2995 2996 This option specifies the current release. The first four characters must 2997 be a year. 2998 2999 =item C<minrelease/I<relspec>> 3000 3001 This option specifies the minimum release for which this repository is 3002 valid. 3003 3004 =back 3005 3006 To set these options the respective lines should be added to 3007 C<00texlive.config.tlpsrc>. 3008 3009 =head1 SEE ALSO 3010 3011 The modules L<TeXLive::TLPSRC>, L<TeXLive::TLPOBJ>, L<TeXLive::TLTREE>, 3012 L<TeXLive::TLUtils>, etc., and the documentation in the repository: 3013 C<Master/tlpkg/doc/>. 3014 3015 =head1 AUTHORS AND COPYRIGHT 3016 3017 This script and its documentation were written for the TeX Live 3018 distribution (L<https://tug.org/texlive>) and both are licensed under the 3019 GNU General Public License Version 2 or later. 3020 3021 =cut 3022 3023 1; 3024 3025 ### Local Variables: 3026 ### perl-indent-level: 2 3027 ### tab-width: 2 3028 ### indent-tabs-mode: nil 3029 ### End: 3030 # vim:set tabstop=2 shiftwidth=2 expandtab autoindent: #