1# $Id: TLUtils.pm 37234 2015-05-06 20:30:33Z siepo $ 2# TeXLive::TLUtils.pm - the inevitable utilities for TeX Live. 3# Copyright 2007-2015 Norbert Preining, Reinhard Kotucha 4# This file is licensed under the GNU General Public License version 2 5# or any later version. 6 7package TeXLive::TLUtils; 8 9my $svnrev = '$Revision: 37234 $'; 10my $_modulerevision; 11if ($svnrev =~ m/: ([0-9]+) /) { 12 $_modulerevision = $1; 13} else { 14 $_modulerevision = "unknown"; 15} 16sub module_revision { 17 return $_modulerevision; 18} 19 20=pod 21 22=head1 NAME 23 24C<TeXLive::TLUtils> -- utilities used in the TeX Live infrastructure 25 26=head1 SYNOPSIS 27 28 use TeXLive::TLUtils; 29 30=head2 Platform detection 31 32 TeXLive::TLUtils::platform(); 33 TeXLive::TLUtils::platform_name($canonical_host); 34 TeXLive::TLUtils::platform_desc($platform); 35 TeXLive::TLUtils::win32(); 36 TeXLive::TLUtils::unix(); 37 38=head2 System tools 39 40 TeXLive::TLUtils::getenv($string); 41 TeXLive::TLUtils::which($string); 42 TeXLive::TLUtils::get_system_tmpdir(); 43 TeXLive::TLUtils::tl_tmpdir(); 44 TeXLive::TLUtils::xchdir($dir); 45 TeXLive::TLUtils::wsystem($msg,@args); 46 TeXLive::TLUtils::xsystem(@args); 47 TeXLive::TLUtils::run_cmd($cmd); 48 49=head2 File utilities 50 51 TeXLive::TLUtils::dirname($path); 52 TeXLive::TLUtils::basename($path); 53 TeXLive::TLUtils::dirname_and_basename($path); 54 TeXLive::TLUtils::tl_abs_path($path); 55 TeXLive::TLUtils::dir_writable($path); 56 TeXLive::TLUtils::dir_creatable($path); 57 TeXLive::TLUtils::mkdirhier($path); 58 TeXLive::TLUtils::rmtree($root, $verbose, $safe); 59 TeXLive::TLUtils::copy($file, $target_dir); 60 TeXLive::TLUtils::touch(@files); 61 TeXLive::TLUtils::collapse_dirs(@files); 62 TeXLive::TLUtils::removed_dirs(@files); 63 TeXLive::TLUtils::download_file($path, $destination [, $progs ]); 64 TeXLive::TLUtils::setup_programs($bindir, $platform); 65 TeXLive::TLUtils::tlcmp($file, $file); 66 TeXLive::TLUtils::nulldev(); 67 TeXLive::TLUtils::get_full_line($fh); 68 69=head2 Installer functions 70 71 TeXLive::TLUtils::make_var_skeleton($path); 72 TeXLive::TLUtils::make_local_skeleton($path); 73 TeXLive::TLUtils::create_fmtutil($tlpdb,$dest); 74 TeXLive::TLUtils::create_updmap($tlpdb,$dest); 75 TeXLive::TLUtils::create_language_dat($tlpdb,$dest,$localconf); 76 TeXLive::TLUtils::create_language_def($tlpdb,$dest,$localconf); 77 TeXLive::TLUtils::create_language_lua($tlpdb,$dest,$localconf); 78 TeXLive::TLUtils::time_estimate($totalsize, $donesize, $starttime) 79 TeXLive::TLUtils::install_packages($from_tlpdb,$media,$to_tlpdb,$what,$opt_src, $opt_doc)>); 80 TeXLive::TLUtils::install_package($what, $filelistref, $target, $platform); 81 TeXLive::TLUtils::do_postaction($how, $tlpobj, $do_fileassocs, $do_menu, $do_desktop, $do_script); 82 TeXLive::TLUtils::announce_execute_actions($how, @executes); 83 TeXLive::TLUtils::add_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info); 84 TeXLive::TLUtils::remove_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info); 85 TeXLive::TLUtils::w32_add_to_path($bindir, $multiuser); 86 TeXLive::TLUtils::w32_remove_from_path($bindir, $multiuser); 87 TeXLive::TLUtils::setup_persistent_downloads(); 88 89=head2 Miscellaneous 90 91 TeXLive::TLUtils::sort_uniq(@list); 92 TeXLive::TLUtils::push_uniq(\@list, @items); 93 TeXLive::TLUtils::member($item, @list); 94 TeXLive::TLUtils::merge_into(\%to, \%from); 95 TeXLive::TLUtils::texdir_check($texdir); 96 TeXLive::TLUtils::quotify_path_with_spaces($path); 97 TeXLive::TLUtils::conv_to_w32_path($path); 98 TeXLive::TLUtils::native_slashify($internal_path); 99 TeXLive::TLUtils::forward_slashify($path_from_user); 100 TeXLive::TLUtils::give_ctan_mirror(); 101 TeXLive::TLUtils::give_ctan_mirror_base(); 102 TeXLive::TLUtils::tlmd5($path); 103 TeXLive::TLUtils::compare_tlpobjs($tlpA, $tlpB); 104 TeXLive::TLUtils::compare_tlpdbs($tlpdbA, $tlpdbB); 105 TeXLive::TLUtils::report_tlpdb_differences(\%ret); 106 TeXLive::TLUtils::tlnet_disabled_packages($root); 107 TeXLive::TLUtils::mktexupd(); 108 109=head1 DESCRIPTION 110 111=cut 112 113# avoid -warnings. 114our $PERL_SINGLE_QUOTE; # we steal code from Text::ParseWords 115use vars qw( 116 $::LOGFILENAME @::LOGLINES 117 @::debug_hook @::ddebug_hook @::dddebug_hook @::info_hook @::warn_hook 118 @::install_packages_hook 119 $::latex_updated 120 $::machinereadable 121 $::no_execute_actions 122 $::regenerate_all_formats 123 $::tex_updated 124 $TeXLive::TLDownload::net_lib_avail 125); 126 127BEGIN { 128 use Exporter (); 129 use vars qw(@ISA @EXPORT_OK @EXPORT); 130 @ISA = qw(Exporter); 131 @EXPORT_OK = qw( 132 &platform 133 &platform_name 134 &platform_desc 135 &unix 136 &getenv 137 &which 138 &get_system_tmpdir 139 &dirname 140 &basename 141 &dirname_and_basename 142 &tl_abs_path 143 &dir_writable 144 &dir_creatable 145 &mkdirhier 146 &rmtree 147 © 148 &touch 149 &collapse_dirs 150 &removed_dirs 151 &install_package 152 &install_packages 153 &make_var_skeleton 154 &make_local_skeleton 155 &create_fmtutil 156 &create_updmap 157 &create_language_dat 158 &create_language_def 159 &create_language_lua 160 &parse_AddFormat_line 161 &parse_AddHyphen_line 162 &sort_uniq 163 &push_uniq 164 &texdir_check 165 &member 166 "ewords 167 "ify_path_with_spaces 168 &conv_to_w32_path 169 &native_slashify 170 &forward_slashify 171 &untar 172 &unpack 173 &merge_into 174 &give_ctan_mirror 175 &give_ctan_mirror_base 176 &create_mirror_list 177 &extract_mirror_entry 178 &tlmd5 179 &wsystem 180 &xsystem 181 &run_cmd 182 &announce_execute_actions 183 &add_symlinks 184 &remove_symlinks 185 &w32_add_to_path 186 &w32_remove_from_path 187 &tlcmp 188 &time_estimate 189 &compare_tlpobjs 190 &compare_tlpdbs 191 &report_tlpdb_differences 192 &setup_persistent_downloads 193 &mktexupd 194 &nulldev 195 &get_full_line 196 &sort_archs 197 ); 198 @EXPORT = qw(setup_programs download_file process_logging_options 199 tldie tlwarn info log debug ddebug dddebug debug_hash 200 win32 xchdir xsystem run_cmd sort_archs); 201} 202 203use Cwd; 204use Digest::MD5; 205use Getopt::Long; 206use File::Temp; 207 208use TeXLive::TLConfig; 209 210$::opt_verbosity = 0; # see process_logging_options 211 212 213=head2 Platform detection 214 215=over 4 216 217=item C<platform> 218 219If C<$^O=~/MSWin(32|64)$/i> is true we know that we're on 220Windows and we set the global variable C<$::_platform_> to C<win32>. 221Otherwise we call C<platform_name> with the output of C<config.guess> 222as argument. 223 224The result is stored in a global variable C<$::_platform_>, and 225subsequent calls just return that value. 226 227=cut 228 229sub platform { 230 unless (defined $::_platform_) { 231 chomp(my $uname_m = `uname -m`); 232 chomp(my $uname_r = `uname -r`); 233 chomp(my $uname_s = `uname -s`); 234 $uname_r =~ s/-.*$//; 235 $uname_s = lc($uname_s); 236 $guessed_platform = sprintf("%s-unknown-%s%s", $uname_m, 237 $uname_s, $uname_r); 238 $::_platform_ = platform_name($guessed_platform); 239 } 240 return $::_platform_; 241} 242 243 244=item C<platform_name($canonical_host)> 245 246Convert a canonical host names as returned by C<config.guess> into 247TeX Live platform names. 248 249CPU type is determined by a regexp, and any C</^i.86/> name is replaced 250by C<i386>. 251 252For OS we need a list because what's returned is not likely to match our 253historical names, e.g., C<config.guess> returns C<linux-gnu> but we need 254C<linux>. This list might/should contain OSs which are not currently 255supported. 256 257If a particular platform is not found in this list we use the regexp 258C</.*-(.*$)/> as a last resort and hope it provides something useful. 259 260=cut 261 262sub platform_name { 263 my ($guessed_platform) = @_; 264 265 $guessed_platform =~ s/^x86_64-(.*-k?)(free|net)bsd/amd64-$1$2bsd/; 266 my $CPU; # CPU type as reported by config.guess. 267 my $OS; # O/S type as reported by config.guess. 268 ($CPU = $guessed_platform) =~ s/(.*?)-.*/$1/; 269 $CPU =~ s/^alpha(.*)/alpha/; # alphaev whatever 270 $CPU =~ s/mips64el/mipsel/; # don't distinguish mips64 and 32 el 271 $CPU =~ s/powerpc64/powerpc/; # don't distinguish ppc64 272 $CPU =~ s/sparc64/sparc/; # don't distinguish sparc64 273 274 # armv6l-unknown-linux-gnueabihf -> armhf-linux (RPi) 275 # armv7l-unknown-linux-gnueabi -> armel-linux (Android) 276 if ($CPU =~ /^arm/) { 277 $CPU = $guessed_platform =~ /hf$/ ? "armhf" : "armel"; 278 } 279 280 my @OSs = qw(aix cygwin darwin freebsd hpux irix 281 kfreebsd linux netbsd openbsd solaris); 282 for my $os (@OSs) { 283 # Match word boundary at the beginning of the os name so that 284 # freebsd and kfreebsd are distinguished. 285 # Do not match word boundary at the end of the os so that 286 # solaris2 is matched. 287 $OS = $os if $guessed_platform =~ /\b$os/; 288 } 289 290 if ($OS eq "darwin") { 291 # We want to guess x86_64-darwin on new-enough systems. 292 # Most robust approach is to check sw_vers (os version) 293 # and sysctl (processor hardware). 294 chomp (my $sw_vers = `sw_vers -productVersion`); 295 my ($os_major,$os_minor) = split (/\./, $sw_vers); 296 # 297 chomp (my $sysctl = `PATH=/usr/sbin:\$PATH sysctl hw.cpu64bit_capable`); 298 my (undef,$hw_64_bit) = split (" ", $sysctl); 299 # 300 $CPU = ($os_major >= 10 && $os_minor >= 6 && $hw_64_bit >= 1) 301 ? "x86_64" : "universal"; 302 303 } elsif ($CPU =~ /^i.86$/) { 304 $CPU = "i386"; # 586, 686, whatever 305 } 306 307 if (! defined $OS) { 308 ($OS = $guessed_platform) =~ s/.*-(.*)/$1/; 309 } 310 311 return "$CPU-$OS"; 312} 313 314=item C<platform_desc($platform)> 315 316Return a string which describes a particular platform identifier, e.g., 317given C<i386-linux> we return C<Intel x86 with GNU/Linux>. 318 319=cut 320 321sub platform_desc { 322 my ($platform) = @_; 323 324 my %platform_name = ( 325 'alpha-linux' => 'GNU/Linux on DEC Alpha', 326 'amd64-freebsd' => 'FreeBSD on x86_64', 327 'amd64-kfreebsd' => 'GNU/kFreeBSD on x86_64', 328 'amd64-netbsd' => 'NetBSD on x86_64', 329 'armel-linux' => 'GNU/Linux on ARM', 330 'armhf-linux' => 'GNU/Linux on ARMhf', 331 'hppa-hpux' => 'HP-UX', 332 'i386-cygwin' => 'Cygwin on Intel x86', 333 'i386-darwin' => 'MacOSX/Darwin on Intel x86', 334 'i386-freebsd' => 'FreeBSD on Intel x86', 335 'i386-kfreebsd' => 'GNU/kFreeBSD on Intel x86', 336 'i386-openbsd' => 'OpenBSD on Intel x86', 337 'i386-netbsd' => 'NetBSD on Intel x86', 338 'i386-linux' => 'GNU/Linux on Intel x86', 339 'i386-solaris' => 'Solaris on Intel x86', 340 'mips-irix' => 'SGI IRIX', 341 'mipsel-linux' => 'GNU/Linux on MIPSel', 342 'powerpc-aix' => 'AIX on PowerPC', 343 'powerpc-darwin' => 'MacOSX/Darwin on PowerPC', 344 'powerpc-linux' => 'GNU/Linux on PowerPC', 345 'sparc-linux' => 'GNU/Linux on Sparc', 346 'sparc-solaris' => 'Solaris on Sparc', 347 'universal-darwin' => 'MacOSX/Darwin universal binaries', 348 'win32' => 'Windows', 349 'x86_64-cygwin' => 'Cygwin on x86_64', 350 'x86_64-darwin' => 'MacOSX/Darwin on x86_64', 351 'x86_64-linux' => 'GNU/Linux on x86_64', 352 'x86_64-solaris' => 'Solaris on x86_64', 353 ); 354 355 # the inconsistency between amd64-freebsd and x86_64-linux is 356 # unfortunate (it's the same hardware), but the os people say those 357 # are the conventional names on the respective os's, so we follow suit. 358 359 if (exists $platform_name{$platform}) { 360 return "$platform_name{$platform}"; 361 } else { 362 my ($CPU,$OS) = split ('-', $platform); 363 return "$CPU with " . ucfirst "$OS"; 364 } 365} 366 367 368=item C<win32> 369 370Return C<1> if platform is Windows and C<0> otherwise. The test is 371currently based on the value of Perl's C<$^O> variable. 372 373=cut 374 375sub win32 { 376 if ($^O =~ /^MSWin/i) { 377 return 1; 378 } else { 379 return 0; 380 } 381 # the following needs config.guess, which is quite bad ... 382 # return (&platform eq "win32")? 1:0; 383} 384 385 386=item C<unix> 387 388Return C<1> if platform is UNIX and C<0> otherwise. 389 390=cut 391 392sub unix { 393 return (&platform eq "win32")? 0:1; 394} 395 396 397=back 398 399=head2 System Tools 400 401=over 4 402 403=item C<getenv($string)> 404 405Get an environment variable. It is assumed that the environment 406variable contains a path. On Windows all backslashes are replaced by 407forward slashes as required by Perl. If this behavior is not desired, 408use C<$ENV{"$variable"}> instead. C<0> is returned if the 409environment variable is not set. 410 411=cut 412 413sub getenv { 414 my $envvar=shift; 415 my $var=$ENV{"$envvar"}; 416 return 0 unless (defined $var); 417 if (&win32) { 418 $var=~s!\\!/!g; # change \ -> / (required by Perl) 419 } 420 return "$var"; 421} 422 423 424=item C<which($string)> 425 426C<which> does the same as the UNIX command C<which(1)>, but it is 427supposed to work on Windows too. On Windows we have to try all the 428extensions given in the C<PATHEXT> environment variable. We also try 429without appending an extension because if C<$string> comes from an 430environment variable, an extension might already be present. 431 432=cut 433 434sub which { 435 my ($prog) = @_; 436 my @PATH; 437 my $PATH = getenv('PATH'); 438 439 if (&win32) { 440 my @PATHEXT = split (';', getenv('PATHEXT')); 441 push (@PATHEXT, ''); # in case argument contains an extension 442 @PATH = split (';', $PATH); 443 for my $dir (@PATH) { 444 for my $ext (@PATHEXT) { 445 if (-f "$dir/$prog$ext") { 446 return "$dir/$prog$ext"; 447 } 448 } 449 } 450 451 } else { # not windows 452 @PATH = split (':', $PATH); 453 for my $dir (@PATH) { 454 if (-x "$dir/$prog") { 455 return "$dir/$prog"; 456 } 457 } 458 } 459 return 0; 460} 461 462=item C<get_system_tmpdir> 463 464Evaluate the environment variables C<TMPDIR>, C<TMP>, and C<TEMP> in 465order to find the system temporary directory. 466 467=cut 468 469sub get_system_tmpdir { 470 my $systmp=0; 471 $systmp||=getenv 'TMPDIR'; 472 $systmp||=getenv 'TMP'; 473 $systmp||=getenv 'TEMP'; 474 $systmp||='/tmp'; 475 return "$systmp"; 476} 477 478=item C<tl_tmpdir> 479 480Create a temporary directory which is removed when the program 481is terminated. 482 483=cut 484 485sub tl_tmpdir { 486 return (File::Temp::tempdir(CLEANUP => 1)); 487} 488 489=item C<xchdir($dir)> 490 491C<chdir($dir)> or die. 492 493=cut 494 495sub xchdir { 496 my ($dir) = @_; 497 chdir($dir) || die "$0: chdir($dir) failed: $!"; 498 ddebug("xchdir($dir) ok\n"); 499} 500 501 502=item C<wsystem($msg, @args)> 503 504Call C<info> about what is being done starting with C<$msg>, then run 505C<system(@args)>; C<tlwarn> if unsuccessful and return the exit status. 506 507=cut 508 509sub wsystem { 510 my ($msg,@args) = @_; 511 info("$msg @args ...\n"); 512 my $status = system(@args); 513 if ($status != 0) { 514 tlwarn("$0: command failed: @args: $!\n"); 515 } 516 return $status; 517} 518 519 520=item C<xsystem(@args)> 521 522Call C<ddebug> about what is being done, then run C<system(@args)>, and 523die if unsuccessful. 524 525=cut 526 527sub xsystem { 528 my (@args) = @_; 529 ddebug("running system(@args)\n"); 530 my $retval = system(@args); 531 if ($retval != 0) { 532 $retval /= 256 if $retval > 0; 533 my $pwd = cwd (); 534 die "$0: system(@args) failed in $pwd, status $retval"; 535 } 536} 537 538=item C<run_cmd($cmd)> 539 540Run shell command C<$cmd> and captures its output. Returns a list with CMD's 541output as the first element and the return value (exit code) as second. 542 543=cut 544 545sub run_cmd { 546 my $cmd = shift; 547 my $output = `$cmd`; 548 $output = "" if ! defined ($output); # don't return undef 549 550 my $retval = $?; 551 if ($retval != 0) { 552 $retval /= 256 if $retval > 0; 553 } 554 return ($output,$retval); 555} 556 557 558=back 559 560=head2 File Utilities 561 562=over 4 563 564=item C<dirname_and_basename($path)> 565 566Return both C<dirname> and C<basename>. Example: 567 568 ($dirpart,$filepart) = dirname_and_basename ($path); 569 570=cut 571 572sub dirname_and_basename { 573 my $path=shift; 574 my ($share, $base) = ("", ""); 575 if (win32) { 576 $path=~s!\\!/!g; 577 } 578 # do not try to make sense of paths ending with /.. 579 return (undef, undef) if $path =~ m!/\.\.$!; 580 if ($path=~m!/!) { # dirname("foo/bar/baz") -> "foo/bar" 581 # eliminate `/.' path components 582 while ($path =~ s!/\./!/!) {}; 583 # UNC path? => first split in $share = //xxx/yy and $path = /zzzz 584 if (win32() and $path =~ m!^(//[^/]+/[^/]+)(.*)$!) { 585 ($share, $path) = ($1, $2); 586 if ($path =~ m!^/?$!) { 587 $path = $share; 588 $base = ""; 589 } elsif ($path =~ m!(/.*)/(.*)!) { 590 $path = $share.$1; 591 $base = $2; 592 } else { 593 $base = $path; 594 $path = $share; 595 } 596 return ($path, $base); 597 } 598 # not a UNC path 599 $path=~m!(.*)/(.*)!; # works because of greedy matching 600 return ((($1 eq '') ? '/' : $1), $2); 601 } else { # dirname("ignore") -> "." 602 return (".", $path); 603 } 604} 605 606 607=item C<dirname($path)> 608 609Return C<$path> with its trailing C</component> removed. 610 611=cut 612 613sub dirname { 614 my $path = shift; 615 my ($dirname, $basename) = dirname_and_basename($path); 616 return $dirname; 617} 618 619 620=item C<basename($path)> 621 622Return C<$path> with any leading directory components removed. 623 624=cut 625 626sub basename { 627 my $path = shift; 628 my ($dirname, $basename) = dirname_and_basename($path); 629 return $basename; 630} 631 632 633=item C<tl_abs_path($path)> 634 635# Other than Cwd::abs_path, tl_abs_path also works 636# if only the grandparent exists. 637 638=cut 639 640sub tl_abs_path { 641 my $path = shift; 642 if (win32) { 643 $path=~s!\\!/!g; 644 } 645 my $ret; 646 eval {$ret = Cwd::abs_path($path);}; # eval needed for w32 647 return $ret if defined $ret; 648 # $ret undefined: probably the parent does not exist. 649 # But we also want an answer if only the grandparent exists. 650 my ($parent, $base) = dirname_and_basename($path); 651 return undef unless defined $parent; 652 eval {$ret = Cwd::abs_path($parent);}; 653 if (defined $ret) { 654 if ($ret =~ m!/$! or $base =~ m!^/!) { 655 $ret = "$ret$base"; 656 } else { 657 $ret = "$ret/$base"; 658 } 659 return $ret; 660 } else { 661 my ($pparent, $pbase) = dirname_and_basename($parent); 662 return undef unless defined $pparent; 663 eval {$ret = Cwd::abs_path($pparent);}; 664 return undef unless defined $ret; 665 if ($ret =~ m!/$!) { 666 $ret = "$ret$pbase/$base"; 667 } else { 668 $ret = "$ret/$pbase/$base"; 669 } 670 return $ret; 671 } 672} 673 674 675=item C<dir_creatable($path)> 676 677Tests whether its argument is a directory where we can create a directory. 678 679=cut 680 681sub dir_slash { 682 my $d = shift; 683 $d = "$d/" unless $d =~ m!/!; 684 return $d; 685} 686 687# test whether subdirectories can be created in the argument 688sub dir_creatable { 689 my $path=shift; 690 #print STDERR "testing $path\n"; 691 $path =~ s!\\!/!g if win32; 692 return 0 unless -d $path; 693 $path =~ s!/$!!; 694 #print STDERR "testing $path\n"; 695 my $i = 0; 696 my $too_large = 100000; 697 while ((-e $path . "/" . $i) and $i<$too_large) { $i++; } 698 return 0 if $i>=$too_large; 699 my $d = $path."/".$i; 700 #print STDERR "creating $d\n"; 701 return 0 unless mkdir $d; 702 return 0 unless -d $d; 703 rmdir $d; 704 return 1; 705} 706 707 708=item C<dir_writable($path)> 709 710Tests whether its argument is writable by trying to write to 711it. This function is necessary because the built-in C<-w> test just 712looks at mode and uid/guid, which on Windows always returns true and 713even on Unix is not always good enough for directories mounted from 714a fileserver. 715 716=cut 717 718# Theoretically, the test below, which uses numbers as names, might 719# lead to a race condition. OTOH, it should work even on a very 720# broken Perl. 721 722# The Unix test gives the wrong answer when used under Windows Vista 723# with one of the `virtualized' directories such as Program Files: 724# lacking administrative permissions, it would write successfully to 725# the virtualized Program Files rather than fail to write to the 726# real Program Files. Ugh. 727 728sub dir_writable { 729 my ($path) = @_; 730 return 0 unless -d $path; 731 $path =~ s!\\!/!g if win32; 732 $path =~ s!/$!!; 733 my $i = 0; 734 my $too_large = 100000; 735 while ((-e "$path/$i") && $i < $too_large) { 736 $i++; 737 } 738 return 0 if $ i >= $too_large; 739 my $f = "$path/$i"; 740 return 0 if ! open (TEST, ">$f"); 741 my $written = 0; 742 $written = (print TEST "\n"); 743 close (TEST); 744 unlink ($f); 745 return $written; 746} 747 748 749=item C<mkdirhier($path, [$mode])> 750 751The function C<mkdirhier> does the same as the UNIX command C<mkdir -p>, 752and dies on failure. The optional parameter sets the permission bits. 753 754=cut 755 756sub mkdirhier { 757 my ($tree,$mode) = @_; 758 759 return if (-d "$tree"); 760 my $subdir = ""; 761 # win32 is special as usual: we need to separate //servername/ part 762 # from the UNC path, since (! -d //servername/) tests true 763 $subdir = $& if ( win32() && ($tree =~ s!^//[^/]+/!!) ); 764 765 @dirs = split (/\//, $tree); 766 for my $dir (@dirs) { 767 $subdir .= "$dir/"; 768 if (! -d $subdir) { 769 if (defined $mode) { 770 mkdir ($subdir, $mode) 771 || die "$0: mkdir($subdir,$mode) failed, goodbye: $!\n"; 772 } else { 773 mkdir ($subdir) || die "$0: mkdir($subdir) failed, goodbye: $!\n"; 774 } 775 } 776 } 777} 778 779 780=item C<rmtree($root, $verbose, $safe)> 781 782The C<rmtree> function provides a convenient way to delete a 783subtree from the directory structure, much like the Unix command C<rm -r>. 784C<rmtree> takes three arguments: 785 786=over 4 787 788=item * 789 790the root of the subtree to delete, or a reference to 791a list of roots. All of the files and directories 792below each root, as well as the roots themselves, 793will be deleted. 794 795=item * 796 797a boolean value, which if TRUE will cause C<rmtree> to 798print a message each time it examines a file, giving the 799name of the file, and indicating whether it's using C<rmdir> 800or C<unlink> to remove it, or that it's skipping it. 801(defaults to FALSE) 802 803=item * 804 805a boolean value, which if TRUE will cause C<rmtree> to 806skip any files to which you do not have delete access 807(if running under VMS) or write access (if running 808under another OS). This will change in the future when 809a criterion for 'delete permission' under OSs other 810than VMS is settled. (defaults to FALSE) 811 812=back 813 814It returns the number of files successfully deleted. Symlinks are 815simply deleted and not followed. 816 817B<NOTE:> There are race conditions internal to the implementation of 818C<rmtree> making it unsafe to use on directory trees which may be 819altered or moved while C<rmtree> is running, and in particular on any 820directory trees with any path components or subdirectories potentially 821writable by untrusted users. 822 823Additionally, if the third parameter is not TRUE and C<rmtree> is 824interrupted, it may leave files and directories with permissions altered 825to allow deletion (and older versions of this module would even set 826files and directories to world-read/writable!) 827 828Note also that the occurrence of errors in C<rmtree> can be determined I<only> 829by trapping diagnostic messages using C<$SIG{__WARN__}>; it is not apparent 830from the return value. 831 832=cut 833 834#taken from File/Path.pm 835# 836my $Is_VMS = $^O eq 'VMS'; 837my $Is_MacOS = $^O eq 'MacOS'; 838 839# These OSes complain if you want to remove a file that you have no 840# write permission to: 841my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' || 842 $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc'); 843 844sub rmtree { 845 my($roots, $verbose, $safe) = @_; 846 my(@files); 847 my($count) = 0; 848 $verbose ||= 0; 849 $safe ||= 0; 850 851 if ( defined($roots) && length($roots) ) { 852 $roots = [$roots] unless ref $roots; 853 } else { 854 warn "No root path(s) specified"; 855 return 0; 856 } 857 858 my($root); 859 foreach $root (@{$roots}) { 860 if ($Is_MacOS) { 861 $root = ":$root" if $root !~ /:/; 862 $root =~ s#([^:])\z#$1:#; 863 } else { 864 $root =~ s#/\z##; 865 } 866 (undef, undef, my $rp) = lstat $root or next; 867 $rp &= 07777; # don't forget setuid, setgid, sticky bits 868 if ( -d _ ) { 869 # notabene: 0700 is for making readable in the first place, 870 # it's also intended to change it to writable in case we have 871 # to recurse in which case we are better than rm -rf for 872 # subtrees with strange permissions 873 chmod($rp | 0700, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) 874 or warn "Can't make directory $root read+writeable: $!" 875 unless $safe; 876 877 if (opendir my $d, $root) { 878 no strict 'refs'; 879 if (!defined ${"\cTAINT"} or ${"\cTAINT"}) { 880 # Blindly untaint dir names 881 @files = map { /^(.*)$/s ; $1 } readdir $d; 882 } else { 883 @files = readdir $d; 884 } 885 closedir $d; 886 } else { 887 warn "Can't read $root: $!"; 888 @files = (); 889 } 890 # Deleting large numbers of files from VMS Files-11 filesystems 891 # is faster if done in reverse ASCIIbetical order 892 @files = reverse @files if $Is_VMS; 893 ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS; 894 if ($Is_MacOS) { 895 @files = map("$root$_", @files); 896 } else { 897 @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files); 898 } 899 $count += rmtree(\@files,$verbose,$safe); 900 if ($safe && 901 ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { 902 print "skipped $root\n" if $verbose; 903 next; 904 } 905 chmod $rp | 0700, $root 906 or warn "Can't make directory $root writeable: $!" 907 if $force_writeable; 908 print "rmdir $root\n" if $verbose; 909 if (rmdir $root) { 910 ++$count; 911 } else { 912 warn "Can't remove directory $root: $!"; 913 chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) 914 or warn("and can't restore permissions to " 915 . sprintf("0%o",$rp) . "\n"); 916 } 917 } else { 918 if ($safe && 919 ($Is_VMS ? !&VMS::Filespec::candelete($root) 920 : !(-l $root || -w $root))) 921 { 922 print "skipped $root\n" if $verbose; 923 next; 924 } 925 chmod $rp | 0600, $root 926 or warn "Can't make file $root writeable: $!" 927 if $force_writeable; 928 print "unlink $root\n" if $verbose; 929 # delete all versions under VMS 930 for (;;) { 931 unless (unlink $root) { 932 warn "Can't unlink file $root: $!"; 933 if ($force_writeable) { 934 chmod $rp, $root 935 or warn("and can't restore permissions to " 936 . sprintf("0%o",$rp) . "\n"); 937 } 938 last; 939 } 940 ++$count; 941 last unless $Is_VMS && lstat $root; 942 } 943 } 944 } 945 $count; 946} 947 948 949=item C<copy($file, $target_dir)> 950 951=item C<copy("-f", $file, $destfile)> 952 953Copy file C<$file> to directory C<$target_dir>, or to the C<$destfile> 954in the second case. No external programs are involved. Since we need 955C<sysopen()>, the Perl module C<Fcntl.pm> is required. The time stamps 956are preserved and symlinks are created on Unix systems. On Windows, 957C<(-l $file)> will never return 'C<true>' and so symlinks will be 958(uselessly) copied as regular files. 959 960C<copy> invokes C<mkdirhier> if target directories do not exist. Files 961have mode C<0777> if they are executable and C<0666> otherwise, with 962the set bits in I<umask> cleared in each case. 963 964C<$file> can begin with a file:/ prefix. 965 966If C<$file> is not readable, we return without copying anything. (This 967can happen when the database and files are not in perfect sync.) On the 968other file, if the destination is not writable, or the writing fails, 969that is a fatal error. 970 971=cut 972 973sub copy { 974 my $infile = shift; 975 my $filemode = 0; 976 if ($infile eq "-f") { # second argument is a file 977 $filemode = 1; 978 $infile = shift; 979 } 980 my $destdir=shift; 981 982 my $outfile; 983 my @stat; 984 my $mode; 985 my $buffer; 986 my $offset; 987 my $filename; 988 my $dirmode = 0755; 989 my $blocksize = $TeXLive::TLConfig::BlockSize; 990 991 $infile =~ s!^file://*!/!i; # remove file:/ url prefix 992 $filename = basename "$infile"; 993 if ($filemode) { 994 # given a destination file 995 $outfile = $destdir; 996 $destdir = dirname($outfile); 997 } else { 998 $outfile = "$destdir/$filename"; 999 } 1000 1001 mkdirhier ($destdir) unless -d "$destdir"; 1002 1003 if (-l "$infile") { 1004 symlink (readlink $infile, "$destdir/$filename"); 1005 } else { 1006 if (! open (IN, $infile)) { 1007 warn "open($infile) failed, not copying: $!"; 1008 return; 1009 } 1010 binmode IN; 1011 1012 $mode = (-x "$infile") ? oct("0777") : oct("0666"); 1013 $mode &= ~umask; 1014 1015 open (OUT, ">$outfile") || die "open(>$outfile) failed: $!"; 1016 binmode OUT; 1017 1018 chmod $mode, "$outfile"; 1019 1020 while ($read = sysread (IN, $buffer, $blocksize)) { 1021 die "read($infile) failed: $!\n" unless defined $read; 1022 $offset = 0; 1023 while ($read) { 1024 $written = syswrite (OUT, $buffer, $read, $offset); 1025 die "write($outfile) failed: $!" unless defined $written; 1026 $read -= $written; 1027 $offset += $written; 1028 } 1029 } 1030 close (OUT) || warn "close($outfile) failed: $!"; 1031 close IN || warn "close($infile) failed: $!";; 1032 @stat = lstat ("$infile"); 1033 utime ($stat[8], $stat[9], $outfile); 1034 } 1035} 1036 1037 1038=item C<touch(@files)> 1039 1040Update modification and access time of C<@files>. Non-existent files 1041are created. 1042 1043=cut 1044 1045sub touch { 1046 my @files=@_; 1047 1048 foreach my $file (@_) { 1049 if (-e $file) { 1050 utime time, time, $file; 1051 } else { 1052 if (open( TMP, ">$file")) { 1053 close(TMP); 1054 } else { 1055 warn "Can't create file $file: $!\n"; 1056 } 1057 } 1058 } 1059} 1060 1061 1062=item C<collapse_dirs(@files)> 1063 1064Return a (more or less) minimal list of directories and files, given an 1065original list of files C<@files>. That is, if every file within a given 1066directory is included in C<@files>, replace all of those files with the 1067absolute directory name in the return list. Any files which have 1068sibling files not included are retained and made absolute. 1069 1070We try to walk up the tree so that the highest-level directory 1071containing only directories or files that are in C<@files> is returned. 1072(This logic may not be perfect, though.) 1073 1074This is not just a string function; we check for other directory entries 1075existing on disk within the directories of C<@files>. Therefore, if the 1076entries are relative pathnames, the current directory must be set by the 1077caller so that file tests work. 1078 1079As mentioned above, the returned list is absolute paths to directories 1080and files. 1081 1082For example, suppose the input list is 1083 1084 dir1/subdir1/file1 1085 dir1/subdir2/file2 1086 dir1/file3 1087 1088If there are no other entries under C<dir1/>, the result will be 1089C</absolute/path/to/dir1>. 1090 1091=cut 1092 1093sub collapse_dirs { 1094 my (@files) = @_; 1095 my @ret = (); 1096 my %by_dir; 1097 1098 # construct hash of all directories mentioned, values are lists of the 1099 # files in that directory. 1100 for my $f (@files) { 1101 my $abs_f = Cwd::abs_path ($f); 1102 die ("oops, no abs_path($f) from " . `pwd`) unless $abs_f; 1103 (my $d = $abs_f) =~ s,/[^/]*$,,; 1104 my @a = exists $by_dir{$d} ? @{$by_dir{$d}} : (); 1105 push (@a, $abs_f); 1106 $by_dir{$d} = \@a; 1107 } 1108 1109 # for each of our directories, see if we are given everything in 1110 # the directory. if so, return the directory; else return the 1111 # individual files. 1112 for my $d (sort keys %by_dir) { 1113 opendir (DIR, $d) || die "opendir($d) failed: $!"; 1114 my @dirents = readdir (DIR); 1115 closedir (DIR) || warn "closedir($d) failed: $!"; 1116 1117 # initialize test hash with all the files we saw in this dir. 1118 # (These idioms are due to "Finding Elements in One Array and Not 1119 # Another" in the Perl Cookbook.) 1120 my %seen; 1121 my @rmfiles = @{$by_dir{$d}}; 1122 @seen{@rmfiles} = (); 1123 1124 # see if everything is the same. 1125 my $ok_to_collapse = 1; 1126 for my $dirent (@dirents) { 1127 next if $dirent =~ /^\.(\.|svn)?$/; # ignore . .. .svn 1128 1129 my $item = "$d/$dirent"; # prepend directory for comparison 1130 if (! exists $seen{$item}) { 1131 $ok_to_collapse = 0; 1132 last; # no need to keep looking after the first. 1133 } 1134 } 1135 1136 push (@ret, $ok_to_collapse ? $d : @{$by_dir{$d}}); 1137 } 1138 1139 if (@ret != @files) { 1140 @ret = &collapse_dirs (@ret); 1141 } 1142 return @ret; 1143} 1144 1145=item C<removed_dirs(@files)> 1146 1147returns all the directories from which all content will be removed 1148 1149=cut 1150 1151# return all the directories from which all content will be removed 1152# 1153# idea: 1154# - create a hashes by_dir listing all files that should be removed 1155# by directory, i.e., key = dir, value is list of files 1156# - for each of the dirs (keys of by_dir and ordered deepest first) 1157# check that all actually contained files are removed 1158# and all the contained dirs are in the removal list. If this is the 1159# case put that directory into the removal list 1160# - return this removal list 1161# 1162sub removed_dirs { 1163 my (@files) = @_; 1164 my %removed_dirs; 1165 my %by_dir; 1166 1167 # construct hash of all directories mentioned, values are lists of the 1168 # files/dirs in that directory. 1169 for my $f (@files) { 1170 # what should we do with not existing entries???? 1171 next if (! -r "$f"); 1172 my $abs_f = Cwd::abs_path ($f); 1173 # the following is necessary because on win32, 1174 # abs_path("tl-portable") 1175 # returns 1176 # c:\tl test\... 1177 # and not forward slashes, while, if there is already a forward / 1178 # in the path, also the rest is done with forward slashes. 1179 $abs_f =~ s!\\!/!g if win32(); 1180 if (!$abs_f) { 1181 warn ("oops, no abs_path($f) from " . `pwd`); 1182 next; 1183 } 1184 (my $d = $abs_f) =~ s,/[^/]*$,,; 1185 my @a = exists $by_dir{$d} ? @{$by_dir{$d}} : (); 1186 push (@a, $abs_f); 1187 $by_dir{$d} = \@a; 1188 } 1189 1190 # for each of our directories, see if we are removing everything in 1191 # the directory. if so, return the directory; else return the 1192 # individual files. 1193 for my $d (reverse sort keys %by_dir) { 1194 opendir (DIR, $d) || die "opendir($d) failed: $!"; 1195 my @dirents = readdir (DIR); 1196 closedir (DIR) || warn "closedir($d) failed: $!"; 1197 1198 # initialize test hash with all the files we saw in this dir. 1199 # (These idioms are due to "Finding Elements in One Array and Not 1200 # Another" in the Perl Cookbook.) 1201 my %seen; 1202 my @rmfiles = @{$by_dir{$d}}; 1203 @seen{@rmfiles} = (); 1204 1205 # see if everything is the same. 1206 my $cleandir = 1; 1207 for my $dirent (@dirents) { 1208 next if $dirent =~ /^\.(\.|svn)?$/; # ignore . .. .svn 1209 my $item = "$d/$dirent"; # prepend directory for comparison 1210 if ( 1211 ((-d $item) && (defined($removed_dirs{$item}))) 1212 || 1213 (exists $seen{$item}) 1214 ) { 1215 # do nothing 1216 } else { 1217 $cleandir = 0; 1218 last; 1219 } 1220 } 1221 if ($cleandir) { 1222 $removed_dirs{$d} = 1; 1223 } 1224 } 1225 return keys %removed_dirs; 1226} 1227 1228=item C<time_estimate($totalsize, $donesize, $starttime)> 1229 1230Returns the current running time and the estimated total time 1231based on the total size, the already done size, and the start time. 1232 1233=cut 1234 1235sub time_estimate { 1236 my ($totalsize, $donesize, $starttime) = @_; 1237 if ($donesize <= 0) { 1238 return ("??:??", "??:??"); 1239 } 1240 my $curtime = time(); 1241 my $passedtime = $curtime - $starttime; 1242 my $esttotalsecs = int ( ( $passedtime * $totalsize ) / $donesize ); 1243 # 1244 # we change the display to show that passed time instead of the 1245 # estimated remaining time. We keep the old code and naming and 1246 # only initialize the $remsecs to the $passedtime instead. 1247 # my $remsecs = $esttotalsecs - $passedtime; 1248 my $remsecs = $passedtime; 1249 my $min = int($remsecs/60); 1250 my $hour; 1251 if ($min >= 60) { 1252 $hour = int($min/60); 1253 $min %= 60; 1254 } 1255 my $sec = $remsecs % 60; 1256 $remtime = sprintf("%02d:%02d", $min, $sec); 1257 if ($hour) { 1258 $remtime = sprintf("%02d:$remtime", $hour); 1259 } 1260 my $tmin = int($esttotalsecs/60); 1261 my $thour; 1262 if ($tmin >= 60) { 1263 $thour = int($tmin/60); 1264 $tmin %= 60; 1265 } 1266 my $tsec = $esttotalsecs % 60; 1267 $tottime = sprintf("%02d:%02d", $tmin, $tsec); 1268 if ($thour) { 1269 $tottime = sprintf("%02d:$tottime", $thour); 1270 } 1271 return($remtime, $tottime); 1272} 1273 1274 1275=item C<install_packages($from_tlpdb, $media, $to_tlpdb, $what, $opt_src, $opt_doc)> 1276 1277Installs the list of packages found in C<@$what> (a ref to a list) into 1278the TLPDB given by C<$to_tlpdb>. Information on files are taken from 1279the TLPDB C<$from_tlpdb>. 1280 1281C<$opt_src> and C<$opt_doc> specify whether srcfiles and docfiles should be 1282installed (currently implemented only for installation from uncompressed media). 1283 1284Returns 1 on success and 0 on error. 1285 1286=cut 1287 1288sub install_packages { 1289 my ($fromtlpdb,$media,$totlpdb,$what,$opt_src,$opt_doc) = @_; 1290 my $container_src_split = $fromtlpdb->config_src_container; 1291 my $container_doc_split = $fromtlpdb->config_doc_container; 1292 my $root = $fromtlpdb->root; 1293 my @packs = @$what; 1294 my $totalnr = $#packs + 1; 1295 my $td = length("$totalnr"); 1296 my $n = 0; 1297 my %tlpobjs; 1298 my $totalsize = 0; 1299 my $donesize = 0; 1300 my %tlpsizes; 1301 foreach my $p (@packs) { 1302 $tlpobjs{$p} = $fromtlpdb->get_package($p); 1303 if (!defined($tlpobjs{$p})) { 1304 die "STRANGE: $p not to be found in ", $fromtlpdb->root; 1305 } 1306 if ($media ne 'local_uncompressed') { 1307 # we use the container size as the measuring unit since probably 1308 # downloading will be the limiting factor 1309 $tlpsizes{$p} = $tlpobjs{$p}->containersize; 1310 $tlpsizes{$p} += $tlpobjs{$p}->srccontainersize if $opt_src; 1311 $tlpsizes{$p} += $tlpobjs{$p}->doccontainersize if $opt_doc; 1312 } else { 1313 # we have to add the respective sizes, that is checking for 1314 # installation of src and doc file 1315 $tlpsizes{$p} = $tlpobjs{$p}->runsize; 1316 $tlpsizes{$p} += $tlpobjs{$p}->srcsize if $opt_src; 1317 $tlpsizes{$p} += $tlpobjs{$p}->docsize if $opt_doc; 1318 my %foo = %{$tlpobjs{$p}->binsize}; 1319 for my $k (keys %foo) { $tlpsizes{$p} += $foo{$k}; } 1320 # all the packages sizes are in blocks, so transfer that to bytes 1321 $tlpsizes{$p} *= $TeXLive::TLConfig::BlockSize; 1322 } 1323 $totalsize += $tlpsizes{$p}; 1324 } 1325 my $starttime = time(); 1326 foreach my $package (@packs) { 1327 my $tlpobj = $tlpobjs{$package}; 1328 my $reloc = $tlpobj->relocated; 1329 $n++; 1330 my ($estrem, $esttot) = time_estimate($totalsize, $donesize, $starttime); 1331 my $infostr = sprintf("Installing [%0${td}d/$totalnr, " 1332 . "time/total: $estrem/$esttot]: $package [%dk]", 1333 $n, int($tlpsizes{$package}/1024) + 1); 1334 info("$infostr\n"); 1335 foreach my $h (@::install_packages_hook) { 1336 &$h($n,$totalnr); 1337 } 1338 my $real_opt_doc = $opt_doc; 1339 my $container; 1340 my @installfiles; 1341 push @installfiles, $tlpobj->runfiles; 1342 push @installfiles, $tlpobj->allbinfiles; 1343 push @installfiles, $tlpobj->srcfiles if ($opt_src); 1344 push @installfiles, $tlpobj->docfiles if ($real_opt_doc); 1345 if ($media eq 'local_uncompressed') { 1346 $container = [ $root, @installfiles ]; 1347 } elsif ($media eq 'local_compressed') { 1348 if (-r "$root/$Archive/$package.zip") { 1349 $container = "$root/$Archive/$package.zip"; 1350 } elsif (-r "$root/$Archive/$package.tar.xz") { 1351 $container = "$root/$Archive/$package.tar.xz"; 1352 } else { 1353 tlwarn("No package $package (.zip or .xz) in $root/$Archive\n"); 1354 next; 1355 } 1356 } elsif ($media eq 'NET') { 1357 $container = "$root/$Archive/$package.$DefaultContainerExtension"; 1358 } 1359 if (!install_package($container, $reloc, $tlpobj->containersize, 1360 $tlpobj->containermd5, \@installfiles, 1361 $totlpdb->root, $vars{'this_platform'})) { 1362 # we already warn in install_package that something bad happened, 1363 # so only return here 1364 return 0; 1365 } 1366 # if we are installing from compressed media we have to fetch the respective 1367 # source and doc packages $pkg.source and $pkg.doc and install them, too 1368 if (($media eq 'NET') || ($media eq 'local_compressed')) { 1369 # we install split containers under the following conditions: 1370 # - the container were split generated 1371 # - src/doc files should be installed 1372 # (- the package is not already a split one (like .i386-linux)) 1373 # the above test has been removed since that would mean that packages 1374 # with a dot like texlive.infra will never have the docfiles installed 1375 # that is already happening ...bummer. But since we already check 1376 # whether there are src/docfiles present at all that is fine 1377 # - there are actually src/doc files present 1378 if ($container_src_split && $opt_src && $tlpobj->srcfiles) { 1379 my $srccontainer = $container; 1380 $srccontainer =~ s/(\.tar\.xz|\.zip)$/.source$1/; 1381 if (!install_package($srccontainer, $reloc, $tlpobj->srccontainersize, 1382 $tlpobj->srccontainermd5, \@installfiles, 1383 $totlpdb->root, $vars{'this_platform'})) { 1384 return 0; 1385 } 1386 } 1387 if ($container_doc_split && $real_opt_doc && $tlpobj->docfiles) { 1388 my $doccontainer = $container; 1389 $doccontainer =~ s/(\.tar\.xz|\.zip)$/.doc$1/; 1390 if (!install_package($doccontainer, $reloc, 1391 $tlpobj->doccontainersize, 1392 $tlpobj->doccontainermd5, \@installfiles, 1393 $totlpdb->root, $vars{'this_platform'})) { 1394 return 0; 1395 } 1396 } 1397 } 1398 # we don't want to have wrong information in the tlpdb, so remove the 1399 # src/doc files if they are not installed ... 1400 if (!$opt_src) { 1401 $tlpobj->clear_srcfiles; 1402 } 1403 if (!$real_opt_doc) { 1404 $tlpobj->clear_docfiles; 1405 } 1406 # if a package is relocatable we have to cancel the reloc prefix 1407 # before we save it to the local tlpdb 1408 if ($tlpobj->relocated) { 1409 $tlpobj->replace_reloc_prefix; 1410 } 1411 $totlpdb->add_tlpobj($tlpobj); 1412 1413 # we have to write out the tlpobj file since it is contained in the 1414 # archives (.tar.xz), but at uncompressed-media install time we 1415 # don't have them. 1416 my $tlpod = $totlpdb->root . "/tlpkg/tlpobj"; 1417 mkdirhier($tlpod); 1418 my $count = 0; 1419 my $tlpobj_file = ">$tlpod/" . $tlpobj->name . ".tlpobj"; 1420 until (open(TMP, $tlpobj_file)) { 1421 # The open might fail for no good reason on Windows. 1422 # Try again for a while, but not forever. 1423 if ($count++ == 100) { die "$0: open($tlpobj_file) failed: $!"; } 1424 select (undef, undef, undef, .1); # sleep briefly 1425 } 1426 $tlpobj->writeout(\*TMP); 1427 close(TMP); 1428 $donesize += $tlpsizes{$package}; 1429 } 1430 my $totaltime = time() - $starttime; 1431 my $totmin = int ($totaltime/60); 1432 my $totsec = $totaltime % 60; 1433 info(sprintf("Time used for installing the packages: %02d:%02d\n", 1434 $totmin, $totsec)); 1435 $totlpdb->save; 1436 return 1; 1437} 1438 1439 1440=item C<install_package($what, $reloc, $size, $md5, $filelistref, $target, $platform)> 1441 1442This function installs the files given in @$filelistref from C<$what> 1443into C<$target>. 1444 1445C<$size> gives the size in bytes of the container, or -1 if we are 1446installing from uncompressed media, i.e., from a list of files to be copied. 1447 1448If C<$what> is a reference to a list of files then these files are 1449assumed to be readable and are copied to C<$target>, creating dirs on 1450the way. In this case the list C<@$filelistref> is not taken into 1451account. 1452 1453If C<$what> starts with C<http://> or C<ftp://> then C<$what> is 1454downloaded from the net and piped through C<xzdec> and C<tar>. 1455 1456If $what ends with C<.tar.xz> (but does not start with C<http://> or 1457C<ftp://>, but possibly with C<file:/>) it is assumed to be a readable 1458file on the system and is likewise piped through C<xzdec> and C<tar>. 1459 1460In both of these cases currently the list C<$@filelistref> currently 1461is not taken into account (should be fixed!). 1462 1463if C<$reloc> is true the container (NET or local_compressed mode) is packaged in a way 1464that the initial texmf-dist is missing. 1465 1466Returns 1 on success and 0 on error. 1467 1468=cut 1469 1470sub install_package { 1471 my ($what, $reloc, $whatsize, $whatmd5, $filelistref, $target, $platform) = @_; 1472 1473 my @filelist = @$filelistref; 1474 1475 my $tempdir = "$target/temp"; 1476 1477 # we assume that $::progs has been set up! 1478 my $wget = $::progs{'wget'}; 1479 my $xzdec = quotify_path_with_spaces($::progs{'xzdec'}); 1480 if (!defined($wget) || !defined($xzdec)) { 1481 tlwarn("install_package: wget/xzdec programs not set up properly.\n"); 1482 return 0; 1483 } 1484 if (ref $what) { 1485 # we are getting a ref to a list of files, so install from uncompressed media 1486 my ($root, @files) = @$what; 1487 foreach my $file (@files) { 1488 # @what is taken, not @filelist! 1489 # is this still needed? 1490 my $dn=dirname($file); 1491 mkdirhier("$target/$dn"); 1492 copy "$root/$file", "$target/$dn"; 1493 } 1494 } elsif ($what =~ m,\.tar.xz$,) { 1495 # this is the case when we install from compressed media 1496 # 1497 # in all other cases we create temp files .tar.xz (or use the present 1498 # one), xzdec them, and then call tar 1499 1500 # if we are unpacking a relocated container we adjust the target 1501 if ($reloc) { 1502 $target .= "/$TeXLive::TLConfig::RelocTree" if $reloc; 1503 mkdir($target) if (! -d $target); 1504 } 1505 1506 my $fn = basename($what); 1507 my $pkg = $fn; 1508 $pkg =~ s/\.tar\.xz$//; 1509 mkdirhier("$tempdir"); 1510 my $xzfile = "$tempdir/$fn"; 1511 my $tarfile = "$tempdir/$fn"; $tarfile =~ s/\.xz$//; 1512 my $xzfile_quote = $xzfile; 1513 my $tarfile_quote = $tarfile; 1514 if (win32()) { 1515 $xzfile =~ s!/!\\!g; 1516 $tarfile =~ s!/!\\!g; 1517 $target =~ s!/!\\!g; 1518 } 1519 $xzfile_quote = "\"$xzfile\""; 1520 $tarfile_quote = "\"$tarfile\""; 1521 my $gotfiledone = 0; 1522 if (-r $xzfile) { 1523 # check that the downloaded file is not partial 1524 if ($whatsize >= 0) { 1525 # we have the size given, so check that first 1526 my $size = (stat $xzfile)[7]; 1527 if ($size == $whatsize) { 1528 # we want to check also the md5sum if we have it present 1529 if ($whatmd5) { 1530 if (tlmd5($xzfile) eq $whatmd5) { 1531 $gotfiledone = 1; 1532 } else { 1533 tlwarn("Downloaded $what, size equal, but md5sum differs;\n", 1534 "downloading again.\n"); 1535 } 1536 } else { 1537 # size ok, no md5sum 1538 tlwarn("Downloaded $what, size equal, but no md5sum available;\n", 1539 "continuing, with fingers crossed."); 1540 $gotfiledone = 1; 1541 } 1542 } else { 1543 tlwarn("Partial download of $what found, removing it.\n"); 1544 unlink($tarfile, $xzfile); 1545 } 1546 } else { 1547 # ok no size information, hopefully we have md5 sums 1548 if ($whatmd5) { 1549 if (tlmd5($xzfile) eq $whatmd5) { 1550 $gotfiledone = 1; 1551 } else { 1552 tlwarn("Downloaded file, but md5sum differs, removing it.\n"); 1553 } 1554 } else { 1555 tlwarn("Container found, but cannot verify size of md5sum;\n", 1556 "continuing, with fingers crossed.\n"); 1557 $gotfiledone = 1; 1558 } 1559 } 1560 debug("Reusing already downloaded container $xzfile\n") 1561 if ($gotfiledone); 1562 } 1563 if (!$gotfiledone) { 1564 if ($what =~ m,http://|ftp://,) { 1565 # we are installing from the NET 1566 # download the file and put it into temp 1567 if (!download_file($what, $xzfile) || (! -r $xzfile)) { 1568 tlwarn("Downloading $what did not succeed.\n"); 1569 return 0; 1570 } 1571 } else { 1572 # we are installing from local compressed media 1573 # copy it to temp 1574 copy($what, $tempdir); 1575 } 1576 } 1577 debug("un-xzing $xzfile to $tarfile\n"); 1578 system("$xzdec < $xzfile_quote > $tarfile_quote"); 1579 if (! -f $tarfile) { 1580 tlwarn("Unpacking $xzfile did not succeed.\n"); 1581 return 0; 1582 } 1583 if (!TeXLive::TLUtils::untar($tarfile, $target, 1)) { 1584 tlwarn("untarring $tarfile failed, stopping install.\n"); 1585 return 0; 1586 } 1587 # we remove the created .tlpobj it is recreated anyway in 1588 # install_packages above in the right place. This way we also 1589 # get rid of the $pkg.source.tlpobj which are useless 1590 unlink ("$target/tlpkg/tlpobj/$pkg.tlpobj") 1591 if (-r "$target/tlpkg/tlpobj/$pkg.tlpobj"); 1592 if ($what =~ m,http://|ftp://,) { 1593 # we downloaded the original .tar.lzma from the net, so we keep it 1594 } else { 1595 # we are downloading it from local compressed media, so we can unlink it to save 1596 # disk space 1597 unlink($xzfile); 1598 } 1599 } else { 1600 tlwarn("Sorry, no idea how to install $what\n"); 1601 return 0; 1602 } 1603 return 1; 1604} 1605 1606=item C<do_postaction($how, $tlpobj, $do_fileassocs, $do_menu, $do_desktop, $do_script)> 1607 1608Evaluates the C<postaction> fields in the C<$tlpobj>. The first parameter 1609can be either C<install> or C<remove>. The second gives the TLPOBJ whos 1610postactions should be evaluated, and the last four arguments specify 1611what type of postactions should (or shouldn't) be evaluated. 1612 1613Returns 1 on success, and 0 on failure. 1614 1615=cut 1616 1617sub do_postaction { 1618 my ($how, $tlpobj, $do_fileassocs, $do_menu, $do_desktop, $do_script) = @_; 1619 my $ret = 1; 1620 if (!defined($tlpobj)) { 1621 tlwarn("do_postaction: didn't get a tlpobj\n"); 1622 return 0; 1623 } 1624 debug("running postaction=$how for " . $tlpobj->name . "\n") 1625 if $tlpobj->postactions; 1626 for my $pa ($tlpobj->postactions) { 1627 if ($pa =~ m/^\s*shortcut\s+(.*)\s*$/) { 1628 $ret &&= _do_postaction_shortcut($how, $tlpobj, $do_menu, $do_desktop, $1); 1629 } elsif ($pa =~ m/\s*filetype\s+(.*)\s*$/) { 1630 next unless $do_fileassocs; 1631 $ret &&= _do_postaction_filetype($how, $tlpobj, $1); 1632 } elsif ($pa =~ m/\s*fileassoc\s+(.*)\s*$/) { 1633 $ret &&= _do_postaction_fileassoc($how, $do_fileassocs, $tlpobj, $1); 1634 next; 1635 } elsif ($pa =~ m/\s*progid\s+(.*)\s*$/) { 1636 next unless $do_fileassocs; 1637 $ret &&= _do_postaction_progid($how, $tlpobj, $1); 1638 } elsif ($pa =~ m/\s*script\s+(.*)\s*$/) { 1639 next unless $do_script; 1640 $ret &&= _do_postaction_script($how, $tlpobj, $1); 1641 } else { 1642 tlwarn("do_postaction: don't know how to do $pa\n"); 1643 $ret = 0; 1644 } 1645 } 1646 # nothing to do 1647 return $ret; 1648} 1649 1650sub _do_postaction_fileassoc { 1651 my ($how, $mode, $tlpobj, $pa) = @_; 1652 return 1 unless win32(); 1653 my ($errors, %keyval) = 1654 parse_into_keywords($pa, qw/extension filetype/); 1655 1656 if ($errors) { 1657 tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); 1658 return 0; 1659 } 1660 1661 # name can be an arbitrary string 1662 if (!defined($keyval{'extension'})) { 1663 tlwarn("extension of fileassoc postaction not given\n"); 1664 return 0; 1665 } 1666 my $extension = $keyval{'extension'}; 1667 1668 # cmd can be an arbitrary string 1669 if (!defined($keyval{'filetype'})) { 1670 tlwarn("filetype of fileassoc postaction not given\n"); 1671 return 0; 1672 } 1673 my $filetype = $keyval{'filetype'}.'.'.$ReleaseYear; 1674 1675 &log("postaction $how fileassoc for " . $tlpobj->name . 1676 ": $extension, $filetype\n"); 1677 if ($how eq "install") { 1678 TeXLive::TLWinGoo::register_extension($mode, $extension, $filetype); 1679 } elsif ($how eq "remove") { 1680 TeXLive::TLWinGoo::unregister_extension($mode, $extension, $filetype); 1681 } else { 1682 tlwarn("Unknown mode $how\n"); 1683 return 0; 1684 } 1685 return 1; 1686} 1687 1688sub _do_postaction_filetype { 1689 my ($how, $tlpobj, $pa) = @_; 1690 return 1 unless win32(); 1691 my ($errors, %keyval) = 1692 parse_into_keywords($pa, qw/name cmd/); 1693 1694 if ($errors) { 1695 tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); 1696 return 0; 1697 } 1698 1699 # name can be an arbitrary string 1700 if (!defined($keyval{'name'})) { 1701 tlwarn("name of filetype postaction not given\n"); 1702 return 0; 1703 } 1704 my $name = $keyval{'name'}.'.'.$ReleaseYear; 1705 1706 # cmd can be an arbitrary string 1707 if (!defined($keyval{'cmd'})) { 1708 tlwarn("cmd of filetype postaction not given\n"); 1709 return 0; 1710 } 1711 my $cmd = $keyval{'cmd'}; 1712 1713 my $texdir = `kpsewhich -var-value=SELFAUTOPARENT`; 1714 chomp($texdir); 1715 my $texdir_bsl = conv_to_w32_path($texdir); 1716 $cmd =~ s!^("?)TEXDIR/!$1$texdir/!g; 1717 1718 &log("postaction $how filetype for " . $tlpobj->name . 1719 ": $name, $cmd\n"); 1720 if ($how eq "install") { 1721 TeXLive::TLWinGoo::register_file_type($name, $cmd); 1722 } elsif ($how eq "remove") { 1723 TeXLive::TLWinGoo::unregister_file_type($name); 1724 } else { 1725 tlwarn("Unknown mode $how\n"); 1726 return 0; 1727 } 1728 return 1; 1729} 1730 1731# alternate filetype (= progid) for an extension; 1732# associated program shows up in `open with' menu 1733sub _do_postaction_progid { 1734 my ($how, $tlpobj, $pa) = @_; 1735 return 1 unless win32(); 1736 my ($errors, %keyval) = 1737 parse_into_keywords($pa, qw/extension filetype/); 1738 1739 if ($errors) { 1740 tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); 1741 return 0; 1742 } 1743 1744 if (!defined($keyval{'extension'})) { 1745 tlwarn("extension of progid postaction not given\n"); 1746 return 0; 1747 } 1748 my $extension = $keyval{'extension'}; 1749 1750 if (!defined($keyval{'filetype'})) { 1751 tlwarn("filetype of progid postaction not given\n"); 1752 return 0; 1753 } 1754 my $filetype = $keyval{'filetype'}.'.'.$ReleaseYear; 1755 1756 &log("postaction $how progid for " . $tlpobj->name . 1757 ": $extension, $filetype\n"); 1758 if ($how eq "install") { 1759 TeXLive::TLWinGoo::add_to_progids($extension, $filetype); 1760 } elsif ($how eq "remove") { 1761 TeXLive::TLWinGoo::remove_from_progids($extension, $filetype); 1762 } else { 1763 tlwarn("Unknown mode $how\n"); 1764 return 0; 1765 } 1766 return 1; 1767} 1768 1769sub _do_postaction_script { 1770 my ($how, $tlpobj, $pa) = @_; 1771 my ($errors, %keyval) = 1772 parse_into_keywords($pa, qw/file filew32/); 1773 1774 if ($errors) { 1775 tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); 1776 return 0; 1777 } 1778 1779 # file can be an arbitrary string 1780 if (!defined($keyval{'file'})) { 1781 tlwarn("filename of script not given\n"); 1782 return 0; 1783 } 1784 my $file = $keyval{'file'}; 1785 if (win32() && defined($keyval{'filew32'})) { 1786 $file = $keyval{'filew32'}; 1787 } 1788 my $texdir = `kpsewhich -var-value=SELFAUTOPARENT`; 1789 chomp($texdir); 1790 my @syscmd; 1791 if ($file =~ m/\.pl$/i) { 1792 # we got a perl script, call it via perl 1793 push @syscmd, "perl", "$texdir/$file"; 1794 } elsif ($file =~ m/\.texlua$/i) { 1795 # we got a texlua script, call it via texlua 1796 push @syscmd, "texlua", "$texdir/$file"; 1797 } else { 1798 # we got anything else, call it directly and hope it is excutable 1799 push @syscmd, "$texdir/$file"; 1800 } 1801 &log("postaction $how script for " . $tlpobj->name . ": @syscmd\n"); 1802 push @syscmd, $how, $texdir; 1803 my $ret = system (@syscmd); 1804 if ($ret != 0) { 1805 $ret /= 256 if $ret > 0; 1806 my $pwd = cwd (); 1807 warn "$0: calling post action script $file did not succeed in $pwd, status $ret"; 1808 return 0; 1809 } 1810 return 1; 1811} 1812 1813sub _do_postaction_shortcut { 1814 my ($how, $tlpobj, $do_menu, $do_desktop, $pa) = @_; 1815 return 1 unless win32(); 1816 my ($errors, %keyval) = 1817 parse_into_keywords($pa, qw/type name icon cmd args hide/); 1818 1819 if ($errors) { 1820 tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); 1821 return 0; 1822 } 1823 1824 # type can be either menu or desktop 1825 if (!defined($keyval{'type'})) { 1826 tlwarn("type of shortcut postaction not given\n"); 1827 return 0; 1828 } 1829 my $type = $keyval{'type'}; 1830 if (($type ne "menu") && ($type ne "desktop")) { 1831 tlwarn("type of shortcut postaction $type is unknown (menu, desktop)\n"); 1832 return 0; 1833 } 1834 1835 if (($type eq "menu") && !$do_menu) { 1836 return 1; 1837 } 1838 if (($type eq "desktop") && !$do_desktop) { 1839 return 1; 1840 } 1841 1842 # name can be an arbitrary string 1843 if (!defined($keyval{'name'})) { 1844 tlwarn("name of shortcut postaction not given\n"); 1845 return 0; 1846 } 1847 my $name = $keyval{'name'}; 1848 1849 # icon, cmd, args is optional 1850 my $icon = (defined($keyval{'icon'}) ? $keyval{'icon'} : ''); 1851 my $cmd = (defined($keyval{'cmd'}) ? $keyval{'cmd'} : ''); 1852 my $args = (defined($keyval{'args'}) ? $keyval{'args'} : ''); 1853 1854 # hide can be only 0 or 1, and defaults to 1 1855 my $hide = (defined($keyval{'hide'}) ? $keyval{'hide'} : 1); 1856 if (($hide ne "0") && ($hide ne "1")) { 1857 tlwarn("hide of shortcut postaction $hide is unknown (0, 1)\n"); 1858 return 0; 1859 } 1860 1861 &log("postaction $how shortcut for " . $tlpobj->name . "\n"); 1862 if ($how eq "install") { 1863 my $texdir = `kpsewhich -var-value=SELFAUTOPARENT`; 1864 chomp($texdir); 1865 my $texdir_bsl = conv_to_w32_path($texdir); 1866 $icon =~ s!^TEXDIR/!$texdir/!; 1867 $cmd =~ s!^TEXDIR/!$texdir/!; 1868 # $cmd can be an URL, in which case we do NOT want to convert it to 1869 # w32 paths! 1870 if ($cmd !~ m!^\s*(http://|ftp://)!) { 1871 if (!(-e $cmd) or !(-r $cmd)) { 1872 tlwarn("Target of shortcut action does not exist: $cmd\n") 1873 if $cmd =~ /\.(exe|bat|cmd)$/i; 1874 # if not an executable, just omit shortcut silently 1875 return 0; 1876 } 1877 $cmd = conv_to_w32_path($cmd); 1878 } 1879 if ($type eq "menu" ) { 1880 TeXLive::TLWinGoo::add_menu_shortcut( 1881 $TeXLive::TLConfig::WindowsMainMenuName, 1882 $name, $icon, $cmd, $args, $hide); 1883 } elsif ($type eq "desktop") { 1884 TeXLive::TLWinGoo::add_desktop_shortcut( 1885 $name, $icon, $cmd, $args, $hide); 1886 } else { 1887 tlwarn("Unknown type of shortcut: $type\n"); 1888 return 0; 1889 } 1890 } elsif ($how eq "remove") { 1891 if ($type eq "menu") { 1892 TeXLive::TLWinGoo::remove_menu_shortcut( 1893 $TeXLive::TLConfig::WindowsMainMenuName, $name); 1894 } elsif ($type eq "desktop") { 1895 TeXLive::TLWinGoo::remove_desktop_shortcut($name); 1896 } else { 1897 tlwarn("Unknown type of shortcut: $type\n"); 1898 return 0; 1899 } 1900 } else { 1901 tlwarn("Unknown mode $how\n"); 1902 return 0; 1903 } 1904 return 1; 1905} 1906 1907sub parse_into_keywords { 1908 my ($str, @keys) = @_; 1909 my @words = quotewords('\s+', 0, $str); 1910 my %ret; 1911 my $error = 0; 1912 while (@words) { 1913 $_ = shift @words; 1914 if (/^([^=]+)=(.*)$/) { 1915 $ret{$1} = $2; 1916 } else { 1917 tlwarn("parser found a invalid word in parsing keys: $_\n"); 1918 $error++; 1919 $ret{$_} = ""; 1920 } 1921 } 1922 for my $k (keys %ret) { 1923 if (!member($k, @keys)) { 1924 $error++; 1925 tlwarn("parser found invalid keyword: $k\n"); 1926 } 1927 } 1928 return($error, %ret); 1929} 1930 1931=item C<announce_execute_actions($how, $tlpobj)> 1932 1933Announces that the actions given in C<$tlpobj> should be executed 1934after all packages have been unpacked. 1935 1936=cut 1937 1938sub announce_execute_actions { 1939 my ($type, $tlp, $what) = @_; 1940 # do simply return immediately if execute actions are suppressed 1941 return if $::no_execute_actions; 1942 1943 if (defined($type) && ($type eq "regenerate-formats")) { 1944 $::regenerate_all_formats = 1; 1945 return; 1946 } 1947 if (defined($type) && ($type eq "files-changed")) { 1948 $::files_changed = 1; 1949 return; 1950 } 1951 if (defined($type) && ($type eq "latex-updated")) { 1952 $::latex_updated = 1; 1953 return; 1954 } 1955 if (defined($type) && ($type eq "tex-updated")) { 1956 $::tex_updated = 1; 1957 return; 1958 } 1959 if (!defined($type) || (($type ne "enable") && ($type ne "disable"))) { 1960 die "announce_execute_actions: enable or disable, not type $type"; 1961 } 1962 my (@maps, @formats, @dats); 1963 if ($tlp->runfiles || $tlp->srcfiles || $tlp->docfiles) { 1964 $::files_changed = 1; 1965 } 1966 $what = "map format hyphen" if (!defined($what)); 1967 foreach my $e ($tlp->executes) { 1968 if ($e =~ m/^add((Mixed|Kanji)?Map)\s+([^\s]+)\s*$/) { 1969 # save the refs as we have another =~ grep in the following lines 1970 my $a = $1; 1971 my $b = $3; 1972 $::execute_actions{$type}{'maps'}{$b} = $a if ($what =~ m/map/); 1973 } elsif ($e =~ m/^AddFormat\s+(.*)\s*$/) { 1974 my %r = TeXLive::TLUtils::parse_AddFormat_line("$1"); 1975 if (defined($r{"error"})) { 1976 tlwarn ("$r{'error'} in parsing $e for return hash\n"); 1977 } else { 1978 $::execute_actions{$type}{'formats'}{$r{'name'}} = \%r 1979 if ($what =~ m/format/); 1980 } 1981 } elsif ($e =~ m/^AddHyphen\s+(.*)\s*$/) { 1982 my %r = TeXLive::TLUtils::parse_AddHyphen_line("$1"); 1983 if (defined($r{"error"})) { 1984 tlwarn ("$r{'error'} in parsing $e for return hash\n"); 1985 } else { 1986 $::execute_actions{$type}{'hyphens'}{$r{'name'}} = \%r 1987 if ($what =~ m/hyphen/); 1988 } 1989 } else { 1990 tlwarn("Unknown execute $e in ", $tlp->name, "\n"); 1991 } 1992 } 1993} 1994 1995 1996=pod 1997 1998=item C<add_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info)> 1999 2000=item C<remove_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info)> 2001 2002These two functions try to create/remove symlinks for binaries, man pages, 2003and info files as specified by the options $sys_bin, $sys_man, $sys_info. 2004 2005The functions return 1 on success and 0 on error. 2006On Windows it returns undefined. 2007 2008=cut 2009 2010sub add_link_dir_dir { 2011 my ($from,$to) = @_; 2012 mkdirhier ($to); 2013 if (-w $to) { 2014 debug ("linking files from $from to $to\n"); 2015 chomp (@files = `ls "$from"`); 2016 my $ret = 1; 2017 for my $f (@files) { 2018 # don't make a system-dir link to our special "man" link. 2019 if ($f eq "man") { 2020 debug ("not linking `man' into $to.\n"); 2021 next; 2022 } 2023 # 2024 # attempt to remove an existing symlink, but nothing else. 2025 unlink ("$to/$f") if -l "$to/$f"; 2026 # 2027 # if the destination still exists, skip it. 2028 if (-e "$to/$f") { 2029 tlwarn ("add_link_dir_dir: $to/$f exists; not making symlink.\n"); 2030 next; 2031 } 2032 # 2033 # try to make the link. 2034 if (symlink ("$from/$f", "$to/$f") == 0) { 2035 tlwarn ("add_link_dir_dir: symlink of $f from $from to $to failed: $!\n"); 2036 $ret = 0; 2037 } 2038 } 2039 return $ret; 2040 } else { 2041 tlwarn ("add_link_dir_dir: destination $to not writable, " 2042 . "no links from $from.\n"); 2043 return 0; 2044 } 2045} 2046 2047sub remove_link_dir_dir { 2048 my ($from, $to) = @_; 2049 if ((-d "$to") && (-w "$to")) { 2050 debug("removing links from $from to $to\n"); 2051 chomp (@files = `ls "$from"`); 2052 my $ret = 1; 2053 foreach my $f (@files) { 2054 next if (! -r "$to/$f"); 2055 if ($f eq "man") { 2056 debug("not considering man in $to, it should not be from us!\n"); 2057 next; 2058 } 2059 if ((-l "$to/$f") && 2060 (readlink("$to/$f") =~ m;^$from/;)) { 2061 $ret = 0 unless unlink("$to/$f"); 2062 } else { 2063 $ret = 0; 2064 tlwarn ("not removing $to/$f, not a link or wrong destination!\n"); 2065 } 2066 } 2067 # trry to remove the destination directory, it might be empty and 2068 # we might have write permissions, ignore errors 2069 # `rmdir "$to" 2>/dev/null`; 2070 return $ret; 2071 } else { 2072 tlwarn ("destination $to not writable, no removal of links done!\n"); 2073 return 0; 2074 } 2075} 2076 2077sub add_remove_symlinks { 2078 my ($mode, $Master, $arch, $sys_bin, $sys_man, $sys_info) = @_; 2079 my $errors = 0; 2080 my $plat_bindir = "$Master/bin/$arch"; 2081 2082 # nothing to do with symlinks on Windows, of course. 2083 return if win32(); 2084 2085 my $info_dir = "$Master/texmf-dist/doc/info"; 2086 if ($mode eq "add") { 2087 $errors++ unless add_link_dir_dir($plat_bindir, $sys_bin); # bin 2088 if (-d $info_dir) { 2089 $errors++ unless add_link_dir_dir($info_dir, $sys_info); 2090 } 2091 } elsif ($mode eq "remove") { 2092 $errors++ unless remove_link_dir_dir($plat_bindir, $sys_bin); # bin 2093 if (-d $info_dir) { 2094 $errors++ unless remove_link_dir_dir($info_dir, $sys_info); 2095 } 2096 } else { 2097 die ("should not happen, unknown mode $mode in add_remove_symlinks!"); 2098 } 2099 2100 # man 2101 my $top_man_dir = "$Master/texmf-dist/doc/man"; 2102 debug("$mode symlinks for man pages to $sys_man from $top_man_dir\n"); 2103 if (! -d $top_man_dir && $mode eq "add") { 2104 ; # better to be silent? 2105 #info("skipping add of man symlinks, no source directory $top_man_dir\n"); 2106 } else { 2107 mkdirhier $sys_man if ($mode eq "add"); 2108 if (-w $sys_man) { 2109 my $foo = `(cd "$top_man_dir" && echo *)`; 2110 my @mans = split (' ', $foo); 2111 chomp (@mans); 2112 foreach my $m (@mans) { 2113 my $mandir = "$top_man_dir/$m"; 2114 next unless -d $mandir; 2115 if ($mode eq "add") { 2116 $errors++ unless add_link_dir_dir($mandir, "$sys_man/$m"); 2117 } else { 2118 $errors++ unless remove_link_dir_dir($mandir, "$sys_man/$m"); 2119 } 2120 } 2121 #`rmdir "$sys_man" 2>/dev/null` if ($mode eq "remove"); 2122 } else { 2123 tlwarn("man symlink destination ($sys_man) not writable," 2124 . "cannot $mode symlinks.\n"); 2125 $errors++; 2126 } 2127 } 2128 2129 # we collected errors in $errors, so return the negation of it 2130 if ($errors) { 2131 info("$mode of symlinks had $errors error(s), see messages above.\n"); 2132 return 0; 2133 } else { 2134 return 1; 2135 } 2136} 2137 2138sub add_symlinks { return (add_remove_symlinks("add", @_)); } 2139sub remove_symlinks { return (add_remove_symlinks("remove", @_)); } 2140 2141=pod 2142 2143=item C<w32_add_to_path($bindir, $multiuser)> 2144=item C<w32_remove_from_path($bindir, $multiuser)> 2145 2146These two functions try to add/remove the binary directory $bindir 2147on Windows to the registry PATH variable. 2148 2149If running as admin user and $multiuser is set, the system path will 2150be adjusted, otherwise the user path. 2151 2152After calling these functions TeXLive::TLWinGoo::broadcast_env() should 2153be called to make the changes immediately visible. 2154 2155=cut 2156 2157sub w32_add_to_path { 2158 my ($bindir, $multiuser) = @_; 2159 return if (!win32()); 2160 2161 my $path = TeXLive::TLWinGoo::get_system_env() -> {'/Path'}; 2162 $path =~ s/[\s\x00]+$//; 2163 &log("Old system path: $path\n"); 2164 $path = TeXLive::TLWinGoo::get_user_env() -> {'/Path'}; 2165 if ($path) { 2166 $path =~ s/[\s\x00]+$//; 2167 &log("Old user path: $path\n"); 2168 } else { 2169 &log("Old user path: none\n"); 2170 } 2171 my $mode = 'user'; 2172 if (TeXLive::TLWinGoo::admin() && $multiuser) { 2173 $mode = 'system'; 2174 } 2175 debug("TLUtils:w32_add_to_path: calling adjust_reg_path_for_texlive add $bindir $mode\n"); 2176 TeXLive::TLWinGoo::adjust_reg_path_for_texlive('add', $bindir, $mode); 2177 $path = TeXLive::TLWinGoo::get_system_env() -> {'/Path'}; 2178 $path =~ s/[\s\x00]+$//; 2179 &log("New system path: $path\n"); 2180 $path = TeXLive::TLWinGoo::get_user_env() -> {'/Path'}; 2181 if ($path) { 2182 $path =~ s/[\s\x00]+$//; 2183 &log("New user path: $path\n"); 2184 } else { 2185 &log("New user path: none\n"); 2186 } 2187} 2188 2189sub w32_remove_from_path { 2190 my ($bindir, $multiuser) = @_; 2191 my $mode = 'user'; 2192 if (TeXLive::TLWinGoo::admin() && $multiuser) { 2193 $mode = 'system'; 2194 } 2195 debug("w32_remove_from_path: trying to remove $bindir in $mode\n"); 2196 TeXLive::TLWinGoo::adjust_reg_path_for_texlive('remove', $bindir, $mode); 2197} 2198 2199=pod 2200 2201=item C<unpack($what, $targetdir> 2202 2203If necessary, downloads C$what>, and then unpacks it into C<$targetdir>. 2204Returns the name of the unpacked package (determined from the name of C<$what>) 2205in case of success, otherwise undefined. 2206 2207=cut 2208 2209sub unpack { 2210 my ($what, $target) = @_; 2211 2212 if (!defined($what)) { 2213 tlwarn("TLUtils::unpack: nothing to unpack!\n"); 2214 return; 2215 } 2216 2217 # we assume that $::progs has been set up! 2218 my $wget = $::progs{'wget'}; 2219 my $xzdec = TeXLive::TLUtils::quotify_path_with_spaces($::progs{'xzdec'}); 2220 if (!defined($wget) || !defined($xzdec)) { 2221 tlwarn("_install_package: programs not set up properly, strange.\n"); 2222 return; 2223 } 2224 2225 my $type; 2226 if ($what =~ m,\.tar(\.xz)?$,) { 2227 $type = defined($what) ? "xz" : "tar"; 2228 } else { 2229 tlwarn("TLUtils::unpack: don't know how to unpack this: $what\n"); 2230 return; 2231 } 2232 2233 my $tempdir = tl_tmpdir(); 2234 2235 # we are still here, so something was handed in and we have either .tar or .tar.xz 2236 my $fn = basename($what); 2237 my $pkg = $fn; 2238 $pkg =~ s/\.tar(\.xz)?$//; 2239 my $tarfile; 2240 my $remove_tarfile = 1; 2241 if ($type eq "xz") { 2242 my $xzfile = "$tempdir/$fn"; 2243 $tarfile = "$tempdir/$fn"; $tarfile =~ s/\.xz$//; 2244 my $xzfile_quote = $xzfile; 2245 my $tarfile_quote = $tarfile; 2246 my $target_quote = $target; 2247 if (win32()) { 2248 $xzfile =~ s!/!\\!g; 2249 $tarfile =~ s!/!\\!g; 2250 $target =~ s!/!\\!g; 2251 } 2252 $xzfile_quote = "\"$xzfile\""; 2253 $tarfile_quote = "\"$tarfile\""; 2254 $target_quote = "\"$target\""; 2255 if ($what =~ m,http://|ftp://,) { 2256 # we are installing from the NET 2257 # download the file and put it into temp 2258 if (!download_file($what, $xzfile) || (! -r $xzfile)) { 2259 tlwarn("Downloading \n"); 2260 tlwarn(" $what\n"); 2261 tlwarn("did not succeed, please retry.\n"); 2262 unlink($tarfile, $xzfile); 2263 return; 2264 } 2265 } else { 2266 # we are installing from local compressed files 2267 # copy it to temp 2268 TeXLive::TLUtils::copy($what, $tempdir); 2269 } 2270 debug("un-xzing $xzfile to $tarfile\n"); 2271 system("$xzdec < $xzfile_quote > $tarfile_quote"); 2272 if (! -f $tarfile) { 2273 tlwarn("TLUtils::unpack: Unpacking $xzfile failed, please retry.\n"); 2274 unlink($tarfile, $xzfile); 2275 return; 2276 } 2277 unlink($xzfile); 2278 } else { 2279 $tarfile = "$tempdir/$fn"; 2280 if ($what =~ m,http://|ftp://,) { 2281 if (!download_file($what, $tarfile) || (! -r $tarfile)) { 2282 tlwarn("Downloading \n"); 2283 tlwarn(" $what\n"); 2284 tlwarn("failed, please retry.\n"); 2285 unlink($tarfile); 2286 return; 2287 } 2288 } else { 2289 $tarfile = $what; 2290 $remove_tarfile = 0; 2291 } 2292 } 2293 if (untar($tarfile, $target, $remove_tarfile)) { 2294 return "$pkg"; 2295 } else { 2296 return; 2297 } 2298} 2299 2300=pod 2301 2302=item C<untar($tarfile, $targetdir, $remove_tarfile)> 2303 2304Unpacks C<$tarfile> in C<$targetdir> (changing directories to 2305C<$targetdir> and then back to the original directory). If 2306C<$remove_tarfile> is true, unlink C<$tarfile> after unpacking. 2307 2308Assumes the global C<$::progs{"tar"}> has been set up. 2309 2310=cut 2311 2312# return 1 if success, 0 if failure. 2313sub untar { 2314 my ($tarfile, $targetdir, $remove_tarfile) = @_; 2315 my $ret; 2316 2317 my $tar = $::progs{'tar'}; # assume it's been set up 2318 2319 # don't use the -C option to tar since Solaris tar et al. don't support it. 2320 # don't use system("cd ... && $tar ...") since that opens us up to 2321 # quoting issues. 2322 # so fall back on chdir in Perl. 2323 # 2324 debug("unpacking $tarfile in $targetdir\n"); 2325 my $cwd = cwd(); 2326 chdir($targetdir) || die "chdir($targetdir) failed: $!"; 2327 2328 # on w32 don't extract file modified time, because AV soft can open 2329 # files in the mean time causing time stamp modification to fail 2330 if (system($tar, win32() ? "xmf" : "xf", $tarfile) != 0) { 2331 tlwarn("untar: untarring $tarfile failed (in $targetdir)\n"); 2332 $ret = 0; 2333 } else { 2334 $ret = 1; 2335 } 2336 unlink($tarfile) if $remove_tarfile; 2337 2338 chdir($cwd) || die "chdir($cwd) failed: $!"; 2339 return $ret; 2340} 2341 2342 2343=item C<tlcmp($file, $file)> 2344 2345Compare two files considering CR, LF, and CRLF as equivalent. 2346Returns 1 if different, 0 if the same. 2347 2348=cut 2349 2350sub tlcmp { 2351 my ($filea, $fileb) = @_; 2352 if (!defined($fileb)) { 2353 die <<END_USAGE; 2354tlcmp needs two arguments FILE1 FILE2. 2355Compare as text files, ignoring line endings. 2356Exit status is zero if the same, 1 if different, something else if trouble. 2357END_USAGE 2358 } 2359 my $file1 = &read_file_ignore_cr ($filea); 2360 my $file2 = &read_file_ignore_cr ($fileb); 2361 2362 return $file1 eq $file2 ? 0 : 1; 2363} 2364 2365 2366=item C<read_file_ignore_cr($file)> 2367 2368Return contents of FILE as a string, converting all of CR, LF, and 2369CRLF to just LF. 2370 2371=cut 2372 2373sub read_file_ignore_cr { 2374 my ($fname) = @_; 2375 my $ret = ""; 2376 2377 local *FILE; 2378 open (FILE, $fname) || die "open($fname) failed: $!"; 2379 while (<FILE>) { 2380 s/\r\n?/\n/g; 2381 #warn "line is |$_|"; 2382 $ret .= $_; 2383 } 2384 close (FILE) || warn "close($fname) failed: $!"; 2385 2386 return $ret; 2387} 2388 2389 2390=item C<setup_programs($bindir, $platform)> 2391 2392Populate the global C<$::progs> hash containing the paths to the 2393programs C<wget>, C<tar>, C<xzdec>. The C<$bindir> argument specifies 2394the path to the location of the C<xzdec> binaries, the C<$platform> 2395gives the TeX Live platform name, used as the extension on our 2396executables. If a program is not present in the TeX Live tree, we also 2397check along PATH (without the platform extension.) 2398 2399Return 0 if failure, nonzero if success. 2400 2401=cut 2402 2403sub setup_programs { 2404 my ($bindir, $platform) = @_; 2405 my $ok = 1; 2406 2407 $::progs{'wget'} = "wget"; 2408 $::progs{'xzdec'} = "xzdec"; 2409 $::progs{'xz'} = "xz"; 2410 $::progs{'tar'} = "tar"; 2411 2412 if ($^O =~ /^MSWin(32|64)$/i) { 2413 $::progs{'wget'} = conv_to_w32_path("$bindir/wget/wget.exe"); 2414 $::progs{'tar'} = conv_to_w32_path("$bindir/tar.exe"); 2415 $::progs{'xzdec'} = conv_to_w32_path("$bindir/xz/xzdec.exe"); 2416 $::progs{'xz'} = conv_to_w32_path("$bindir/xz/xz.exe"); 2417 for my $prog ("xzdec", "wget") { 2418 my $opt = $prog eq "xzdec" ? "--help" : "--version"; 2419 my $ret = system("$::progs{$prog} $opt >nul 2>&1"); # on windows 2420 if ($ret != 0) { 2421 warn "TeXLive::TLUtils::setup_programs (w32) failed"; # no nl for perl 2422 warn "$::progs{$prog} $opt failed (status $ret): $!\n"; 2423 warn "Output is:\n"; 2424 system ("$::progs{$prog} $opt"); 2425 warn "\n"; 2426 $ok = 0; 2427 } 2428 } 2429 } else { 2430 if (!defined($platform) || ($platform eq "")) { 2431 # we assume that we run from uncompressed media, so we can call platform() and 2432 # thus also the config.guess script 2433 # but we have to setup $::installerdir because the platform script 2434 # relies on it 2435 $::installerdir = "$bindir/../.."; 2436 $platform = platform(); 2437 } 2438 my $s = 0; 2439 $s += setup_unix_one('wget', "$bindir/wget/wget.$platform", "--version"); 2440 $s += setup_unix_one('xzdec',"$bindir/xz/xzdec.$platform","--help"); 2441 $s += setup_unix_one('xz', "$bindir/xz/xz.$platform", "notest"); 2442 $ok = ($s == 3); # failure return unless all are present. 2443 } 2444 2445 return $ok; 2446} 2447 2448 2449# setup one prog on unix using the following logic: 2450# - if the shipped one is -x and can be executed, use it 2451# - if the shipped one is -x but cannot be executed, copy it. set -x 2452# . if the copy is -x and executable, use it 2453# . if the copy is not executable, GOTO fallback 2454# - if the shipped one is not -x, copy it, set -x 2455# . if the copy is -x and executable, use it 2456# . if the copy is not executable, GOTO fallback 2457# - if nothing shipped, GOTO fallback 2458# 2459# fallback: 2460# if prog is found in PATH and can be executed, use it. 2461# 2462# Return 0 if failure, 1 if success. 2463# 2464sub setup_unix_one { 2465 my ($p, $def, $arg) = @_; 2466 our $tmp; 2467 my $test_fallback = 0; 2468 if (-r $def) { 2469 my $ready = 0; 2470 if (-x $def) { 2471 # checking only for the executable bit is not enough, we have 2472 # to check for actualy "executability" since a "noexec" mount 2473 # option may interfere, which is not taken into account by 2474 # perl's -x test. 2475 $::progs{$p} = $def; 2476 if ($arg ne "notest") { 2477 my $ret = system("$def $arg > /dev/null 2>&1" ); # we are on Unix 2478 if ($ret == 0) { 2479 $ready = 1; 2480 debug("Using shipped $def for $p (tested).\n"); 2481 } else { 2482 ddebug("Shipped $def has -x but cannot be executed.\n"); 2483 } 2484 } else { 2485 # do not test, just return 2486 $ready = 1; 2487 debug("Using shipped $def for $p (not tested).\n"); 2488 } 2489 } 2490 if (!$ready) { 2491 # out of some reasons we couldn't execute the shipped program 2492 # try to copy it to a temp directory and make it executable 2493 # 2494 # create tmp dir only when necessary 2495 $tmp = TeXLive::TLUtils::tl_tmpdir() unless defined($tmp); 2496 # probably we are running from uncompressed media and want to copy it to 2497 # some temporary location 2498 copy($def, $tmp); 2499 my $bn = basename($def); 2500 $::progs{$p} = "$tmp/$bn"; 2501 chmod(0755,$::progs{$p}); 2502 # we do not check the return value of chmod, but check whether 2503 # the -x bit is now set, the only thing that counts 2504 if (! -x $::progs{$p}) { 2505 # hmm, something is going really bad, not even the copy is 2506 # executable. Fall back to normal path element 2507 $test_fallback = 1; 2508 ddebug("Copied $p $::progs{$p} does not have -x bit, strange!\n"); 2509 } else { 2510 # check again for executability 2511 if ($arg ne "notest") { 2512 my $ret = system("$::progs{$p} $arg > /dev/null 2>&1"); 2513 if ($ret == 0) { 2514 # ok, the copy works 2515 debug("Using copied $::progs{$p} for $p (tested).\n"); 2516 } else { 2517 # even the copied prog is not executable, strange 2518 $test_fallback = 1; 2519 ddebug("Copied $p $::progs{$p} has x bit but not executable, strange!\n"); 2520 } 2521 } else { 2522 debug("Using copied $::progs{$p} for $p (not tested).\n"); 2523 } 2524 } 2525 } 2526 } else { 2527 # hope that we can find in in the global PATH 2528 $test_fallback = 1; 2529 } 2530 if ($test_fallback) { 2531 # all our playing around and copying did not succeed, try the 2532 # fallback 2533 $::progs{$p} = $p; 2534 if ($arg ne "notest") { 2535 my $ret = system("$p $arg > /dev/null 2>&1"); 2536 if ($ret == 0) { 2537 debug("Using system $p (tested).\n"); 2538 } else { 2539 tlwarn("$0: Initialization failed (in setup_unix_one):\n"); 2540 tlwarn("$0: could not find a usable $p.\n"); 2541 tlwarn("$0: Please install $p and try again.\n"); 2542 return 0; 2543 } 2544 } else { 2545 debug ("Using system $p (not tested).\n"); 2546 } 2547 } 2548 return 1; 2549} 2550 2551=item C<download_file( $relpath, $destination [, $progs ] )> 2552 2553Try to download the file given in C<$relpath> from C<$TeXLiveURL> 2554into C<$destination>, which can be either 2555a filename of simply C<|>. In the latter case a file handle is returned. 2556 2557The optional argument C<$progs> is a reference to a hash giving full 2558paths to the respective programs, at least C<wget>. If C<$progs> is not 2559given the C<%::progs> hash is consulted, and if this also does not exist 2560we try a literal C<wget>. 2561 2562Downloading honors two environment variables: C<TL_DOWNLOAD_PROGRAM> and 2563C<TL_DOWNLOAD_ARGS>. The former overrides the above specification 2564devolving to C<wget>, and the latter overrides the default wget 2565arguments. 2566 2567C<TL_DOWNLOAD_ARGS> must be defined so that the file the output goes to 2568is the first argument after the C<TL_DOWNLOAD_ARGS>. Thus, typically it 2569would end in C<-O>. Use with care. 2570 2571=cut 2572 2573sub download_file { 2574 my ($relpath, $dest, $progs) = @_; 2575 my $wget; 2576 if (defined($progs) && defined($progs->{'wget'})) { 2577 $wget = $progs->{'wget'}; 2578 } elsif (defined($::progs{'wget'})) { 2579 $wget = $::progs{'wget'}; 2580 } else { 2581 tlwarn ("download_file: Programs not set up, trying literal wget\n"); 2582 $wget = "wget"; 2583 } 2584 my $url; 2585 if ($relpath =~ m;^file://*(.*)$;) { 2586 my $filetoopen = "/$1"; 2587 # $dest is a file name, we have to get the respective dirname 2588 if ($dest eq "|") { 2589 open(RETFH, "<$filetoopen") or 2590 die("Cannot open $filetoopen for reading"); 2591 # opening to a pipe always succeeds, so we return immediately 2592 return \*RETFH; 2593 } else { 2594 my $par = dirname ($dest); 2595 if (-r $filetoopen) { 2596 copy ($filetoopen, $par); 2597 return 1; 2598 } 2599 return 0; 2600 } 2601 } 2602 if ($relpath =~ /^(http|ftp):\/\//) { 2603 $url = $relpath; 2604 } else { 2605 $url = "$TeXLiveURL/$relpath"; 2606 } 2607 2608 my $wget_retry = 0; 2609 if (defined($::tldownload_server) && $::tldownload_server->enabled) { 2610 debug("persistent connection set up, trying to get $url (for $dest)\n"); 2611 $ret = $::tldownload_server->get_file($url, $dest); 2612 if ($ret) { 2613 debug("downloading file via persistent connection succeeded\n"); 2614 return $ret; 2615 } else { 2616 tlwarn("TLUtils::download_file: persistent connection ok," 2617 . " but download failed: $url\n"); 2618 tlwarn("TLUtils::download_file: retrying with wget.\n"); 2619 $wget_retry = 1; # just so we can give another msg. 2620 } 2621 } else { 2622 if (!defined($::tldownload_server)) { 2623 debug("::tldownload_server not defined\n"); 2624 } else { 2625 debug("::tldownload_server->enabled is not set\n"); 2626 } 2627 debug("persistent connection not set up, using wget\n"); 2628 } 2629 2630 # try again. 2631 my $ret = _download_file($url, $dest, $wget); 2632 2633 if ($wget_retry) { 2634 tlwarn("TLUtils::download_file: retry with wget " 2635 . ($ret ? "succeeded" : "failed") . ": $url\n"); 2636 } 2637 2638 return($ret); 2639} 2640 2641sub _download_file { 2642 my ($url, $dest, $wgetdefault) = @_; 2643 if (win32()) { 2644 $dest =~ s!/!\\!g; 2645 } 2646 2647 my $wget = $ENV{"TL_DOWNLOAD_PROGRAM"} || $wgetdefault; 2648 my $wgetargs = $ENV{"TL_DOWNLOAD_ARGS"} 2649 || "--user-agent=texlive/wget --tries=10 --timeout=$NetworkTimeout -q -O"; 2650 2651 debug("downloading $url using $wget $wgetargs\n"); 2652 my $ret; 2653 if ($dest eq "|") { 2654 open(RETFH, "$wget $wgetargs - $url|") 2655 || die "open($url) via $wget $wgetargs failed: $!"; 2656 # opening to a pipe always succeeds, so we return immediately 2657 return \*RETFH; 2658 } else { 2659 my @wgetargs = split (" ", $wgetargs); 2660 $ret = system ($wget, @wgetargs, $dest, $url); 2661 # we have to reverse the meaning of ret because system has 0=success. 2662 $ret = ($ret ? 0 : 1); 2663 } 2664 # return false/undef in case the download did not succeed. 2665 return ($ret) unless $ret; 2666 debug("download of $url succeeded\n"); 2667 if ($dest eq "|") { 2668 return \*RETFH; 2669 } else { 2670 return 1; 2671 } 2672} 2673 2674=item C<nulldev ()> 2675 2676Return C</dev/null> on Unix and C<nul> on Windows. 2677 2678=cut 2679 2680sub nulldev { 2681 return (&win32)? 'nul' : '/dev/null'; 2682} 2683 2684=item C<get_full_line ($fh)> 2685 2686returns the next line from the file handle $fh, taking 2687continuation lines into account (last character of a line is \, and 2688no quoting is parsed). 2689 2690=cut 2691 2692# open my $f, '<', $file_name or die; 2693# while (my $l = get_full_line($f)) { ... } 2694# close $f or die; 2695sub get_full_line { 2696 my ($fh) = @_; 2697 my $line = <$fh>; 2698 return undef unless defined $line; 2699 return $line unless $line =~ s/\\\r?\n$//; 2700 my $cont = get_full_line($fh); 2701 if (!defined($cont)) { 2702 tlwarn('Continuation disallowed at end of file'); 2703 $cont = ""; 2704 } 2705 $cont =~ s/^\s*//; 2706 return $line . $cont; 2707} 2708 2709 2710=back 2711 2712=head2 Installer Functions 2713 2714=over 4 2715 2716=item C<make_var_skeleton($prefix)> 2717 2718Generate a skeleton of empty directories in the C<TEXMFSYSVAR> tree. 2719 2720=cut 2721 2722sub make_var_skeleton { 2723 my ($prefix) = @_; 2724 2725 mkdirhier "$prefix/tex/generic/config"; 2726 mkdirhier "$prefix/fonts/map/dvipdfmx/updmap"; 2727 mkdirhier "$prefix/fonts/map/dvips/updmap"; 2728 mkdirhier "$prefix/fonts/map/pdftex/updmap"; 2729 mkdirhier "$prefix/fonts/pk"; 2730 mkdirhier "$prefix/fonts/tfm"; 2731 mkdirhier "$prefix/web2c"; 2732 mkdirhier "$prefix/xdvi"; 2733 mkdirhier "$prefix/tex/context/config"; 2734} 2735 2736 2737=item C<make_local_skeleton($prefix)> 2738 2739Generate a skeleton of empty directories in the C<TEXMFLOCAL> tree, 2740unless C<TEXMFLOCAL> already exists. 2741 2742=cut 2743 2744sub make_local_skeleton { 2745 my ($prefix) = @_; 2746 2747 return if (-d $prefix); 2748 2749 mkdirhier "$prefix/bibtex/bib/local"; 2750 mkdirhier "$prefix/bibtex/bst/local"; 2751 mkdirhier "$prefix/doc/local"; 2752 mkdirhier "$prefix/dvips/local"; 2753 mkdirhier "$prefix/fonts/source/local"; 2754 mkdirhier "$prefix/fonts/tfm/local"; 2755 mkdirhier "$prefix/fonts/type1/local"; 2756 mkdirhier "$prefix/fonts/vf/local"; 2757 mkdirhier "$prefix/metapost/local"; 2758 mkdirhier "$prefix/tex/latex/local"; 2759 mkdirhier "$prefix/tex/plain/local"; 2760 mkdirhier "$prefix/tlpkg"; 2761 mkdirhier "$prefix/web2c"; 2762} 2763 2764 2765=item C<create_fmtutil($tlpdb, $dest)> 2766 2767=item C<create_updmap($tlpdb, $dest)> 2768 2769=item C<create_language_dat($tlpdb, $dest, $localconf)> 2770 2771=item C<create_language_def($tlpdb, $dest, $localconf)> 2772 2773=item C<create_language_lua($tlpdb, $dest, $localconf)> 2774 2775These five functions create C<fmtutil.cnf>, C<updmap.cfg>, C<language.dat>, 2776C<language.def>, and C<language.dat.lua> respectively, in C<$dest> (which by 2777default is below C<$TEXMFSYSVAR>). These functions merge the information 2778present in the TLPDB C<$tlpdb> (formats, maps, hyphenations) with local 2779configuration additions: C<$localconf>. 2780 2781Currently the merging is done by omitting disabled entries specified 2782in the local file, and then appending the content of the local 2783configuration files at the end of the file. We should also check for 2784duplicates, maybe even error checking. 2785 2786=cut 2787 2788# 2789# get_disabled_local_configs 2790# returns the list of disabled formats/hyphenpatterns/maps 2791# disabling is done by putting 2792# #!NAME 2793# or 2794# %!NAME 2795# into the respective foo-local.cnf/cfg file 2796# 2797sub get_disabled_local_configs { 2798 my $localconf = shift; 2799 my $cc = shift; 2800 my @disabled = (); 2801 if ($localconf && -r $localconf) { 2802 open (FOO, "<$localconf") 2803 || die "strange, -r ok but open($localconf) failed: $!"; 2804 my @tmp = <FOO>; 2805 close(FOO) || warn("close($localconf) failed: $!"); 2806 @disabled = map { if (m/^$cc!(\S+)\s*$/) { $1 } else { } } @tmp; 2807 } 2808 return @disabled; 2809} 2810 2811sub create_fmtutil { 2812 my ($tlpdb,$dest) = @_; 2813 my @lines = $tlpdb->fmtutil_cnf_lines(); 2814 _create_config_files($tlpdb, "texmf-dist/web2c/fmtutil-hdr.cnf", $dest, 2815 undef, 0, '#', \@lines); 2816} 2817 2818sub create_updmap { 2819 my ($tlpdb,$dest) = @_; 2820 check_for_old_updmap_cfg(); 2821 my @tlpdblines = $tlpdb->updmap_cfg_lines(); 2822 _create_config_files($tlpdb, "texmf-dist/web2c/updmap-hdr.cfg", $dest, 2823 undef, 0, '#', \@tlpdblines); 2824} 2825 2826sub check_for_old_updmap_cfg { 2827 chomp( my $tmfsysconf = `kpsewhich -var-value=TEXMFSYSCONFIG` ) ; 2828 my $oldupd = "$tmfsysconf/web2c/updmap.cfg"; 2829 return unless -r $oldupd; # if no such file, good. 2830 2831 open (OLDUPD, "<$oldupd") || die "open($oldupd) failed: $!"; 2832 my $firstline = <OLDUPD>; 2833 close(OLDUPD); 2834 # cygwin returns undef when reading from an empty file, we have 2835 # to make sure that this is anyway initialized 2836 $firstline = "" if (!defined($firstline)); 2837 chomp ($firstline); 2838 # 2839 if ($firstline =~ m/^# Generated by (install-tl|.*\/tlmgr) on/) { 2840 # assume it was our doing, rename it. 2841 my $nn = "$oldupd.DISABLED"; 2842 if (-r $nn) { 2843 my $fh; 2844 ($fh, $nn) = File::Temp::tempfile( 2845 "updmap.cfg.DISABLED.XXXXXX", DIR => "$tmfsysconf/web2c"); 2846 } 2847 print "Renaming old config file from 2848 $oldupd 2849to 2850 $nn 2851"; 2852 if (rename($oldupd, $nn)) { 2853 if (system("mktexlsr", $tmfsysconf) != 0) { 2854 die "mktexlsr $tmfsysconf failed after updmap.cfg rename, fix fix: $!"; 2855 } 2856 print "No further action should be necessary.\n"; 2857 } else { 2858 print STDERR " 2859Renaming of 2860 $oldupd 2861did not succeed. This config file should not be used anymore, 2862so please do what's necessary to eliminate it. 2863See the documentation for updmap. 2864"; 2865 } 2866 2867 } else { # first line did not match 2868 # that is NOT a good idea, because updmap creates updmap.cfg in 2869 # TEXMFSYSCONFIG when called with --enable Map etc, so we should 2870 # NOT warn here 2871 # print STDERR "Apparently 2872# $oldupd 2873# was created by hand. This config file should not be used anymore, 2874# so please do what's necessary to eliminate it. 2875# See the documentation for updmap. 2876# "; 2877 } 2878} 2879 2880sub check_updmap_config_value { 2881 my ($k, $v, $f) = @_; 2882 return 0 if !defined($k); 2883 return 0 if !defined($v); 2884 if (member( $k, qw/dvipsPreferOutline dvipsDownloadBase35 2885 pdftexDownloadBase14 dvipdfmDownloadBase14/)) { 2886 if ($v eq "true" || $v eq "false") { 2887 return 1; 2888 } else { 2889 tlwarn("Unknown setting for $k in $f: $v\n"); 2890 return 0; 2891 } 2892 } elsif ($k eq "LW35") { 2893 if (member($v, qw/URW URWkb ADOBE ADOBEkb/)) { 2894 return 1; 2895 } else { 2896 tlwarn("Unknown setting for LW35 in $f: $v\n"); 2897 return 0; 2898 } 2899 } elsif ($k eq "kanjiEmbed") { 2900 # any string is fine 2901 return 1; 2902 } else { 2903 return 0; 2904 } 2905} 2906 2907sub create_language_dat { 2908 my ($tlpdb,$dest,$localconf) = @_; 2909 # no checking for disabled stuff for language.dat and .def 2910 my @lines = $tlpdb->language_dat_lines( 2911 get_disabled_local_configs($localconf, '%')); 2912 _create_config_files($tlpdb, "texmf-dist/tex/generic/config/language.us", 2913 $dest, $localconf, 0, '%', \@lines); 2914} 2915 2916sub create_language_def { 2917 my ($tlpdb,$dest,$localconf) = @_; 2918 # no checking for disabled stuff for language.dat and .def 2919 my @lines = $tlpdb->language_def_lines( 2920 get_disabled_local_configs($localconf, '%')); 2921 my @postlines; 2922 push @postlines, "%%% No changes may be made beyond this point.\n"; 2923 push @postlines, "\n"; 2924 push @postlines, "\\uselanguage {USenglish} %%% This MUST be the last line of the file.\n"; 2925 _create_config_files ($tlpdb,"texmf-dist/tex/generic/config/language.us.def", 2926 $dest, $localconf, 1, '%', \@lines, @postlines); 2927} 2928 2929sub create_language_lua { 2930 my ($tlpdb,$dest,$localconf) = @_; 2931 # no checking for disabled stuff for language.dat and .lua 2932 my @lines = $tlpdb->language_lua_lines( 2933 get_disabled_local_configs($localconf, '--')); 2934 my @postlines = ("}\n"); 2935 _create_config_files ($tlpdb,"texmf-dist/tex/generic/config/language.us.lua", 2936 $dest, $localconf, 0, '--', \@lines, @postlines); 2937} 2938 2939sub _create_config_files { 2940 my ($tlpdb, $headfile, $dest,$localconf, $keepfirstline, $cc, 2941 $tlpdblinesref, @postlines) = @_; 2942 my $root = $tlpdb->root; 2943 my @lines = (); 2944 if (-r "$root/$headfile") { 2945 # we might be in user mode and do *not* want that the generation 2946 # of the configuration file just boils out. 2947 open (INFILE, "<$root/$headfile") 2948 || die "open($root/$headfile) failed, but -r ok: $!"; 2949 @lines = <INFILE>; 2950 close (INFILE); 2951 } else { 2952 tlwarn("TLUtils::_create_config_files: $root/$headfile: " 2953 . " head file not found, ok in user mode"); 2954 } 2955 push @lines, @$tlpdblinesref; 2956 if (defined($localconf) && -r $localconf) { 2957 # 2958 # this should be done more intelligently, but for now only add those 2959 # lines without any duplication check ... 2960 open (FOO, "<$localconf") 2961 || die "strange, -r ok but cannot open $localconf: $!"; 2962 my @tmp = <FOO>; 2963 close (FOO); 2964 push @lines, @tmp; 2965 } 2966 if (@postlines) { 2967 push @lines, @postlines; 2968 } 2969 if ($#lines >= 0) { 2970 open(OUTFILE,">$dest") 2971 or die("Cannot open $dest for writing: $!"); 2972 2973 if (!$keepfirstline) { 2974 print OUTFILE $cc; 2975 printf OUTFILE " Generated by %s on %s\n", "$0", scalar localtime; 2976 } 2977 print OUTFILE @lines; 2978 close(OUTFILE) || warn "close(>$dest) failed: $!"; 2979 } 2980} 2981 2982sub parse_AddHyphen_line { 2983 my $line = shift; 2984 my %ret; 2985 # default values 2986 my $default_lefthyphenmin = 2; 2987 my $default_righthyphenmin = 3; 2988 $ret{"lefthyphenmin"} = $default_lefthyphenmin; 2989 $ret{"righthyphenmin"} = $default_righthyphenmin; 2990 $ret{"synonyms"} = []; 2991 for my $p (quotewords('\s+', 0, "$line")) { 2992 my ($a, $b) = split /=/, $p; 2993 if ($a eq "name") { 2994 if (!$b) { 2995 $ret{"error"} = "AddHyphen line needs name=something"; 2996 return %ret; 2997 } 2998 $ret{"name"} = $b; 2999 next; 3000 } 3001 if ($a eq "lefthyphenmin") { 3002 $ret{"lefthyphenmin"} = ( $b ? $b : $default_lefthyphenmin ); 3003 next; 3004 } 3005 if ($a eq "righthyphenmin") { 3006 $ret{"righthyphenmin"} = ( $b ? $b : $default_righthyphenmin ); 3007 next; 3008 } 3009 if ($a eq "file") { 3010 if (!$b) { 3011 $ret{"error"} = "AddHyphen line needs file=something"; 3012 return %ret; 3013 } 3014 $ret{"file"} = $b; 3015 next; 3016 } 3017 if ($a eq "file_patterns") { 3018 $ret{"file_patterns"} = $b; 3019 next; 3020 } 3021 if ($a eq "file_exceptions") { 3022 $ret{"file_exceptions"} = $b; 3023 next; 3024 } 3025 if ($a eq "luaspecial") { 3026 $ret{"luaspecial"} = $b; 3027 next; 3028 } 3029 if ($a eq "databases") { 3030 @{$ret{"databases"}} = split /,/, $b; 3031 next; 3032 } 3033 if ($a eq "synonyms") { 3034 @{$ret{"synonyms"}} = split /,/, $b; 3035 next; 3036 } 3037 if ($a eq "comment") { 3038 $ret{"comment"} = $b; 3039 next; 3040 } 3041 # should not be reached at all 3042 $ret{"error"} = "Unknown language directive $a"; 3043 return %ret; 3044 } 3045 # this default value couldn't be set earlier 3046 if (not defined($ret{"databases"})) { 3047 if (defined $ret{"file_patterns"} or defined $ret{"file_exceptions"} 3048 or defined $ret{"luaspecial"}) { 3049 @{$ret{"databases"}} = qw(dat def lua); 3050 } else { 3051 @{$ret{"databases"}} = qw(dat def); 3052 } 3053 } 3054 return %ret; 3055} 3056 3057 3058sub parse_AddFormat_line { 3059 my $line = shift; 3060 my %ret; 3061 $ret{"options"} = ""; 3062 $ret{"patterns"} = "-"; 3063 $ret{"mode"} = 1; 3064 for my $p (quotewords('\s+', 0, "$line")) { 3065 my ($a, $b); 3066 if ($p =~ m/^(name|engine|mode|patterns|options)=(.*)$/) { 3067 $a = $1; 3068 $b = $2; 3069 } else { 3070 $ret{"error"} = "Unknown format directive $p"; 3071 return %ret; 3072 } 3073 if ($a eq "name") { 3074 if (!$b) { 3075 $ret{"error"} = "AddFormat line needs name=something"; 3076 return %ret; 3077 } 3078 $ret{"name"} = $b; 3079 next; 3080 } 3081 if ($a eq "engine") { 3082 if (!$b) { 3083 $ret{"error"} = "AddFormat line needs engine=something"; 3084 return %ret; 3085 } 3086 $ret{"engine"} = $b; 3087 next; 3088 } 3089 if ($a eq "patterns") { 3090 $ret{"patterns"} = ( $b ? $b : "-" ); 3091 next; 3092 } 3093 if ($a eq "mode") { 3094 $ret{"mode"} = ( $b eq "disabled" ? 0 : 1 ); 3095 next; 3096 } 3097 if ($a eq "options") { 3098 $ret{"options"} = ( $b ? $b : "" ); 3099 next; 3100 } 3101 # should not be reached at all 3102 $ret{"error"} = "Unknown format directive $p"; 3103 return %ret; 3104 } 3105 return %ret; 3106} 3107 3108 3109=back 3110 3111=head2 Miscellaneous 3112 3113Ideas from Fabrice Popineau's C<FileUtils.pm>. 3114 3115=over 4 3116 3117=item C<sort_uniq(@list)> 3118 3119The C<sort_uniq> function sorts the given array and throws away multiple 3120occurrences of elements. It returns a sorted and unified array. 3121 3122=cut 3123 3124sub sort_uniq { 3125 my (@l) = @_; 3126 my ($e, $f, @r); 3127 $f = ""; 3128 @l = sort(@l); 3129 foreach $e (@l) { 3130 if ($e ne $f) { 3131 $f = $e; 3132 push @r, $e; 3133 } 3134 } 3135 return @r; 3136} 3137 3138 3139=item C<push_uniq(\@list, @items)> 3140 3141The C<push_uniq> function pushes the last elements on the list referenced 3142by the first argument. 3143 3144=cut 3145 3146sub push_uniq { 3147 # can't we use $l as a reference, and then use my? later ... 3148 local (*l, @le) = @_; 3149 foreach my $e (@le) { 3150 if (! &member($e, @l)) { 3151 push @l, $e; 3152 } 3153 } 3154} 3155 3156 3157=item C<member($item, @list)> 3158 3159The C<member> function returns true if the the first argument is contained 3160in the list of the remaining arguments. 3161 3162=cut 3163 3164sub member { 3165 my $what = shift; 3166 return scalar grep($_ eq $what, @_); 3167} 3168 3169 3170=item C<merge_into(\%to, \%from)> 3171 3172Merges the keys of %from into %to. 3173 3174=cut 3175 3176sub merge_into { 3177 my ($to, $from) = @_; 3178 foreach my $k (keys %$from) { 3179 if (defined($to->{$k})) { 3180 push @{$to->{$k}}, @{$from->{$k}}; 3181 } else { 3182 $to->{$k} = [ @{$from->{$k}} ]; 3183 } 3184 } 3185} 3186 3187 3188=item C<texdir_check($texdir)> 3189 3190Test whether installation with TEXDIR set to $texdir would succeed due to 3191writing permissions. 3192 3193Writable or not, we will not allow installation to the root 3194directory (Unix) or the root of a drive (Windows). 3195 3196=cut 3197 3198sub texdir_check { 3199 my $texdir = shift; 3200 return 0 unless defined $texdir; 3201 # convert to absolute/canonical, for safer parsing 3202 # tl_abs_path should work as long as grandparent exists 3203 $texdir = tl_abs_path($texdir); 3204 return 0 unless defined $texdir; 3205 # also reject the root of a drive/volume, 3206 # assuming that only the canonical form of the root ends with / 3207 return 0 if $texdir =~ m!/$!; 3208 my $texdirparent; 3209 my $texdirpparent; 3210 3211 return dir_writable($texdir) if (-d $texdir); 3212 ($texdirparent = $texdir) =~ s!/[^/]*$!!; 3213 #print STDERR "Checking $texdirparent".'[/]'."\n"; 3214 return dir_creatable($texdirparent) if -d dir_slash($texdirparent); 3215 # try another level up the tree 3216 ($texdirpparent = $texdirparent) =~ s!/[^/]*$!!; 3217 #print STDERR "Checking $texdirpparent".'[/]'."\n"; 3218 return dir_creatable($texdirpparent) if -d dir_slash($texdirpparent); 3219 return 0; 3220} 3221 3222 3223# no newlines or spaces are added, multiple args are just concatenated. 3224# 3225sub logit { 3226 my ($out, $level, @rest) = @_; 3227 _logit($out, $level, @rest) unless $::opt_quiet; 3228 _logit('file', $level, @rest); 3229} 3230 3231sub _logit { 3232 my ($out, $level, @rest) = @_; 3233 if ($::opt_verbosity >= $level) { 3234 # if $out is a ref/glob to STDOUT or STDERR, print it there 3235 if (ref($out) eq "GLOB") { 3236 print $out @rest; 3237 } else { 3238 # we should log it into the logfile, but that might be not initialized 3239 # so either print it to the filehandle $::LOGFILE, or push it onto 3240 # the to be printed log lines @::LOGLINES 3241 if (defined($::LOGFILE)) { 3242 print $::LOGFILE @rest; 3243 } else { 3244 push (@::LOGLINES, join ("", @rest)); 3245 } 3246 } 3247 } 3248} 3249 3250 3251=item C<info ($str1, $str2, ...)> 3252 3253Write a normal informational message, the concatenation of the argument 3254strings. The message will be written unless C<-q> was specified. If 3255the global C<$::machinereadable> is set (the C<--machine-readable> 3256option to C<tlmgr>), then output is written to stderr, else to stdout. 3257If the log file (see L<process_logging_options>) is defined, it also 3258writes there. 3259 3260It is best to use this sparingly, mainly to give feedback during lengthy 3261operations and for final results. 3262 3263=cut 3264 3265sub info { 3266 my $str = join("", @_); 3267 my $fh = ($::machinereadable ? \*STDERR : \*STDOUT); 3268 logit($fh, 0, $str); 3269 for my $i (@::info_hook) { 3270 &{$i}($str); 3271 } 3272} 3273 3274 3275=item C<debug ($str1, $str2, ...)> 3276 3277Write a debugging message, the concatenation of the argument strings. 3278The message will be omitted unless C<-v> was specified. If the log 3279file (see L<process_logging_options>) is defined, it also writes there. 3280 3281This first level debugging message reports on the overall flow of 3282work, but does not include repeated messages about processing of each 3283package. 3284 3285=cut 3286 3287sub debug { 3288 my $str = "D:" . join("", @_); 3289 return if ($::opt_verbosity < 1); 3290 logit(\*STDOUT, 1, $str); 3291 for my $i (@::debug_hook) { 3292 &{$i}($str); 3293 } 3294} 3295 3296 3297=item C<ddebug ($str1, $str2, ...)> 3298 3299Write a deep debugging message, the concatenation of the argument 3300strings. The message will be omitted unless C<-v -v> (or higher) was 3301specified. If the log file (see L<process_logging_options>) is defined, 3302it also writes there. 3303 3304This second level debugging message reports messages about processing 3305each package, in addition to the first level. 3306 3307=cut 3308 3309sub ddebug { 3310 my $str = "DD:" . join("", @_); 3311 return if ($::opt_verbosity < 2); 3312 logit(\*STDOUT, 2, $str); 3313 for my $i (@::ddebug_hook) { 3314 &{$i}($str); 3315 } 3316} 3317 3318=item C<dddebug ($str1, $str2, ...)> 3319 3320Write the deepest debugging message, the concatenation of the argument 3321strings. The message will be omitted unless C<-v -v -v> was specified. 3322If the log file (see L<process_logging_options>) is defined, it also 3323writes there. 3324 3325This third level debugging message reports messages about processing 3326each line of any tlpdb files read, in addition to the first and second 3327levels. 3328 3329=cut 3330 3331sub dddebug { 3332 my $str = "DDD:" . join("", @_); 3333 return if ($::opt_verbosity < 3); 3334 logit(\*STDOUT, 3, $str); 3335 for my $i (@::dddebug_hook) { 3336 &{$i}($str); 3337 } 3338} 3339 3340 3341=item C<log ($str1, $str2, ...)> 3342 3343Write a message to the log file (and nowhere else), the concatenation of 3344the argument strings. 3345 3346=cut 3347 3348sub log { 3349 my $savequiet = $::opt_quiet; 3350 $::opt_quiet = 0; 3351 _logit('file', -100, @_); 3352 $::opt_quiet = $savequiet; 3353} 3354 3355 3356=item C<tlwarn ($str1, $str2, ...)> 3357 3358Write a warning message, the concatenation of the argument strings. 3359This always and unconditionally writes the message to standard error; if 3360the log file (see L<process_logging_options>) is defined, it also writes 3361there. 3362 3363=cut 3364 3365sub tlwarn { 3366 my $savequiet = $::opt_quiet; 3367 my $str = join("", @_); 3368 $::opt_quiet = 0; 3369 logit (\*STDERR, -100, $str); 3370 $::opt_quiet = $savequiet; 3371 for my $i (@::warn_hook) { 3372 &{$i}($str); 3373 } 3374} 3375 3376=item C<tldie ($str1, $str2, ...)> 3377 3378Uses C<tlwarn> to issue a warning, then exits with exit code 1. 3379 3380=cut 3381 3382sub tldie { 3383 tlwarn(@_); 3384 exit(1); 3385} 3386 3387=item C<debug_hash ($label, hash))> 3388 3389Write LABEL followed by HASH elements, all on one line, to stderr. 3390If HASH is a reference, it is followed. 3391 3392=cut 3393 3394sub debug_hash { 3395 my ($label) = shift; 3396 my (%hash) = (ref $_[0] && $_[0] =~ /.*HASH.*/) ? %{$_[0]} : @_; 3397 3398 my $str = "$label: {"; 3399 my @items = (); 3400 for my $key (sort keys %hash) { 3401 my $val = $hash{$key}; 3402 $key =~ s/\n/\\n/g; 3403 $val =~ s/\n/\\n/g; 3404 push (@items, "$key:$val"); 3405 } 3406 $str .= join (",", @items); 3407 $str .= "}"; 3408 3409 warn "$str\n"; 3410} 3411 3412 3413=item C<process_logging_options ($texdir)> 3414 3415This function handles the common logging options for TeX Live scripts. 3416It should be called before C<GetOptions> for any program-specific option 3417handling. For our conventional calling sequence, see (for example) the 3418L<tlpfiles> script. 3419 3420These are the options handled here: 3421 3422=over 4 3423 3424=item B<-q> 3425 3426Omit normal informational messages. 3427 3428=item B<-v> 3429 3430Include debugging messages. With one C<-v>, reports overall flow; with 3431C<-v -v> (or C<-vv>), also reports per-package processing; with C<-v -v 3432-v> (or C<-vvv>), also reports each line read from any tlpdb files. 3433Further repeats of C<-v>, as in C<-v -v -v -v>, are accepted but 3434ignored. C<-vvvv> is an error. 3435 3436The idea behind these levels is to be able to specify C<-v> to get an 3437overall idea of what is going on, but avoid terribly voluminous output 3438when processing many packages, as we often are. When debugging a 3439specific problem with a specific package, C<-vv> can help. When 3440debugging problems with parsing tlpdb files, C<-vvv> gives that too. 3441 3442=item B<-logfile> I<file> 3443 3444Write all messages (informational, debugging, warnings) to I<file>, in 3445addition to standard output or standard error. In TeX Live, only the 3446installer sets a log file by default; none of the other standard TeX 3447Live scripts use this feature, but you can specify it explicitly. 3448 3449=back 3450 3451See also the L<info>, L<debug>, L<ddebug>, and L<tlwarn> functions, 3452which actually write the messages. 3453 3454=cut 3455 3456sub process_logging_options { 3457 $::opt_verbosity = 0; 3458 $::opt_quiet = 0; 3459 my $opt_logfile; 3460 my $opt_Verbosity = 0; 3461 my $opt_VERBOSITY = 0; 3462 # check all the command line options for occurrences of -q and -v; 3463 # do not report errors. 3464 my $oldconfig = Getopt::Long::Configure(qw(pass_through permute)); 3465 GetOptions("logfile=s" => \$opt_logfile, 3466 "v+" => \$::opt_verbosity, 3467 "vv" => \$opt_Verbosity, 3468 "vvv" => \$opt_VERBOSITY, 3469 "q" => \$::opt_quiet); 3470 Getopt::Long::Configure($oldconfig); 3471 3472 # verbosity level, forcing -v -v instead of -vv is too annoying. 3473 $::opt_verbosity = 2 if $opt_Verbosity; 3474 $::opt_verbosity = 3 if $opt_VERBOSITY; 3475 3476 # open log file if one was requested. 3477 if ($opt_logfile) { 3478 open(TLUTILS_LOGFILE, ">$opt_logfile") || die "open(>$opt_logfile) failed: $!\n"; 3479 $::LOGFILE = \*TLUTILS_LOGFILE; 3480 $::LOGFILENAME = $opt_logfile; 3481 } 3482} 3483 3484=pod 3485 3486This function takes a single argument I<path> and returns it with 3487C<"> chars surrounding it on Unix. On Windows, the C<"> chars are only 3488added if I<path> a few special characters, since unconditional quoting 3489leads to errors there. In all cases, any C<"> chars in I<path> itself 3490are (erroneously) eradicated. 3491 3492=cut 3493 3494sub quotify_path_with_spaces { 3495 my $p = shift; 3496 my $m = win32() ? '[+=^&();,!%\s]' : '.'; 3497 if ( $p =~ m/$m/ ) { 3498 $p =~ s/"//g; # remove any existing double quotes 3499 $p = "\"$p\""; 3500 } 3501 return($p); 3502} 3503 3504=pod 3505 3506This function returns a "Windows-ized" version of its single argument 3507I<path>, i.e., replaces all forward slashes with backslashes, and adds 3508an additional C<"> at the beginning and end if I<path> contains any 3509spaces. It also makes the path absolute. So if $path does not start 3510with one (arbitrary) characer followed by C<:>, we add the output of 3511C<`cd`>. 3512 3513The result is suitable for running in shell commands, but not file tests 3514or other manipulations, since in such internal Perl contexts, the quotes 3515would be considered part of the filename. 3516 3517=cut 3518 3519sub conv_to_w32_path { 3520 my $p = shift; 3521 # we need absolute paths, too 3522 my $pabs = tl_abs_path($p); 3523 if (not $pabs) { 3524 $pabs = $p; 3525 tlwarn ("sorry, could not determine absolute path of $p!\n". 3526 "using original path instead"); 3527 } 3528 $pabs =~ s!/!\\!g; 3529 $pabs = quotify_path_with_spaces($pabs); 3530 return($pabs); 3531} 3532 3533=pod 3534 3535The next two functions are meant for user input/output in installer menus. 3536They help making the windows user happy by turning slashes into backslashes 3537before displaying a path, and our code happy by turning backslashes into forwars 3538slashes after reading a path. They both are no-ops on Unix. 3539 3540=cut 3541 3542sub native_slashify { 3543 my ($r) = @_; 3544 $r =~ s!/!\\!g if win32(); 3545 return $r; 3546} 3547 3548sub forward_slashify { 3549 my ($r) = @_; 3550 $r =~ s!\\!/!g if win32(); 3551 return $r; 3552} 3553 3554=item C<setup_persistent_downloads()> 3555 3556Set up to use persistent connections using LWP/TLDownload, that is look 3557for a download server. Return the TLDownload object if successful, else 3558false. 3559 3560=cut 3561 3562sub setup_persistent_downloads { 3563 if ($TeXLive::TLDownload::net_lib_avail) { 3564 ddebug("setup_persistent_downloads has net_lib_avail set\n"); 3565 $::tldownload_server = TeXLive::TLDownload->new; 3566 if (!defined($::tldownload_server)) { 3567 ddebug("TLUtils:setup_persistent_downloads: failed to get ::tldownload_server\n"); 3568 } else { 3569 ddebug("TLUtils:setup_persistent_downloads: got ::tldownload_server\n"); 3570 } 3571 return $::tldownload_server; 3572 } 3573 return 0; 3574} 3575 3576 3577=item C<query_ctan_mirror()> 3578 3579Return a particular mirror given by the generic CTAN auto-redirecting 3580default (specified in L<$TLConfig::TexLiveServerURL>) if we get a 3581response, else the empty string. 3582 3583Neither C<TL_DOWNLOAD_PROGRAM> nor <TL_DOWNLOAD_ARGS> is honored (see 3584L<download_file>), since certain options have to be set to do the job 3585and the program has to be C<wget> since we parse the output. 3586 3587=cut 3588 3589sub query_ctan_mirror { 3590 my $wget = $::progs{'wget'}; 3591 if (!defined ($wget)) { 3592 tlwarn("query_ctan_mirror: Programs not set up, trying wget\n"); 3593 $wget = "wget"; 3594 } 3595 3596 # we need the verbose output, so no -q. 3597 # do not reduce retries here, but timeout still seems desirable. 3598 my $mirror = $TeXLiveServerURL; 3599 my $cmd = "$wget $mirror --timeout=$NetworkTimeout -O " 3600 . (win32() ? "nul" : "/dev/null") . " 2>&1"; 3601 3602 # 3603 # since we are reading the output of wget to find a mirror 3604 # we have to make sure that the locale is unset 3605 my $saved_lcall; 3606 if (defined($ENV{'LC_ALL'})) { 3607 $saved_lcall = $ENV{'LC_ALL'}; 3608 } 3609 $ENV{'LC_ALL'} = "C"; 3610 # we try 3 times to get a mirror from mirror.ctan.org in case we have 3611 # bad luck with what gets returned. 3612 my $max_trial = 3; 3613 my $mhost; 3614 for (my $i = 1; $i <= $max_trial; $i++) { 3615 my @out = `$cmd`; 3616 # analyze the output for the mirror actually selected. 3617 foreach (@out) { 3618 if (m/^Location: (\S*)\s*.*$/) { 3619 (my $mhost = $1) =~ s,/*$,,; # remove trailing slashes since we add it 3620 return $mhost; 3621 } 3622 } 3623 sleep(1); 3624 } 3625 3626 # reset LC_ALL to undefined or the previous value 3627 if (defined($saved_lcall)) { 3628 $ENV{'LC_ALL'} = $saved_lcall; 3629 } else { 3630 delete($ENV{'LC_ALL'}); 3631 } 3632 3633 # we are still here, so three times we didn't get a mirror, give up 3634 # and return undefined 3635 return; 3636} 3637 3638=item C<check_on_working_mirror($mirror)> 3639 3640Check if MIRROR is functional. 3641 3642=cut 3643 3644sub check_on_working_mirror { 3645 my $mirror = shift; 3646 3647 my $wget = $::progs{'wget'}; 3648 if (!defined ($wget)) { 3649 tlwarn ("check_on_working_mirror: Programs not set up, trying wget\n"); 3650 $wget = "wget"; 3651 } 3652 $wget = quotify_path_with_spaces($wget); 3653 # 3654 # the test is currently not completely correct, because we do not 3655 # use the LWP if it is set up for it, but I am currently too lazy 3656 # to program it, 3657 # so try wget and only check for the return value 3658 # please KEEP the / after $mirror, some ftp mirrors do give back 3659 # an error if the / is missing after ../CTAN/ 3660 my $cmd = "$wget $mirror/ --timeout=$NetworkTimeout -O " 3661 . (win32() ? "nul" : "/dev/null") 3662 . " 2>" . (win32() ? "nul" : "/dev/null"); 3663 my $ret = system($cmd); 3664 # if return value is not zero it is a failure, so switch the meanings 3665 return ($ret ? 0 : 1); 3666} 3667 3668=item C<give_ctan_mirror_base()> 3669 3670 1. get a mirror (retries 3 times to contact mirror.ctan.org) 3671 - if no mirror found, use one of the backbone servers 3672 - if it is an http server return it (no test is done) 3673 - if it is a ftp server, continue 3674 2. if the ftp mirror is good, return it 3675 3. if the ftp mirror is bad, search for http mirror (5 times) 3676 4. if http mirror is found, return it (again, no test,) 3677 5. if no http mirror is found, return one of the backbone servers 3678 3679=cut 3680 3681sub give_ctan_mirror_base { 3682 my @backbone = qw!http://www.ctan.org/tex-archive 3683 http://www.tex.ac.uk/tex-archive 3684 http://dante.ctan.org/tex-archive!; 3685 3686 # start by selecting a mirror and test its operationality 3687 my $mirror = query_ctan_mirror(); 3688 if (!defined($mirror)) { 3689 # three times calling mirror.ctan.org did not give anything useful, 3690 # return one of the backbone servers 3691 tlwarn("cannot contact mirror.ctan.org, returning a backbone server!\n"); 3692 return $backbone[int(rand($#backbone + 1))]; 3693 } 3694 3695 if ($mirror =~ m!^http://!) { # if http mirror, assume good and return. 3696 return $mirror; 3697 } 3698 3699 # we are still here, so we got a ftp mirror from mirror.ctan.org 3700 if (check_on_working_mirror($mirror)) { 3701 return $mirror; # ftp mirror is working, return. 3702 } 3703 3704 # we are still here, so the ftp mirror failed, retry and hope for http. 3705 # theory is that if one ftp fails, probably all ftp is broken. 3706 my $max_mirror_trial = 5; 3707 for (my $try = 1; $try <= $max_mirror_trial; $try++) { 3708 my $m = query_ctan_mirror(); 3709 debug("querying mirror, got " . (defined($m) ? $m : "(nothing)") . "\n"); 3710 if (defined($m) && $m =~ m!^http://!) { 3711 return $m; # got http this time, assume ok. 3712 } 3713 # sleep to make mirror happy, but only if we are not ready to return 3714 sleep(1) if $try < $max_mirror_trial; 3715 } 3716 3717 # 5 times contacting the mirror service did not return a http server, 3718 # use one of the backbone servers. 3719 debug("no mirror found ... randomly selecting backbone\n"); 3720 return $backbone[int(rand($#backbone + 1))]; 3721} 3722 3723 3724sub give_ctan_mirror { 3725 return (give_ctan_mirror_base(@_) . "/$TeXLiveServerPath"); 3726} 3727 3728=item C<create_mirror_list()> 3729 3730=item C<extract_mirror_entry($listentry)> 3731 3732C<create_mirror_list> returns the lists of viable mirrors according to 3733ctan-mirrors.pl, in a list which also contains continents, and country headers. 3734 3735C<extract_mirror_entry> extracts the actual repository data from one 3736of these entries. 3737 3738# KEEP THESE TWO FUNCTIONS IN SYNC!!! 3739 3740=cut 3741 3742sub create_mirror_list { 3743 our $mirrors; 3744 my @ret = (); 3745 require("installer/ctan-mirrors.pl"); 3746 my @continents = sort keys %$mirrors; 3747 for my $continent (@continents) { 3748 # first push the name of the continent 3749 push @ret, uc($continent); 3750 my @countries = sort keys %{$mirrors->{$continent}}; 3751 for my $country (@countries) { 3752 my @mirrors = sort keys %{$mirrors->{$continent}{$country}}; 3753 my $first = 1; 3754 for my $mirror (@mirrors) { 3755 my $mfull = $mirror; 3756 $mfull =~ s!/$!!; 3757 # do not append the server path part here, but add 3758 # it down there in the extract mirror entry 3759 #$mfull .= "/" . $TeXLive::TLConfig::TeXLiveServerPath; 3760 #if ($first) { 3761 my $country_str = sprintf "%-12s", $country; 3762 push @ret, " $country_str $mfull"; 3763 # $first = 0; 3764 #} else { 3765 # push @ret, " $mfull"; 3766 #} 3767 } 3768 } 3769 } 3770 return @ret; 3771} 3772 3773# extract_mirror_entry is not very intelligent, it assumes that 3774# the last "word" is the URL 3775sub extract_mirror_entry { 3776 my $ent = shift; 3777 my @foo = split ' ', $ent; 3778 return $foo[$#foo] . "/" . $TeXLive::TLConfig::TeXLiveServerPath; 3779} 3780 3781sub tlmd5 { 3782 my ($file) = @_; 3783 if (-r $file) { 3784 open(FILE, $file) || die "open($file) failed: $!"; 3785 binmode(FILE); 3786 my $md5hash = Digest::MD5->new->addfile(*FILE)->hexdigest; 3787 close(FILE); 3788 return $md5hash; 3789 } else { 3790 tlwarn("tlmd5, given file not readable: $file\n"); 3791 return ""; 3792 } 3793} 3794 3795# 3796# compare_tlpobjs 3797# returns a hash 3798# $ret{'revision'} = "leftRev:rightRev" if revision differ 3799# $ret{'removed'} = \[ list of files removed from A to B ] 3800# $ret{'added'} = \[ list of files added from A to B ] 3801# 3802sub compare_tlpobjs { 3803 my ($tlpA, $tlpB) = @_; 3804 my %ret; 3805 my @rem; 3806 my @add; 3807 3808 my $rA = $tlpA->revision; 3809 my $rB = $tlpB->revision; 3810 if ($rA != $rB) { 3811 $ret{'revision'} = "$rA:$rB"; 3812 } 3813 if ($tlpA->relocated) { 3814 $tlpA->replace_reloc_prefix; 3815 } 3816 if ($tlpB->relocated) { 3817 $tlpB->replace_reloc_prefix; 3818 } 3819 my @fA = $tlpA->all_files; 3820 my @fB = $tlpB->all_files; 3821 my %removed; 3822 my %added; 3823 for my $f (@fA) { $removed{$f} = 1; } 3824 for my $f (@fB) { delete($removed{$f}); $added{$f} = 1; } 3825 for my $f (@fA) { delete($added{$f}); } 3826 @rem = sort keys %removed; 3827 @add = sort keys %added; 3828 $ret{'removed'} = \@rem if @rem; 3829 $ret{'added'} = \@add if @add; 3830 return %ret; 3831} 3832 3833# 3834# compare_tlpdbs 3835# return several hashes 3836# @{$ret{'removed_packages'}} = list of removed packages from A to B 3837# @{$ret{'added_packages'}} = list of added packages from A to B 3838# $ret{'different_packages'}->{$package} = output of compare_tlpobjs 3839# 3840sub compare_tlpdbs { 3841 my ($tlpdbA, $tlpdbB, @add_ignored_packs) = @_; 3842 my @ignored_packs = qw/00texlive.installer 00texlive.image/; 3843 push @ignored_packs, @add_ignored_packs; 3844 3845 my @inAnotinB; 3846 my @inBnotinA; 3847 my %diffpacks; 3848 my %do_compare; 3849 my %ret; 3850 3851 for my $p ($tlpdbA->list_packages()) { 3852 my $is_ignored = 0; 3853 for my $ign (@ignored_packs) { 3854 if (($p =~ m/^$ign$/) || ($p =~ m/^$ign\./)) { 3855 $is_ignored = 1; 3856 last; 3857 } 3858 } 3859 next if $is_ignored; 3860 my $tlpB = $tlpdbB->get_package($p); 3861 if (!defined($tlpB)) { 3862 push @inAnotinB, $p; 3863 } else { 3864 $do_compare{$p} = 1; 3865 } 3866 } 3867 $ret{'removed_packages'} = \@inAnotinB if @inAnotinB; 3868 3869 for my $p ($tlpdbB->list_packages()) { 3870 my $is_ignored = 0; 3871 for my $ign (@ignored_packs) { 3872 if (($p =~ m/^$ign$/) || ($p =~ m/^$ign\./)) { 3873 $is_ignored = 1; 3874 last; 3875 } 3876 } 3877 next if $is_ignored; 3878 my $tlpA = $tlpdbA->get_package($p); 3879 if (!defined($tlpA)) { 3880 push @inBnotinA, $p; 3881 } else { 3882 $do_compare{$p} = 1; 3883 } 3884 } 3885 $ret{'added_packages'} = \@inBnotinA if @inBnotinA; 3886 3887 for my $p (sort keys %do_compare) { 3888 my $tlpA = $tlpdbA->get_package($p); 3889 my $tlpB = $tlpdbB->get_package($p); 3890 my %foo = compare_tlpobjs($tlpA, $tlpB); 3891 if (keys %foo) { 3892 # some diffs were found 3893 $diffpacks{$p} = \%foo; 3894 } 3895 } 3896 $ret{'different_packages'} = \%diffpacks if (keys %diffpacks); 3897 3898 return %ret; 3899} 3900 3901sub tlnet_disabled_packages { 3902 my ($root) = @_; 3903 my $disabled_pkgs = "$root/tlpkg/dev/tlnet-disabled-packages.txt"; 3904 my @ret; 3905 if (-r $disabled_pkgs) { 3906 open (DISABLED, "<$disabled_pkgs") || die "Huu, -r but cannot open: $?"; 3907 while (<DISABLED>) { 3908 chomp; 3909 next if /^\s*#/; 3910 next if /^\s*$/; 3911 $_ =~ s/^\s*//; 3912 $_ =~ s/\s*$//; 3913 push @ret, $_; 3914 } 3915 close(DISABLED) || warn ("Cannot close tlnet-disabled-packages.txt: $?"); 3916 } 3917 return @ret; 3918} 3919 3920sub report_tlpdb_differences { 3921 my $rret = shift; 3922 my %ret = %$rret; 3923 3924 if (defined($ret{'removed_packages'})) { 3925 info ("removed packages from A to B:\n"); 3926 for my $f (@{$ret{'removed_packages'}}) { 3927 info (" $f\n"); 3928 } 3929 } 3930 if (defined($ret{'added_packages'})) { 3931 info ("added packages from A to B:\n"); 3932 for my $f (@{$ret{'added_packages'}}) { 3933 info (" $f\n"); 3934 } 3935 } 3936 if (defined($ret{'different_packages'})) { 3937 info ("different packages from A to B:\n"); 3938 for my $p (keys %{$ret{'different_packages'}}) { 3939 info (" $p\n"); 3940 for my $k (keys %{$ret{'different_packages'}->{$p}}) { 3941 if ($k eq "revision") { 3942 info(" revision differ: $ret{'different_packages'}->{$p}->{$k}\n"); 3943 } elsif ($k eq "removed" || $k eq "added") { 3944 info(" $k files:\n"); 3945 for my $f (@{$ret{'different_packages'}->{$p}->{$k}}) { 3946 info(" $f\n"); 3947 } 3948 } else { 3949 info(" unknown differ $k\n"); 3950 } 3951 } 3952 } 3953 } 3954} 3955 3956sub sort_archs ($$) { 3957 my $aa = $_[0]; 3958 my $bb = $_[1]; 3959 $aa =~ s/^(.*)-(.*)$/$2-$1/; 3960 $bb =~ s/^(.*)-(.*)$/$2-$1/; 3961 $aa cmp $bb ; 3962} 3963 3964# Taken from Text::ParseWords 3965# 3966sub quotewords { 3967 my($delim, $keep, @lines) = @_; 3968 my($line, @words, @allwords); 3969 3970 foreach $line (@lines) { 3971 @words = parse_line($delim, $keep, $line); 3972 return() unless (@words || !length($line)); 3973 push(@allwords, @words); 3974 } 3975 return(@allwords); 3976} 3977 3978sub parse_line { 3979 my($delimiter, $keep, $line) = @_; 3980 my($word, @pieces); 3981 3982 no warnings 'uninitialized'; # we will be testing undef strings 3983 3984 $line =~ s/\s+$//; # kill trailing whitespace 3985 while (length($line)) { 3986 $line =~ s/^(["']) # a $quote 3987 ((?:\\.|(?!\1)[^\\])*) # and $quoted text 3988 \1 # followed by the same quote 3989 | # --OR-- 3990 ^((?:\\.|[^\\"'])*?) # an $unquoted text 3991 (\Z(?!\n)|(?-x:$delimiter)|(?!^)(?=["'])) 3992 # plus EOL, delimiter, or quote 3993 //xs or return; # extended layout 3994 my($quote, $quoted, $unquoted, $delim) = ($1, $2, $3, $4); 3995 return() unless( defined($quote) || length($unquoted) || length($delim)); 3996 3997 if ($keep) { 3998 $quoted = "$quote$quoted$quote"; 3999 } else { 4000 $unquoted =~ s/\\(.)/$1/sg; 4001 if (defined $quote) { 4002 $quoted =~ s/\\(.)/$1/sg if ($quote eq '"'); 4003 $quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'"); 4004 } 4005 } 4006 $word .= substr($line, 0, 0); # leave results tainted 4007 $word .= defined $quote ? $quoted : $unquoted; 4008 4009 if (length($delim)) { 4010 push(@pieces, $word); 4011 push(@pieces, $delim) if ($keep eq 'delimiters'); 4012 undef $word; 4013 } 4014 if (!length($line)) { 4015 push(@pieces, $word); 4016 } 4017 } 4018 return(@pieces); 4019} 4020 4021=item C<mktexupd ()> 4022 4023Append entries to C<ls-R> files. Usage example: 4024 4025 my $updLSR=&mktexupd(); 4026 $updLSR->{mustexist}(1); 4027 $updLSR->{add}(file1); 4028 $updLSR->{add}(file2); 4029 $updLSR->{add}(file3); 4030 $updLSR->{exec}(); 4031 4032The first line creates a new object. Only one such object should be 4033created in a program in order to avoid duplicate entries in C<ls-R> files. 4034 4035C<add> pushes a filename or a list of filenames to a hash encapsulated 4036in a closure. Filenames must be specified with the full (absolute) path. 4037Duplicate entries are ignored. 4038 4039C<exec> checks for each component of C<$TEXMFDBS> whether there are files 4040in the hash which have to be appended to the corresponding C<ls-R> files 4041and eventually updates the corresponding C<ls-R> files. Files which are 4042in directories not stated in C<$TEXMFDBS> are silently ignored. 4043 4044If the flag C<mustexist> is set, C<exec> aborts with an error message 4045if a file supposed to be appended to an C<ls-R> file doesn't exist physically 4046on the file system. This option was added for compatibility with the 4047C<mktexupd> shell script. This option shouldn't be enabled in scripts, 4048except for testing, because it degrades performance on non-cached file 4049systems. 4050 4051=cut 4052 4053sub mktexupd { 4054 my %files; 4055 my $mustexist=0; 4056 4057 my $hash={ 4058 "add" => sub { 4059 foreach my $file (@_) { 4060 $file =~ s|\\|/|g; 4061 $files{$file}=1; 4062 } 4063 }, 4064 "reset" => sub { 4065 %files=(); 4066 }, 4067 "mustexist" => sub { 4068 $mustexist=shift; 4069 }, 4070 "exec" => sub { 4071 # check whether files exist 4072 if ($mustexist) { 4073 foreach my $file (keys %files) { 4074 die "File \"$file\" doesn't exist.\n" if (! -f $file); 4075 } 4076 } 4077 my $delim= (&win32)? ';' : ':'; 4078 my $TEXMFDBS; 4079 chomp($TEXMFDBS=`kpsewhich --show-path="ls-R"`); 4080 4081 my @texmfdbs=split ($delim, "$TEXMFDBS"); 4082 my %dbs; 4083 4084 foreach my $path (keys %files) { 4085 foreach my $db (@texmfdbs) { 4086 $db=substr($db, -1) if ($db=~m|/$|); # strip leading / 4087 $db = lc($db) if win32(); 4088 $up = (win32() ? lc($path) : $path); 4089 if (substr($up, 0, length("$db/")) eq "$db/") { 4090 # we appended a / because otherwise "texmf" is recognized as a 4091 # substring of "texmf-dist". 4092 my $np = './' . substr($up, length("$db/")); 4093 my ($dir, $file); 4094 $_=$np; 4095 ($dir, $file) = m|(.*)/(.*)|; 4096 $dbs{$db}{$dir}{$file}=1; 4097 } 4098 } 4099 } 4100 foreach my $db (keys %dbs) { 4101 if (! -f "$db" || ! -w "$db/ls-R") { 4102 &mkdirhier ($db); 4103 } 4104 open LSR, ">>$db/ls-R"; 4105 foreach my $dir (keys %{$dbs{$db}}) { 4106 print LSR "\n$dir:\n"; 4107 foreach my $file (keys %{$dbs{$db}{$dir}}) { 4108 print LSR "$file\n"; 4109 } 4110 } 4111 close LSR; 4112 } 4113 } 4114 }; 4115 return $hash; 4116} 4117 4118=back 4119=cut 41201; 4121__END__ 4122 4123=head1 SEE ALSO 4124 4125The modules L<TeXLive::TLPSRC>, L<TeXLive::TLPOBJ>, 4126L<TeXLive::TLPDB>, L<TeXLive::TLTREE>, and the 4127document L<Perl-API.txt> and the specification in the TeX Live 4128repository trunk/Master/tlpkg/doc/. 4129 4130=head1 AUTHORS AND COPYRIGHT 4131 4132This script and its documentation were written for the TeX Live 4133distribution (L<http://tug.org/texlive>) and both are licensed under the 4134GNU General Public License Version 2 or later. 4135 4136=cut 4137 4138### Local Variables: 4139### perl-indent-level: 2 4140### tab-width: 2 4141### indent-tabs-mode: nil 4142### End: 4143# vim:set tabstop=2 expandtab: # 4144