# $Id: TLUtils.pm 79583 2026-07-04 17:43:22Z karl $
# TeXLive::TLUtils.pm - the inevitable utilities for TeX Live.
# Copyright 2007-2026 Norbert Preining, Reinhard Kotucha
# This file is licensed under the GNU General Public License version 2
# or any later version.

use strict; use warnings;

package TeXLive::TLUtils;

my $svnrev = '$Revision: 79583 $';
my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown";
sub module_revision { return $_modulerevision; }

=pod

=head1 NAME

C<TeXLive::TLUtils> - TeX Live infrastructure miscellany

=head1 SYNOPSIS

  use TeXLive::TLUtils;

=head2 Platform detection

  TeXLive::TLUtils::platform();
  TeXLive::TLUtils::platform_name($canonical_host);
  TeXLive::TLUtils::platform_desc($platform);
  TeXLive::TLUtils::wndws();
  TeXLive::TLUtils::unix();

=head2 System tools

  TeXLive::TLUtils::getenv($string);
  TeXLive::TLUtils::which($string);
  TeXLive::TLUtils::initialize_global_tmpdir();
  TeXLive::TLUtils::tl_tmpdir();
  TeXLive::TLUtils::tl_tmpfile();
  TeXLive::TLUtils::xchdir($dir);
  TeXLive::TLUtils::wsystem($msg,@args);
  TeXLive::TLUtils::xsystem(@args);
  TeXLive::TLUtils::run_cmd($cmd [, @envvars ]);
  TeXLive::TLUtils::run_cmd_with_log($cmd, $logfn);
  TeXLive::TLUtils::system_pipe($prog, $infile, $outfile, $removeIn, @args);
  TeXLive::TLUtils::diskfree($path);
  TeXLive::TLUtils::get_user_home();
  TeXLive::TLUtils::expand_tilde($str);

=head2 File utilities

  TeXLive::TLUtils::dirname($path);
  TeXLive::TLUtils::basename($path);
  TeXLive::TLUtils::dirname_and_basename($path);
  TeXLive::TLUtils::tl_abs_path($path);
  TeXLive::TLUtils::dir_writable($path);
  TeXLive::TLUtils::dir_creatable($path);
  TeXLive::TLUtils::mkdirhier($path);
  TeXLive::TLUtils::rmtree($root, $verbose, $safe);
  TeXLive::TLUtils::copy($file, $target_dir);
  TeXLive::TLUtils::touch(@files);
  TeXLive::TLUtils::collapse_dirs(@files);
  TeXLive::TLUtils::all_dirs_and_removed_dirs(@files);
  TeXLive::TLUtils::dirs_of_files(@files);
  TeXLive::TLUtils::removed_dirs(@files);
  TeXLive::TLUtils::download_file($path, $destination);
  TeXLive::TLUtils::setup_programs($bindir, $platform);
  TeXLive::TLUtils::tlcmp($file, $file);
  TeXLive::TLUtils::nulldev();
  TeXLive::TLUtils::get_full_line($fh);

=head2 Installer functions

  TeXLive::TLUtils::make_var_skeleton($path);
  TeXLive::TLUtils::make_local_skeleton($path);
  TeXLive::TLUtils::create_fmtutil($tlpdb,$dest);
  TeXLive::TLUtils::create_updmap($tlpdb,$dest);
  TeXLive::TLUtils::create_language_dat($tlpdb,$dest,$localconf);
  TeXLive::TLUtils::create_language_def($tlpdb,$dest,$localconf);
  TeXLive::TLUtils::create_language_lua($tlpdb,$dest,$localconf);
  TeXLive::TLUtils::time_estimate($totalsize, $donesize, $starttime)
  TeXLive::TLUtils::install_packages($from_tlpdb,$media,$to_tlpdb,$what,$opt_src, $opt_doc, $retry, $continue);
  TeXLive::TLUtils::do_postaction($how, $tlpobj, $do_fileassocs, $do_menu, $do_desktop, $do_script);
  TeXLive::TLUtils::update_context_cache($plat_bindir);
  TeXLive::TLUtils::announce_execute_actions($how, @executes, $what);
  TeXLive::TLUtils::add_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info);
  TeXLive::TLUtils::remove_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info);
  TeXLive::TLUtils::w32_add_to_path($bindir, $multiuser);
  TeXLive::TLUtils::w32_remove_from_path($bindir, $multiuser);
  TeXLive::TLUtils::setup_persistent_downloads();

