"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/TeXLive/TLUtils.pm" (7 Jul 2020, 140948 Bytes) of package /windows/misc/install-tl.zip:


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

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