diff options
author | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
commit | e0c6872cf40896c7be36b11dcc744620f10adf1d (patch) | |
tree | 60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/TeXLive/TLUtils.pm |
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/TeXLive/TLUtils.pm')
-rw-r--r-- | systems/texlive/tlnet/tlpkg/TeXLive/TLUtils.pm | 4578 |
1 files changed, 4578 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TLUtils.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TLUtils.pm new file mode 100644 index 0000000000..08c146a9a3 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/TeXLive/TLUtils.pm @@ -0,0 +1,4578 @@ +# $Id: TLUtils.pm 50493 2019-03-20 22:57:54Z karl $ +# TeXLive::TLUtils.pm - the inevitable utilities for TeX Live. +# Copyright 2007-2019 Norbert Preining, Reinhard Kotucha +# This file is licensed under the GNU General Public License version 2 +# or any later version. + +package TeXLive::TLUtils; + +my $svnrev = '$Revision: 50493 $'; +my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown"; +sub module_revision { return $_modulerevision; } + +=pod + +=head1 NAME + +C<TeXLive::TLUtils> -- utilities used in TeX Live infrastructure + +=head1 SYNOPSIS + + use TeXLive::TLUtils; + +=head2 Platform detection + + TeXLive::TLUtils::platform(); + TeXLive::TLUtils::platform_name($canonical_host); + TeXLive::TLUtils::platform_desc($platform); + TeXLive::TLUtils::win32(); + 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); + TeXLive::TLUtils::system_pipe($prog, $infile, $outfile, $removeIn, @extraargs); + +=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::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)>); + TeXLive::TLUtils::do_postaction($how, $tlpobj, $do_fileassocs, $do_menu, $do_desktop, $do_script); + 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 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::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); + TeXLive::TLUtils::give_ctan_mirror(); + TeXLive::TLUtils::give_ctan_mirror_base(); + 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($optsref,$tmfc, $tmfsc, $tmfv, $tmfsv); + TeXLive::TLUtils::prepend_own_path(); + TeXLive::TLUtils::repository_to_array($str); + +=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 +use vars qw( + $::LOGFILENAME @::LOGLINES + @::debug_hook @::ddebug_hook @::dddebug_hook @::info_hook + @::install_packages_hook @::warn_hook + $TeXLive::TLDownload::net_lib_avail + $::checksum_method $::gui_mode $::machinereadable $::no_execute_actions + $::regenerate_all_formats + $JSON::false $JSON::true +); + +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 + © + &touch + &collapse_dirs + &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 + "ewords + "ify_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 + &wsystem + &xsystem + &run_cmd + &system_pipe + &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_hash + win32 xchdir xsystem run_cmd system_pipe sort_archs); +} + +use Cwd; +use Getopt::Long; +use File::Temp; +use File::Copy qw//; + +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<win32>. +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. + +=cut + +sub platform { + unless (defined $::_platform_) { + if ($^O =~ /^MSWin/i) { + $::_platform_ = "win32"; + } else { + my $config_guess = "$::installerdir/tlpkg/installer/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. + chomp (my $guessed_platform = `/bin/sh '$config_guess'`); + + # For example, if the disc or reader has hardware problems. + 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 a canonical host names as returned by C<config.guess> into +TeX Live platform names. + +CPU type is determined by a regexp, and any C</^i.86/> name is replaced +by C<i386>. + +For OS we need a list because what's returned is not likely to match our +historical names, e.g., C<config.guess> returns C<linux-gnu> but we need +C<linux>. This list might/should contain OSs which are not currently +supported. + +If a particular platform is not found in this list we use the regexp +C</.*-(.*$)/> as a last resort and hope it provides something useful. + +=cut + +sub platform_name { + my ($guessed_platform) = @_; + + $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"; + } + + my @OSs = qw(aix cygwin darwin freebsd hpux irix + kfreebsd linux 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 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. + # 10.10/Yosemite and newer (Yosemite specially left over): + # -> x86_64-darwin [MacTeX] + # 10.6/Snow Leopard through 10.10/Yosemite: + # -> x86_64-darwinlegacy if 64-bit + # + # (BTW, uname -r numbers are larger by 4 than the Mac minor version. + # We don't use uname numbers here.) + # + # this changes each year, per above: + my $mactex_darwin = 12; # lowest minor rev supported by x86_64-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 "unknown-unknown"; + } + if ($os_minor >= $mactex_darwin) { + ; # current version, default is ok (x86_64-darwin). + } elsif ($os_minor >= 6 && $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-netbsd' => 'NetBSD on x86_64', + 'armel-linux' => 'GNU/Linux on ARM', + 'armhf-linux' => 'GNU/Linux on ARMv6/RPi', + '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 universal binaries', + 'win32' => 'Windows', + 'x86_64-cygwin' => 'Cygwin on x86_64', + 'x86_64-darwin' => 'MacOSX current (10.12-) on x86_64', + 'x86_64-darwinlegacy' => 'MacOSX legacy (10.6-) 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); + return "$CPU with " . ucfirst "$OS"; + } +} + + +=item C<win32> + +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 win32 { + if ($^O =~ /^MSWin/i) { + return 1; + } else { + return 0; + } + # the following needs config.guess, which is quite bad ... + # return (&platform eq "win32")? 1:0; +} + + +=item C<unix> + +Return C<1> if platform is UNIX and C<0> otherwise. + +=cut + +sub unix { + return (&platform eq "win32")? 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 (&win32) { + $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 (&win32) { + 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("tl_tempdir: 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("tl_tempdir: 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("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<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)> + +Run shell command C<$cmd> and captures its output. Returns a list with CMD's +output as the first element and the return value (exit code) as second. + +=cut + +sub run_cmd { + my $cmd = shift; + my $output = `$cmd`; + $output = "" if ! defined ($output); # don't return undef + + my $retval = $?; + if ($retval != 0) { + $retval /= 256 if $retval > 0; + } + return ($output,$retval); +} + +=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 (win32()) { + $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; + } +} + +=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 (win32) { + $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 (win32() 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 (win32) { + $path=~s!\\!/!g; + } + if (-e $path) { + $path = Cwd::abs_path($path); + } elsif ($path eq '.') { + $path = Cwd::getcwd(); + } else{ + # collapse /./ components + $path =~ s!/\./!/!g; + # no support for .. path components or for win32 long-path syntax + # (//?/ path prefix) + die "Unsupported path syntax" if $path =~ m!/\.\./! || $path =~ m!/\.\.$! + || $path =~ m!^\.\.!; + die "Unsupported path syntax" if win32() && $path =~ m!^//\?/!; + if ($path !~ m!^(.:)?/!) { # relative path + if (win32() && $path =~ /^.:/) { # drive letter + my $dcwd; + # starts with drive letter: current dir on drive + $dcwd = Cwd::getdcwd ($1); + $dcwd .= '/' unless $dcwd =~ m!/$!; + return $dcwd.$path; + } else { # relative path without drive letter + my $cwd = Cwd::getcwd(); + $cwd .= '/' unless $cwd =~ m!/$!; + return $cwd . $path; + } + } # else absolute path + } + $path =~ s!/$!! unless $path =~ m!^(.:)?/$!; + return $path; +} + + +=item C<dir_creatable($path)> + +Tests whether its argument is a directory where we can create a directory. + +=cut + +sub dir_slash { + my $d = shift; + $d = "$d/" unless $d =~ m!/!; + return $d; +} + +# test whether subdirectories can be created in the argument +sub dir_creatable { + my $path=shift; + #print STDERR "testing $path\n"; + $path =~ s!\\!/!g if win32; + return 0 unless -d $path; + $path .= '/' unless $path =~ m!/$!; + #print STDERR "testing $path\n"; + my $d; + for my $i (1..100) { + $d = ""; + # find a non-existent dirname + $d = $path . int(rand(1000000)); + last unless -e $d; + } + if (!$d) { + tlwarn("Cannot find available testdir name\n"); + return 0; + } + #print STDERR "creating $d\n"; + return 0 unless mkdir $d; + return 0 unless -d $d; + rmdir $d; + return 1; +} + + +=item C<dir_writable($path)> + +Tests whether its argument is writable by trying to write to +it. This function is necessary because the built-in C<-w> test just +looks at mode and uid/guid, which on Windows always returns true and +even on Unix is not always good enough for directories mounted from +a fileserver. + +=cut + +# The Unix test gives the wrong answer when used under Windows Vista +# with one of the `virtualized' directories such as Program Files: +# lacking administrative permissions, it would write successfully to +# the virtualized Program Files rather than fail to write to the +# real Program Files. Ugh. + +sub dir_writable { + my ($path) = @_; + return 0 unless -d $path; + $path =~ s!\\!/!g if win32; + $path .= '/' unless $path =~ m!/$!; + my $i = 0; + my $f; + for my $i (1..100) { + $f = ""; + # find a non-existent filename + $f = $path . int(rand(1000000)); + last unless -e $f; + } + if (!$f) { + tlwarn("Cannot find available testfile name\n"); + return 0; + } + return 0 if ! open (TEST, ">$f"); + my $written = 0; + $written = (print TEST "\n"); + close (TEST); + unlink ($f); + return $written; +} + + +=item C<mkdirhier($path, [$mode])> + +The function C<mkdirhier> does the same as the UNIX command C<mkdir -p>. +It behaves differently depending on the context in which it is called: +If called in void context it will die on failure. If called in +scalar context, it will return 1/0 on sucess/failure. If called in +list context, it returns 1/0 as first element and an error message +as second, if an error occurred (and no second element in case of +success). The optional parameter sets the permission bits. + +=cut + +sub mkdirhier { + my ($tree,$mode) = @_; + my $ret = 1; + my $reterror; + + if (-d "$tree") { + $ret = 1; + } else { + my $subdir = ""; + # win32 is special as usual: we need to separate //servername/ part + # from the UNC path, since (! -d //servername/) tests true + $subdir = $& if ( win32() && ($tree =~ s!^//[^/]+/!!) ); + + @dirs = split (/[\/\\]/, $tree); + for my $dir (@dirs) { + $subdir .= "$dir/"; + if (! -d $subdir) { + if (defined $mode) { + if (! mkdir ($subdir, $mode)) { + $ret = 0; + $reterror = "mkdir($subdir,$mode) failed: $!"; + last; + } + } else { + if (! mkdir ($subdir)) { + $ret = 0; + $reterror = "mkdir($subdir) failed for tree $tree: $!"; + last; + } + } + } + } + } + if ($ret) { + return(1); # nothing bad here returning 1 in any case, will + # be ignored in void context, and give 1 in list context + } else { + if (wantarray) { + return(0, $reterror); + } elsif (defined wantarray) { + return(0); + } else { + die "$0: $reterror"; + } + } +} + + +=item C<rmtree($root, $verbose, $safe)> + +The C<rmtree> function provides a convenient way to delete a +subtree from the directory structure, much like the Unix command C<rm -r>. +C<rmtree> takes three arguments: + +=over 4 + +=item * + +the root of the subtree to delete, or a reference to +a list of roots. All of the files and directories +below each root, as well as the roots themselves, +will be deleted. + +=item * + +a boolean value, which if TRUE will cause C<rmtree> to +print a message each time it examines a file, giving the +name of the file, and indicating whether it's using C<rmdir> +or C<unlink> to remove it, or that it's skipping it. +(defaults to FALSE) + +=item * + +a boolean value, which if TRUE will cause C<rmtree> to +skip any files to which you do not have delete access +(if running under VMS) or write access (if running +under another OS). This will change in the future when +a criterion for 'delete permission' under OSs other +than VMS is settled. (defaults to FALSE) + +=back + +It returns the number of files successfully deleted. Symlinks are +simply deleted and not followed. + +B<NOTE:> There are race conditions internal to the implementation of +C<rmtree> making it unsafe to use on directory trees which may be +altered or moved while C<rmtree> is running, and in particular on any +directory trees with any path components or subdirectories potentially +writable by untrusted users. + +Additionally, if the third parameter is not TRUE and C<rmtree> is +interrupted, it may leave files and directories with permissions altered +to allow deletion (and older versions of this module would even set +files and directories to world-read/writable!) + +Note also that the occurrence of errors in C<rmtree> can be determined I<only> +by trapping diagnostic messages using C<$SIG{__WARN__}>; it is not apparent +from the return value. + +=cut + +#taken from File/Path.pm +# +my $Is_VMS = $^O eq 'VMS'; +my $Is_MacOS = $^O eq 'MacOS'; + +# These OSes complain if you want to remove a file that you have no +# write permission to: +my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' || + $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc'); + +sub rmtree { + my($roots, $verbose, $safe) = @_; + my(@files); + my($count) = 0; + $verbose ||= 0; + $safe ||= 0; + + if ( defined($roots) && length($roots) ) { + $roots = [$roots] unless ref $roots; + } else { + warn "No root path(s) specified"; + return 0; + } + + my($root); + foreach $root (@{$roots}) { + if ($Is_MacOS) { + $root = ":$root" if $root !~ /:/; + $root =~ s#([^:])\z#$1:#; + } else { + $root =~ s#/\z##; + } + (undef, undef, my $rp) = lstat $root or next; + $rp &= 07777; # don't forget setuid, setgid, sticky bits + if ( -d _ ) { + # notabene: 0700 is for making readable in the first place, + # it's also intended to change it to writable in case we have + # to recurse in which case we are better than rm -rf for + # subtrees with strange permissions + chmod($rp | 0700, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) + or warn "Can't make directory $root read+writeable: $!" + unless $safe; + + if (opendir my $d, $root) { + no strict 'refs'; + if (!defined ${"\cTAINT"} or ${"\cTAINT"}) { + # Blindly untaint dir names + @files = map { /^(.*)$/s ; $1 } readdir $d; + } else { + @files = readdir $d; + } + closedir $d; + } else { + warn "Can't read $root: $!"; + @files = (); + } + # Deleting large numbers of files from VMS Files-11 filesystems + # is faster if done in reverse ASCIIbetical order + @files = reverse @files if $Is_VMS; + ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS; + if ($Is_MacOS) { + @files = map("$root$_", @files); + } else { + @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files); + } + $count += rmtree(\@files,$verbose,$safe); + if ($safe && + ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { + print "skipped $root\n" if $verbose; + next; + } + chmod $rp | 0700, $root + or warn "Can't make directory $root writeable: $!" + if $force_writeable; + print "rmdir $root\n" if $verbose; + if (rmdir $root) { + ++$count; + } else { + warn "Can't remove directory $root: $!"; + chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) + or warn("and can't restore permissions to " + . sprintf("0%o",$rp) . "\n"); + } + } else { + if ($safe && + ($Is_VMS ? !&VMS::Filespec::candelete($root) + : !(-l $root || -w $root))) + { + print "skipped $root\n" if $verbose; + next; + } + chmod $rp | 0600, $root + or warn "Can't make file $root writeable: $!" + if $force_writeable; + print "unlink $root\n" if $verbose; + # delete all versions under VMS + for (;;) { + unless (unlink $root) { + warn "Can't unlink file $root: $!"; + if ($force_writeable) { + chmod $rp, $root + or warn("and can't restore permissions to " + . sprintf("0%o",$rp) . "\n"); + } + last; + } + ++$count; + last unless $Is_VMS && lstat $root; + } + } + } + $count; +} + + +=item C<copy($file, $target_dir)> + +=item C<copy("-f", $file, $destfile)> + +Copy file C<$file> to directory C<$target_dir>, or to the C<$destfile> +in the second case. No external programs are involved. Since we need +C<sysopen()>, the Perl module C<Fcntl.pm> is required. The time stamps +are preserved and symlinks are created on Unix systems. On Windows, +C<(-l $file)> will never return 'C<true>' and so symlinks will be +(uselessly) copied as regular files. + +C<copy> invokes C<mkdirhier> if target directories do not exist. Files +have mode C<0777> if they are executable and C<0666> otherwise, with +the set bits in I<umask> cleared in each case. + +C<$file> can begin with a file:/ prefix. + +If C<$file> is not readable, we return without copying anything. (This +can happen when the database and files are not in perfect sync.) On the +other file, if the destination is not writable, or the writing fails, +that is a fatal error. + +=cut + +sub copy { + my $infile = shift; + my $filemode = 0; + if ($infile eq "-f") { # second argument is a file + $filemode = 1; + $infile = shift; + } + my $destdir=shift; + + my $outfile; + my @stat; + my $mode; + my $buffer; + my $offset; + my $filename; + my $dirmode = 0755; + my $blocksize = $TeXLive::TLConfig::BlockSize; + + $infile =~ s!^file://*!/!i; # remove file:/ url prefix + $filename = basename "$infile"; + if ($filemode) { + # given a destination file + $outfile = $destdir; + $destdir = dirname($outfile); + } else { + $outfile = "$destdir/$filename"; + } + + if (! -d $destdir) { + my ($ret,$err) = mkdirhier ($destdir); + die "mkdirhier($destdir) failed: $err\n" if ! $ret; + } + + if (-l "$infile") { + symlink (readlink $infile, "$destdir/$filename") + || die "symlink(readlink $infile, $destdir/$filename) failed: $!"; + } else { + if (! open (IN, $infile)) { + warn "open($infile) failed, not copying: $!"; + return; + } + binmode IN; + + $mode = (-x $infile) ? oct("0777") : oct("0666"); + $mode &= ~umask; + + open (OUT, ">$outfile") || die "open(>$outfile) failed: $!"; + binmode OUT; + + chmod ($mode, $outfile) || warn "chmod($mode,$outfile) failed: $!"; + + while ($read = sysread (IN, $buffer, $blocksize)) { + die "read($infile) failed: $!" unless defined $read; + $offset = 0; + while ($read) { + $written = syswrite (OUT, $buffer, $read, $offset); + die "write($outfile) failed: $!" unless defined $written; + $read -= $written; + $offset += $written; + } + } + close (OUT) || warn "close($outfile) failed: $!"; + close (IN) || warn "close($infile) failed: $!";; + @stat = lstat ($infile); + die "lstat($infile) failed: $!" if ! @stat; + utime ($stat[8], $stat[9], $outfile); + } +} + + +=item C<touch(@files)> + +Update modification and access time of C<@files>. Non-existent files +are created. + +=cut + +sub touch { + my @files=@_; + + foreach my $file (@_) { + if (-e $file) { + utime time, time, $file; + } else { + if (open( TMP, ">$file")) { + close(TMP); + } else { + warn "Can't create file $file: $!\n"; + } + } + } +} + + +=item C<collapse_dirs(@files)> + +Return a (more or less) minimal list of directories and files, given an +original list of files C<@files>. That is, if every file within a given +directory is included in C<@files>, replace all of those files with the +absolute directory name in the return list. Any files which have +sibling files not included are retained and made absolute. + +We try to walk up the tree so that the highest-level directory +containing only directories or files that are in C<@files> is returned. +(This logic may not be perfect, though.) + +This is not just a string function; we check for other directory entries +existing on disk within the directories of C<@files>. Therefore, if the +entries are relative pathnames, the current directory must be set by the +caller so that file tests work. + +As mentioned above, the returned list is absolute paths to directories +and files. + +For example, suppose the input list is + + dir1/subdir1/file1 + dir1/subdir2/file2 + dir1/file3 + +If there are no other entries under C<dir1/>, the result will be +C</absolute/path/to/dir1>. + +=cut + +sub collapse_dirs { + my (@files) = @_; + my @ret = (); + my %by_dir; + + # construct hash of all directories mentioned, values are lists of the + # files in that directory. + for my $f (@files) { + my $abs_f = Cwd::abs_path ($f); + die ("oops, no abs_path($f) from " . `pwd`) unless $abs_f; + (my $d = $abs_f) =~ s,/[^/]*$,,; + my @a = exists $by_dir{$d} ? @{$by_dir{$d}} : (); + push (@a, $abs_f); + $by_dir{$d} = \@a; + } + + # for each of our directories, see if we are given everything in + # the directory. if so, return the directory; else return the + # individual files. + for my $d (sort keys %by_dir) { + opendir (DIR, $d) || die "opendir($d) failed: $!"; + my @dirents = readdir (DIR); + closedir (DIR) || warn "closedir($d) failed: $!"; + + # initialize test hash with all the files we saw in this dir. + # (These idioms are due to "Finding Elements in One Array and Not + # Another" in the Perl Cookbook.) + my %seen; + my @rmfiles = @{$by_dir{$d}}; + @seen{@rmfiles} = (); + + # see if everything is the same. + my $ok_to_collapse = 1; + for my $dirent (@dirents) { + next if $dirent =~ /^\.(\.|svn)?$/; # ignore . .. .svn + + my $item = "$d/$dirent"; # prepend directory for comparison + if (! exists $seen{$item}) { + $ok_to_collapse = 0; + last; # no need to keep looking after the first. + } + } + + push (@ret, $ok_to_collapse ? $d : @{$by_dir{$d}}); + } + + if (@ret != @files) { + @ret = &collapse_dirs (@ret); + } + return @ret; +} + +=item C<removed_dirs(@files)> + +returns all the directories from which all content will be removed + +=cut + +# return all the directories from which all content will be removed +# +# idea: +# - create a hashes by_dir listing all files that should be removed +# by directory, i.e., key = dir, value is list of files +# - for each of the dirs (keys of by_dir and ordered deepest first) +# check that all actually contained files are removed +# and all the contained dirs are in the removal list. If this is the +# case put that directory into the removal list +# - return this removal list +# +sub removed_dirs { + my (@files) = @_; + my %removed_dirs; + my %by_dir; + + # construct hash of all directories mentioned, values are lists of the + # files/dirs in that directory. + for my $f (@files) { + # what should we do with not existing entries???? + next if (! -r "$f"); + my $abs_f = Cwd::abs_path ($f); + # the following is necessary because on win32, + # abs_path("tl-portable") + # returns + # c:\tl test\... + # and not forward slashes, while, if there is already a forward / + # in the path, also the rest is done with forward slashes. + $abs_f =~ s!\\!/!g if win32(); + if (!$abs_f) { + warn ("oops, no abs_path($f) from " . `pwd`); + next; + } + (my $d = $abs_f) =~ s,/[^/]*$,,; + my @a = exists $by_dir{$d} ? @{$by_dir{$d}} : (); + push (@a, $abs_f); + $by_dir{$d} = \@a; + } + + # for each of our directories, see if we are removing everything in + # the directory. if so, return the directory; else return the + # individual files. + for my $d (reverse sort keys %by_dir) { + opendir (DIR, $d) || die "opendir($d) failed: $!"; + my @dirents = readdir (DIR); + closedir (DIR) || warn "closedir($d) failed: $!"; + + # initialize test hash with all the files we saw in this dir. + # (These idioms are due to "Finding Elements in One Array and Not + # Another" in the Perl Cookbook.) + my %seen; + my @rmfiles = @{$by_dir{$d}}; + @seen{@rmfiles} = (); + + # see if everything is the same. + my $cleandir = 1; + for my $dirent (@dirents) { + next if $dirent =~ /^\.(\.|svn)?$/; # ignore . .. .svn + my $item = "$d/$dirent"; # prepend directory for comparison + if ( + ((-d $item) && (defined($removed_dirs{$item}))) + || + (exists $seen{$item}) + ) { + # do nothing + } else { + $cleandir = 0; + last; + } + } + if ($cleandir) { + $removed_dirs{$d} = 1; + } + } + return keys %removed_dirs; +} + +=item C<time_estimate($totalsize, $donesize, $starttime)> + +Returns the current running time and the estimated total time +based on the total size, the already done size, and the start time. + +=cut + +sub time_estimate { + my ($totalsize, $donesize, $starttime) = @_; + if ($donesize <= 0) { + return ("??:??", "??:??"); + } + my $curtime = time(); + my $passedtime = $curtime - $starttime; + my $esttotalsecs = int ( ( $passedtime * $totalsize ) / $donesize ); + # + # we change the display to show that passed time instead of the + # estimated remaining time. We keep the old code and naming and + # only initialize the $remsecs to the $passedtime instead. + # my $remsecs = $esttotalsecs - $passedtime; + my $remsecs = $passedtime; + my $min = int($remsecs/60); + my $hour; + if ($min >= 60) { + $hour = int($min/60); + $min %= 60; + } + my $sec = $remsecs % 60; + $remtime = sprintf("%02d:%02d", $min, $sec); + if ($hour) { + $remtime = sprintf("%02d:$remtime", $hour); + } + my $tmin = int($esttotalsecs/60); + my $thour; + if ($tmin >= 60) { + $thour = int($tmin/60); + $tmin %= 60; + } + my $tsec = $esttotalsecs % 60; + $tottime = sprintf("%02d:%02d", $tmin, $tsec); + if ($thour) { + $tottime = sprintf("%02d:$tottime", $thour); + } + return($remtime, $tottime); +} + + +=item C<install_packages($from_tlpdb, $media, $to_tlpdb, $what, $opt_src, $opt_doc)> + +Installs the list of packages found in C<@$what> (a ref to a list) into +the TLPDB given by C<$to_tlpdb>. Information on files are taken from +the TLPDB C<$from_tlpdb>. + +C<$opt_src> and C<$opt_doc> specify whether srcfiles and docfiles should be +installed (currently implemented only for installation from uncompressed media). + +Returns 1 on success and 0 on error. + +=cut + +sub install_packages { + my ($fromtlpdb,$media,$totlpdb,$what,$opt_src,$opt_doc) = @_; + my $container_src_split = $fromtlpdb->config_src_container; + my $container_doc_split = $fromtlpdb->config_doc_container; + my $root = $fromtlpdb->root; + my @packs = @$what; + my $totalnr = $#packs + 1; + my $td = length("$totalnr"); + my $n = 0; + my %tlpobjs; + my $totalsize = 0; + my $donesize = 0; + my %tlpsizes; + foreach my $p (@packs) { + $tlpobjs{$p} = $fromtlpdb->get_package($p); + if (!defined($tlpobjs{$p})) { + die "STRANGE: $p not to be found in ", $fromtlpdb->root; + } + if ($media ne 'local_uncompressed') { + # we use the container size as the measuring unit since probably + # downloading will be the limiting factor + $tlpsizes{$p} = $tlpobjs{$p}->containersize; + $tlpsizes{$p} += $tlpobjs{$p}->srccontainersize if $opt_src; + $tlpsizes{$p} += $tlpobjs{$p}->doccontainersize if $opt_doc; + } else { + # we have to add the respective sizes, that is checking for + # installation of src and doc file + $tlpsizes{$p} = $tlpobjs{$p}->runsize; + $tlpsizes{$p} += $tlpobjs{$p}->srcsize if $opt_src; + $tlpsizes{$p} += $tlpobjs{$p}->docsize if $opt_doc; + my %foo = %{$tlpobjs{$p}->binsize}; + for my $k (keys %foo) { $tlpsizes{$p} += $foo{$k}; } + # all the packages sizes are in blocks, so transfer that to bytes + $tlpsizes{$p} *= $TeXLive::TLConfig::BlockSize; + } + $totalsize += $tlpsizes{$p}; + } + my $starttime = time(); + foreach my $package (@packs) { + my $tlpobj = $tlpobjs{$package}; + my $reloc = $tlpobj->relocated; + $n++; + my ($estrem, $esttot) = time_estimate($totalsize, $donesize, $starttime); + my $infostr = sprintf("Installing [%0${td}d/$totalnr, " + . "time/total: $estrem/$esttot]: $package [%dk]", + $n, int($tlpsizes{$package}/1024) + 1); + info("$infostr\n"); + foreach my $h (@::install_packages_hook) { + &$h($n,$totalnr); + } + # return false if something went wrong + if (!$fromtlpdb->install_package($package, $totlpdb)) { + return 0; + } + $donesize += $tlpsizes{$package}; + } + my $totaltime = time() - $starttime; + my $totmin = int ($totaltime/60); + my $totsec = $totaltime % 60; + info(sprintf("Time used for installing the packages: %02d:%02d\n", + $totmin, $totsec)); + $totlpdb->save; + return 1; +} + +=item C<do_postaction($how, $tlpobj, $do_fileassocs, $do_menu, $do_desktop, $do_script)> + +Evaluates the C<postaction> fields in the C<$tlpobj>. The first parameter +can be either C<install> or C<remove>. The second gives the TLPOBJ whos +postactions should be evaluated, and the last four arguments specify +what type of postactions should (or shouldn't) be evaluated. + +Returns 1 on success, and 0 on failure. + +=cut + +sub do_postaction { + my ($how, $tlpobj, $do_fileassocs, $do_menu, $do_desktop, $do_script) = @_; + my $ret = 1; + if (!defined($tlpobj)) { + tlwarn("do_postaction: didn't get a tlpobj\n"); + return 0; + } + debug("running postaction=$how for " . $tlpobj->name . "\n") + if $tlpobj->postactions; + for my $pa ($tlpobj->postactions) { + if ($pa =~ m/^\s*shortcut\s+(.*)\s*$/) { + $ret &&= _do_postaction_shortcut($how, $tlpobj, $do_menu, $do_desktop, $1); + } elsif ($pa =~ m/\s*filetype\s+(.*)\s*$/) { + next unless $do_fileassocs; + $ret &&= _do_postaction_filetype($how, $tlpobj, $1); + } elsif ($pa =~ m/\s*fileassoc\s+(.*)\s*$/) { + $ret &&= _do_postaction_fileassoc($how, $do_fileassocs, $tlpobj, $1); + next; + } elsif ($pa =~ m/\s*progid\s+(.*)\s*$/) { + next unless $do_fileassocs; + $ret &&= _do_postaction_progid($how, $tlpobj, $1); + } elsif ($pa =~ m/\s*script\s+(.*)\s*$/) { + next unless $do_script; + $ret &&= _do_postaction_script($how, $tlpobj, $1); + } else { + tlwarn("do_postaction: don't know how to do $pa\n"); + $ret = 0; + } + } + # nothing to do + return $ret; +} + +sub _do_postaction_fileassoc { + my ($how, $mode, $tlpobj, $pa) = @_; + return 1 unless win32(); + my ($errors, %keyval) = + parse_into_keywords($pa, qw/extension filetype/); + + if ($errors) { + tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); + return 0; + } + + # name can be an arbitrary string + if (!defined($keyval{'extension'})) { + tlwarn("extension of fileassoc postaction not given\n"); + return 0; + } + my $extension = $keyval{'extension'}; + + # cmd can be an arbitrary string + if (!defined($keyval{'filetype'})) { + tlwarn("filetype of fileassoc postaction not given\n"); + return 0; + } + my $filetype = $keyval{'filetype'}.'.'.$ReleaseYear; + + &log("postaction $how fileassoc for " . $tlpobj->name . + ": $extension, $filetype\n"); + if ($how eq "install") { + TeXLive::TLWinGoo::register_extension($mode, $extension, $filetype); + } elsif ($how eq "remove") { + TeXLive::TLWinGoo::unregister_extension($mode, $extension, $filetype); + } else { + tlwarn("Unknown mode $how\n"); + return 0; + } + return 1; +} + +sub _do_postaction_filetype { + my ($how, $tlpobj, $pa) = @_; + return 1 unless win32(); + my ($errors, %keyval) = + parse_into_keywords($pa, qw/name cmd/); + + if ($errors) { + tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); + return 0; + } + + # name can be an arbitrary string + if (!defined($keyval{'name'})) { + tlwarn("name of filetype postaction not given\n"); + return 0; + } + my $name = $keyval{'name'}.'.'.$ReleaseYear; + + # cmd can be an arbitrary string + if (!defined($keyval{'cmd'})) { + tlwarn("cmd of filetype postaction not given\n"); + return 0; + } + my $cmd = $keyval{'cmd'}; + + my $texdir = `kpsewhich -var-value=SELFAUTOPARENT`; + chomp($texdir); + my $texdir_bsl = conv_to_w32_path($texdir); + $cmd =~ s!^("?)TEXDIR/!$1$texdir/!g; + + &log("postaction $how filetype for " . $tlpobj->name . + ": $name, $cmd\n"); + if ($how eq "install") { + TeXLive::TLWinGoo::register_file_type($name, $cmd); + } elsif ($how eq "remove") { + TeXLive::TLWinGoo::unregister_file_type($name); + } else { + tlwarn("Unknown mode $how\n"); + return 0; + } + return 1; +} + +# alternate filetype (= progid) for an extension; +# associated program shows up in `open with' menu +sub _do_postaction_progid { + my ($how, $tlpobj, $pa) = @_; + return 1 unless win32(); + my ($errors, %keyval) = + parse_into_keywords($pa, qw/extension filetype/); + + if ($errors) { + tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); + return 0; + } + + if (!defined($keyval{'extension'})) { + tlwarn("extension of progid postaction not given\n"); + return 0; + } + my $extension = $keyval{'extension'}; + + if (!defined($keyval{'filetype'})) { + tlwarn("filetype of progid postaction not given\n"); + return 0; + } + my $filetype = $keyval{'filetype'}.'.'.$ReleaseYear; + + &log("postaction $how progid for " . $tlpobj->name . + ": $extension, $filetype\n"); + if ($how eq "install") { + TeXLive::TLWinGoo::add_to_progids($extension, $filetype); + } elsif ($how eq "remove") { + TeXLive::TLWinGoo::remove_from_progids($extension, $filetype); + } else { + tlwarn("Unknown mode $how\n"); + return 0; + } + return 1; +} + +sub _do_postaction_script { + my ($how, $tlpobj, $pa) = @_; + my ($errors, %keyval) = + parse_into_keywords($pa, qw/file filew32/); + + if ($errors) { + tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); + return 0; + } + + # file can be an arbitrary string + if (!defined($keyval{'file'})) { + tlwarn("filename of script not given\n"); + return 0; + } + my $file = $keyval{'file'}; + if (win32() && defined($keyval{'filew32'})) { + $file = $keyval{'filew32'}; + } + my $texdir = `kpsewhich -var-value=SELFAUTOPARENT`; + chomp($texdir); + my @syscmd; + if ($file =~ m/\.pl$/i) { + # we got a perl script, call it via perl + push @syscmd, "perl", "$texdir/$file"; + } elsif ($file =~ m/\.texlua$/i) { + # we got a texlua script, call it via texlua + push @syscmd, "texlua", "$texdir/$file"; + } else { + # we got anything else, call it directly and hope it is excutable + push @syscmd, "$texdir/$file"; + } + &log("postaction $how script for " . $tlpobj->name . ": @syscmd\n"); + push @syscmd, $how, $texdir; + my $ret = system (@syscmd); + if ($ret != 0) { + $ret /= 256 if $ret > 0; + my $pwd = cwd (); + warn "$0: calling post action script $file did not succeed in $pwd, status $ret"; + return 0; + } + return 1; +} + +sub _do_postaction_shortcut { + my ($how, $tlpobj, $do_menu, $do_desktop, $pa) = @_; + return 1 unless win32(); + my ($errors, %keyval) = + parse_into_keywords($pa, qw/type name icon cmd args hide/); + + if ($errors) { + tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); + return 0; + } + + # type can be either menu or desktop + if (!defined($keyval{'type'})) { + tlwarn("type of shortcut postaction not given\n"); + return 0; + } + my $type = $keyval{'type'}; + if (($type ne "menu") && ($type ne "desktop")) { + tlwarn("type of shortcut postaction $type is unknown (menu, desktop)\n"); + return 0; + } + + if (($type eq "menu") && !$do_menu) { + return 1; + } + if (($type eq "desktop") && !$do_desktop) { + return 1; + } + + # name can be an arbitrary string + if (!defined($keyval{'name'})) { + tlwarn("name of shortcut postaction not given\n"); + return 0; + } + my $name = $keyval{'name'}; + + # icon, cmd, args is optional + my $icon = (defined($keyval{'icon'}) ? $keyval{'icon'} : ''); + my $cmd = (defined($keyval{'cmd'}) ? $keyval{'cmd'} : ''); + my $args = (defined($keyval{'args'}) ? $keyval{'args'} : ''); + + # hide can be only 0 or 1, and defaults to 1 + my $hide = (defined($keyval{'hide'}) ? $keyval{'hide'} : 1); + if (($hide ne "0") && ($hide ne "1")) { + tlwarn("hide of shortcut postaction $hide is unknown (0, 1)\n"); + return 0; + } + + &log("postaction $how shortcut for " . $tlpobj->name . "\n"); + if ($how eq "install") { + my $texdir = `kpsewhich -var-value=SELFAUTOPARENT`; + chomp($texdir); + my $texdir_bsl = conv_to_w32_path($texdir); + $icon =~ s!^TEXDIR/!$texdir/!; + $cmd =~ s!^TEXDIR/!$texdir/!; + # $cmd can be an URL, in which case we do NOT want to convert it to + # w32 paths! + if ($cmd !~ m!^\s*(https?://|ftp://)!) { + if (!(-e $cmd) or !(-r $cmd)) { + tlwarn("Target of shortcut action does not exist: $cmd\n") + if $cmd =~ /\.(exe|bat|cmd)$/i; + # if not an executable, just omit shortcut silently: no error + return 1; + } + $cmd = conv_to_w32_path($cmd); + } + if ($type eq "menu" ) { + TeXLive::TLWinGoo::add_menu_shortcut( + $TeXLive::TLConfig::WindowsMainMenuName, + $name, $icon, $cmd, $args, $hide); + } elsif ($type eq "desktop") { + TeXLive::TLWinGoo::add_desktop_shortcut( + $name, $icon, $cmd, $args, $hide); + } else { + tlwarn("Unknown type of shortcut: $type\n"); + return 0; + } + } elsif ($how eq "remove") { + if ($type eq "menu") { + TeXLive::TLWinGoo::remove_menu_shortcut( + $TeXLive::TLConfig::WindowsMainMenuName, $name); + } elsif ($type eq "desktop") { + TeXLive::TLWinGoo::remove_desktop_shortcut($name); + } else { + tlwarn("Unknown type of shortcut: $type\n"); + return 0; + } + } else { + tlwarn("Unknown mode $how\n"); + return 0; + } + return 1; +} + +sub parse_into_keywords { + my ($str, @keys) = @_; + my @words = quotewords('\s+', 0, $str); + my %ret; + my $error = 0; + while (@words) { + $_ = shift @words; + if (/^([^=]+)=(.*)$/) { + $ret{$1} = $2; + } else { + tlwarn("parser found a invalid word in parsing keys: $_\n"); + $error++; + $ret{$_} = ""; + } + } + for my $k (keys %ret) { + if (!member($k, @keys)) { + $error++; + tlwarn("parser found invalid keyword: $k\n"); + } + } + return($error, %ret); +} + +=item C<announce_execute_actions($how, $tlpobj, $what)> + +Announces that the actions given in C<$tlpobj> should be executed +after all packages have been unpacked. C<$what> provides +additional information. + +=cut + +sub announce_execute_actions { + my ($type, $tlp, $what) = @_; + # do simply return immediately if execute actions are suppressed + return if $::no_execute_actions; + + if (defined($type) && ($type eq "regenerate-formats")) { + $::regenerate_all_formats = 1; + return; + } + if (defined($type) && ($type eq "files-changed")) { + $::files_changed = 1; + return; + } + if (defined($type) && ($type eq "rebuild-format")) { + # rebuild-format must feed in a hashref of a parse_AddFormat_line data + # the $tlp argument is not used + $::execute_actions{'enable'}{'formats'}{$what->{'name'}} = $what; + return; + } + if (!defined($type) || (($type ne "enable") && ($type ne "disable"))) { + die "announce_execute_actions: enable or disable, not type $type"; + } + my (@maps, @formats, @dats); + if ($tlp->runfiles || $tlp->srcfiles || $tlp->docfiles) { + $::files_changed = 1; + } + $what = "map format hyphen" if (!defined($what)); + foreach my $e ($tlp->executes) { + if ($e =~ m/^add((Mixed|Kanji)?Map)\s+([^\s]+)\s*$/) { + # save the refs as we have another =~ grep in the following lines + my $a = $1; + my $b = $3; + $::execute_actions{$type}{'maps'}{$b} = $a if ($what =~ m/map/); + } elsif ($e =~ m/^AddFormat\s+(.*)\s*$/) { + my %r = TeXLive::TLUtils::parse_AddFormat_line("$1"); + if (defined($r{"error"})) { + tlwarn ("$r{'error'} in parsing $e for return hash\n"); + } else { + $::execute_actions{$type}{'formats'}{$r{'name'}} = \%r + if ($what =~ m/format/); + } + } elsif ($e =~ m/^AddHyphen\s+(.*)\s*$/) { + my %r = TeXLive::TLUtils::parse_AddHyphen_line("$1"); + if (defined($r{"error"})) { + tlwarn ("$r{'error'} in parsing $e for return hash\n"); + } else { + $::execute_actions{$type}{'hyphens'}{$r{'name'}} = \%r + if ($what =~ m/hyphen/); + } + } else { + tlwarn("Unknown execute $e in ", $tlp->name, "\n"); + } + } +} + + +=pod + +=item C<add_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info)> + +=item C<remove_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info)> + +These two functions try to create/remove symlinks for binaries, man pages, +and info files as specified by the options $sys_bin, $sys_man, $sys_info. + +The functions return 1 on success and 0 on error. +On Windows it returns undefined. + +=cut + +sub add_link_dir_dir { + my ($from,$to) = @_; + my ($ret, $err) = mkdirhier ($to); + if (!$ret) { + tlwarn("$err\n"); + return 0; + } + if (-w $to) { + debug ("linking files from $from to $to\n"); + chomp (@files = `ls "$from"`); + my $ret = 1; + for my $f (@files) { + # don't make a system-dir link to our special "man" link. + if ($f eq "man") { + debug ("not linking `man' into $to.\n"); + next; + } + # + # attempt to remove an existing symlink, but nothing else. + unlink ("$to/$f") if -l "$to/$f"; + # + # if the destination still exists, skip it. + if (-e "$to/$f") { + tlwarn ("add_link_dir_dir: $to/$f exists; not making symlink.\n"); + next; + } + # + # try to make the link. + if (symlink ("$from/$f", "$to/$f") == 0) { + tlwarn ("add_link_dir_dir: symlink of $f from $from to $to failed: $!\n"); + $ret = 0; + } + } + return $ret; + } else { + tlwarn ("add_link_dir_dir: destination $to not writable, " + . "no links from $from.\n"); + return 0; + } +} + +sub remove_link_dir_dir { + my ($from, $to) = @_; + if ((-d "$to") && (-w "$to")) { + debug("removing links from $from to $to\n"); + chomp (@files = `ls "$from"`); + my $ret = 1; + foreach my $f (@files) { + next if (! -r "$to/$f"); + if ($f eq "man") { + debug("not considering man in $to, it should not be from us!\n"); + next; + } + if ((-l "$to/$f") && + (readlink("$to/$f") =~ m;^$from/;)) { + $ret = 0 unless unlink("$to/$f"); + } else { + $ret = 0; + tlwarn ("not removing $to/$f, not a link or wrong destination!\n"); + } + } + # try to remove the destination directory, it might be empty and + # we might have write permissions, ignore errors + # `rmdir "$to" 2>/dev/null`; + return $ret; + } else { + tlwarn ("destination $to not writable, no removal of links done!\n"); + return 0; + } +} + +sub add_remove_symlinks { + my ($mode, $Master, $arch, $sys_bin, $sys_man, $sys_info) = @_; + my $errors = 0; + my $plat_bindir = "$Master/bin/$arch"; + + # nothing to do with symlinks on Windows, of course. + return if win32(); + + my $info_dir = "$Master/texmf-dist/doc/info"; + if ($mode eq "add") { + $errors++ unless add_link_dir_dir($plat_bindir, $sys_bin); # bin + if (-d $info_dir) { + $errors++ unless add_link_dir_dir($info_dir, $sys_info); + } + } elsif ($mode eq "remove") { + $errors++ unless remove_link_dir_dir($plat_bindir, $sys_bin); # bin + if (-d $info_dir) { + $errors++ unless remove_link_dir_dir($info_dir, $sys_info); + } + } else { + die ("should not happen, unknown mode $mode in add_remove_symlinks!"); + } + + # man + my $top_man_dir = "$Master/texmf-dist/doc/man"; + debug("$mode symlinks for man pages to $sys_man from $top_man_dir\n"); + if (! -d $top_man_dir) { + ; # better to be silent? + #info("skipping add of man symlinks, no source directory $top_man_dir\n"); + } else { + my $man_doable = 1; + if ($mode eq "add") { + my ($ret, $err) = mkdirhier $sys_man; + if (!$ret) { + $man_doable = 0; + tlwarn("$err\n"); + $errors++; + } + } + if ($man_doable) { + if (-w $sys_man) { + my $foo = `(cd "$top_man_dir" && echo *)`; + my @mans = split (' ', $foo); + chomp (@mans); + foreach my $m (@mans) { + my $mandir = "$top_man_dir/$m"; + next unless -d $mandir; + if ($mode eq "add") { + $errors++ unless add_link_dir_dir($mandir, "$sys_man/$m"); + } else { + $errors++ unless remove_link_dir_dir($mandir, "$sys_man/$m"); + } + } + #`rmdir "$sys_man" 2>/dev/null` if ($mode eq "remove"); + } else { + tlwarn("man symlink destination ($sys_man) not writable, " + . "cannot $mode symlinks.\n"); + $errors++; + } + } + } + + # we collected errors in $errors, so return the negation of it + if ($errors) { + info("$mode of symlinks had $errors error(s), see messages above.\n"); + return $F_ERROR; + } else { + return $F_OK; + } +} + +sub add_symlinks { return (add_remove_symlinks("add", @_)); } +sub remove_symlinks { return (add_remove_symlinks("remove", @_)); } + +=pod + +=item C<w32_add_to_path($bindir, $multiuser)> +=item C<w32_remove_from_path($bindir, $multiuser)> + +These two functions try to add/remove the binary directory $bindir +on Windows to the registry PATH variable. + +If running as admin user and $multiuser is set, the system path will +be adjusted, otherwise the user path. + +After calling these functions TeXLive::TLWinGoo::broadcast_env() should +be called to make the changes immediately visible. + +=cut + +sub w32_add_to_path { + my ($bindir, $multiuser) = @_; + return if (!win32()); + + my $path = TeXLive::TLWinGoo::get_system_env() -> {'/Path'}; + $path =~ s/[\s\x00]+$//; + &log("Old system path: $path\n"); + $path = TeXLive::TLWinGoo::get_user_env() -> {'/Path'}; + if ($path) { + $path =~ s/[\s\x00]+$//; + &log("Old user path: $path\n"); + } else { + &log("Old user path: none\n"); + } + my $mode = 'user'; + if (TeXLive::TLWinGoo::admin() && $multiuser) { + $mode = 'system'; + } + debug("TLUtils:w32_add_to_path: calling adjust_reg_path_for_texlive add $bindir $mode\n"); + TeXLive::TLWinGoo::adjust_reg_path_for_texlive('add', $bindir, $mode); + $path = TeXLive::TLWinGoo::get_system_env() -> {'/Path'}; + $path =~ s/[\s\x00]+$//; + &log("New system path: $path\n"); + $path = TeXLive::TLWinGoo::get_user_env() -> {'/Path'}; + if ($path) { + $path =~ s/[\s\x00]+$//; + &log("New user path: $path\n"); + } else { + &log("New user path: none\n"); + } +} + +sub w32_remove_from_path { + my ($bindir, $multiuser) = @_; + my $mode = 'user'; + if (TeXLive::TLWinGoo::admin() && $multiuser) { + $mode = 'system'; + } + debug("w32_remove_from_path: trying to remove $bindir in $mode\n"); + TeXLive::TLWinGoo::adjust_reg_path_for_texlive('remove', $bindir, $mode); +} + +=pod + +=item C<check_file($what, $checksum, $checksize> + +Remove C<$what> if either the given C<$checksum> or C<$checksize> does +not agree. If a check argument is not given, that check is not performed. + +=cut + +sub check_file { + my ($xzfile, $checksum, $checksize) = @_; + debug("check_file $xzfile, $checksum, $checksize\n"); + if (!$checksum && !$checksize) { + tlwarn("TLUtils::check_file: neither checksum nor checksize " . + "available for $xzfile, cannot check integrity"); + return; + } + # only run checksum tests if we can actually compute the checksum + if ($checksum && ($checksum ne "-1") && $::checksum_method) { + my $tlchecksum = TeXLive::TLCrypto::tlchecksum($xzfile); + if ($tlchecksum ne $checksum) { + tlwarn("TLUtils::check_file: removing $xzfile, checksums differ:\n"); + tlwarn("TLUtils::check_file: TL=$tlchecksum, arg=$checksum\n"); + unlink($xzfile); + return; + } else { + debug("TLUtils::check_file: checksums for $xzfile agree\n"); + # if we have checked the checksum, we don't need to check the size, too + return; + } + } + if ($checksize && ($checksize ne "-1")) { + my $filesize = (stat $xzfile)[7]; + if ($filesize != $checksize) { + tlwarn("TLUtils::check_file: removing $xzfile, sizes differ:\n"); + tlwarn("TLUtils::check_file: TL=$filesize, arg=$checksize\n"); + unlink($xzfile); + return; + } + } + # We cannot remove the file here, otherwise restoring of backups + # or unwind packages might die. +} + +=pod + +=item C<unpack($what, $targetdir, @opts> + +If necessary, downloads C$what>, and then unpacks it into C<$targetdir>. +C<@opts> is assigned to a hash and can contain the following +options: C<tmpdir> (use this directory for downloaded files), +C<checksum> (check downloaded file against this checksum), +C<size> (check downloaded file against this size), +C<remove> (remove temporary files after operation). +Returns a pair of values: in case of error return 0 and an additional +explanation, in case of success return 1 and the name of the package. + +If C<checksum> or C<size> is C<-1>, no warnings about missing checksum/size +is printed. This is used during restore and unwinding of failed updates. + +=cut + +sub unpack { + my ($what, $target, %opts) = @_; + # remove by default + my $remove = (defined($opts{'remove'}) ? $opts{'remove'} : 1); + my $tempdir = (defined($opts{'tmpdir'}) ? $opts{'tmpdir'} : tl_tmpdir()); + my $checksum = (defined($opts{'checksum'}) ? $opts{'checksum'} : 0); + my $size = (defined($opts{'size'}) ? $opts{'size'} : 0); + + if (!defined($what)) { + return (0, "nothing to unpack"); + } + + my $decompressorType; + my $compressorextension; + if ($what =~ m/\.tar\.$CompressorExtRegexp$/) { + $compressorextension = $1; + $decompressorType = $1 eq "gz" ? "gzip" : $1; + } + if (!$decompressorType) { + return(0, "don't know how to unpack"); + } + # make sure that the found uncompressor type is also available + if (!member($decompressorType, @{$::progs{'working_compressors'}})) { + return(0, "unsupported container format $decompressorType"); + } + + # only check the necessary compressor program + my $decompressor = $::progs{$decompressorType}; + my @decompressorArgs = @{$Compressors{$decompressorType}{'decompress_args'}}; + + my $fn = basename($what); + my $pkg = $fn; + $pkg =~ s/\.tar\.$compressorextension$//; + my $remove_containerfile = $remove; + my $containerfile = "$tempdir/$fn"; + my $tarfile = "$tempdir/$fn"; + $tarfile =~ s/\.$compressorextension$//; + if ($what =~ m,^(https?|ftp)://, || $what =~ m!$SshURIRegex!) { + # we are installing from the NET + # check for the presence of $what in $tempdir + if (-r $containerfile) { + check_file($containerfile, $checksum, $size); + } + # if the file is now not present, we can use it + if (! -r $containerfile) { + # try download the file and put it into temp + if (!download_file($what, $containerfile)) { + return(0, "downloading did not succeed"); + } + # remove false downloads + check_file($containerfile, $checksum, $size); + if ( ! -r $containerfile ) { + return(0, "downloading did not succeed"); + } + } + } else { + # we are installing from local compressed files + # copy it to temp + TeXLive::TLUtils::copy($what, $tempdir); + + check_file($containerfile, $checksum, $size); + if (! -r $containerfile) { + return (0, "consistency checks failed"); + } + # we can remove it afterwards + $remove_containerfile = 1; + } + if (!system_pipe($decompressor, $containerfile, $tarfile, + $remove_containerfile, @decompressorArgs) + || + ! -f $tarfile) { + unlink($tarfile, $containerfile); + return(0, "Decompressing $containerfile failed"); + } + if (untar($tarfile, $target, 1)) { + return (1, "$pkg"); + } else { + return (0, "untar failed"); + } +} + +=pod + +=item C<untar($tarfile, $targetdir, $remove_tarfile)> + +Unpacks C<$tarfile> in C<$targetdir> (changing directories to +C<$targetdir> and then back to the original directory). If +C<$remove_tarfile> is true, unlink C<$tarfile> after unpacking. + +Assumes the global C<$::progs{"tar"}> has been set up. + +=cut + +# return 1 if success, 0 if failure. +sub untar { + my ($tarfile, $targetdir, $remove_tarfile) = @_; + my $ret; + + my $tar = $::progs{'tar'}; # assume it's been set up + + # don't use the -C option to tar since Solaris tar et al. don't support it. + # don't use system("cd ... && $tar ...") since that opens us up to + # quoting issues. + # so fall back on chdir in Perl. + # + debug("unpacking $tarfile in $targetdir\n"); + my $cwd = cwd(); + chdir($targetdir) || die "chdir($targetdir) failed: $!"; + + # on w32 don't extract file modified time, because AV soft can open + # files in the mean time causing time stamp modification to fail + my $taropt = win32() ? "xmf" : "xf"; + if (system($tar, $taropt, $tarfile) != 0) { + tlwarn("TLUtils::untar: $tar $taropt $tarfile failed (in $targetdir)\n"); + $ret = 0; + } else { + $ret = 1; + } + unlink($tarfile) if $remove_tarfile; + + chdir($cwd) || die "chdir($cwd) failed: $!"; + return $ret; +} + + +=item C<tlcmp($file, $file)> + +Compare two files considering CR, LF, and CRLF as equivalent. +Returns 1 if different, 0 if the same. + +=cut + +sub tlcmp { + my ($filea, $fileb) = @_; + if (!defined($fileb)) { + die <<END_USAGE; +tlcmp needs two arguments FILE1 FILE2. +Compare as text files, ignoring line endings. +Exit status is zero if the same, 1 if different, something else if trouble. +END_USAGE + } + my $file1 = &read_file_ignore_cr ($filea); + my $file2 = &read_file_ignore_cr ($fileb); + + return $file1 eq $file2 ? 0 : 1; +} + + +=item C<read_file_ignore_cr($file)> + +Return contents of FILE as a string, converting all of CR, LF, and +CRLF to just LF. + +=cut + +sub read_file_ignore_cr { + my ($fname) = @_; + my $ret = ""; + + local *FILE; + open (FILE, $fname) || die "open($fname) failed: $!"; + while (<FILE>) { + s/\r\n?/\n/g; + #warn "line is |$_|"; + $ret .= $_; + } + close (FILE) || warn "close($fname) failed: $!"; + + return $ret; +} + + +=item C<setup_programs($bindir, $platform, $tlfirst)> + +Populate the global C<$::progs> hash containing the paths to the +programs C<lz4>, C<tar>, C<wget>, C<xz>. The C<$bindir> argument specifies +the path to the location of the C<xz> binaries, the C<$platform> +gives the TeX Live platform name, used as the extension on our +executables. If a program is not present in the TeX Live tree, we also +check along PATH (without the platform extension.) + +If the C<$tlfirst> argument or the C<TEXLIVE_PREFER_OWN> envvar is set, +prefer TL versions; else prefer system versions (except for Windows +C<tar.exe>, where we always use ours). + +Check many different downloads and compressors to determine what is +working. + +Return 0 if failure, nonzero if success. + +=cut + +sub setup_programs { + my ($bindir, $platform, $tlfirst) = @_; + my $ok = 1; + + # tlfirst is (currently) not passed in by either the installer or + # tlmgr, so it will be always false. + # If it is not defined, we check for the env variable + # TEXLIVE_PREFER_OWN + # + if (!defined($tlfirst)) { + if ($ENV{'TEXLIVE_PREFER_OWN'}) { + debug("setup_programs: TEXLIVE_PREFER_OWN is set!\n"); + $tlfirst = 1; + } + } + + debug("setup_programs: preferring " . ($tlfirst ? "TL" : "system") . " versions\n"); + + my $isWin = ($^O =~ /^MSWin/i); + + if ($isWin) { + # we need to make sure that we use our own tar, since + # Windows system tar is stupid bsdtar ... + setup_one("w32", 'tar', "$bindir/tar.exe", "--version", 1); + $platform = "exe"; + } else { + # tar needs to be provided by the system, we not even check! + $::progs{'tar'} = "tar"; + + if (!defined($platform) || ($platform eq "")) { + # we assume that we run from uncompressed media, so we can call + # platform() and thus also the config.guess script but we have to + # setup $::installerdir because the platform script relies on it + $::installerdir = "$bindir/../.."; + $platform = platform(); + } + } + + # setup of the fallback downloaders + my @working_downloaders; + for my $dltype (@AcceptedFallbackDownloaders) { + my $defprog = $FallbackDownloaderProgram{$dltype}; + # do not warn on errors + push @working_downloaders, $dltype if + setup_one(($isWin ? "w32" : "unix"), $defprog, + "$bindir/$dltype/$defprog.$platform", "--version", $tlfirst); + } + $::progs{'working_downloaders'} = [ @working_downloaders ]; + my @working_compressors; + for my $defprog (sort + { $Compressors{$a}{'priority'} <=> $Compressors{$b}{'priority'} } + keys %Compressors) { + # do not warn on errors + if (setup_one(($isWin ? "w32" : "unix"), $defprog, + "$bindir/$defprog/$defprog.$platform", "--version", + $tlfirst)) { + push @working_compressors, $defprog; + # also set up $::{'compressor'} if not already done + # this selects the first one, but we might reset this depending on + # TEXLIVE_COMPRESSOR setting, see below + defined($::progs{'compressor'}) || ($::progs{'compressor'} = $defprog); + } + } + $::progs{'working_compressors'} = [ @working_compressors ]; + + # check whether selected downloader/compressor is working + # for downloader we allow 'lwp' as setting, too + if ($ENV{'TEXLIVE_DOWNLOADER'} + && $ENV{'TEXLIVE_DOWNLOADER'} ne 'lwp' + && !TeXLive::TLUtils::member($ENV{'TEXLIVE_DOWNLOADER'}, + @{$::progs{'working_downloaders'}})) { + tlwarn(<<END_DOWNLOADER_BAD); +Selected download program TEXLIVE_DOWNLOADER=$ENV{'TEXLIVE_DOWNLOADER'} +is not working! +Please choose a different downloader or don't set TEXLIVE_DOWNLOADER. +Detected working downloaders: @{$::progs{'working_downloaders'}}. +END_DOWNLOADER_BAD + $ok = 0; + } + if ($ENV{'TEXLIVE_COMPRESSOR'} + && !TeXLive::TLUtils::member($ENV{'TEXLIVE_COMPRESSOR'}, + @{$::progs{'working_compressors'}})) { + tlwarn(<<END_COMPRESSOR_BAD); +Selected compression program TEXLIVE_COMPRESSOR=$ENV{'TEXLIVE_COMPRESSOR'} +is not working! +Please choose a different compressor or don't set TEXLIVE_COMPRESSOR. +Detected working compressors: @{$::progs{'working_compressors'}}. +END_COMPRESSOR_BAD + $ok = 0; + } + # setup default compressor $::progs{'compressor'} which is used in + # tlmgr in the calls to make_container. By default we have already + # chosen the first that is actually working from our list of + # @AcceptableCompressors, but let the user override this. + if ($ENV{'TEXLIVE_COMPRESSOR'}) { + $::progs{'compressor'} = $ENV{'TEXLIVE_COMPRESSOR'}; + } + + if ($::opt_verbosity >= 1) { + require Data::Dumper; + use vars qw($Data::Dumper::Indent $Data::Dumper::Sortkeys + $Data::Dumper::Purity); # -w pain + $Data::Dumper::Indent = 1; + $Data::Dumper::Sortkeys = 1; # stable output + $Data::Dumper::Purity = 1; # recursive structures must be safe + print STDERR "DD:dumping "; + print STDERR Data::Dumper->Dump([\%::progs], [qw(::progs)]); + } + return $ok; +} + +sub setup_one { + my ($what, $p, $def, $arg, $tlfirst) = @_; + my $setupfunc = ($what eq "unix") ? \&setup_unix_tl_one : \&setup_windows_tl_one ; + if ($tlfirst) { + if (&$setupfunc($p, $def, $arg)) { + return(1); + } else { + return(setup_system_one($p, $arg)); + } + } else { + if (setup_system_one($p, $arg)) { + return(1); + } else { + return(&$setupfunc($p, $def, $arg)); + } + } +} + +sub setup_system_one { + my ($p, $arg) = @_; + my $nulldev = nulldev(); + debug("trying to set up system $p, arg $arg\n"); + my $ret = system("$p $arg >$nulldev 2>&1"); + if ($ret == 0) { + debug("program $p found in the path\n"); + $::progs{$p} = $p; + return(1); + } else { + debug("program $p not usable from path\n"); + return(0); + } +} + +sub setup_windows_tl_one { + my ($p, $def, $arg) = @_; + debug("(w32) trying to set up $p, default $def, arg $arg\n"); + + if (-r $def) { + my $prog = conv_to_w32_path($def); + my $ret = system("$prog $arg >nul 2>&1"); # on windows + if ($ret == 0) { + debug("Using shipped $def for $p (tested).\n"); + $::progs{$p} = $prog; + return(1); + } else { + tlwarn("Setting up $p with $def as $prog didn't work\n"); + system("$prog $arg"); + return(0); + } + } else { + debug("Default program $def not readable?\n"); + return(0); + } +} + + +# setup one prog on unix using the following logic: +# - if the shipped one is -x and can be executed, use it +# - if the shipped one is -x but cannot be executed, copy it. set -x +# . if the copy is -x and executable, use it +# - if the shipped one is not -x, copy it, set -x +# . if the copy is -x and executable, use it +sub setup_unix_tl_one { + my ($p, $def, $arg) = @_; + our $tmp; + debug("(unix) trying to set up $p, default $def, arg $arg\n"); + if (-r $def) { + if (-x $def) { + ddebug("default $def has executable permissions\n"); + # we have to check for actual "executability" since a "noexec" + # mount option may interfere, which is not taken into account by -x. + my $ret = system("'$def' $arg >/dev/null 2>&1" ); # we are on Unix + if ($ret == 0) { + $::progs{$p} = $def; + debug("Using shipped $def for $p (tested).\n"); + return(1); + } else { + ddebug("Shipped $def has -x but cannot be executed, " + . "trying tmp copy.\n"); + } + } + # we are still here + # out of some reasons we couldn't execute the shipped program + # try to copy it to a temp directory and make it executable + # + # create tmp dir only when necessary + $tmp = TeXLive::TLUtils::tl_tmpdir() unless defined($tmp); + # probably we are running from uncompressed media and want to copy it to + # some temporary location + copy($def, $tmp); + my $bn = basename($def); + my $tmpprog = "$tmp/$bn"; + chmod(0755,$tmpprog); + # we do not check the return value of chmod, but check whether + # the -x bit is now set, the only thing that counts + if (! -x $tmpprog) { + # hmm, something is going really bad, not even the copy is + # executable. Fall back to normal path element + ddebug("Copied $p $tmpprog does not have -x bit, strange!\n"); + return(0); + } else { + # check again for executability + my $ret = system("$tmpprog $arg > /dev/null 2>&1"); + if ($ret == 0) { + # ok, the copy works + debug("Using copied $tmpprog for $p (tested).\n"); + $::progs{$p} = $tmpprog; + return(1); + } else { + # even the copied prog is not executable, strange + ddebug("Copied $p $tmpprog has x bit but not executable?!\n"); + return(0); + } + } + } else { + # default program is not readable + return(0); + } +} + + +=item C<download_file( $relpath, $destination )> + +Try to download the file given in C<$relpath> from C<$TeXLiveURL> +into C<$destination>, which can be either +a filename of simply C<|>. In the latter case a file handle is returned. + +Downloading first checks for the environment variable C<TEXLIVE_DOWNLOADER>, +which takes various built-in values. If not set, the next check is for +C<TL_DOWNLOAD_PROGRAM> and C<TL_DOWNLOAD_ARGS>. The former overrides the +above specification devolving to C<wget>, and the latter overrides the +default wget arguments. + +C<TL_DOWNLOAD_ARGS> must be defined so that the file the output goes to +is the first argument after the C<TL_DOWNLOAD_ARGS>. Thus, for wget it +would end in C<-O>. Use with care. + +=cut + +sub download_file { + my ($relpath, $dest) = @_; + # create output dir if necessary + my $par; + if ($dest ne "|") { + $par = dirname($dest); + mkdirhier ($par) unless -d "$par"; + } + my $url; + if ($relpath =~ m;^file://*(.*)$;) { + my $filetoopen = "/$1"; + # $dest is a file name, we have to get the respective dirname + if ($dest eq "|") { + open(RETFH, "<$filetoopen") or + die("Cannot open $filetoopen for reading"); + # opening to a pipe always succeeds, so we return immediately + return \*RETFH; + } else { + if (-r $filetoopen) { + copy ($filetoopen, $par); + return 1; + } + return 0; + } + } + + if ($relpath =~ m!$SshURIRegex!) { + my $downdest; + if ($dest eq "|") { + my ($fh, $fn) = TeXLive::TLUtils::tl_tmpfile(); + $downdest = $fn; + } else { + $downdest = $dest; + } + # massage ssh:// into the scp-acceptable scp:// + $relpath =~ s!^ssh://!scp://!; + my $retval = system("scp", "-q", $relpath, $downdest); + if ($retval != 0) { + $retval /= 256 if $retval > 0; + my $pwd = cwd (); + tlwarn("$0: system(scp -q $relpath $downdest) failed in $pwd, status $retval"); + return 0; + } + if ($dest eq "|") { + open(RETFH, "<$downdest") or + die("Cannot open $downdest for reading"); + # opening to a pipe always succeeds, so we return immediately + return \*RETFH; + } else { + return 1; + } + } + + if ($relpath =~ /^(https?|ftp):\/\//) { + $url = $relpath; + } else { + $url = "$TeXLiveURL/$relpath"; + } + + my @downloader_trials; + if ($ENV{'TEXLIVE_DOWNLOADER'}) { + push @downloader_trials, $ENV{'TEXLIVE_DOWNLOADER'}; + } elsif ($ENV{"TL_DOWNLOAD_PROGRAM"}) { + push @downloader_trials, 'custom'; + } else { + @downloader_trials = qw/lwp curl wget/; + } + + my $success = 0; + for my $downtype (@downloader_trials) { + if ($downtype eq 'lwp') { + if (_download_file_lwp($url, $dest)) { + $success = $downtype; + last; + } + } + if ($downtype eq "custom" || TeXLive::TLUtils::member($downtype, @{$::progs{'working_downloaders'}})) { + if (_download_file_program($url, $dest, $downtype)) { + $success = $downtype; + last; + } + } + } + if ($success) { + debug("TLUtils::download_file: downloading using $success succeeded\n"); + return(1); + } else { + debug("TLUtils::download_file: tried to download using @downloader_trials, none succeeded\n"); + return(0); + } +} + +sub _download_file_lwp { + my ($url, $dest) = @_; + if (defined($::tldownload_server) && $::tldownload_server->enabled) { + debug("persistent connection set up, trying to get $url (for $dest)\n"); + my $ret = $::tldownload_server->get_file($url, $dest); + if ($ret) { + ddebug("downloading file via persistent connection succeeded\n"); + return $ret; + } else { + debug("TLUtils::download_file: persistent connection ok," + . " but download failed: $url\n"); + debug("TLUtils::download_file: retrying with wget.\n"); + } + } else { + if (!defined($::tldownload_server)) { + ddebug("::tldownload_server not defined\n"); + } else { + ddebug("::tldownload_server->enabled is not set\n"); + } + debug("persistent connection not set up\n"); + } + # if we are still here, download with LWP didn't succeed. + return(0); +} + +sub _download_file_program { + my ($url, $dest, $type) = @_; + if (win32()) { + $dest =~ s!/!\\!g; + } + + debug("TLUtils::_download_file_program: $type $url $dest\n"); + my $downloader; + my $downloaderargs; + my @downloaderargs; + if ($type eq 'custom') { + $downloader = $ENV{"TL_DOWNLOAD_PROGRAM"}; + if ($ENV{"TL_DOWNLOAD_ARGS"}) { + $downloaderargs = $ENV{"TL_DOWNLOAD_ARGS"}; + @downloaderargs = split(' ', $downloaderargs); + } + } else { + $downloader = $::progs{$FallbackDownloaderProgram{$type}}; + @downloaderargs = @{$FallbackDownloaderArgs{$type}}; + $downloaderargs = join(' ',@downloaderargs); + } + + debug("downloading $url using $downloader $downloaderargs\n"); + my $ret; + if ($dest eq "|") { + open(RETFH, "$downloader $downloaderargs - $url|") + || die "open($url) via $downloader $downloaderargs failed: $!"; + # opening to a pipe always succeeds, so we return immediately + return \*RETFH; + } else { + $ret = system ($downloader, @downloaderargs, $dest, $url); + # we have to reverse the meaning of ret because system has 0=success. + $ret = ($ret ? 0 : 1); + } + # return false/undef in case the download did not succeed. + return ($ret) unless $ret; + debug("download of $url succeeded\n"); + if ($dest eq "|") { + return \*RETFH; + } else { + return 1; + } +} + +=item C<nulldev ()> + +Return C</dev/null> on Unix and C<nul> on Windows. + +=cut + +sub nulldev { + return (&win32)? 'nul' : '/dev/null'; +} + +=item C<get_full_line ($fh)> + +returns the next line from the file handle $fh, taking +continuation lines into account (last character of a line is \, and +no quoting is parsed). + +=cut + +# open my $f, '<', $file_name or die; +# while (my $l = get_full_line($f)) { ... } +# close $f or die; +sub get_full_line { + my ($fh) = @_; + my $line = <$fh>; + return undef unless defined $line; + return $line unless $line =~ s/\\\r?\n$//; + my $cont = get_full_line($fh); + if (!defined($cont)) { + tlwarn('Continuation disallowed at end of file'); + $cont = ""; + } + $cont =~ s/^\s*//; + return $line . $cont; +} + + +=back + +=head2 Installer Functions + +=over 4 + +=item C<make_var_skeleton($prefix)> + +Generate a skeleton of empty directories in the C<TEXMFSYSVAR> tree. + +=cut + +sub make_var_skeleton { + my ($prefix) = @_; + + mkdirhier "$prefix/tex/generic/config"; + mkdirhier "$prefix/fonts/map/dvipdfmx/updmap"; + mkdirhier "$prefix/fonts/map/dvips/updmap"; + mkdirhier "$prefix/fonts/map/pdftex/updmap"; + mkdirhier "$prefix/fonts/pk"; + mkdirhier "$prefix/fonts/tfm"; + mkdirhier "$prefix/web2c"; + mkdirhier "$prefix/xdvi"; + mkdirhier "$prefix/tex/context/config"; +} + + +=item C<make_local_skeleton($prefix)> + +Generate a skeleton of empty directories in the C<TEXMFLOCAL> tree, +unless C<TEXMFLOCAL> already exists. + +=cut + +sub make_local_skeleton { + my ($prefix) = @_; + + return if (-d $prefix); + + mkdirhier "$prefix/bibtex/bib/local"; + mkdirhier "$prefix/bibtex/bst/local"; + mkdirhier "$prefix/doc/local"; + mkdirhier "$prefix/dvips/local"; + mkdirhier "$prefix/fonts/source/local"; + mkdirhier "$prefix/fonts/tfm/local"; + mkdirhier "$prefix/fonts/type1/local"; + mkdirhier "$prefix/fonts/vf/local"; + mkdirhier "$prefix/metapost/local"; + mkdirhier "$prefix/tex/latex/local"; + mkdirhier "$prefix/tex/plain/local"; + mkdirhier "$prefix/tlpkg"; + mkdirhier "$prefix/web2c"; +} + + +=item C<create_fmtutil($tlpdb, $dest)> + +=item C<create_updmap($tlpdb, $dest)> + +=item C<create_language_dat($tlpdb, $dest, $localconf)> + +=item C<create_language_def($tlpdb, $dest, $localconf)> + +=item C<create_language_lua($tlpdb, $dest, $localconf)> + +These five functions create C<fmtutil.cnf>, C<updmap.cfg>, C<language.dat>, +C<language.def>, and C<language.dat.lua> respectively, in C<$dest> (which by +default is below C<$TEXMFSYSVAR>). These functions merge the information +present in the TLPDB C<$tlpdb> (formats, maps, hyphenations) with local +configuration additions: C<$localconf>. + +Currently the merging is done by omitting disabled entries specified +in the local file, and then appending the content of the local +configuration files at the end of the file. We should also check for +duplicates, maybe even error checking. + +=cut + +# +# get_disabled_local_configs +# returns the list of disabled formats/hyphenpatterns/maps +# disabling is done by putting +# #!NAME +# or +# %!NAME +# into the respective foo-local.cnf/cfg file +# +sub get_disabled_local_configs { + my $localconf = shift; + my $cc = shift; + my @disabled = (); + if ($localconf && -r $localconf) { + open (FOO, "<$localconf") + || die "strange, -r ok but open($localconf) failed: $!"; + my @tmp = <FOO>; + close(FOO) || warn("close($localconf) failed: $!"); + @disabled = map { if (m/^$cc!(\S+)\s*$/) { $1 } else { } } @tmp; + } + return @disabled; +} + +sub create_fmtutil { + my ($tlpdb,$dest) = @_; + my @lines = $tlpdb->fmtutil_cnf_lines(); + _create_config_files($tlpdb, "texmf-dist/web2c/fmtutil-hdr.cnf", $dest, + undef, 0, '#', \@lines); +} + +sub create_updmap { + my ($tlpdb,$dest) = @_; + check_for_old_updmap_cfg(); + my @tlpdblines = $tlpdb->updmap_cfg_lines(); + _create_config_files($tlpdb, "texmf-dist/web2c/updmap-hdr.cfg", $dest, + undef, 0, '#', \@tlpdblines); +} + +sub check_for_old_updmap_cfg { + chomp( my $tmfsysconf = `kpsewhich -var-value=TEXMFSYSCONFIG` ) ; + my $oldupd = "$tmfsysconf/web2c/updmap.cfg"; + return unless -r $oldupd; # if no such file, good. + + open (OLDUPD, "<$oldupd") || die "open($oldupd) failed: $!"; + my $firstline = <OLDUPD>; + close(OLDUPD); + # cygwin returns undef when reading from an empty file, we have + # to make sure that this is anyway initialized + $firstline = "" if (!defined($firstline)); + chomp ($firstline); + # + if ($firstline =~ m/^# Generated by (install-tl|.*\/tlmgr) on/) { + # assume it was our doing, rename it. + my $nn = "$oldupd.DISABLED"; + if (-r $nn) { + my $fh; + ($fh, $nn) = tl_tmpfile( + "updmap.cfg.DISABLED.XXXXXX", DIR => "$tmfsysconf/web2c"); + } + print "Renaming old config file from + $oldupd +to + $nn +"; + if (rename($oldupd, $nn)) { + if (system("mktexlsr", $tmfsysconf) != 0) { + die "mktexlsr $tmfsysconf failed after updmap.cfg rename, fix fix: $!"; + } + print "No further action should be necessary.\n"; + } else { + print STDERR " +Renaming of + $oldupd +did not succeed. This config file should not be used anymore, +so please do what's necessary to eliminate it. +See the documentation for updmap. +"; + } + + } else { # first line did not match + # that is NOT a good idea, because updmap creates updmap.cfg in + # TEXMFSYSCONFIG when called with --enable Map etc, so we should + # NOT warn here + # print STDERR "Apparently +# $oldupd +# was created by hand. This config file should not be used anymore, +# so please do what's necessary to eliminate it. +# See the documentation for updmap. +# "; + } +} + +sub check_updmap_config_value { + my ($k, $v, $f) = @_; + return 0 if !defined($k); + return 0 if !defined($v); + if (member( $k, qw/dvipsPreferOutline dvipsDownloadBase35 + pdftexDownloadBase14 dvipdfmDownloadBase14/)) { + if ($v eq "true" || $v eq "false") { + return 1; + } else { + tlwarn("Unknown setting for $k in $f: $v\n"); + return 0; + } + } elsif ($k eq "LW35") { + if (member($v, qw/URW URWkb ADOBE ADOBEkb/)) { + return 1; + } else { + tlwarn("Unknown setting for LW35 in $f: $v\n"); + return 0; + } + } elsif ($k eq "kanjiEmbed") { + # any string is fine + return 1; + } else { + return 0; + } +} + +sub create_language_dat { + my ($tlpdb,$dest,$localconf) = @_; + # no checking for disabled stuff for language.dat and .def + my @lines = $tlpdb->language_dat_lines( + get_disabled_local_configs($localconf, '%')); + _create_config_files($tlpdb, "texmf-dist/tex/generic/config/language.us", + $dest, $localconf, 0, '%', \@lines); +} + +sub create_language_def { + my ($tlpdb,$dest,$localconf) = @_; + # no checking for disabled stuff for language.dat and .def + my @lines = $tlpdb->language_def_lines( + get_disabled_local_configs($localconf, '%')); + my @postlines; + push @postlines, "%%% No changes may be made beyond this point.\n"; + push @postlines, "\n"; + push @postlines, "\\uselanguage {USenglish} %%% This MUST be the last line of the file.\n"; + _create_config_files ($tlpdb,"texmf-dist/tex/generic/config/language.us.def", + $dest, $localconf, 1, '%', \@lines, @postlines); +} + +sub create_language_lua { + my ($tlpdb,$dest,$localconf) = @_; + # no checking for disabled stuff for language.dat and .lua + my @lines = $tlpdb->language_lua_lines( + get_disabled_local_configs($localconf, '--')); + my @postlines = ("}\n"); + _create_config_files ($tlpdb,"texmf-dist/tex/generic/config/language.us.lua", + $dest, $localconf, 0, '--', \@lines, @postlines); +} + +sub _create_config_files { + my ($tlpdb, $headfile, $dest,$localconf, $keepfirstline, $cc, + $tlpdblinesref, @postlines) = @_; + my $root = $tlpdb->root; + my @lines = (); + my $usermode = $tlpdb->setting( "usertree" ); + if (-r "$root/$headfile") { + open (INFILE, "<$root/$headfile") + || die "open($root/$headfile) failed, but -r ok: $!"; + @lines = <INFILE>; + close (INFILE); + } elsif (!$usermode) { + # we might be in user mode and then do *not* want the generation + # of the configuration file to just bail out. + tldie ("TLUtils::_create_config_files: giving up, unreadable: " + . "$root/$headfile\n") + } + push @lines, @$tlpdblinesref; + if (defined($localconf) && -r $localconf) { + # + # this should be done more intelligently, but for now only add those + # lines without any duplication check ... + open (FOO, "<$localconf") + || die "strange, -r ok but cannot open $localconf: $!"; + my @tmp = <FOO>; + close (FOO); + push @lines, @tmp; + } + if (@postlines) { + push @lines, @postlines; + } + if ($usermode && -e $dest) { + tlwarn("Updating $dest, backup copy in $dest.backup\n"); + File::Copy::copy($dest, "$dest.backup"); + } + open(OUTFILE,">$dest") + or die("Cannot open $dest for writing: $!"); + + if (!$keepfirstline) { + print OUTFILE $cc; + printf OUTFILE " Generated by %s on %s\n", "$0", scalar localtime; + } + print OUTFILE @lines; + close(OUTFILE) || warn "close(>$dest) failed: $!"; +} + +sub parse_AddHyphen_line { + my $line = shift; + my %ret; + # default values + my $default_lefthyphenmin = 2; + my $default_righthyphenmin = 3; + $ret{"lefthyphenmin"} = $default_lefthyphenmin; + $ret{"righthyphenmin"} = $default_righthyphenmin; + $ret{"synonyms"} = []; + for my $p (quotewords('\s+', 0, "$line")) { + my ($a, $b) = split /=/, $p; + if ($a eq "name") { + if (!$b) { + $ret{"error"} = "AddHyphen line needs name=something"; + return %ret; + } + $ret{"name"} = $b; + next; + } + if ($a eq "lefthyphenmin") { + $ret{"lefthyphenmin"} = ( $b ? $b : $default_lefthyphenmin ); + next; + } + if ($a eq "righthyphenmin") { + $ret{"righthyphenmin"} = ( $b ? $b : $default_righthyphenmin ); + next; + } + if ($a eq "file") { + if (!$b) { + $ret{"error"} = "AddHyphen line needs file=something"; + return %ret; + } + $ret{"file"} = $b; + next; + } + if ($a eq "file_patterns") { + $ret{"file_patterns"} = $b; + next; + } + if ($a eq "file_exceptions") { + $ret{"file_exceptions"} = $b; + next; + } + if ($a eq "luaspecial") { + $ret{"luaspecial"} = $b; + next; + } + if ($a eq "databases") { + @{$ret{"databases"}} = split /,/, $b; + next; + } + if ($a eq "synonyms") { + @{$ret{"synonyms"}} = split /,/, $b; + next; + } + if ($a eq "comment") { + $ret{"comment"} = $b; + next; + } + # should not be reached at all + $ret{"error"} = "Unknown language directive $a"; + return %ret; + } + # this default value couldn't be set earlier + if (not defined($ret{"databases"})) { + if (defined $ret{"file_patterns"} or defined $ret{"file_exceptions"} + or defined $ret{"luaspecial"}) { + @{$ret{"databases"}} = qw(dat def lua); + } else { + @{$ret{"databases"}} = qw(dat def); + } + } + return %ret; +} + +# +# return hash of items on AddFormat line LINE (which must not have the +# leading "execute AddFormat"). If parse fails, hash will contain a key +# "error" with a message. +# +sub parse_AddFormat_line { + my $line = shift; + my %ret; + $ret{"options"} = ""; + $ret{"patterns"} = "-"; + $ret{"mode"} = 1; + for my $p (quotewords('\s+', 0, "$line")) { + my ($a, $b); + if ($p =~ m/^(name|engine|mode|patterns|options|fmttriggers)=(.*)$/) { + $a = $1; + $b = $2; + } else { + $ret{"error"} = "Unknown format directive $p"; + return %ret; + } + if ($a eq "name") { + if (!$b) { + $ret{"error"} = "AddFormat line needs name=something"; + return %ret; + } + $ret{"name"} = $b; + next; + } + if ($a eq "engine") { + if (!$b) { + $ret{"error"} = "AddFormat line needs engine=something"; + return %ret; + } + $ret{"engine"} = $b; + next; + } + if ($a eq "patterns") { + $ret{"patterns"} = ( $b ? $b : "-" ); + next; + } + if ($a eq "mode") { + $ret{"mode"} = ( $b eq "disabled" ? 0 : 1 ); + next; + } + if ($a eq "options") { + $ret{"options"} = ( $b ? $b : "" ); + next; + } + if ($a eq "fmttriggers") { + my @tl = split(',',$b); + $ret{"fmttriggers"} = \@tl ; + next; + } + # should not be reached at all + $ret{"error"} = "Unknown format directive $p"; + return %ret; + } + return %ret; +} + + +=back + +=head2 Miscellaneous + +Ideas from Fabrice Popineau's C<FileUtils.pm>. + +=over 4 + +=item C<sort_uniq(@list)> + +The C<sort_uniq> function sorts the given array and throws away multiple +occurrences of elements. It returns a sorted and unified array. + +=cut + +sub sort_uniq { + my (@l) = @_; + my ($e, $f, @r); + $f = ""; + @l = sort(@l); + foreach $e (@l) { + if ($e ne $f) { + $f = $e; + push @r, $e; + } + } + return @r; +} + + +=item C<push_uniq(\@list, @new_items)> + +The C<push_uniq> function pushes the last argument @ITEMS to the $LIST +referenced by the first argument, if they are not already in the list. + +=cut + +sub push_uniq { + my ($l, @new_items) = @_; + for my $e (@new_items) { + if (! &member($e, @$l)) { + push (@$l, $e); + } + } +} + +=item C<member($item, @list)> + +The C<member> function returns true if the first argument +is also inclued in the list of the remaining arguments. + +=cut + +sub member { + my $what = shift; + return scalar grep($_ eq $what, @_); +} + + +=item C<merge_into(\%to, \%from)> + +Merges the keys of %from into %to. + +=cut + +sub merge_into { + my ($to, $from) = @_; + foreach my $k (keys %$from) { + if (defined($to->{$k})) { + push @{$to->{$k}}, @{$from->{$k}}; + } else { + $to->{$k} = [ @{$from->{$k}} ]; + } + } +} + + +=item C<texdir_check($texdir)> + +Test whether installation with TEXDIR set to $texdir would succeed due to +writing permissions. + +Writable or not, we will not allow installation to the root +directory (Unix) or the root of a drive (Windows). + +=cut + +sub texdir_check { + my $texdir = shift; + return 0 unless defined $texdir; + # convert to absolute, for safer parsing. + # The return value may still contain symlinks, + # but no unnecessary terminating '/'. + $texdir = tl_abs_path($texdir); + return 0 unless defined $texdir; + # also reject the root of a drive, + # assuming that only the canonical form of the root ends with / + return 0 if $texdir =~ m!/$!; + # win32: for now, reject the root of a samba share + return 0 if win32() && $texdir =~ m!^//[^/]+/[^/]+$!; + my $texdirparent; + my $texdirpparent; + + return dir_writable($texdir) if (-d $texdir); + ($texdirparent = $texdir) =~ s!/[^/]*$!!; + #print STDERR "Checking $texdirparent".'[/]'."\n"; + return dir_creatable($texdirparent) if -d dir_slash($texdirparent); + # try another level up the tree + ($texdirpparent = $texdirparent) =~ s!/[^/]*$!!; + #print STDERR "Checking $texdirpparent".'[/]'."\n"; + return dir_creatable($texdirpparent) if -d dir_slash($texdirpparent); + return 0; +} + + +# no newlines or spaces are added, multiple args are just concatenated. +# +sub logit { + my ($out, $level, @rest) = @_; + _logit($out, $level, @rest) unless $::opt_quiet; + _logit('file', $level, @rest); +} + +sub _logit { + my ($out, $level, @rest) = @_; + if ($::opt_verbosity >= $level) { + # if $out is a ref/glob to STDOUT or STDERR, print it there + if (ref($out) eq "GLOB") { + print $out @rest; + } else { + # we should log it into the logfile, but that might be not initialized + # so either print it to the filehandle $::LOGFILE, or push it onto + # the to be printed log lines @::LOGLINES + if (defined($::LOGFILE)) { + print $::LOGFILE @rest; + } else { + push (@::LOGLINES, join ("", @rest)); + } + } + } +} + + +=item C<info ($str1, $str2, ...)> + +Write a normal informational message, the concatenation of the argument +strings. The message will be written unless C<-q> was specified. If +the global C<$::machinereadable> is set (the C<--machine-readable> +option to C<tlmgr>), then output is written to stderr, else to stdout. +If the log file (see L<process_logging_options>) is defined, it also +writes there. + +It is best to use this sparingly, mainly to give feedback during lengthy +operations and for final results. + +=cut + +sub info { + my $str = join("", @_); + my $fh = ($::machinereadable ? \*STDERR : \*STDOUT); + logit($fh, 0, $str); + for my $i (@::info_hook) { + &{$i}($str); + } +} + + +=item C<debug ($str1, $str2, ...)> + +Write a debugging message, the concatenation of the argument strings. +The message will be omitted unless C<-v> was specified. If the log +file (see L<process_logging_options>) is defined, it also writes there. + +This first level debugging message reports on the overall flow of +work, but does not include repeated messages about processing of each +package. + +=cut + +sub debug { + my $str = "D:" . join("", @_); + return if ($::opt_verbosity < 1); + logit(\*STDERR, 1, $str); + for my $i (@::debug_hook) { + &{$i}($str); + } +} + + +=item C<ddebug ($str1, $str2, ...)> + +Write a deep debugging message, the concatenation of the argument +strings. The message will be omitted unless C<-v -v> (or higher) was +specified. If the log file (see L<process_logging_options>) is defined, +it also writes there. + +This second level debugging message reports messages about processing +each package, in addition to the first level. + +=cut + +sub ddebug { + my $str = "DD:" . join("", @_); + return if ($::opt_verbosity < 2); + logit(\*STDERR, 2, $str); + for my $i (@::ddebug_hook) { + &{$i}($str); + } +} + +=item C<dddebug ($str1, $str2, ...)> + +Write the deepest debugging message, the concatenation of the argument +strings. The message will be omitted unless C<-v -v -v> was specified. +If the log file (see L<process_logging_options>) is defined, it also +writes there. + +This third level debugging message reports messages about processing +each line of any tlpdb files read, in addition to the first and second +levels. + +=cut + +sub dddebug { + my $str = "DDD:" . join("", @_); + return if ($::opt_verbosity < 3); + logit(\*STDERR, 3, $str); + for my $i (@::dddebug_hook) { + &{$i}($str); + } +} + +=item C<log ($str1, $str2, ...)> + +Write a message to the log file (and nowhere else), the concatenation of +the argument strings. The log file may not ever be defined (e.g., the +C<-logfile> option isn't given), in which case the message will never be +written anywhere. + +=cut + +sub log { + my $savequiet = $::opt_quiet; + $::opt_quiet = 0; + _logit('file', -100, @_); + $::opt_quiet = $savequiet; +} + +=item C<tlwarn ($str1, $str2, ...)> + +Write a warning message, the concatenation of the argument strings. +This always and unconditionally writes the message to standard error; if +the log file (see L<process_logging_options>) is defined, it also writes +there. + +=cut + +sub tlwarn { + my $savequiet = $::opt_quiet; + my $str = join("", @_); + $::opt_quiet = 0; + logit (\*STDERR, -100, $str); + $::opt_quiet = $savequiet; + for my $i (@::warn_hook) { + &{$i}($str); + } +} + +=item C<tldie ($str1, $str2, ...)> + +Uses C<tlwarn> to issue a warning for @_ preceded by a newline, then +exits with exit code 1. + +=cut + +sub tldie { + tlwarn("\n", @_); + if ($::gui_mode) { + Tk::exit(1); + } else { + exit(1); + } +} + +=item C<debug_hash ($label, hash))> + +Write LABEL followed by HASH elements, all on one line, to stderr. +If HASH is a reference, it is followed. + +=cut + +sub debug_hash { + my ($label) = shift; + my (%hash) = (ref $_[0] && $_[0] =~ /.*HASH.*/) ? %{$_[0]} : @_; + + my $str = "$label: {"; + my @items = (); + for my $key (sort keys %hash) { + my $val = $hash{$key}; + $key =~ s/\n/\\n/g; + $val =~ s/\n/\\n/g; + push (@items, "$key:$val"); + } + $str .= join (",", @items); + $str .= "}"; + + warn "$str\n"; +} + + +=item C<process_logging_options ($texdir)> + +This function handles the common logging options for TeX Live scripts. +It should be called before C<GetOptions> for any program-specific option +handling. For our conventional calling sequence, see (for example) the +L<tlpfiles> script. + +These are the options handled here: + +=over 4 + +=item B<-q> + +Omit normal informational messages. + +=item B<-v> + +Include debugging messages. With one C<-v>, reports overall flow; with +C<-v -v> (or C<-vv>), also reports per-package processing; with C<-v -v +-v> (or C<-vvv>), also reports each line read from any tlpdb files. +Further repeats of C<-v>, as in C<-v -v -v -v>, are accepted but +ignored. C<-vvvv> is an error. + +The idea behind these levels is to be able to specify C<-v> to get an +overall idea of what is going on, but avoid terribly voluminous output +when processing many packages, as we often are. When debugging a +specific problem with a specific package, C<-vv> can help. When +debugging problems with parsing tlpdb files, C<-vvv> gives that too. + +=item B<-logfile> I<file> + +Write all messages (informational, debugging, warnings) to I<file>, in +addition to standard output or standard error. In TeX Live, only the +installer sets a log file by default; none of the other standard TeX +Live scripts use this feature, but you can specify it explicitly. + +=back + +See also the L<info>, L<debug>, L<ddebug>, and L<tlwarn> functions, +which actually write the messages. + +=cut + +sub process_logging_options { + $::opt_verbosity = 0; + $::opt_quiet = 0; + my $opt_logfile; + my $opt_Verbosity = 0; + my $opt_VERBOSITY = 0; + # check all the command line options for occurrences of -q and -v; + # do not report errors. + my $oldconfig = Getopt::Long::Configure(qw(pass_through permute)); + GetOptions("logfile=s" => \$opt_logfile, + "v+" => \$::opt_verbosity, + "vv" => \$opt_Verbosity, + "vvv" => \$opt_VERBOSITY, + "q" => \$::opt_quiet); + Getopt::Long::Configure($oldconfig); + + # verbosity level, forcing -v -v instead of -vv is too annoying. + $::opt_verbosity = 2 if $opt_Verbosity; + $::opt_verbosity = 3 if $opt_VERBOSITY; + + # open log file if one was requested. + if ($opt_logfile) { + open(TLUTILS_LOGFILE, ">$opt_logfile") + || die "open(>$opt_logfile) failed: $!\n"; + $::LOGFILE = \*TLUTILS_LOGFILE; + $::LOGFILENAME = $opt_logfile; + } +} + +=pod + +This function takes a single argument I<path> and returns it with +C<"> chars surrounding it on Unix. On Windows, the C<"> chars are only +added if I<path> contains special characters, since unconditional quoting +leads to errors there. In all cases, any C<"> chars in I<path> itself +are (erroneously) eradicated. + +=cut + +sub quotify_path_with_spaces { + my $p = shift; + my $m = win32() ? '[+=^&();,!%\s]' : '.'; + if ( $p =~ m/$m/ ) { + $p =~ s/"//g; # remove any existing double quotes + $p = "\"$p\""; + } + return($p); +} + +=pod + +This function returns a "Windows-ized" version of its single argument +I<path>, i.e., replaces all forward slashes with backslashes, and adds +an additional C<"> at the beginning and end if I<path> contains any +spaces. It also makes the path absolute. So if $path does not start +with one (arbitrary) characer followed by C<:>, we add the output of +C<`cd`>. + +The result is suitable for running in shell commands, but not file tests +or other manipulations, since in such internal Perl contexts, the quotes +would be considered part of the filename. + +=cut + +sub conv_to_w32_path { + my $p = shift; + # we need absolute paths, too + my $pabs = tl_abs_path($p); + if (not $pabs) { + $pabs = $p; + tlwarn ("sorry, could not determine absolute path of $p!\n". + "using original path instead"); + } + $pabs =~ s!/!\\!g; + $pabs = quotify_path_with_spaces($pabs); + return($pabs); +} + +=pod + +The next two functions are meant for user input/output in installer menus. +They help making the windows user happy by turning slashes into backslashes +before displaying a path, and our code happy by turning backslashes into forwars +slashes after reading a path. They both are no-ops on Unix. + +=cut + +sub native_slashify { + my ($r) = @_; + $r =~ s!/!\\!g if win32(); + return $r; +} + +sub forward_slashify { + my ($r) = @_; + $r =~ s!\\!/!g if win32(); + return $r; +} + +=item C<setup_persistent_downloads()> + +Set up to use persistent connections using LWP/TLDownload, that is look +for a download server. Return the TLDownload object if successful, else +false. + +=cut + +sub setup_persistent_downloads { + if ($TeXLive::TLDownload::net_lib_avail) { + ddebug("setup_persistent_downloads has net_lib_avail set\n"); + $::tldownload_server = TeXLive::TLDownload->new; + if (!defined($::tldownload_server)) { + ddebug("TLUtils:setup_persistent_downloads: failed to get ::tldownload_server\n"); + } else { + ddebug("TLUtils:setup_persistent_downloads: got ::tldownload_server\n"); + } + return $::tldownload_server; + } + return 0; +} + + +=item C<query_ctan_mirror()> + +Return a particular mirror given by the generic CTAN auto-redirecting +default (specified in L<$TLConfig::TexLiveServerURL>) if we get a +response, else the empty string. + +Neither C<TL_DOWNLOAD_PROGRAM> nor <TL_DOWNLOAD_ARGS> is honored (see +L<download_file>), since certain options have to be set to do the job +and the program has to be C<wget> since we parse the output. + +=cut + +sub query_ctan_mirror { + my $wget = $::progs{'wget'}; + if (!defined ($wget)) { + tlwarn("query_ctan_mirror: Programs not set up, trying wget\n"); + $wget = "wget"; + } + + # we need the verbose output, so no -q. + # do not reduce retries here, but timeout still seems desirable. + my $mirror = $TeXLiveServerURL; + my $cmd = "$wget $mirror --timeout=$NetworkTimeout -O " + . (win32() ? "nul" : "/dev/null") . " 2>&1"; + + # + # since we are reading the output of wget to find a mirror + # we have to make sure that the locale is unset + my $saved_lcall; + if (defined($ENV{'LC_ALL'})) { + $saved_lcall = $ENV{'LC_ALL'}; + } + $ENV{'LC_ALL'} = "C"; + # we try 3 times to get a mirror from mirror.ctan.org in case we have + # bad luck with what gets returned. + my $max_trial = 3; + my $mhost; + for (my $i = 1; $i <= $max_trial; $i++) { + my @out = `$cmd`; + # analyze the output for the mirror actually selected. + foreach (@out) { + if (m/^Location: (\S*)\s*.*$/) { + (my $mhost = $1) =~ s,/*$,,; # remove trailing slashes since we add it + return $mhost; + } + } + sleep(1); + } + + # reset LC_ALL to undefined or the previous value + if (defined($saved_lcall)) { + $ENV{'LC_ALL'} = $saved_lcall; + } else { + delete($ENV{'LC_ALL'}); + } + + # we are still here, so three times we didn't get a mirror, give up + # and return undefined + return; +} + +=item C<check_on_working_mirror($mirror)> + +Check if MIRROR is functional. + +=cut + +sub check_on_working_mirror { + my $mirror = shift; + + my $wget = $::progs{'wget'}; + if (!defined ($wget)) { + tlwarn ("check_on_working_mirror: Programs not set up, trying wget\n"); + $wget = "wget"; + } + $wget = quotify_path_with_spaces($wget); + # + # the test is currently not completely correct, because we do not + # use the LWP if it is set up for it, but I am currently too lazy + # to program it, + # so try wget and only check for the return value + # please KEEP the / after $mirror, some ftp mirrors do give back + # an error if the / is missing after ../CTAN/ + my $cmd = "$wget $mirror/ --timeout=$NetworkTimeout -O " + . (win32() ? "nul" : "/dev/null") + . " 2>" . (win32() ? "nul" : "/dev/null"); + my $ret = system($cmd); + # if return value is not zero it is a failure, so switch the meanings + return ($ret ? 0 : 1); +} + +=item C<give_ctan_mirror_base()> + + 1. get a mirror (retries 3 times to contact mirror.ctan.org) + - if no mirror found, use one of the backbone servers + - if it is an http server return it (no test is done) + - if it is a ftp server, continue + 2. if the ftp mirror is good, return it + 3. if the ftp mirror is bad, search for http mirror (5 times) + 4. if http mirror is found, return it (again, no test,) + 5. if no http mirror is found, return one of the backbone servers + +=cut + +sub give_ctan_mirror_base { + # only one backbone has existed for a while (2018). + my @backbone = qw!http://www.ctan.org/tex-archive!; + + # start by selecting a mirror and test its operationality + my $mirror = query_ctan_mirror(); + if (!defined($mirror)) { + # three times calling mirror.ctan.org did not give anything useful, + # return one of the backbone servers + tlwarn("cannot contact mirror.ctan.org, returning a backbone server!\n"); + return $backbone[int(rand($#backbone + 1))]; + } + + if ($mirror =~ m!^https?://!) { # if http mirror, assume good and return. + return $mirror; + } + + # we are still here, so we got a ftp mirror from mirror.ctan.org + if (check_on_working_mirror($mirror)) { + return $mirror; # ftp mirror is working, return. + } + + # we are still here, so the ftp mirror failed, retry and hope for http. + # theory is that if one ftp fails, probably all ftp is broken. + my $max_mirror_trial = 5; + for (my $try = 1; $try <= $max_mirror_trial; $try++) { + my $m = query_ctan_mirror(); + debug("querying mirror, got " . (defined($m) ? $m : "(nothing)") . "\n"); + if (defined($m) && $m =~ m!^https?://!) { + return $m; # got http this time, assume ok. + } + # sleep to make mirror happy, but only if we are not ready to return + sleep(1) if $try < $max_mirror_trial; + } + + # 5 times contacting the mirror service did not return a http server, + # use one of the backbone servers. + debug("no mirror found ... randomly selecting backbone\n"); + return $backbone[int(rand($#backbone + 1))]; +} + + +sub give_ctan_mirror { + return (give_ctan_mirror_base(@_) . "/$TeXLiveServerPath"); +} + +=item C<create_mirror_list()> + +=item C<extract_mirror_entry($listentry)> + +C<create_mirror_list> returns the lists of viable mirrors according to +ctan-mirrors.pl, in a list which also contains continents, and country headers. + +C<extract_mirror_entry> extracts the actual repository data from one +of these entries. + +# KEEP THESE TWO FUNCTIONS IN SYNC!!! + +=cut + +sub create_mirror_list { + our $mirrors; + my @ret = (); + require("installer/ctan-mirrors.pl"); + my @continents = sort keys %$mirrors; + for my $continent (@continents) { + # first push the name of the continent + push @ret, uc($continent); + my @countries = sort keys %{$mirrors->{$continent}}; + for my $country (@countries) { + my @mirrors = sort keys %{$mirrors->{$continent}{$country}}; + my $first = 1; + for my $mirror (@mirrors) { + my $mfull = $mirror; + $mfull =~ s!/$!!; + # do not append the server path part here, but add + # it down there in the extract mirror entry + #$mfull .= "/" . $TeXLive::TLConfig::TeXLiveServerPath; + #if ($first) { + my $country_str = sprintf "%-12s", $country; + push @ret, " $country_str $mfull"; + # $first = 0; + #} else { + # push @ret, " $mfull"; + #} + } + } + } + return @ret; +} + +# extract_mirror_entry is not very intelligent, it assumes that +# the last "word" is the URL +sub extract_mirror_entry { + my $ent = shift; + my @foo = split ' ', $ent; + return $foo[$#foo] . "/" . $TeXLive::TLConfig::TeXLiveServerPath; +} + +=pod + +=item C<< slurp_file($file) >> + +Reads the whole file and returns the content in a scalar. + +=cut + +sub slurp_file { + my $file = shift; + my $file_data = do { + local $/ = undef; + open my $fh, "<", $file || die "open($file) failed: $!"; + <$fh>; + }; + return($file_data); +} + +=pod + +=item C<< download_to_temp_or_file($url) >> + +If C<$url> is a url, tries to download the file into a temporary file. +Otherwise assume that C<$url> is a local file. +In both cases returns the local file. + +Returns the local file name if succeeded, otherwise undef. + +=cut + +sub download_to_temp_or_file { + my $url = shift; + my ($url_fh, $url_file); + if ($url =~ m,^(https?|ftp|file)://, || $url =~ m!$SshURIRegex!) { + ($url_fh, $url_file) = tl_tmpfile(); + # now $url_fh filehandle is open, the file created + # TLUtils::download_file will just overwrite what is there + # on windows that doesn't work, so we close the fh immediately + # this creates a short loophole, but much better than before anyway + close($url_fh); + $ret = download_file($url, $url_file); + } else { + $url_file = $url; + $ret = 1; + } + if ($ret && (-r "$url_file")) { + return $url_file; + } + return; +} + +# compare_tlpobjs +# returns a hash +# $ret{'revision'} = "leftRev:rightRev" if revision differ +# $ret{'removed'} = \[ list of files removed from A to B ] +# $ret{'added'} = \[ list of files added from A to B ] +# +sub compare_tlpobjs { + my ($tlpA, $tlpB) = @_; + my %ret; + my @rem; + my @add; + + my $rA = $tlpA->revision; + my $rB = $tlpB->revision; + if ($rA != $rB) { + $ret{'revision'} = "$rA:$rB"; + } + if ($tlpA->relocated) { + $tlpA->replace_reloc_prefix; + } + if ($tlpB->relocated) { + $tlpB->replace_reloc_prefix; + } + my @fA = $tlpA->all_files; + my @fB = $tlpB->all_files; + my %removed; + my %added; + for my $f (@fA) { $removed{$f} = 1; } + for my $f (@fB) { delete($removed{$f}); $added{$f} = 1; } + for my $f (@fA) { delete($added{$f}); } + @rem = sort keys %removed; + @add = sort keys %added; + $ret{'removed'} = \@rem if @rem; + $ret{'added'} = \@add if @add; + return %ret; +} + +# +# compare_tlpdbs +# return several hashes +# @{$ret{'removed_packages'}} = list of removed packages from A to B +# @{$ret{'added_packages'}} = list of added packages from A to B +# $ret{'different_packages'}->{$package} = output of compare_tlpobjs +# +sub compare_tlpdbs { + my ($tlpdbA, $tlpdbB, @add_ignored_packs) = @_; + my @ignored_packs = qw/00texlive.installer 00texlive.image/; + push @ignored_packs, @add_ignored_packs; + + my @inAnotinB; + my @inBnotinA; + my %diffpacks; + my %do_compare; + my %ret; + + for my $p ($tlpdbA->list_packages()) { + my $is_ignored = 0; + for my $ign (@ignored_packs) { + if (($p =~ m/^$ign$/) || ($p =~ m/^$ign\./)) { + $is_ignored = 1; + last; + } + } + next if $is_ignored; + my $tlpB = $tlpdbB->get_package($p); + if (!defined($tlpB)) { + push @inAnotinB, $p; + } else { + $do_compare{$p} = 1; + } + } + $ret{'removed_packages'} = \@inAnotinB if @inAnotinB; + + for my $p ($tlpdbB->list_packages()) { + my $is_ignored = 0; + for my $ign (@ignored_packs) { + if (($p =~ m/^$ign$/) || ($p =~ m/^$ign\./)) { + $is_ignored = 1; + last; + } + } + next if $is_ignored; + my $tlpA = $tlpdbA->get_package($p); + if (!defined($tlpA)) { + push @inBnotinA, $p; + } else { + $do_compare{$p} = 1; + } + } + $ret{'added_packages'} = \@inBnotinA if @inBnotinA; + + for my $p (sort keys %do_compare) { + my $tlpA = $tlpdbA->get_package($p); + my $tlpB = $tlpdbB->get_package($p); + my %foo = compare_tlpobjs($tlpA, $tlpB); + if (keys %foo) { + # some diffs were found + $diffpacks{$p} = \%foo; + } + } + $ret{'different_packages'} = \%diffpacks if (keys %diffpacks); + + return %ret; +} + +sub tlnet_disabled_packages { + my ($root) = @_; + my $disabled_pkgs = "$root/tlpkg/dev/tlnet-disabled-packages.txt"; + my @ret; + if (-r $disabled_pkgs) { + open (DISABLED, "<$disabled_pkgs") || die "Huu, -r but cannot open: $?"; + while (<DISABLED>) { + chomp; + next if /^\s*#/; + next if /^\s*$/; + $_ =~ s/^\s*//; + $_ =~ s/\s*$//; + push @ret, $_; + } + close(DISABLED) || warn ("Cannot close tlnet-disabled-packages.txt: $?"); + } + return @ret; +} + +sub report_tlpdb_differences { + my $rret = shift; + my %ret = %$rret; + + if (defined($ret{'removed_packages'})) { + info ("removed packages from A to B:\n"); + for my $f (@{$ret{'removed_packages'}}) { + info (" $f\n"); + } + } + if (defined($ret{'added_packages'})) { + info ("added packages from A to B:\n"); + for my $f (@{$ret{'added_packages'}}) { + info (" $f\n"); + } + } + if (defined($ret{'different_packages'})) { + info ("different packages from A to B:\n"); + for my $p (keys %{$ret{'different_packages'}}) { + info (" $p\n"); + for my $k (keys %{$ret{'different_packages'}->{$p}}) { + if ($k eq "revision") { + info(" revision differ: $ret{'different_packages'}->{$p}->{$k}\n"); + } elsif ($k eq "removed" || $k eq "added") { + info(" $k files:\n"); + for my $f (@{$ret{'different_packages'}->{$p}->{$k}}) { + info(" $f\n"); + } + } else { + info(" unknown differ $k\n"); + } + } + } + } +} + +sub sort_archs ($$) { + my $aa = $_[0]; + my $bb = $_[1]; + $aa =~ s/^(.*)-(.*)$/$2-$1/; + $bb =~ s/^(.*)-(.*)$/$2-$1/; + $aa cmp $bb ; +} + +# Taken from Text::ParseWords +# +sub quotewords { + my($delim, $keep, @lines) = @_; + my($line, @words, @allwords); + + foreach $line (@lines) { + @words = parse_line($delim, $keep, $line); + return() unless (@words || !length($line)); + push(@allwords, @words); + } + return(@allwords); +} + +sub parse_line { + my($delimiter, $keep, $line) = @_; + my($word, @pieces); + + no warnings 'uninitialized'; # we will be testing undef strings + + $line =~ s/\s+$//; # kill trailing whitespace + while (length($line)) { + $line =~ s/^(["']) # a $quote + ((?:\\.|(?!\1)[^\\])*) # and $quoted text + \1 # followed by the same quote + | # --OR-- + ^((?:\\.|[^\\"'])*?) # an $unquoted text + (\Z(?!\n)|(?-x:$delimiter)|(?!^)(?=["'])) + # plus EOL, delimiter, or quote + //xs or return; # extended layout + my($quote, $quoted, $unquoted, $delim) = ($1, $2, $3, $4); + return() unless( defined($quote) || length($unquoted) || length($delim)); + + if ($keep) { + $quoted = "$quote$quoted$quote"; + } else { + $unquoted =~ s/\\(.)/$1/sg; + if (defined $quote) { + $quoted =~ s/\\(.)/$1/sg if ($quote eq '"'); + $quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'"); + } + } + $word .= substr($line, 0, 0); # leave results tainted + $word .= defined $quote ? $quoted : $unquoted; + + if (length($delim)) { + push(@pieces, $word); + push(@pieces, $delim) if ($keep eq 'delimiters'); + undef $word; + } + if (!length($line)) { + push(@pieces, $word); + } + } + return(@pieces); +} + +=item C<mktexupd ()> + +Append entries to C<ls-R> files. Usage example: + + my $updLSR=&mktexupd(); + $updLSR->{mustexist}(1); + $updLSR->{add}(file1); + $updLSR->{add}(file2); + $updLSR->{add}(file3); + $updLSR->{exec}(); + +The first line creates a new object. Only one such object should be +created in a program in order to avoid duplicate entries in C<ls-R> files. + +C<add> pushes a filename or a list of filenames to a hash encapsulated +in a closure. Filenames must be specified with the full (absolute) path. +Duplicate entries are ignored. + +C<exec> checks for each component of C<$TEXMFDBS> whether there are files +in the hash which have to be appended to the corresponding C<ls-R> files +and eventually updates the corresponding C<ls-R> files. Files which are +in directories not stated in C<$TEXMFDBS> are silently ignored. + +If the flag C<mustexist> is set, C<exec> aborts with an error message +if a file supposed to be appended to an C<ls-R> file doesn't exist physically +on the file system. This option was added for compatibility with the +C<mktexupd> shell script. This option shouldn't be enabled in scripts, +except for testing, because it degrades performance on non-cached file +systems. + +=cut + +sub mktexupd { + my %files; + my $mustexist=0; + + my $hash={ + "add" => sub { + foreach my $file (@_) { + $file =~ s|\\|/|g; + $files{$file}=1; + } + }, + "reset" => sub { + %files=(); + }, + "mustexist" => sub { + $mustexist=shift; + }, + "exec" => sub { + # check whether files exist + if ($mustexist) { + foreach my $file (keys %files) { + die "mktexupd: exec file does not exist: $file" if (! -f $file); + } + } + my $delim= (&win32)? ';' : ':'; + my $TEXMFDBS; + chomp($TEXMFDBS=`kpsewhich --show-path="ls-R"`); + + my @texmfdbs=split ($delim, "$TEXMFDBS"); + my %dbs; + + foreach my $path (keys %files) { + foreach my $db (@texmfdbs) { + $db=substr($db, -1) if ($db=~m|/$|); # strip leading / + $db = lc($db) if win32(); + $up = (win32() ? lc($path) : $path); + if (substr($up, 0, length("$db/")) eq "$db/") { + # we appended a / because otherwise "texmf" is recognized as a + # substring of "texmf-dist". + my $np = './' . substr($up, length("$db/")); + my ($dir, $file); + $_=$np; + ($dir, $file) = m|(.*)/(.*)|; + $dbs{$db}{$dir}{$file}=1; + } + } + } + foreach my $db (keys %dbs) { + if (! -f "$db" || ! -w "$db/ls-R") { + &mkdirhier ($db); + } + open LSR, ">>$db/ls-R"; + foreach my $dir (keys %{$dbs{$db}}) { + print LSR "\n$dir:\n"; + foreach my $file (keys %{$dbs{$db}{$dir}}) { + print LSR "$file\n"; + } + } + close LSR; + } + } + }; + return $hash; +} + + +=item C<check_sys_user_mode($user,$sys,$tmfc, $tmfsc, $tmfv, $tmfsv)> + +=cut + +sub setup_sys_user_mode { + my ($prg, $optsref, $TEXMFCONFIG, $TEXMFSYSCONFIG, + $TEXMFVAR, $TEXMFSYSVAR) = @_; + + if ($optsref->{'user'} && $optsref->{'sys'}) { + print STDERR "$prg [ERROR]: only one of -sys or -user can be used.\n"; + exit(1); + } + + # check if we are in *hidden* sys mode, in which case we switch + # to sys mode + # Nowdays we use -sys switch instead of simply overriding TEXMFVAR + # and TEXMFCONFIG + # This is used to warn users when they run updmap in usermode the first time. + # But it might happen that this script is called via another wrapper that + # sets TEXMFCONFIG and TEXMFVAR, and does not pass on the -sys option. + # for this case we check whether the SYS and non-SYS variants agree, + # and if, then switch to sys mode (with a warning) + if (($TEXMFSYSCONFIG eq $TEXMFCONFIG) && ($TEXMFSYSVAR eq $TEXMFVAR)) { + if ($optsref->{'user'}) { + print STDERR "$prg [ERROR]: -user mode but path setup is -sys type, bailing out.\n"; + exit(1); + } + if (!$optsref->{'sys'}) { + print STDERR "$prg [WARNING]: hidden sys mode found, switching to sys mode.\n" if (!$optsref->{'quiet'}); + $optsref->{'sys'} = 1; + } + } + + my ($texmfconfig, $texmfvar); + if ($optsref->{'sys'}) { + # we are running as updmap-sys, make sure that the right tree is used + $texmfconfig = $TEXMFSYSCONFIG; + $texmfvar = $TEXMFSYSVAR; + } elsif ($optsref->{'user'}) { + $texmfconfig = $TEXMFCONFIG; + $texmfvar = $TEXMFVAR; + } else { + print STDERR "" . + "$prg [ERROR]: Either -sys or -user mode is required.\n" . + "$prg [ERROR]: In nearly all cases you should use $prg -sys.\n" . + "$prg [ERROR]: For special cases see http://tug.org/texlive/scripts-sys-user.html\n" ; + exit(1); + } + return ($texmfconfig, $texmfvar); +} + +=item C<prepend_own_path()> + +Prepend the location of the TeX Live binaries to the PATH environment +variable. This is used by (e.g.) C<fmtutil>. The location is found by +calling C<Cwd::abs_path> on C<which('kpsewhich')>. We use kpsewhich +because it is known to be a true binary executable; C<$0> could be a +symlink into (say) C<texmf-dist/scripts/>, which is not a useful +directory for PATH. + +=cut + +sub prepend_own_path { + my $bindir = dirname(Cwd::abs_path(which('kpsewhich'))); + if (win32()) { + $bindir =~ s!\\!/!g; + $ENV{'PATH'} = "$bindir;$ENV{PATH}"; + } else { + $ENV{'PATH'} = "$bindir:$ENV{PATH}"; + } +} + + +=item C<repository_to_array($r)> + +Return hash of tags to urls for space-separated list of repositories +passed in C<$r>. If passed undef or empty string, die. + +=cut + +sub repository_to_array { + my $r = shift; + my %r; + if (!$r) { + # either empty string or undef was passed + # before 20181023 we die here, now we return + # an empty array + return %r; + } + #die "internal error, repository_to_array passed nothing (caller=" + # . caller . ")" if (!$r); + my @repos = split (' ', $r); + if ($#repos == 0) { + # only one repo, this is the main one! + $r{'main'} = $repos[0]; + return %r; + } + for my $rr (@repos) { + my $tag; + my $url; + # decode spaces and % in reverse order + $rr =~ s/%20/ /g; + $rr =~ s/%25/%/g; + $tag = $url = $rr; + if ($rr =~ m/^([^#]+)#(.*)$/) { + $tag = $2; + $url = $1; + } + $r{$tag} = $url; + } + return %r; +} + +=item C<encode_json($ref)> + +Returns the JSON representation of the object C<$ref> is pointing at. +This tries to load the C<JSON> Perl module, and uses it if available, +otherwise falls back to module internal conversion. + +The used backend can be selected by setting the environment variable +C<TL_JSONMODE> to either C<json> or C<texlive> (all other values are +ignored). If C<json> is requested and the C<JSON> module cannot be loaded +the program terminates. + +=cut + +my $TLTrueValue = 1; +my $TLFalseValue = 0; +my $TLTrue = \$TLTrueValue; +my $TLFalse = \$TLFalseValue; +bless $TLTrue, 'TLBOOLEAN'; +bless $TLFalse, 'TLBOOLEAN'; + +our $jsonmode = ""; + +=item C<True()> +=item C<False()> + +these two function must be used to get proper JSON C<true> and C<false> +in the output independent of the backend used. + +=cut + +sub True { + ensure_json_available(); + if ($jsonmode eq "json") { + return($JSON::true); + } else { + return($TLTrue); + } +} +sub False { + ensure_json_available(); + if ($jsonmode eq "json") { + return($JSON::false); + } else { + return($TLFalse); + } +} + +sub ensure_json_available { + return if ($jsonmode); + # check the environment for mode to use: + # $ENV{'TL_JSONMODE'} = texlive | json + my $envdefined = 0; + if ($ENV{'TL_JSONMODE'}) { + $envdefined = 1; + if ($ENV{'TL_JSONMODE'} eq "texlive") { + $jsonmode = "texlive"; + debug("texlive json module used!\n"); + return; + } elsif ($ENV{'TL_JSONMODE'} eq "json") { + # nothing to do + } else { + tlwarn("Unsupported mode \'$ENV{TL_JSONMODE}\' set in TL_JSONMODE, ignoring it!"); + $envdefined = 0; + } + } + return if ($jsonmode); # was set to texlive + eval { require JSON; }; + if ($@) { + # that didn't work out, use home-grown json + if ($envdefined) { + # environment asks for JSON but cannot be loaded, die! + tldie("envvar TL_JSONMODE request JSON module but cannot be loaded!\n"); + } + $jsonmode = "texlive"; + debug("texlive json module used!\n"); + } else { + $jsonmode = "json"; + my $json = JSON->new; + debug("JSON " . $json->backend . " used!\n"); + } +} + +sub encode_json { + my $val = shift; + ensure_json_available(); + if ($jsonmode eq "json") { + my $utf8_encoded_json_text = JSON::encode_json($val); + return $utf8_encoded_json_text; + } else { + my $type = ref($val); + if ($type eq "") { + tldie("encode_json: accept only refs: $val"); + } elsif ($type eq 'SCALAR') { + return(scalar_to_json($$val)); + } elsif ($type eq 'ARRAY') { + return(array_to_json($val)); + } elsif ($type eq 'HASH') { + return(hash_to_json($val)); + } elsif ($type eq 'REF') { + return(encode_json($$val)); + } elsif (Scalar::Util::blessed($val)) { + if ($type eq "TLBOOLEAN") { + return($$val ? "true" : "false"); + } else { + tldie("encode_json: unsupported blessed object"); + } + } else { + tldie("encode_json: unsupported format $type"); + } + } +} + +sub scalar_to_json { + sub looks_like_numeric { + # code from JSON/backportPP.pm + my $value = shift; + no warnings 'numeric'; + # detect numbers + # string & "" -> "" + # number & "" -> 0 (with warning) + # nan and inf can detect as numbers, so check with * 0 + return unless length((my $dummy = "") & $value); + return unless 0 + $value eq $value; + return 1 if $value * 0 == 0; + return -1; # inf/nan + } + my $val = shift; + if (defined($val)) { + if (looks_like_numeric($val)) { + return("$val"); + } else { + return(string_to_json($val)); + } + } else { + return("null"); + } +} + +sub string_to_json { + my $val = shift; + my %esc = ( + "\n" => '\n', + "\r" => '\r', + "\t" => '\t', + "\f" => '\f', + "\b" => '\b', + "\"" => '\"', + "\\" => '\\\\', + "\'" => '\\\'', + ); + $val =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g; + return("\"$val\""); +} + +sub hash_to_json { + my $hr = shift; + my @retvals; + for my $k (keys(%$hr)) { + my $val = $hr->{$k}; + push @retvals, "\"$k\":" . encode_json(\$val); + } + my $ret = "{" . join(",", @retvals) . "}"; + return($ret); +} + +sub array_to_json { + my $hr = shift; + my $ret = "[" . join(",", map { encode_json(\$_) } @$hr) . "]"; + return($ret); +} + + + +=back +=cut + +1; +__END__ + +=head1 SEE ALSO + +The modules L<TeXLive::TLConfig>, L<TeXLive::TLCrypto>, +L<TeXLive::TLDownload>, L<TeXLive::TLWinGoo>, etc., and the +documentation in the repository: C<Master/tlpkg/doc/>. + +=head1 AUTHORS AND COPYRIGHT + +This script and its documentation were written for the TeX Live +distribution (L<http://tug.org/texlive>) and both are licensed under the +GNU General Public License Version 2 or later. + +=cut + +### Local Variables: +### perl-indent-level: 2 +### tab-width: 2 +### indent-tabs-mode: nil +### End: +# vim:set tabstop=2 expandtab: # |