=head2 Logging and debugging

  TeXLive::TLUtils::info($str1, ...);    # output unless -q
  TeXLive::TLUtils::debug($str1, ...);   # output if -v
  TeXLive::TLUtils::ddebug($str1, ...);  # output if -vv
  TeXLive::TLUtils::dddebug($str1, ...); # output if -vvv
  TeXLive::TLUtils::log($str1, ...);     # only to log file
  TeXLive::TLUtils::tlwarn($str1, ...);  # warn on stderr and log
  TeXLive::TLUtils::tldie($str1, ...);   # tlwarn and die
  TeXLive::TLUtils::debug_hash_str($label, HASH); # stringified HASH
  TeXLive::TLUtils::debug_hash($label, HASH);   # warn stringified HASH
  TeXLive::TLUtils::backtrace();                # return call stack as string
  TeXLive::TLUtils::process_logging_options($texdir); # handle -q -v* -logfile

=head2 Miscellaneous

  TeXLive::TLUtils::sort_uniq(@list);
  TeXLive::TLUtils::push_uniq(\@list, @items);
  TeXLive::TLUtils::member($item, @list);
  TeXLive::TLUtils::merge_into(\%to, \%from);
  TeXLive::TLUtils::texdir_check($texdir);
  TeXLive::TLUtils::compare_tlpobjs($tlpA, $tlpB);
  TeXLive::TLUtils::compare_tlpdbs($tlpdbA, $tlpdbB);
  TeXLive::TLUtils::report_tlpdb_differences(\%ret);
  TeXLive::TLUtils::tlnet_disabled_packages($root);
  TeXLive::TLUtils::mktexupd();
  TeXLive::TLUtils::setup_sys_user_mode($prg,$optsref,$tmfc,$tmfsc,$tmfv,$tmfsv);
  TeXLive::TLUtils::prepend_own_path();
  TeXLive::TLUtils::repository_to_array($str);

=head2 Windows and paths

  TeXLive::TLUtils::quotify_path_with_spaces($path);
  TeXLive::TLUtils::conv_to_w32_path($path);
  TeXLive::TLUtils::native_slashify($internal_path);
  TeXLive::TLUtils::forward_slashify($path_from_user);

=head2 CTAN

  TeXLive::TLUtils::give_ctan_mirror();
  TeXLive::TLUtils::give_ctan_mirror_base();

=head2 JSON

  TeXLive::TLUtils::encode_json($ref);
  TeXLive::TLUtils::True();
  TeXLive::TLUtils::False();

=head1 DESCRIPTION

=cut

# avoid -warnings.
our $PERL_SINGLE_QUOTE; # we steal code from Text::ParseWords

# We use myriad global and package-global variables, unfortunately.
# To avoid "used only once" warnings, we must use the variable names again.
# 
# This ugly repetition in the BEGIN block works with all Perl versions;
# cleaner/fancier ways of handling this don't.
BEGIN {
  $::LOGFILE = $::LOGFILE;
  $::LOGFILENAME = $::LOGFILENAME;
  @::LOGLINES = @::LOGLINES;
  @::debug_hook = @::debug_hook;
  @::ddebug_hook = @::ddebug_hook;
  @::dddebug_hook = @::dddebug_hook;
  @::info_hook = @::info_hook;
  @::install_packages_hook = @::install_packages_hook;
  @::installation_failed_packages = @::installation_failed_packages;
  @::warn_hook = @::warn_hook;
  $::checksum_method = $::checksum_method;
  $::gui_mode = $::gui_mode;
  $::machinereadable = $::machinereadable;
  $::no_execute_actions = $::no_execute_actions;
  $::regenerate_all_formats = $::regenerate_all_formats;
  $::context_cache_update_needed = $::context_cache_update_needed;
  #
  $JSON::false = $JSON::false;
  $JSON::true = $JSON::true;
  #
  $TeXLive::TLDownload::net_lib_avail = $TeXLive::TLDownload::net_lib_avail;
}
      
