|
|
# $Id: TLUtils.pm 55776 2020-07-07 22:32:40Z karl $
|
|
|
# TeXLive::TLUtils.pm - the inevitable utilities for TeX Live.
|
|
|
# Copyright 2007-2020 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: 55776 $';
|
|
|
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, @args);
|
|
|
|
|
|
=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 Logging and debugging
|
|
|
|
|
|
TeXLive::TLUtils::info($str1, ...); # output unless -q
|
|
|
TeXLive::TLUtils::debug($str1, ...); # output if -v
|
|
|
TeXLive::TLUtils::ddebug($str1, ...); # output if -vv
|
|
|
TeXLive::TLUtils::dddebug($str1, ...); # output if -vvv
|
|
|
TeXLive::TLUtils::log($str1, ...); # only to log file
|
|
|
TeXLive::TLUtils::tlwarn($str1, ...); # warn on stderr and log
|
|
|
TeXLive::TLUtils::tldie($str1, ...); # tlwarn and die
|
|
|
TeXLive::TLUtils::debug_hash_str($label, HASH); # stringified HASH
|
|
|
TeXLive::TLUtils::debug_hash($label, HASH); # warn stringified HASH
|
|
|
TeXLive::TLUtils::backtrace(); # return call stack as string
|
|
|
TeXLive::TLUtils::process_logging_options($texdir); # handle -q -v* -logfile
|
|
|
|
|
|
=head2 Miscellaneous
|
|
|
|
|
|
TeXLive::TLUtils::sort_uniq(@list);
|
|
|
TeXLive::TLUtils::push_uniq(\@list, @items);
|
|
|
TeXLive::TLUtils::member($item, @list);
|
|
|
TeXLive::TLUtils::merge_into(\%to, \%from);
|
|
|
TeXLive::TLUtils::texdir_check($texdir);
|
|
|
TeXLive::TLUtils::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(
|
|
|
$::LOGFILE $::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
|
|
|
debug_hash_str 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 ORIG_PLATFORM, a canonical host name as returned by
|
|
|
C<config.guess>, into a TeX Live platform name.
|
|
|
|
|
|
CPU type is determined by a regexp, and any C</^i.86/> name is replaced
|
|
|
by C<i386>.
|
|
|
|
|
|
For the OS value 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 contains old OSs which are no longer
|
|
|
supported, just in case.
|
|
|
|
|
|
If the environment variable TEXLIVE_OS_NAME is set, it is used as-is.
|
|
|
|
|
|
=cut
|
|
|
|
|
|
sub platform_name {
|
|
|
my ($orig_platform) = @_;
|
|
|
my $guessed_platform = $orig_platform;
|
|
|
|
|
|
# try to parse out some bsd variants that use amd64.
|
|
|
# We throw away everything after the "bsd" to elide version numbers,
|
|
|
# as in amd64-unknown-midnightbsd1.2.
|
|
|
$guessed_platform =~ s/^x86_64-(.*-k?)(free|net)bsd/amd64-$1$2bsd/;
|
|
|
my $CPU; # CPU type as reported by config.guess.
|
|
|
my $OS; # O/S type as reported by config.guess.
|
|
|
($CPU = $guessed_platform) =~ s/(.*?)-.*/$1/;
|
|
|
|
|
|
$CPU =~ s/^alpha(.*)/alpha/; # alphaev whatever
|
|
|
$CPU =~ s/mips64el/mipsel/; # don't distinguish mips64 and 32 el
|
|
|
$CPU =~ s/powerpc64/powerpc/; # don't distinguish ppc64
|
|
|
$CPU =~ s/sparc64/sparc/; # don't distinguish sparc64
|
|
|
|
|
|
# armv6l-unknown-linux-gnueabihf -> armhf-linux (RPi)
|
|
|
# armv7l-unknown-linux-gnueabi -> armel-linux (Android)
|
|
|
if ($CPU =~ /^arm/) {
|
|
|
$CPU = $guessed_platform =~ /hf$/ ? "armhf" : "armel";
|
|
|
}
|
|
|
|
|
|
if ($ENV{"TEXLIVE_OS_NAME"}) {
|
|
|
$OS = $ENV{"TEXLIVE_OS_NAME"};
|
|
|
} else {
|
|
|
my @OSs = qw(aix cygwin darwin dragonfly freebsd hpux irix
|
|
|
kfreebsd linux midnightbsd netbsd openbsd solaris);
|
|
|
for my $os (@OSs) {
|
|
|
# Match word boundary at the beginning of the os name so that
|
|
|
# freebsd and kfreebsd are distinguished.
|
|
|
# Do not match word boundary at the end of the os so that
|
|
|
# solaris2 is matched.
|
|
|
$OS = $os if $guessed_platform =~ /\b$os/;
|
|
|
}
|
|
|
}
|
|
|
|
|
|
if (! $OS) {
|
|
|
warn "$0: could not guess OS from config.guess string: $orig_platform";
|
|
|
$OS = "unknownOS";
|
|
|
}
|
|
|
|
|
|
if ($OS eq "linux") {
|
|
|
# deal with the special case of musl based distributions
|
|
|
# config.guess returns
|
|
|
# x86_64-pc-linux-musl
|
|
|
# i386-pc-linux-musl
|
|
|
$OS = "linuxmusl" if $guessed_platform =~ /\blinux-musl/;
|
|
|
}
|
|
|
|
|
|
if ($OS eq "darwin") {
|
|
|
# We have two versions of Mac binary sets.
|
|
|
# 10.x and newer -> x86_64-darwin [MacTeX]
|
|
|
# 10.6/Snow Leopard through 10.x -> x86_64-darwinlegacy, if 64-bit
|
|
|
# x changes every year. In 2020 (Big Sur) Apple started with 11.x.
|
|
|
#
|
|
|
# (BTW, uname -r numbers are larger by 4 than the Mac minor version.
|
|
|
# We don't use uname numbers here.)
|
|
|
#
|
|
|
# this changes each year, per above:
|
|
|
my $mactex_darwin = 13; # 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 "unknownmac-unknownmac";
|
|
|
}
|
|
|
if ($os_major >= 11) {
|
|
|
$CPU = "x86_64";
|
|
|
$OS = "darwin";
|
|
|
} elsif ($os_minor >= $mactex_darwin) {
|
|
|
; # sufficiently new 10.x, 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-midnightbsd'=> 'MidnightBSD 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.13-) on x86_64',
|
|
|
'x86_64-darwinlegacy' => 'MacOSX legacy (10.6-) on x86_64',
|
|
|
'x86_64-dragonfly' => 'DragonFlyBSD on x86_64',
|
|
|
'x86_64-linux' => 'GNU/Linux on x86_64',
|
|
|
'x86_64-linuxmusl' => 'GNU/Linux on x86_64 with musl',
|
|
|
'x86_64-solaris' => 'Solaris on x86_64',
|
|
|
);
|
|
|
|
|
|
# the inconsistency between amd64-freebsd and x86_64-linux is
|
|
|
# unfortunate (it's the same hardware), but the os people say those
|
|
|
# are the conventional names on the respective os's, so we follow suit.
|
|
|
|
|
|
if (exists $platform_name{$platform}) {
|
|
|
return "$platform_name{$platform}";
|
|
|
} else {
|
|
|
my ($CPU,$OS) = split ('-', $platform);
|
|
|
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("TLUtils::initialize_global_tmpdir: creating global tempdir $::tl_tmpdir\n");
|
|
|
return ($::tl_tmpdir);
|
|
|
}
|
|
|
|
|
|
=item C<tl_tmpdir>
|
|
|
|
|
|
Create a temporary directory which is removed when the program
|
|
|
is terminated.
|
|
|
|
|
|
=cut
|
|
|
|
|
|
sub tl_tmpdir {
|
|
|
initialize_global_tmpdir() if (!defined($::tl_tmpdir));
|
|
|
my $tmp = File::Temp::tempdir(DIR => $::tl_tmpdir, CLEANUP => 1);
|
|
|
ddebug("TLUtils::tl_tmpdir: creating tempdir $tmp\n");
|
|
|
return ($tmp);
|
|
|
}
|
|
|
|
|
|
=item C<tl_tmpfile>
|
|
|
|
|
|
Create a temporary file which is removed when the program
|
|
|
is terminated. Returns file handle and file name.
|
|
|
Arguments are passed on to C<File::Temp::tempfile>.
|
|
|
|
|
|
=cut
|
|
|
|
|
|
sub tl_tmpfile {
|
|
|
initialize_global_tmpdir() if (!defined($::tl_tmpdir));
|
|
|
my ($fh, $fn) = File::Temp::tempfile(@_, DIR => $::tl_tmpdir, UNLINK => 1);
|
|
|
ddebug("TLUtils::tl_tempfile: creating tempfile $fn\n");
|
|
|
return ($fh, $fn);
|
|
|
}
|
|
|
|
|
|
|
|
|
=item C<xchdir($dir)>
|
|
|
|
|
|
C<chdir($dir)> or die.
|
|
|
|
|
|
=cut
|
|
|
|
|
|
sub xchdir {
|
|
|
my ($dir) = @_;
|
|
|
chdir($dir) || die "$0: chdir($dir) failed: $!";
|
|
|
ddebug("xchdir($dir) ok\n");
|
|
|
}
|
|
|
|
|
|
|
|
|
=item C<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/gid, 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)>
|
|
|
|
|
|
=item C<copy("-L", $file, $destfile)>
|
|
|
|
|
|
Copy file C<$file> to directory C<$target_dir>, or to the C<$destfile>
|
|
|
if the first argument is C<"-f">. 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.
|
|
|
|
|
|
If the argument is C<"-L"> and C<$file> is a symlink, the link is
|
|
|
dereferenced before the copying is done. (If both C<"-f"> and C<"-L">
|
|
|
are desired, they must be given in that order, although the current code
|
|
|
has no need to do this.)
|
|
|
|
|
|
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 C<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 {
|
|
|
#too verbose ddebug("TLUtils::copy(", join (",", @_), "\n");
|
|
|
my $infile = shift;
|
|
|
my $filemode = 0;
|
|
|
my $dereference = 0;
|
|
|
if ($infile eq "-f") { # second argument is a file
|
|
|
$filemode = 1;
|
|
|
$infile = shift;
|
|
|
}
|
|
|
if ($infile eq "-L") {
|
|
|
$dereference = 1;
|
|
|
$infile = shift;
|
|
|
}
|
|
|
my $destdir=shift;
|
|
|
|
|
|
# while we're trying to figure out the versioned containers.
|
|
|
#debug("copy($infile, $destdir, filemode=$filemode)\n");
|
|
|
#debug("copy: backtrace:\n", backtrace(), "copy: end backtrace\n");
|
|
|
|
|
|
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 we should dereference, change $infile to refer to the link target.
|
|
|
if (-l $infile && $dereference) {
|
|
|
my $linktarget = readlink($infile);
|
|
|
# The symlink target should always be relative, and we need to
|
|
|
# prepend the directory containing the link in that case.
|
|
|
# (Although it should never happen, if the symlink target happens
|
|
|
# to already be absolute, do not prepend.)
|
|
|
if ($linktarget !~ m,^/,) {
|
|
|
$infile = Cwd::abs_path(dirname($infile)) . "/$linktarget";
|
|
|
}
|
|
|
ddebug("TLUtils::copy: dereferencing symlink $infile -> $linktarget");
|
|
|
}
|
|
|
|
|
|
if (-l $infile) {
|
|
|
my $linktarget = readlink($infile);
|
|
|
my $dest = "$destdir/$filename";
|
|
|
ddebug("TLUtils::copy: doing symlink($linktarget,$dest)"
|
|
|
. " [from readlink($infile)]\n");
|
|
|
symlink($linktarget, $dest) || die "symlink($linktarget,$dest) 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}) {
|
|
|
ddebug(" no collapse of $d because of: $dirent\n");
|
|
|
$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.
|
|
|
|
|
|
Here is the idea:
|
|
|
|
|
|
=over 4
|
|
|
|
|
|
=item create a hashes by_dir listing all files that should be removed
|
|
|
by directory, i.e., key = dir, value is list of files
|
|
|
|
|
|
=item 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
|
|
|
|
|
|
=item return this removal list
|
|
|
|
|
|
=back
|
|
|
=cut
|
|
|
|
|
|
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;
|
|
|
debug("TLUtils::install_packages: fromtlpdb.root=$root, media=$media,"
|
|
|
. " totlpdb.root=" . $totlpdb->root
|
|
|
. " what=$what ($totalnr), opt_src=$opt_src, opt_doc=$opt_doc\n");
|
|
|
|
|
|
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();
|
|
|
my @packs_again; # packages that we failed to download and should retry later
|
|
|
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);
|
|
|
}
|
|
|
# push $package to @packs_again if download failed
|
|
|
# (and not installing from disk).
|
|
|
if (!$fromtlpdb->install_package($package, $totlpdb)) {
|
|
|
tlwarn("TLUtils::install_packages: Failed to install $package\n");
|
|
|
if ($media eq "NET") {
|
|
|
tlwarn(" $package will be retried later.\n");
|
|
|
push @packs_again, $package;
|
|
|
} else {
|
|
|
# return false as soon as one package failed, since we won't
|
|
|
# be trying again.
|
|
|
return 0;
|
|
|
}
|
|
|
} else {
|
|
|
$donesize += $tlpsizes{$package};
|
|
|
}
|
|
|
}
|
|
|
# try to download packages in @packs_again again
|
|
|
foreach my $package (@packs_again) {
|
|
|
my $infostr = sprintf("Retrying to install: $package [%dk]",
|
|
|
int($tlpsizes{$package}/1024) + 1);
|
|
|
info("$infostr\n");
|
|
|
# return false if download failed again
|
|
|
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 ("TLUtils::add_link_dir_dir: linking 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("TLUtils::remove_link_dir_dir: 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("TLUtils::remove_link_dir_dir: 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 ("TLUtils::remove_link_dir_dir: 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 ("TLUtils::remove_link_dir_dir: 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("TLUtils::add_remove_symlinks: $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("TLUtils::add_remove_symlinks: 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("TLUtils::add_remove_symlinks: $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_and_remove($what, $checksum, $checksize>
|
|
|
|
|
|
Remove the file C<$what> if either the given C<$checksum> or
|
|
|
C<$checksize> for C<$what> does not agree with our recomputation using
|
|
|
C<TLCrypto::tlchecksum> and C<stat>, respectively. If a check argument
|
|
|
is not given, that check is not performed. If the checksums agree, the
|
|
|
size is not checked. The return status is random.
|
|
|
|
|
|
This unusual behavior (removing the given file) is because this is used
|
|
|
for newly-downloaded files; see the calls in the C<unpack> routine
|
|
|
(which is the only caller).
|
|
|
|
|
|
=cut
|
|
|
|
|
|
sub check_file_and_remove {
|
|
|
my ($xzfile, $checksum, $checksize) = @_;
|
|
|
my $fn_name = (caller(0))[3];
|
|
|
debug("$fn_name $xzfile, $checksum, $checksize\n");
|
|
|
|
|
|
if (!$checksum && !$checksize) {
|
|
|
tlwarn("$fn_name: neither checksum nor checksize " .
|
|
|
"available for $xzfile, cannot check integrity");
|
|
|
return;
|
|
|
}
|
|
|
|
|
|
# The idea is that if one of the tests fail, we want to save a copy of
|
|
|
# the input file for debugging. But we can't just omit removing the
|
|
|
# file, since the caller depends on the removal. So we copy it to a
|
|
|
# new temporary directory, which we want to persist, so can't use tl_tmpdir.
|
|
|
my $check_file_tmpdir = undef;
|
|
|
|
|
|
# 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("$fn_name: checksums differ for $xzfile:\n");
|
|
|
tlwarn("$fn_name: tlchecksum=$tlchecksum, arg=$checksum\n");
|
|
|
tlwarn("$fn_name: backtrace:\n" . backtrace());
|
|
|
# on Windows passing a pattern creates the tmpdir in PWD
|
|
|
# which means that it will be tried to be created on the DVD
|
|
|
# $check_file_tmpdir = File::Temp::tempdir("tlcheckfileXXXXXXXX");
|
|
|
$check_file_tmpdir = File::Temp::tempdir();
|
|
|
tlwarn("$fn_name: removing $xzfile, "
|
|
|
. "but saving copy in $check_file_tmpdir\n");
|
|
|
copy($xzfile, $check_file_tmpdir);
|
|
|
unlink($xzfile);
|
|
|
return;
|
|
|
} else {
|
|
|
debug("$fn_name: 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("$fn_name: removing $xzfile, sizes differ:\n");
|
|
|
tlwarn("$fn_name: tlfilesize=$filesize, arg=$checksize\n");
|
|
|
if (!defined($check_file_tmpdir)) {
|
|
|
# the tmpdir should always be undefined, since we shouldn't get
|
|
|
# here if the checksums failed, but test anyway.
|
|
|
$check_file_tmpdir = File::Temp::tempdir("tlcheckfileXXXXXXXX");
|
|
|
tlwarn("$fn_name: saving copy in $check_file_tmpdir\n");
|
|
|
copy($xzfile, $check_file_tmpdir);
|
|
|
}
|
|
|
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
|
|
|
keys: 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_and_remove($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 (download_file failed)");
|
|
|
}
|
|
|
# remove false downloads
|
|
|
check_file_and_remove($containerfile, $checksum, $size);
|
|
|
if ( ! -r $containerfile ) {
|
|
|
return(0, "downloading did not succeed (check_file_and_remove failed)");
|
|
|
}
|
|
|
}
|
|
|
} else {
|
|
|
# we are installing from local compressed files
|
|
|
# copy it to temp with dereferencing of link target
|
|
|
TeXLive::TLUtils::copy("-L", $what, $tempdir);
|
|
|
|
|
|
check_file_and_remove($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 >= 2) {
|
|
|
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();
|
|
|
ddebug("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 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)) {
|
|
|
ddebug("::tldownload_server not defined\n");
|
|
|
return(0);
|
|
|
}
|
|
|
if (!$::tldownload_server->enabled) {
|
|
|
# try to reinitialize a disabled connection
|
|
|
# disabling happens after 6 failed download trials
|
|
|
# we just re-initialize the connection
|
|
|
if (!setup_persistent_downloads()) {
|
|
|
# setup failed, give up
|
|
|
debug("reinitialization of LWP download failed\n");
|
|
|
return(0);
|
|
|
}
|
|
|
# we don't need to check for ->enabled, because
|
|
|
# setup_persistent_downloads calls TLDownload->new()
|
|
|
# which, if it succeeds, automatically set enabled to 1
|
|
|
}
|
|
|
# we are still here, so try to download
|
|
|
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 other downloaders.\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 Logging
|
|
|
|
|
|
Logging and debugging messages.
|
|
|
|
|
|
=over 4
|
|
|
|
|
|
=item C<logit($out,$level,@rest)>
|
|
|
|
|
|
Internal routine to write message to both C<$out> (references to
|
|
|
filehandle) and C<$::LOGFILE>, at level C<$level>, of concatenated items
|
|
|
in C<@rest>. If the log file is not initialized yet, the message is
|
|
|
saved to be logged later (unless the log file never comes into existence).
|
|
|
|
|
|
=cut
|
|
|
|
|
|
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.
|
|
|
|
|
|
In addition to the first and second levels, this third level debugging
|
|
|
message reports messages about processing each line of any tlpdb files
|
|
|
read, and messages about files tested or matched against tlpsrc
|
|
|
patterns. This output is extremely voluminous, so unless you're
|
|
|
debugging those parts of the code, it just gets in the way.
|
|
|
|
|
|
=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_str($label, HASH)>
|
|
|
|
|
|
Return LABEL followed by HASH elements, followed by a newline, as a
|
|
|
single string. If HASH is a reference, it is followed (but no recursive
|
|
|
derefencing).
|
|
|
|
|
|
=item C<debug_hash($label, HASH)>
|
|
|
|
|
|
Write the result of C<debug_hash_str> to stderr.
|
|
|
|
|
|
=cut
|
|
|
|
|
|
sub debug_hash_str {
|
|
|
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};
|
|
|
$val = ".undef" if ! defined $val;
|
|
|
$key =~ s/\n/\\n/g;
|
|
|
$val =~ s/\n/\\n/g;
|
|
|
push (@items, "$key:$val");
|
|
|
}
|
|
|
$str .= join (",", @items);
|
|
|
$str .= "}";
|
|
|
|
|
|
return "$str\n";
|
|
|
}
|
|
|
|
|
|
sub debug_hash {
|
|
|
warn &debug_hash_str(@_);
|
|
|
}
|
|
|
|
|
|
=item C<backtrace()>
|
|
|
|
|
|
Return call(er) stack, as a string.
|
|
|
|
|
|
=cut
|
|
|
|
|
|
sub backtrace {
|
|
|
my $ret = "";
|
|
|
|
|
|
my ($line, $subr);
|
|
|
my $stackframe = 1; # skip ourselves
|
|
|
while ((undef,$filename,$line,$subr) = caller ($stackframe)) {
|
|
|
# the undef is for the package, which is already included in $subr.
|
|
|
$ret .= " -> ${filename}:${line}: ${subr}\n";
|
|
|
$stackframe++;
|
|
|
}
|
|
|
|
|
|
return $ret;
|
|
|
}
|
|
|
|
|
|
=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;
|
|
|
}
|
|
|
}
|
|
|
|
|
|
=back
|
|
|
|
|
|
=head2 Miscellaneous
|
|
|
|
|
|
A few 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 each element in the last argument
|
|
|
@ITEMS to the $LIST referenced by the first argument, if it is not
|
|
|
already in the list.
|
|
|
|
|
|
=cut
|
|
|
|
|
|
sub push_uniq {
|
|
|
my ($l, @new_items) = @_;
|
|
|
for my $e (@new_items) {
|
|
|
# turns out this is one of the most-used functions when updating the
|
|
|
# tlpdb, with hundreds of thousands of calls. So let's write it out
|
|
|
# to eliminate the sub overhead.
|
|
|
#if (! &member($e, @$l)) {
|
|
|
if (! scalar grep($_ eq $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 should be ok, e.g.,
|
|
|
would be a creatable directory. Return 1 if ok, 0 if not.
|
|
|
|
|
|
Writable or not, we will not allow installation to the root
|
|
|
directory (Unix) or the root of a drive (Windows).
|
|
|
|
|
|
We also do not allow paths containing various special characters, and
|
|
|
print a message about this if second argument WARN is true. (We only
|
|
|
want to do this for the regular text installer, since spewing output in
|
|
|
a GUI program wouldn't be good; the generic message will have to do for
|
|
|
them.)
|
|
|
|
|
|
=cut
|
|
|
|
|
|
sub texdir_check {
|
|
|
my ($orig_texdir,$warn) = @_;
|
|
|
return 0 unless defined $orig_texdir;
|
|
|
|
|
|
# convert to absolute, for safer parsing.
|
|
|
# also replaces backslashes with slashes on w32.
|
|
|
# The return value may still contain symlinks,
|
|
|
# but no unnecessary terminating '/'.
|
|
|
my $texdir = tl_abs_path($orig_texdir);
|
|
|
return 0 unless defined $texdir;
|
|
|
|
|
|
# reject the root of a drive,
|
|
|
# assuming that only the canonical form of the root ends with /
|
|
|
return 0 if $texdir =~ m!/$!;
|
|
|
|
|
|
# Unfortunately we have lots of special characters.
|
|
|
# On Windows, backslashes are normal but will already have been changed
|
|
|
# to slashes by tl_abs_path. And we should only check for : on Unix.
|
|
|
my $colon = win32() ? "" : ":";
|
|
|
if ($texdir =~ /[,$colon;\\{}\$]/) {
|
|
|
if ($warn) {
|
|
|
print " !! TEXDIR value has problematic characters: $orig_texdir\n";
|
|
|
print " !! (such as comma, colon, semicolon, backslash, braces\n";
|
|
|
print " !! and dollar sign; sorry)\n";
|
|
|
}
|
|
|
# although we could check each character individually and give a
|
|
|
# specific error, it seems plausibly useful to report all the chars
|
|
|
# that cause problems, regardless of which was there. Simpler too.
|
|
|
return 0;
|
|
|
}
|
|
|
# w32: for now, reject the root of a samba share
|
|
|
return 0 if win32() && $texdir =~ m!^//[^/]+/[^/]+$!;
|
|
|
|
|
|
# if texdir already exists, make sure we can write into it.
|
|
|
return dir_writable($texdir) if (-d $texdir);
|
|
|
|
|
|
# if texdir doesn't exist, make sure we can write the parent.
|
|
|
(my $texdirparent = $texdir) =~ s!/[^/]*$!!;
|
|
|
#print STDERR "Checking $texdirparent".'[/]'."\n";
|
|
|
return dir_creatable($texdirparent) if -d dir_slash($texdirparent);
|
|
|
|
|
|
# ditto for the next level up the tree
|
|
|
(my $texdirpparent = $texdirparent) =~ s!/[^/]*$!!;
|
|
|
#print STDERR "Checking $texdirpparent".'[/]'."\n";
|
|
|
return dir_creatable($texdirpparent) if -d dir_slash($texdirpparent);
|
|
|
|
|
|
# doesn't look plausible.
|
|
|
return 0;
|
|
|
}
|
|
|
|
|
|
=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");
|
|
|
if ($::tldownload_server) {
|
|
|
if ($::tldownload_server->initcount() > $TeXLive::TLConfig::MaxLWPReinitCount) {
|
|
|
debug("stop retrying to initialize LWP after 10 failures\n");
|
|
|
return 0;
|
|
|
} else {
|
|
|
$::tldownload_server->reinit();
|
|
|
}
|
|
|
} else {
|
|
|
$::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;
|
|
|
}
|
|
|
|
|
|
|
|
|
=item C<< compare_tlpobjs($tlpA, $tlpB) >>
|
|
|
|
|
|
Compare the two passed L<TLPOBJ> objects. Returns a hash:
|
|
|
|
|
|
$ret{'revision'} = "revA:revB" # if revisions differ
|
|
|
$ret{'removed'} = \[ list of files removed from A to B ]
|
|
|
$ret{'added'} = \[ list of files added from A to B ]
|
|
|
|
|
|
=cut
|
|
|
|
|
|
sub compare_tlpobjs {
|
|
|
my ($tlpA, $tlpB) = @_;
|
|
|
my %ret;
|
|
|
|
|
|
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}); }
|
|
|
my @rem = sort keys %removed;
|
|
|
my @add = sort keys %added;
|
|
|
$ret{'removed'} = \@rem if @rem;
|
|
|
$ret{'added'} = \@add if @add;
|
|
|
|
|
|
return %ret;
|
|
|
}
|
|
|
|
|
|
|
|
|
=item C<< compare_tlpdbs($tlpdbA, $tlpdbB, @more_ignored_pkgs) >>
|
|
|
|
|
|
Compare the two passed L<TLPDB> objects, ignoring the packages
|
|
|
C<00texlive.installer>, C<00texlive.image>, and any passed
|
|
|
C<@more_ignore_pkgs>. Returns a hash:
|
|
|
|
|
|
$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
|
|
|
|
|
|
=cut
|
|
|
|
|
|
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 https://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;
|
|
|
}
|
|
|
|
|
|
|
|
|
=back
|
|
|
|
|
|
=head2 JSON
|
|
|
|
|
|
=over 4
|
|
|
|
|
|
=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 = "";
|
|
|
|
|
|
=pod
|
|
|
|
|
|
=item C<True()>
|
|
|
|
|
|
=item C<False()>
|
|
|
|
|
|
These two crazy functions 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);
|
|
|
}
|
|
|
|
|
|
=pod
|
|
|
|
|
|
=back
|
|
|
|
|
|
=cut
|
|
|
|
|
|
1;
|
|
|
__END__
|
|
|
|
|
|
=head1 SEE ALSO
|
|
|
|
|
|
The other modules in C<Master/tlpkg/TeXLive/> (L<TeXLive::TLConfig> and
|
|
|
the rest), and the scripts in C<Master/tlpg/bin/> (especially
|
|
|
C<tl-update-tlpdb>), the documentation in C<Master/tlpkg/doc/>, etc.
|
|
|
|
|
|
=head1 AUTHORS AND COPYRIGHT
|
|
|
|
|
|
This script and its documentation were written for the TeX Live
|
|
|
distribution (L<https://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: #
|
|
|
|