## A cleaner way is to use the "package PKGNAME BLOCK" syntax:
## when providing a block to the package command, the scope is
## limited to that block, so the current real package ends up unaffected.
## Example in first reply to: https://perlmonks.org/?node_id=11139324
## (Other solutions are also given there, but they don't work well in
## our context here, although we use them elsewhere.)
## 
## Unfortunately the package BLOCK syntax was invented for perl 5.14.0,
## ca.2011, and OpenCSW on Solaris 10 only provides an older Perl. If we
## ever drop Solaris 10 support, we can replace the above with this.
## 
#package main {
#  our ($LOGFILE, $LOGFILENAME, @LOGLINES,
#    @debug_hook, @ddebug_hook, @dddebug_hook, @info_hook,
#    @install_packages_hook, @warn_hook,
#    $checksum_method, $gui_mode, $machinereadable,
#    $no_execute_actions, $regenerate_all_formats); }
#package JSON { our ($false, $true); }
#package TeXLive::TLDownload { our $net_lib_avail; }

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT_OK @EXPORT);
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(
    &platform
    &platform_name
    &platform_desc
    &unix
    &getenv
    &which
    &initialize_global_tmpdir
    &dirname
    &basename
    &dirname_and_basename
    &tl_abs_path
    &dir_writable
    &dir_creatable
    &mkdirhier
    &rmtree
    &copy
    &touch
    &collapse_dirs
    &all_dirs_and_removed_dirs
    &dirs_of_files
    &removed_dirs
    &install_package
    &install_packages
    &make_var_skeleton
    &make_local_skeleton
    &create_fmtutil
    &create_updmap
    &create_language_dat
    &create_language_def
    &create_language_lua
    &parse_AddFormat_line
    &parse_AddHyphen_line
    &sort_uniq
    &push_uniq
    &texdir_check
    &member
    &quotewords
    &quotify_path_with_spaces
    &conv_to_w32_path
    &native_slashify
    &forward_slashify
    &untar
    &unpack
    &merge_into
    &give_ctan_mirror
    &give_ctan_mirror_base
    &create_mirror_list
    &extract_mirror_entry
    &system_ok
    &wsystem
    &xsystem
    &run_cmd
    &run_cmd_with_log
    &system_pipe
    &diskfree
    &get_user_home
    &expand_tilde
    &announce_execute_actions
    &add_symlinks
    &remove_symlinks
    &w32_add_to_path
    &w32_remove_from_path
    &tlcmp
    &time_estimate
    &compare_tlpobjs
    &compare_tlpdbs
    &report_tlpdb_differences
    &setup_persistent_downloads
    &mktexupd
    &setup_sys_user_mode
    &prepend_own_path
    &nulldev
    &get_full_line
    &sort_archs
    &repository_to_array
    &encode_json
    &True
    &False
    &SshURIRegex
  );
  @EXPORT = qw(setup_programs download_file process_logging_options
               tldie tlwarn info log debug ddebug dddebug debug
               debug_hash_str debug_hash
               wndws xchdir xsystem run_cmd system_pipe sort_archs);
}

use Cwd;
use Getopt::Long;
use File::Temp;

use TeXLive::TLConfig;

$::opt_verbosity = 0;  # see process_logging_options

our $SshURIRegex = '^((ssh|scp)://([^@]*)@([^/]*)/|([^@]*)@([^:]*):).*$';

=head2 Platform detection

=over 4

=item C<platform>

If C<$^O =~ /MSWin/i> is true we know that we're on
Windows and we set the global variable C<$::_platform_> to C<windows>.
Otherwise we call C<platform_name> with the output of C<config.guess>
as argument.

The result is stored in a global variable C<$::_platform_>, and
subsequent calls just return that value.

As of 2021, C<config.guess> unfortunately requires a shell that
understands the C<$(...)> construct. This means that on old-enough
systems, such as Solaris, we have to look for a shell. We use the value
of the C<CONFIG_SHELL> environment variable if it is set, else
C</bin/ksh> if it exists, else C</bin/bash> if it exists, else give up.
Happily, C<config.guess> later reverted this change, but we keep our
shell-finding code anyway to defend against future mistakes of the same ilk.

=cut

sub platform {
  if (! defined $::_platform_) {
    if ($^O =~ /^MSWin/i) {
      # print STDERR "\$^O is $^O\n";
      $::_platform_ = "windows";
    } else {
      my $config_guess = "$::installerdir/tlpkg/installer/config.guess";

      # For example, if the disc or reader has hardware problems.
      die "$0: config.guess script does not exist, goodbye: $config_guess"
        if ! -r $config_guess;

      # We cannot rely on #! in config.guess but have to call /bin/sh
      # explicitly because sometimes the 'noexec' flag is set in
      # /etc/fstab for ISO9660 file systems.
      # 
      # In addition, config.guess was (unnecessarily) changed in 2020 by
      # to use $(...) instead of `...`, although $(...) is not supported
      # by Solaris /bin/sh (and others). The maintainers have declined
      # to revert the change, so now every caller of config.guess must
      # laboriously find a usable shell. Sigh.
      # 
      my $config_shell = $ENV{"CONFIG_SHELL"} || "/bin/sh";
      #
      # check if $(...) is supported:
      my $paren_cmdout = `'$config_shell' -c 'echo \$(echo foo)' 2>/dev/null`;
      #warn "paren test out: `$paren_cmdout'.\n";
      #
      # The echo command might output a newline (maybe CRLF?) even if
      # the $(...) fails, so don't just check for non-empty output.
      # Maybe checking exit status would be better, but maybe not.
      # 
      if (length ($paren_cmdout) <= 2) {
        # if CONFIG_SHELL is set to something bad, give up.
        if ($ENV{"CONFIG_SHELL"}) {
          die <<END_BAD_CONFIG_SHELL;
$0: the CONFIG_SHELL environment variable is set to $ENV{CONFIG_SHELL}
  but this cannot execute \$(...) shell constructs,
  which is required. Set CONFIG_SHELL to something that works.
END_BAD_CONFIG_SHELL

        } elsif (-x "/bin/ksh") {
          $config_shell = "/bin/ksh";

        } elsif (-x "/bin/bash") {
          $config_shell = "/bin/bash";

        } else {
          die <<END_NO_PAREN_CMDS_SHELL
$0: can't find shell to execute $config_guess
  (which gratuitously requires support for \$(...) command substitution).
  Tried $config_shell, /bin/ksh, bin/bash.
  Set the environment variable CONFIG_SHELL to specify explicitly.
END_NO_PAREN_CMDS_SHELL
        }
      }
      #warn "executing config.guess with $config_shell\n";
      chomp (my $guessed_platform = `'$config_shell' '$config_guess'`);

      # If we didn't get anything usable, give up.
      die "$0: could not run $config_guess, cannot proceed, sorry"
        if ! $guessed_platform;

      $::_platform_ = platform_name($guessed_platform);
    }
  }
  return $::_platform_;
}


=item C<platform_name($canonical_host)>

Convert the C<$canonical_host> argument, a system description as
returned by C<config.guess>, into a TeX Live platform name, that is, a
name used as a subdirectory of our C<bin/> dir. Our names have the
form CPU-OS, for example, C<x86_64-linux>.

We need this because what's returned from C<config.,guess> does not
match our historical names, e.g., C<config.guess> returns C<linux-gnu>
but we need C<linux>.

The C<CPU> part of our name is always taken from the argument, with
various transformation.

For the C<OS> part, if the environment variable C<TEXLIVE_OS_NAME> is
set, it is used as-is. Otherwise we do our best to figure it out.

This function still handles old systems which are no longer supported,
just in case.

=cut

sub platform_name {
  my ($orig_platform) = @_;
  my $guessed_platform = $orig_platform;

  # try to parse out some bsd variants that use amd64.
  # We throw away everything after the "bsd" to elide version numbers,
  # as in amd64-unknown-midnightbsd1.2.
  $guessed_platform =~ s/^x86_64-(.*-k?)(free|net)bsd/amd64-$1$2bsd/;
  my $CPU; # CPU type as reported by config.guess.
  my $OS;  # O/S type as reported by config.guess.
  ($CPU = $guessed_platform) =~ s/(.*?)-.*/$1/;

  $CPU =~ s/^alpha(.*)/alpha/;   # alphaev whatever
  $CPU =~ s/mips64el/mipsel/;    # don't distinguish mips64 and 32 el
  $CPU =~ s/powerpc64/powerpc/;  # don't distinguish ppc64
  $CPU =~ s/sparc64/sparc/;      # don't distinguish sparc64

  # armv6l-unknown-linux-gnueabihf -> armhf-linux (RPi)
  # armv7l-unknown-linux-gnueabi   -> armel-linux (Android)
  if ($CPU =~ /^arm/) {
    $CPU = $guessed_platform =~ /hf$/ ? "armhf" : "armel";
  }

  if ($ENV{"TEXLIVE_OS_NAME"}) {
    $OS = $ENV{"TEXLIVE_OS_NAME"};
  } else {
    my @OSs = qw(aix cygwin darwin dragonfly freebsd hpux irix
                 kfreebsd linux midnightbsd netbsd openbsd solaris);
    for my $os (@OSs) {
      # Match word boundary at the beginning of the os name so that
      #   freebsd and kfreebsd are distinguished.
      # Do not match word boundary at the end of the os so that
      #   solaris2 is matched.
      $OS = $os if $guessed_platform =~ /\b$os/;
    }
  }  

  if (! $OS) {
    warn "$0: could not guess OS from config.guess string: $orig_platform";
    $OS = "unknownOS";
  }
  
  if ($OS eq "linux") {
    # deal with the special case of musl based distributions
    # config.guess returns
    #   x86_64-pc-linux-musl
    #   i386-pc-linux-musl
    $OS = "linuxmusl" if $guessed_platform =~ /\blinux-musl/;
  }
  
  if ($OS eq "darwin") {
    # We have two versions of Mac binary sets.
    # 11.x and newer -> universal-darwin [MacTeX]
    # 10.x -> x86_64-darwinlegacy, if 64-bit.
    # x changes every year. As of TL 2021 (Big Sur) Apple started with 11.x.
    #
    # (BTW, uname -r numbers are larger by 4 than the Mac minor version.
    # We don't use uname numbers here.)
    #
    # When MacTeX stops supporting the earliest 11.x, reinstate this.
    #my $mactex_darwin = ;  # lowest minor rev supported by universal-darwin.
    #
    # Most robust approach is apparently to check sw_vers (os version,
    # returns "10.x" values), and sysctl (processor hardware).
    chomp (my $sw_vers = `sw_vers -productVersion`);
    my ($os_major,$os_minor) = split (/\./, $sw_vers);
    if ($os_major < 10) {
      warn "$0: only MacOSX is supported, not $OS $os_major.$os_minor "
           . " (from sw_vers -productVersion: $sw_vers)\n";
      return "unknownmac-unknownmac";
    }
    # have to refine after all 10.x become "legacy".
    if ($os_major >= 11) { # see above: || $os_minor >= $mactex_darwin) {
      $CPU = "universal";
      $OS = "darwin";
    } elsif ($os_major == 10 && 6 <= $os_minor) {
             # see above: && $os_minor < $mactex_darwin){
      # in between, x86 hardware only.  On 10.6 only, must check if 64-bit,
      # since if later than that, always 64-bit.
      my $is64 = $os_minor == 6
                 ? `/usr/sbin/sysctl -n hw.cpu64bit_capable` >= 1
                 : 1;
      if ($is64) {
        $CPU = "x86_64";
        $OS = "darwinlegacy";
      } # if not 64-bit, default is ok (i386-darwin).
    } else {
      ; # older version, default is ok (i386-darwin, powerpc-darwin).
    }
    
  } elsif ($CPU =~ /^i.86$/) {
    $CPU = "i386";  # 586, 686, whatever
  }

  if (! defined $OS) {
    ($OS = $guessed_platform) =~ s/.*-(.*)/$1/;
  }

  return "$CPU-$OS";
}

=item C<platform_desc($platform)>

Return a string which describes a particular platform identifier, e.g.,
given C<i386-linux> we return C<Intel x86 with GNU/Linux>.

=cut

sub platform_desc {
  my ($platform) = @_;

  my %platform_name = (
    'aarch64-linux'    => 'GNU/Linux on ARM64',
    'alpha-linux'      => 'GNU/Linux on DEC Alpha',
    'amd64-freebsd'    => 'FreeBSD on x86_64',
    'amd64-kfreebsd'   => 'GNU/kFreeBSD on x86_64',
    'amd64-midnightbsd'=> 'MidnightBSD on x86_64',
    'amd64-netbsd'     => 'NetBSD on x86_64',
    'armel-linux'      => 'GNU/Linux on ARM',
    'armhf-linux'      => 'GNU/Linux on RPi(32-bit) and ARMv7',
    'hppa-hpux'        => 'HP-UX',
    'i386-cygwin'      => 'Cygwin on Intel x86',
    'i386-darwin'      => 'MacOSX legacy (10.5-10.6) on Intel x86',
    'i386-freebsd'     => 'FreeBSD on Intel x86',
    'i386-kfreebsd'    => 'GNU/kFreeBSD on Intel x86',
    'i386-linux'       => 'GNU/Linux on Intel x86',
    'i386-linuxmusl'   => 'GNU/Linux on Intel x86 with musl',
    'i386-netbsd'      => 'NetBSD on Intel x86',
    'i386-openbsd'     => 'OpenBSD on Intel x86',
    'i386-solaris'     => 'Solaris on Intel x86',
    'mips-irix'        => 'SGI IRIX',
    'mipsel-linux'     => 'GNU/Linux on MIPSel',
    'powerpc-aix'      => 'AIX on PowerPC',
    'powerpc-darwin'   => 'MacOSX legacy (10.5) on PowerPC',
    'powerpc-linux'    => 'GNU/Linux on PowerPC',
    'sparc-linux'      => 'GNU/Linux on Sparc',
    'sparc-solaris'    => 'Solaris on Sparc',
    'universal-darwin' => 'MacOSX current (11-) on ARM/x86_64',
    'win32'            => 'Windows (32-bit)',
    'windows'          => 'Windows (64-bit)',
    'x86_64-cygwin'    => 'Cygwin on x86_64',
    'x86_64-darwinlegacy' => 'MacOSX legacy (10.6-) on x86_64',
    'x86_64-dragonfly' => 'DragonFlyBSD on x86_64',
    'x86_64-linux'     => 'GNU/Linux on x86_64',
    'x86_64-linuxmusl' => 'GNU/Linux on x86_64 with musl',
    'x86_64-solaris'   => 'Solaris on x86_64',
  );

  # the inconsistency between amd64-freebsd and x86_64-linux is
  # unfortunate (it's the same hardware), but the os people say those
  # are the conventional names on the respective os's, so we follow suit.

  if (exists $platform_name{$platform}) {
    return "$platform_name{$platform}";
  } else {
    my ($CPU,$OS) = split ('-', $platform);
    $OS = "" if ! defined $OS; # e.g., -force-platform foo
    return "$CPU with " . ucfirst "$OS";
  }
}


=item C<wndws>

Return C<1> if platform is Windows and C<0> otherwise.  The test is
currently based on the value of Perl's C<$^O> variable.

=cut

sub wndws {
  if ($^O =~ /^MSWin/i) {
    return 1;
  } else {
    return 0;
  }
  # the following needs config.guess, which is quite bad ...
  # return (&platform eq "windows")? 1:0;
}


=item C<unix>

Return C<1> if platform is UNIX and C<0> otherwise.

=cut

sub unix {
  return (&platform eq "windows")? 0:1;
}


=back

=head2 System Tools

=over 4

=item C<getenv($string)>

Get an environment variable.  It is assumed that the environment
variable contains a path.  On Windows all backslashes are replaced by
forward slashes as required by Perl.  If this behavior is not desired,
use C<$ENV{"$variable"}> instead.  C<0> is returned if the
environment variable is not set.

=cut

sub getenv {
  my $envvar=shift;
  my $var=$ENV{"$envvar"};
  return 0 unless (defined $var);
  if (&wndws) {
    $var=~s!\\!/!g;  # change \ -> / (required by Perl)
  }
  return "$var";
}


=item C<which($string)>

C<which> does the same as the UNIX command C<which(1)>, but it is
supposed to work on Windows too.  On Windows we have to try all the
extensions given in the C<PATHEXT> environment variable.  We also try
without appending an extension because if C<$string> comes from an
environment variable, an extension might already be present.

=cut

sub which {
  my ($prog) = @_;
  my @PATH;
  my $PATH = getenv('PATH');

  if (&wndws) {
    my @PATHEXT = split (';', getenv('PATHEXT'));
    push (@PATHEXT, '');  # in case argument contains an extension
    @PATH = split (';', $PATH);
    for my $dir (@PATH) {
      for my $ext (@PATHEXT) {
        if (-f "$dir/$prog$ext") {
          return "$dir/$prog$ext";
        }
      }
    }

  } else { # not windows
    @PATH = split (':', $PATH);
    for my $dir (@PATH) {
      if (-x "$dir/$prog") {
        return "$dir/$prog";
      }
    }
  }
  return 0;
}

=item C<initialize_global_tmpdir();>

Initializes a directory for all temporary files. This uses C<File::Temp>
and thus honors various env variables like  C<TMPDIR>, C<TMP>, and C<TEMP>.

=cut

sub initialize_global_tmpdir {
  $::tl_tmpdir = File::Temp::tempdir(CLEANUP => 1);
  ddebug("TLUtils::initialize_global_tmpdir: creating global tempdir $::tl_tmpdir\n");
  return ($::tl_tmpdir);
}

=item C<tl_tmpdir>

Create a temporary directory which is removed when the program
is terminated.

=cut

sub tl_tmpdir {
  initialize_global_tmpdir() if (!defined($::tl_tmpdir));
  my $tmp = File::Temp::tempdir(DIR => $::tl_tmpdir, CLEANUP => 1);
  ddebug("TLUtils::tl_tmpdir: creating tempdir $tmp\n");
  return ($tmp);
}

=item C<tl_tmpfile>

Create a temporary file which is removed when the program
is terminated. Returns file handle and file name.
Arguments are passed on to C<File::Temp::tempfile>.

=cut

sub tl_tmpfile {
  initialize_global_tmpdir() if (!defined($::tl_tmpdir));
  my ($fh, $fn) = File::Temp::tempfile(@_, DIR => $::tl_tmpdir, UNLINK => 1);
  ddebug("TLUtils::tl_tempfile: creating tempfile $fn\n");
  return ($fh, $fn);
}


=item C<xchdir($dir)>

C<chdir($dir)> or die.

=cut

sub xchdir {
  my ($dir) = @_;
  chdir($dir) || die "$0: chdir($dir) failed: $!";
  ddebug("xchdir($dir) ok\n");
}

=item C<system_ok($cmdline)>

Run C<system($cmdline)> and return true if return status was zero, false
if status was nonzero. Throw away stdout and stderr.

=cut

sub system_ok {
  my $nulldev = nulldev();
  my ($cmdline) = @_;
  `$cmdline >$nulldev 2>&1`;
  return $? == 0;
}

=item C<wsystem($msg, @args)>

Call C<info> about what is being done starting with C<$msg>, then run
C<system(@args)>; C<tlwarn> if unsuccessful and return the exit status.

=cut

sub wsystem {
  my ($msg,@args) = @_;
  info("$msg @args ...\n");
  my $retval = system(@args);
  if ($retval != 0) {
    $retval /= 256 if $retval > 0;
    tlwarn("$0:  command failed (status $retval): @args: $!\n");
  }
  return $retval;
}


=item C<xsystem(@args)>

Call C<ddebug> about what is being done, then run C<system(@args)>, and
die if unsuccessful.

=cut

sub xsystem {
  my (@args) = @_;
  ddebug("running system(@args)\n");
  my $retval = system(@args);
  if ($retval != 0) {
    $retval /= 256 if $retval > 0;
    my $pwd = cwd ();
    die "$0: system(@args) failed in $pwd, status $retval";
  }
  return $retval;
}

=item C<run_cmd($cmd, @envvars)>

Run shell command C<$cmd> and captures its standard output (not standard
error). Returns a list with CMD's output as the first element and its
return value (exit code) as second.

If given, C<@envvars> is a list of environment variable name / value
pairs set in C<%ENV> for the call and reset to their original value (or
unset if not defined initially).

=cut

sub run_cmd {
  my $cmd = shift;
  my %envvars = @_;
  my %envvarsSetState;
  my %envvarsValue;
  for my $k (keys %envvars) {
    $envvarsSetState{$k} = exists $ENV{$k};
    $envvarsValue{$k} = $ENV{$k};
    $ENV{$k} = $envvars{$k};
  }
  my $output = `$cmd`;
  for my $k (keys %envvars) {
    if ($envvarsSetState{$k}) {
      $ENV{$k} = $envvarsValue{$k};
    } else {
      delete $ENV{$k};
    }
  }

  $output = "" if ! defined ($output);  # don't return undef

  my $retval = $?;
  if ($retval != 0) {
    $retval /= 256 if $retval > 0;
  }
  return ($output,$retval);
}

=item C<run_cmd_with_log($cmd, $logfn)>

Run shell command C<$cmd> and captures both standard output and standard
error (as one string), passing them to C<$logfn>. The return value is
the exit status of C<$cmd>. Environment variable overrides cannot be
passed. (This is used for running special post-installation commands in
install-tl and tlmgr.)

The C<info> function is called to report what is happening.

=cut

sub run_cmd_with_log {
  my ($cmd,$logfn) = @_;
  
  info ("running $cmd ...");
  my ($out,$ret) = TeXLive::TLUtils::run_cmd ("$cmd 2>&1");
  if ($ret == 0) {
    info ("done\n");
  } else {
    info ("failed\n");
    tlwarn ("$0: $cmd failed: status $ret",
            $! ? ", error: $!" : "", # usually $! will not be set
            ")\n");
    $ret = 1;
  }
  &$logfn ($out); # log the output
  
  return $ret;
} # run_cmd_with_log


=item C<system_pipe($prog, $infile, $outfile, $removeIn, @extraargs)>

Runs C<$prog> with C<@extraargs> redirecting stdin from C<$infile>,
stdout to C<$outfile>. Removes C<$infile> if C<$removeIn> is true.

=cut

sub system_pipe {
  my ($prog, $infile, $outfile, $removeIn, @extraargs) = @_;
  
  my $progQuote = quotify_path_with_spaces($prog);
  if (wndws()) {
    $infile =~ s!/!\\!g;
    $outfile =~ s!/!\\!g;
  }
  my $infileQuote = "\"$infile\"";
  my $outfileQuote = "\"$outfile\"";
  debug("TLUtils::system_pipe: calling $progQuote @extraargs < $infileQuote > $outfileQuote\n");
  my $retval = system("$progQuote @extraargs < $infileQuote > $outfileQuote");
  if ($retval != 0) {
    $retval /= 256 if $retval > 0;
    debug("TLUtils::system_pipe: system exit code = $retval\n");
    return 0;
  } else {
    if ($removeIn) {
      debug("TLUtils::system_pipe: removing $infile\n");
      unlink($infile);
    }
    return 1;
  }
}

=item C<diskfree($path)>

If a POSIX compliant C<df> program is found, returns the number of Mb
free at C<$path>, otherwise C<-1>. If C<$path> does not exist, check
upwards for two levels for an existing parent, and if found, use it for
computing the disk space.

=cut

sub diskfree {
  my $td = shift;
  my ($output, $retval);
  if (wndws()) {
    # the powershell one-liner only works from win8 on.
    my @winver = Win32::GetOSVersion();
    if ($winver[1]<=6 && $winver[2]<=1) {
      return -1;
    }
    my $avl;
    if ($td =~ /^[a-zA-Z]:/) {
      my $drv = substr($td,0,1);
      # ea ignore: error action ignore: no output at all
      my $cmd = "powershell -nologo -noninteractive -noprofile -command " .
       "\"get-psdrive -name $drv -ea ignore |select-object free |format-wide\"";
      ($output, $retval) = run_cmd($cmd);
      # ignore exit code, just parse the output, which should
      # consist of empty lines and a number surrounded by spaces
      my @lines = split(/\r*\n/, $output);
      foreach (@lines) {
        chomp $_;
        if ($_ !~ /^\s*$/) {
          $_ =~ s/^\s*//;
          $_ =~ s/\s*$//;
          $avl = $_;
          last;
        }
      }
      if ($avl !~ /^[0-9]+$/) {
        return (-1);
      } else {
        return (int($avl/(1024*1024)));
      }
    } else {
      # maybe UNC drive; do not try to handle this
      return -1;
    }
  }
  # now windows case has been taken care of
  return (-1) if (! $::progs{"df"});
  # drop final /
  $td =~ s!/$!!;
  if (! -e $td) {
    my $ptd = dirname($td);
    if (-e $ptd) {
      $td = $ptd;
    } else {
      my $pptd = dirname($ptd);
      if (-e $pptd) {
        $td = $pptd;
      }
    }
  }
  $td .= "/" if ($td !~ m!/$!);
  return (-1) if (! -e $td);
  debug("checking diskfree() in $td\n");
  ($output, $retval) = run_cmd("df -Pk \"$td\"");
    # With -k (mandated by POSIX), we should always get 1024-blocks.
    # Otherwise, the POSIXLY_CORRECT envvar for GNU df would need to
    # be set, to force 512-blocks; and the BLOCKSIZE envvar would need
    # to be unset to avoid overriding.
  if ($retval == 0) {
    # Output format should be this:
    # Filesystem      1024-blocks     Used Available Capacity Mounted on
    # /dev/sdb3       209611780 67718736 141893044      33% /
    my ($h,$l) = split(/\n/, $output);
    my ($fs, $nrb, $used, $avail, @rest) = split(' ', $l);
    debug("diskfree: df -Pk output: $output");
    debug("diskfree: used=$used (1024-block), avail=$avail (1024-block)\n");
    # $avail is in 1024-byte blocks, so we divide by 1024 to obtain Mb.
    return (int($avail / 1024));
  } else {
    # error in running df -P for whatever reason, just skip the check.
    return (-1);
  }
}

=item C<get_user_home()>

Returns the current user's home directory (C<$HOME> on Unix,
C<$USERPROFILE> on Windows, and C<~> if none of the two are
set. Save in package variable C<$user_home_dir> after computing.

=cut

# only search for home directory once, and save expansion here
my $user_home_dir;

sub get_user_home {
  return $user_home_dir if ($user_home_dir);
  $user_home_dir = getenv (wndws() ? 'USERPROFILE' : 'HOME') || '~';
  return $user_home_dir;
}

=item C<expand_tilde($str)>

Expands initial C<~> with the user's home directory in C<$str> if
available, else leave C<~> in place.

=cut

sub expand_tilde {
  my $str = shift;
  my $h = get_user_home();
  $str =~ s/^~/$h/;
  return $str;
}

=back

=head2 File utilities

=over 4

=item C<dirname_and_basename($path)>

Return both C<dirname> and C<basename>.  Example:

  ($dirpart,$filepart) = dirname_and_basename ($path);

=cut

sub dirname_and_basename {
  my $path=shift;
  my ($share, $base) = ("", "");
  if (wndws()) {
    $path=~s!\\!/!g;
  }
  # do not try to make sense of paths ending with /..
  return (undef, undef) if $path =~ m!/\.\.$!;
  if ($path=~m!/!) {   # dirname("foo/bar/baz") -> "foo/bar"
    # eliminate `/.' path components
    while ($path =~ s!/\./!/!) {};
    # UNC path? => first split in $share = //xxx/yy and $path = /zzzz
    if (wndws() and $path =~ m!^(//[^/]+/[^/]+)(.*)$!) {
      ($share, $path) = ($1, $2);
      if ($path =~ m!^/?$!) {
        $path = $share;
        $base = "";
      } elsif ($path =~ m!(/.*)/(.*)!) {
        $path = $share.$1;
        $base = $2;
      } else {
        $base = $path;
        $path = $share;
      }
      return ($path, $base);
    }
    # not a UNC path
    $path=~m!(.*)/(.*)!; # works because of greedy matching
    return ((($1 eq '') ? '/' : $1), $2);
  } else {             # dirname("ignore") -> "."
    return (".", $path);
  }
}


=item C<dirname($path)>

Return C<$path> with its trailing C</component> removed.

=cut

sub dirname {
  my $path = shift;
  my ($dirname, $basename) = dirname_and_basename($path);
  return $dirname;
}


=item C<basename($path)>

Return C<$path> with any leading directory components removed.

=cut

sub basename {
  my $path = shift;
  my ($dirname, $basename) = dirname_and_basename($path);
  return $basename;
}


=item C<tl_abs_path($path)>

# Other than Cwd::abs_path, tl_abs_path also works if the argument does not
# yet exist as long as the path does not contain '..' components.

=cut

sub tl_abs_path {
  my $path = shift;
  if (wndws()) {
    $path=~s!\\!/!g;
  }
  if (-e $path) {
    $path = Cwd::abs_path($path);
  } elsif ($path eq '.') {
    $path = Cwd::getcwd();
  } else{
    # collapse /./ components
    $path =~ s!/\./!/!g;