summaryrefslogtreecommitdiff
path: root/Build/source/utils/biber/TeXLive/TLUtils.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Build/source/utils/biber/TeXLive/TLUtils.pm')
-rw-r--r--Build/source/utils/biber/TeXLive/TLUtils.pm4083
1 files changed, 0 insertions, 4083 deletions
diff --git a/Build/source/utils/biber/TeXLive/TLUtils.pm b/Build/source/utils/biber/TeXLive/TLUtils.pm
deleted file mode 100644
index 8710c7b0e2a..00000000000
--- a/Build/source/utils/biber/TeXLive/TLUtils.pm
+++ /dev/null
@@ -1,4083 +0,0 @@
-# TeXLive::TLUtils.pm - the inevitable utilities for TeX Live.
-# Copyright 2007-2013 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: 30935 $';
-my $_modulerevision;
-if ($svnrev =~ m/: ([0-9]+) /) {
- $_modulerevision = $1;
-} else {
- $_modulerevision = "unknown";
-}
-sub module_revision {
- return $_modulerevision;
-}
-
-=pod
-
-=head1 NAME
-
-C<TeXLive::TLUtils> -- utilities used in the 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::get_system_tmpdir();
- TeXLive::TLUtils::tl_tmpdir();
- TeXLive::TLUtils::xchdir($dir);
- TeXLive::TLUtils::xsystem(@args);
- TeXLive::TLUtils::run_cmd($cmd);
-
-=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 [, $progs ]);
- 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,$localconf);
- TeXLive::TLUtils::create_updmap($tlpdb,$dest,$localconf);
- 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::install_package($what, $filelistref, $target, $platform);
- TeXLive::TLUtils::do_postaction($how, $tlpobj, $do_fileassocs, $do_menu, $do_desktop, $do_script);
- TeXLive::TLUtils::announce_execute_actions($how, @executes);
- TeXLive::TLUtils::add_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info);
- TeXLive::TLUtils::remove_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info);
- TeXLive::TLUtils::w32_add_to_path($bindir, $multiuser);
- TeXLive::TLUtils::w32_remove_from_path($bindir, $multiuser);
- TeXLive::TLUtils::setup_persistent_downloads();
-
-=head2 Miscellaneous
-
- TeXLive::TLUtils::sort_uniq(@list);
- TeXLive::TLUtils::push_uniq(\@list, @items);
- TeXLive::TLUtils::member($item, @list);
- TeXLive::TLUtils::merge_into(\%to, \%from);
- TeXLive::TLUtils::texdir_check($texdir);
- TeXLive::TLUtils::quotify_path_with_spaces($path);
- TeXLive::TLUtils::conv_to_w32_path($path);
- TeXLive::TLUtils::native_slashify($internal_path);
- TeXLive::TLUtils::forward_slashify($path_from_user);
- TeXLive::TLUtils::give_ctan_mirror();
- TeXLive::TLUtils::give_ctan_mirror_base();
- TeXLive::TLUtils::tlmd5($path);
- 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();
-
-=head1 DESCRIPTION
-
-=cut
-
-# avoid -warnings.
-our $PERL_SINGLE_QUOTE; # we steal code from Text::ParseWords
-use vars qw(
- $::LOGFILENAME @::LOGLINES
- @::debug_hook @::ddebug_hook @::dddebug_hook @::info_hook @::warn_hook
- @::install_packages_hook
- $::latex_updated
- $::machinereadable
- $::no_execute_actions
- $::regenerate_all_formats
- $::tex_updated
- $TeXLive::TLDownload::net_lib_avail
-);
-
-BEGIN {
- use Exporter ();
- use vars qw(@ISA @EXPORT_OK @EXPORT);
- @ISA = qw(Exporter);
- @EXPORT_OK = qw(
- &platform
- &platform_name
- &platform_desc
- &unix
- &getenv
- &which
- &get_system_tmpdir
- &dirname
- &basename
- &dirname_and_basename
- &tl_abs_path
- &dir_writable
- &dir_creatable
- &mkdirhier
- &rmtree
- &copy
- &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
- &quotewords
- &quotify_path_with_spaces
- &conv_to_w32_path
- &native_slashify
- &forward_slashify
- &untar
- &unpack
- &merge_into
- &give_ctan_mirror
- &give_ctan_mirror_base
- &create_mirror_list
- &extract_mirror_entry
- &tlmd5
- &xsystem
- &run_cmd
- &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
- &nulldev
- &get_full_line
- );
- @EXPORT = qw(setup_programs download_file process_logging_options
- tldie tlwarn info log debug ddebug dddebug debug_hash
- win32 xchdir xsystem run_cmd);
-}
-
-use Cwd;
-use Digest::MD5;
-use Getopt::Long;
-use File::Temp;
-
-use TeXLive::TLConfig;
-
-$::opt_verbosity = 0; # see process_logging_options
-
-
-=head2 Platform Detection
-
-=over 4
-
-=item C<platform>
-
-If C<$^O=~/MSWin(32|64)$/i> is true we know that we're on
-Windows and we set the global variable C<$::_platform_> to C<win32>.
-Otherwise we call C<platform_name> with the output of C<config.guess>
-as argument.
-
-The result is stored in a global variable C<$::_platform_>, and
-subsequent calls just return that value.
-
-=cut
-
-sub platform {
- unless (defined $::_platform_) {
- if ($^O =~ /^MSWin/i) {
- $::_platform_ = "win32";
- } else {
- my $config_guess = "$::installerdir/tlpkg/installer/config.guess";
-
- # We cannot rely on #! in config.guess but have to call /bin/sh
- # explicitly because sometimes the 'noexec' flag is set in
- # /etc/fstab for ISO9660 file systems.
- chomp (my $guessed_platform = `/bin/sh '$config_guess'`);
-
- # For example, if the disc or reader has hardware problems.
- die "$0: could not run $config_guess, cannot proceed, sorry"
- if ! $guessed_platform;
-
- $::_platform_ = platform_name($guessed_platform);
- }
- }
- return $::_platform_;
-}
-
-
-=item C<platform_name($canonical_host)>
-
-Convert a canonical host names as returned by C<config.guess> into
-TeX Live platform names.
-
-CPU type is determined by a regexp, and any C</^i.86/> name is replaced
-by C<i386>.
-
-For OS we need a list because what's returned is not likely to match our
-historical names, e.g., C<config.guess> returns C<linux-gnu> but we need
-C<linux>. This list might/should contain OSs which are not currently
-supported.
-
-If a particular platform is not found in this list we use the regexp
-C</.*-(.*$)/> as a last resort and hope it provides something useful.
-
-=cut
-
-sub platform_name {
- my ($guessed_platform) = @_;
-
- $guessed_platform =~ s/^x86_64-(.*-k?)(free|net)bsd/amd64-$1$2bsd/;
- my $CPU; # CPU type as reported by config.guess.
- my $OS; # O/S type as reported by config.guess.
- ($CPU = $guessed_platform) =~ s/(.*?)-.*/$1/;
- $CPU =~ s/^alpha(.*)/alpha/; # alphaev whatever
- $CPU =~ s/mips64el/mipsel/; # don't distinguish mips64 and 32 el
- $CPU =~ s/powerpc64/powerpc/; # don't distinguish ppc64
- $CPU =~ s/sparc64/sparc/; # don't distinguish sparc64
-
- # armv6l-unknown-linux-gnueabihf -> armhf-linux (RPi)
- # armv7l-unknown-linux-gnueabi -> armel-linux (Android)
- if ($CPU =~ /^arm/) {
- $CPU = $guessed_platform =~ /hf$/ ? "armhf" : "armel";
- }
-
- my @OSs = qw(aix cygwin darwin freebsd hpux irix
- kfreebsd linux netbsd openbsd solaris);
- for my $os (@OSs) {
- # Match word boundary at the beginning of the os name so that
- # freebsd and kfreebsd are distinguished.
- # Do not match word boundary at the end of the os so that
- # solaris2 is matched.
- $OS = $os if $guessed_platform =~ /\b$os/;
- }
-
- if ($OS eq "darwin") {
- # We want to guess x86_64-darwin on new-enough systems.
- # Most robust approach is to check sw_vers (os version)
- # and sysctl (processor hardware).
- chomp (my $sw_vers = `sw_vers -productVersion`);
- my ($os_major,$os_minor) = split (/\./, $sw_vers);
- #
- chomp (my $sysctl = `sysctl hw.cpu64bit_capable`);
- my (undef,$hw_64_bit) = split (" ", $sysctl);
- #
- $CPU = ($os_major >= 10 && $os_minor >= 6 && $hw_64_bit >= 1)
- ? "x86_64" : "universal";
-
- } 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 = (
- 'alpha-linux' => 'DEC Alpha with GNU/Linux',
- 'amd64-freebsd' => 'x86_64 with FreeBSD',
- 'amd64-kfreebsd' => 'x86_64 with GNU/kFreeBSD',
- 'amd64-netbsd' => 'x86_64 with NetBSD',
- 'armel-linux' => 'ARM with GNU/Linux',
- 'armhf-linux' => 'ARMhf with GNU/Linux',
- 'hppa-hpux' => 'HP-UX',
- 'i386-cygwin' => 'Intel x86 with Cygwin',
- 'i386-darwin' => 'Intel x86 with MacOSX/Darwin',
- 'i386-freebsd' => 'Intel x86 with FreeBSD',
- 'i386-kfreebsd' => 'Intel x86 with GNU/kFreeBSD',
- 'i386-openbsd' => 'Intel x86 with OpenBSD',
- 'i386-netbsd' => 'Intel x86 with NetBSD',
- 'i386-linux' => 'Intel x86 with GNU/Linux',
- 'i386-solaris' => 'Intel x86 with Solaris',
- 'mips-irix' => 'SGI IRIX',
- 'mipsel-linux' => 'MIPSel with GNU/Linux',
- 'powerpc-aix' => 'PowerPC with AIX',
- 'powerpc-darwin' => 'PowerPC with MacOSX/Darwin',
- 'powerpc-linux' => 'PowerPC with GNU/Linux',
- 'sparc-linux' => 'Sparc with GNU/Linux',
- 'sparc-solaris' => 'Sparc with Solaris',
- 'universal-darwin' => 'universal binaries for MacOSX/Darwin',
- 'win32' => 'Windows',
- 'x86_64-darwin' => 'x86_64 with MacOSX/Darwin',
- 'x86_64-linux' => 'x86_64 with GNU/Linux',
- 'x86_64-solaris' => 'x86_64 with Solaris',
- );
-
- # 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<get_system_tmpdir>
-
-Evaluate the environment variables C<TMPDIR>, C<TMP>, and C<TEMP> in
-order to find the system temporary directory.
-
-=cut
-
-sub get_system_tmpdir {
- my $systmp=0;
- $systmp||=getenv 'TMPDIR';
- $systmp||=getenv 'TMP';
- $systmp||=getenv 'TEMP';
- $systmp||='/tmp';
- return "$systmp";
-}
-
-=item C<tl_tmpdir>
-
-Create a temporary directory which is cleaned up as soon as the program
-is terminated.
-
-=cut
-
-sub tl_tmpdir {
- return (File::Temp::tempdir(CLEANUP => 1));
-}
-
-=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<xsystem(@args)>
-
-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";
- }
-}
-
-=item C<run_cmd($cmd)>
-
-runs a command and captures its output. Then returns a list with the
-output as first element and the return value (exit code) as second.
-
-=cut
-
-sub run_cmd {
- my $cmd = shift;
- my $output = `$cmd`;
- my $retval = $?;
- if ($retval != 0) {
- $retval /= 256 if $retval > 0;
- }
- return ($output, $retval);
-}
-
-
-
-
-=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 only the grandparent exists.
-
-=cut
-
-sub tl_abs_path {
- my $path = shift;
- if (win32) {
- $path=~s!\\!/!g;
- }
- my $ret;
- eval {$ret = Cwd::abs_path($path);}; # eval needed for w32
- return $ret if defined $ret;
- # $ret undefined: probably the parent does not exist.
- # But we also want an answer if only the grandparent exists.
- my ($parent, $base) = dirname_and_basename($path);
- return undef unless defined $parent;
- eval {$ret = Cwd::abs_path($parent);};
- if (defined $ret) {
- if ($ret =~ m!/$! or $base =~ m!^/!) {
- $ret = "$ret$base";
- } else {
- $ret = "$ret/$base";
- }
- return $ret;
- } else {
- my ($pparent, $pbase) = dirname_and_basename($parent);
- return undef unless defined $pparent;
- eval {$ret = Cwd::abs_path($pparent);};
- return undef unless defined $ret;
- if ($ret =~ m!/$!) {
- $ret = "$ret$pbase/$base";
- } else {
- $ret = "$ret/$pbase/$base";
- }
- return $ret;
- }
-}
-
-
-=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 =~ s!/$!!;
- #print STDERR "testing $path\n";
- my $i = 0;
- my $too_large = 100000;
- while ((-e $path . "/" . $i) and $i<$too_large) { $i++; }
- return 0 if $i>=$too_large;
- my $d = $path."/".$i;
- #print STDERR "creating $d\n";
- return 0 unless mkdir $d;
- return 0 unless -d $d;
- rmdir $d;
- return 1;
-}
-
-
-=item C<dir_writable($path)>
-
-Tests whether its argument is writable by trying to write to
-it. This function is necessary because the built-in C<-w> test just
-looks at mode and uid/guid, which on Windows always returns true and
-even on Unix is not always good enough for directories mounted from
-a fileserver.
-
-=cut
-
-# Theoretically, the test below, which uses numbers as names, might
-# lead to a race condition. OTOH, it should work even on a very
-# broken Perl.
-
-# 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=shift;
- return 0 unless -d $path;
- $path =~ s!\\!/!g if win32;
- $path =~ s!/$!!;
- my $i = 0;
- my $too_large = 100000;
- while ((-e $path . "/" . $i) and $i<$too_large) { $i++; }
- return 0 if $i>=$too_large;
- my $f = $path."/".$i;
- return 0 unless 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>.
-The optional parameter sets the permission flags.
-
-=cut
-
-sub mkdirhier {
- my ($tree,$mode) = @_;
-
- return if (-d "$tree");
- 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) {
- mkdir ($subdir, $mode)
- || die "$0: mkdir($subdir,$mode) failed, goodbye: $!\n";
- } else {
- mkdir ($subdir) || die "$0: mkdir($subdir) failed, goodbye: $!\n";
- }
- }
- }
-}
-
-
-=item C<rmtree($root, $verbose, $safe)>
-
-The C<rmtree> function provides a convenient way to delete a
-subtree from the directory structure, much like the Unix command C<rm -r>.
-C<rmtree> takes three arguments:
-
-=over 4
-
-=item *
-
-the root of the subtree to delete, or a reference to
-a list of roots. All of the files and directories
-below each root, as well as the roots themselves,
-will be deleted.
-
-=item *
-
-a boolean value, which if TRUE will cause C<rmtree> to
-print a message each time it examines a file, giving the
-name of the file, and indicating whether it's using C<rmdir>
-or C<unlink> to remove it, or that it's skipping it.
-(defaults to FALSE)
-
-=item *
-
-a boolean value, which if TRUE will cause C<rmtree> to
-skip any files to which you do not have delete access
-(if running under VMS) or write access (if running
-under another OS). This will change in the future when
-a criterion for 'delete permission' under OSs other
-than VMS is settled. (defaults to FALSE)
-
-=back
-
-It returns the number of files successfully deleted. Symlinks are
-simply deleted and not followed.
-
-B<NOTE:> There are race conditions internal to the implementation of
-C<rmtree> making it unsafe to use on directory trees which may be
-altered or moved while C<rmtree> is running, and in particular on any
-directory trees with any path components or subdirectories potentially
-writable by untrusted users.
-
-Additionally, if the third parameter is not TRUE and C<rmtree> is
-interrupted, it may leave files and directories with permissions altered
-to allow deletion (and older versions of this module would even set
-files and directories to world-read/writable!)
-
-Note also that the occurrence of errors in C<rmtree> can be determined I<only>
-by trapping diagnostic messages using C<$SIG{__WARN__}>; it is not apparent
-from the return value.
-
-=cut
-
-#taken from File/Path.pm
-#
-my $Is_VMS = $^O eq 'VMS';
-my $Is_MacOS = $^O eq 'MacOS';
-
-# These OSes complain if you want to remove a file that you have no
-# write permission to:
-my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' ||
- $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc');
-
-sub rmtree {
- my($roots, $verbose, $safe) = @_;
- my(@files);
- my($count) = 0;
- $verbose ||= 0;
- $safe ||= 0;
-
- if ( defined($roots) && length($roots) ) {
- $roots = [$roots] unless ref $roots;
- } else {
- warn "No root path(s) specified";
- return 0;
- }
-
- my($root);
- foreach $root (@{$roots}) {
- if ($Is_MacOS) {
- $root = ":$root" if $root !~ /:/;
- $root =~ s#([^:])\z#$1:#;
- } else {
- $root =~ s#/\z##;
- }
- (undef, undef, my $rp) = lstat $root or next;
- $rp &= 07777; # don't forget setuid, setgid, sticky bits
- if ( -d _ ) {
- # notabene: 0700 is for making readable in the first place,
- # it's also intended to change it to writable in case we have
- # to recurse in which case we are better than rm -rf for
- # subtrees with strange permissions
- chmod($rp | 0700, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
- or warn "Can't make directory $root read+writeable: $!"
- unless $safe;
-
- if (opendir my $d, $root) {
- no strict 'refs';
- if (!defined ${"\cTAINT"} or ${"\cTAINT"}) {
- # Blindly untaint dir names
- @files = map { /^(.*)$/s ; $1 } readdir $d;
- } else {
- @files = readdir $d;
- }
- closedir $d;
- } else {
- warn "Can't read $root: $!";
- @files = ();
- }
- # Deleting large numbers of files from VMS Files-11 filesystems
- # is faster if done in reverse ASCIIbetical order
- @files = reverse @files if $Is_VMS;
- ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS;
- if ($Is_MacOS) {
- @files = map("$root$_", @files);
- } else {
- @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files);
- }
- $count += rmtree(\@files,$verbose,$safe);
- if ($safe &&
- ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
- print "skipped $root\n" if $verbose;
- next;
- }
- chmod $rp | 0700, $root
- or warn "Can't make directory $root writeable: $!"
- if $force_writeable;
- print "rmdir $root\n" if $verbose;
- if (rmdir $root) {
- ++$count;
- } else {
- warn "Can't remove directory $root: $!";
- chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
- or warn("and can't restore permissions to "
- . sprintf("0%o",$rp) . "\n");
- }
- } else {
- if ($safe &&
- ($Is_VMS ? !&VMS::Filespec::candelete($root)
- : !(-l $root || -w $root)))
- {
- print "skipped $root\n" if $verbose;
- next;
- }
- chmod $rp | 0600, $root
- or warn "Can't make file $root writeable: $!"
- if $force_writeable;
- print "unlink $root\n" if $verbose;
- # delete all versions under VMS
- for (;;) {
- unless (unlink $root) {
- warn "Can't unlink file $root: $!";
- if ($force_writeable) {
- chmod $rp, $root
- or warn("and can't restore permissions to "
- . sprintf("0%o",$rp) . "\n");
- }
- last;
- }
- ++$count;
- last unless $Is_VMS && lstat $root;
- }
- }
- }
- $count;
-}
-
-
-=item C<copy($file, $target_dir)>
-
-=item C<copy("-f", $file, $destfile)>
-
-Copy file C<$file> to directory C<$target_dir>, or to the C<$destfile>
-in the second case. No external programs are involved. Since we need
-C<sysopen()>, the Perl module C<Fcntl.pm> is required. The time stamps
-are preserved and symlinks are created on Unix systems. On Windows,
-C<(-l $file)> will never return 'C<true>' and so symlinks will be
-(uselessly) copied as regular files.
-
-C<copy> invokes C<mkdirhier> if target directories do not exist. Files
-have mode C<0777> if they are executable and C<0666> otherwise, with
-the set bits in I<umask> cleared in each case.
-
-C<$file> can begin with a file:/ prefix.
-
-If C<$file> is not readable, we return without copying anything. (This
-can happen when the database and files are not in perfect sync.) On the
-other file, if the destination is not writable, or the writing fails,
-that is a fatal error.
-
-=cut
-
-sub copy {
- my $infile = shift;
- my $filemode = 0;
- if ($infile eq "-f") { # second argument is a file
- $filemode = 1;
- $infile = shift;
- }
- my $destdir=shift;
-
- my $outfile;
- my @stat;
- my $mode;
- my $buffer;
- my $offset;
- my $filename;
- my $dirmode = 0755;
- my $blocksize = $TeXLive::TLConfig::BlockSize;
-
- $infile =~ s!^file://*!/!i; # remove file:/ url prefix
- $filename = basename "$infile";
- if ($filemode) {
- # given a destination file
- $outfile = $destdir;
- $destdir = dirname($outfile);
- } else {
- $outfile = "$destdir/$filename";
- }
-
- mkdirhier ($destdir) unless -d "$destdir";
-
- if (-l "$infile") {
- symlink (readlink $infile, "$destdir/$filename");
- } 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";
-
- while ($read = sysread (IN, $buffer, $blocksize)) {
- die "read($infile) failed: $!\n" 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");
- utime ($stat[8], $stat[9], $outfile);
- }
-}
-
-
-=item C<touch(@files)>
-
-Update modification and access time of C<@files>. Non-existent files
-are created.
-
-=cut
-
-sub touch {
- my @files=@_;
-
- foreach my $file (@_) {
- if (-e $file) {
- utime time, time, $file;
- } else {
- if (open( TMP, ">$file")) {
- close(TMP);
- } else {
- warn "Can't create file $file: $!\n";
- }
- }
- }
-}
-
-
-
-
-
-=item C<collapse_dirs(@files)>
-
-Return a (more or less) minimal list of directories and files, given an
-original list of files C<@files>. That is, if every file within a given
-directory is included in C<@files>, replace all of those files with the
-absolute directory name in the return list. Any files which have
-sibling files not included are retained and made absolute.
-
-We try to walk up the tree so that the highest-level directory
-containing only directories or files that are in C<@files> is returned.
-(This logic may not be perfect, though.)
-
-This is not just a string function; we check for other directory entries
-existing on disk within the directories of C<@files>. Therefore, if the
-entries are relative pathnames, the current directory must be set by the
-caller so that file tests work.
-
-As mentioned above, the returned list is absolute paths to directories
-and files.
-
-For example, suppose the input list is
-
- dir1/subdir1/file1
- dir1/subdir2/file2
- dir1/file3
-
-If there are no other entries under C<dir1/>, the result will be
-C</absolute/path/to/dir1>.
-
-=cut
-
-sub collapse_dirs {
- my (@files) = @_;
- my @ret = ();
- my %by_dir;
-
- # construct hash of all directories mentioned, values are lists of the
- # files in that directory.
- for my $f (@files) {
- my $abs_f = Cwd::abs_path ($f);
- die ("oops, no abs_path($f) from " . `pwd`) unless $abs_f;
- (my $d = $abs_f) =~ s,/[^/]*$,,;
- my @a = exists $by_dir{$d} ? @{$by_dir{$d}} : ();
- push (@a, $abs_f);
- $by_dir{$d} = \@a;
- }
-
- # for each of our directories, see if we are given everything in
- # the directory. if so, return the directory; else return the
- # individual files.
- for my $d (sort keys %by_dir) {
- opendir (DIR, $d) || die "opendir($d) failed: $!";
- my @dirents = readdir (DIR);
- closedir (DIR) || warn "closedir($d) failed: $!";
-
- # initialize test hash with all the files we saw in this dir.
- # (These idioms are due to "Finding Elements in One Array and Not
- # Another" in the Perl Cookbook.)
- my %seen;
- my @rmfiles = @{$by_dir{$d}};
- @seen{@rmfiles} = ();
-
- # see if everything is the same.
- my $ok_to_collapse = 1;
- for my $dirent (@dirents) {
- next if $dirent =~ /^\.(\.|svn)?$/; # ignore . .. .svn
-
- my $item = "$d/$dirent"; # prepend directory for comparison
- if (! exists $seen{$item}) {
- $ok_to_collapse = 0;
- last; # no need to keep looking after the first.
- }
- }
-
- push (@ret, $ok_to_collapse ? $d : @{$by_dir{$d}});
- }
-
- if (@ret != @files) {
- @ret = &collapse_dirs (@ret);
- }
- return @ret;
-}
-
-=item C<removed_dirs(@files)>
-
-returns all the directories from which all content will be removed
-
-=cut
-
-# return all the directories from which all content will be removed
-#
-# idea:
-# - create a hashes by_dir listing all files that should be removed
-# by directory, i.e., key = dir, value is list of files
-# - for each of the dirs (keys of by_dir and ordered deepest first)
-# check that all actually contained files are removed
-# and all the contained dirs are in the removal list. If this is the
-# case put that directory into the removal list
-# - return this removal list
-#
-sub removed_dirs {
- my (@files) = @_;
- my %removed_dirs;
- my %by_dir;
-
- # construct hash of all directories mentioned, values are lists of the
- # files/dirs in that directory.
- for my $f (@files) {
- # what should we do with not existing entries????
- next if (! -r "$f");
- my $abs_f = Cwd::abs_path ($f);
- # the following is necessary because on win32,
- # abs_path("tl-portable")
- # returns
- # c:\tl test\...
- # and not forward slashes, while, if there is already a forward /
- # in the path, also the rest is done with forward slashes.
- $abs_f =~ s!\\!/!g if win32();
- if (!$abs_f) {
- warn ("oops, no abs_path($f) from " . `pwd`);
- next;
- }
- (my $d = $abs_f) =~ s,/[^/]*$,,;
- my @a = exists $by_dir{$d} ? @{$by_dir{$d}} : ();
- push (@a, $abs_f);
- $by_dir{$d} = \@a;
- }
-
- # for each of our directories, see if we are removing everything in
- # the directory. if so, return the directory; else return the
- # individual files.
- for my $d (reverse sort keys %by_dir) {
- opendir (DIR, $d) || die "opendir($d) failed: $!";
- my @dirents = readdir (DIR);
- closedir (DIR) || warn "closedir($d) failed: $!";
-
- # initialize test hash with all the files we saw in this dir.
- # (These idioms are due to "Finding Elements in One Array and Not
- # Another" in the Perl Cookbook.)
- my %seen;
- my @rmfiles = @{$by_dir{$d}};
- @seen{@rmfiles} = ();
-
- # see if everything is the same.
- my $cleandir = 1;
- for my $dirent (@dirents) {
- next if $dirent =~ /^\.(\.|svn)?$/; # ignore . .. .svn
- my $item = "$d/$dirent"; # prepend directory for comparison
- if (
- ((-d $item) && (defined($removed_dirs{$item})))
- ||
- (exists $seen{$item})
- ) {
- # do nothing
- } else {
- $cleandir = 0;
- last;
- }
- }
- if ($cleandir) {
- $removed_dirs{$d} = 1;
- }
- }
- return keys %removed_dirs;
-}
-
-=item C<time_estimate($totalsize, $donesize, $starttime)>
-
-Returns the current running time and the estimated total time
-based on the total size, the already done size, and the start time.
-
-=cut
-
-sub time_estimate {
- my ($totalsize, $donesize, $starttime) = @_;
- if ($donesize <= 0) {
- return ("??:??", "??:??");
- }
- my $curtime = time();
- my $passedtime = $curtime - $starttime;
- my $esttotalsecs = int ( ( $passedtime * $totalsize ) / $donesize );
- #
- # we change the display to show that passed time instead of the
- # estimated remaining time. We keep the old code and naming and
- # only initialize the $remsecs to the $passedtime instead.
- # my $remsecs = $esttotalsecs - $passedtime;
- my $remsecs = $passedtime;
- my $min = int($remsecs/60);
- my $hour;
- if ($min >= 60) {
- $hour = int($min/60);
- $min %= 60;
- }
- my $sec = $remsecs % 60;
- $remtime = sprintf("%02d:%02d", $min, $sec);
- if ($hour) {
- $remtime = sprintf("%02d:$remtime", $hour);
- }
- my $tmin = int($esttotalsecs/60);
- my $thour;
- if ($tmin >= 60) {
- $thour = int($tmin/60);
- $tmin %= 60;
- }
- my $tsec = $esttotalsecs % 60;
- $tottime = sprintf("%02d:%02d", $tmin, $tsec);
- if ($thour) {
- $tottime = sprintf("%02d:$tottime", $thour);
- }
- return($remtime, $tottime);
-}
-
-
-=item C<install_packages($from_tlpdb, $media, $to_tlpdb, $what, $opt_src, $opt_doc)>
-
-Installs the list of packages found in C<@$what> (a ref to a list) into
-the TLPDB given by C<$to_tlpdb>. Information on files are taken from
-the TLPDB C<$from_tlpdb>.
-
-C<$opt_src> and C<$opt_doc> specify whether srcfiles and docfiles should be
-installed (currently implemented only for installation from uncompressed media).
-
-Returns 1 on success and 0 on error.
-
-=cut
-
-sub install_packages {
- my ($fromtlpdb,$media,$totlpdb,$what,$opt_src,$opt_doc) = @_;
- my $container_src_split = $fromtlpdb->config_src_container;
- my $container_doc_split = $fromtlpdb->config_doc_container;
- my $root = $fromtlpdb->root;
- my @packs = @$what;
- my $totalnr = $#packs + 1;
- my $td = length("$totalnr");
- my $n = 0;
- my %tlpobjs;
- my $totalsize = 0;
- my $donesize = 0;
- my %tlpsizes;
- foreach my $p (@packs) {
- $tlpobjs{$p} = $fromtlpdb->get_package($p);
- if (!defined($tlpobjs{$p})) {
- die "STRANGE: $p not to be found in ", $fromtlpdb->root;
- }
- if ($media ne 'local_uncompressed') {
- # we use the container size as the measuring unit since probably
- # downloading will be the limiting factor
- $tlpsizes{$p} = $tlpobjs{$p}->containersize;
- $tlpsizes{$p} += $tlpobjs{$p}->srccontainersize if $opt_src;
- $tlpsizes{$p} += $tlpobjs{$p}->doccontainersize if $opt_doc;
- } else {
- # we have to add the respective sizes, that is checking for
- # installation of src and doc file
- $tlpsizes{$p} = $tlpobjs{$p}->runsize;
- $tlpsizes{$p} += $tlpobjs{$p}->srcsize if $opt_src;
- $tlpsizes{$p} += $tlpobjs{$p}->docsize if $opt_doc;
- my %foo = %{$tlpobjs{$p}->binsize};
- for my $k (keys %foo) { $tlpsizes{$p} += $foo{$k}; }
- # all the packages sizes are in blocks, so transfer that to bytes
- $tlpsizes{$p} *= $TeXLive::TLConfig::BlockSize;
- }
- $totalsize += $tlpsizes{$p};
- }
- my $starttime = time();
- foreach my $package (@packs) {
- my $tlpobj = $tlpobjs{$package};
- my $reloc = $tlpobj->relocated;
- $n++;
- my ($estrem, $esttot) = time_estimate($totalsize, $donesize, $starttime);
- my $infostr = sprintf("Installing [%0${td}d/$totalnr, "
- . "time/total: $estrem/$esttot]: $package [%dk]",
- $n, int($tlpsizes{$package}/1024) + 1);
- info("$infostr\n");
- foreach my $h (@::install_packages_hook) {
- &$h($n,$totalnr);
- }
- my $real_opt_doc = $opt_doc;
- my $container;
- my @installfiles;
- push @installfiles, $tlpobj->runfiles;
- push @installfiles, $tlpobj->allbinfiles;
- push @installfiles, $tlpobj->srcfiles if ($opt_src);
- push @installfiles, $tlpobj->docfiles if ($real_opt_doc);
- if ($media eq 'local_uncompressed') {
- $container = [ $root, @installfiles ];
- } elsif ($media eq 'local_compressed') {
- if (-r "$root/$Archive/$package.zip") {
- $container = "$root/$Archive/$package.zip";
- } elsif (-r "$root/$Archive/$package.tar.xz") {
- $container = "$root/$Archive/$package.tar.xz";
- } else {
- tlwarn("No package $package (.zip or .xz) in $root/$Archive\n");
- next;
- }
- } elsif ($media eq 'NET') {
- $container = "$root/$Archive/$package.$DefaultContainerExtension";
- }
- if (!install_package($container, $reloc, $tlpobj->containersize,
- $tlpobj->containermd5, \@installfiles,
- $totlpdb->root, $vars{'this_platform'})) {
- # we already warn in install_package that something bad happened,
- # so only return here
- return 0;
- }
- # if we are installing from compressed media we have to fetch the respective
- # source and doc packages $pkg.source and $pkg.doc and install them, too
- if (($media eq 'NET') || ($media eq 'local_compressed')) {
- # we install split containers under the following conditions:
- # - the container were split generated
- # - src/doc files should be installed
- # (- the package is not already a split one (like .i386-linux))
- # the above test has been removed since that would mean that packages
- # with a dot like texlive.infra will never have the docfiles installed
- # that is already happening ...bummer. But since we already check
- # whether there are src/docfiles present at all that is fine
- # - there are actually src/doc files present
- if ($container_src_split && $opt_src && $tlpobj->srcfiles) {
- my $srccontainer = $container;
- $srccontainer =~ s/(\.tar\.xz|\.zip)$/.source$1/;
- if (!install_package($srccontainer, $reloc, $tlpobj->srccontainersize,
- $tlpobj->srccontainermd5, \@installfiles,
- $totlpdb->root, $vars{'this_platform'})) {
- return 0;
- }
- }
- if ($container_doc_split && $real_opt_doc && $tlpobj->docfiles) {
- my $doccontainer = $container;
- $doccontainer =~ s/(\.tar\.xz|\.zip)$/.doc$1/;
- if (!install_package($doccontainer, $reloc,
- $tlpobj->doccontainersize,
- $tlpobj->doccontainermd5, \@installfiles,
- $totlpdb->root, $vars{'this_platform'})) {
- return 0;
- }
- }
- }
- # we don't want to have wrong information in the tlpdb, so remove the
- # src/doc files if they are not installed ...
- if (!$opt_src) {
- $tlpobj->clear_srcfiles;
- }
- if (!$real_opt_doc) {
- $tlpobj->clear_docfiles;
- }
- # if a package is relocatable we have to cancel the reloc prefix
- # before we save it to the local tlpdb
- if ($tlpobj->relocated) {
- $tlpobj->replace_reloc_prefix;
- }
- $totlpdb->add_tlpobj($tlpobj);
- # we have to write out the tlpobj file since it is contained in the
- # archives (.tar.xz) but at uncompressed-media install time we don't have them
- my $tlpod = $totlpdb->root . "/tlpkg/tlpobj";
- mkdirhier( $tlpod );
- open(TMP,">$tlpod/".$tlpobj->name.".tlpobj") ||
- die "$0: open tlpobj " . $tlpobj->name . "failed: $!";
- $tlpobj->writeout(\*TMP);
- close(TMP);
- $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<install_package($what, $reloc, $size, $md5, $filelistref, $target, $platform)>
-
-This function installs the files given in @$filelistref from C<$what>
-into C<$target>.
-
-C<$size> gives the size in bytes of the container, or -1 if we are
-installing from uncompressed media, i.e., from a list of files to be copied.
-
-If C<$what> is a reference to a list of files then these files are
-assumed to be readable and are copied to C<$target>, creating dirs on
-the way. In this case the list C<@$filelistref> is not taken into
-account.
-
-If C<$what> starts with C<http://> or C<ftp://> then C<$what> is
-downloaded from the net and piped through C<xzdec> and C<tar>.
-
-If $what ends with C<.tar.xz> (but does not start with C<http://> or
-C<ftp://>, but possibly with C<file:/>) it is assumed to be a readable
-file on the system and is likewise piped through C<xzdec> and C<tar>.
-
-In both of these cases currently the list C<$@filelistref> currently
-is not taken into account (should be fixed!).
-
-if C<$reloc> is true the container (NET or local_compressed mode) is packaged in a way
-that the initial texmf-dist is missing.
-
-Returns 1 on success and 0 on error.
-
-=cut
-
-sub install_package {
- my ($what, $reloc, $whatsize, $whatmd5, $filelistref, $target, $platform) = @_;
-
- my @filelist = @$filelistref;
-
- my $tempdir = "$target/temp";
-
- # we assume that $::progs has been set up!
- my $wget = $::progs{'wget'};
- my $xzdec = quotify_path_with_spaces($::progs{'xzdec'});
- if (!defined($wget) || !defined($xzdec)) {
- tlwarn("install_package: wget/xzdec programs not set up properly.\n");
- return 0;
- }
- if (ref $what) {
- # we are getting a ref to a list of files, so install from uncompressed media
- my ($root, @files) = @$what;
- foreach my $file (@files) {
- # @what is taken, not @filelist!
- # is this still needed?
- my $dn=dirname($file);
- mkdirhier("$target/$dn");
- copy "$root/$file", "$target/$dn";
- }
- } elsif ($what =~ m,\.tar.xz$,) {
- # this is the case when we install from compressed media
- #
- # in all other cases we create temp files .tar.xz (or use the present
- # one), xzdec them, and then call tar
-
- # if we are unpacking a relocated container we adjust the target
- if ($reloc) {
- $target .= "/$TeXLive::TLConfig::RelocTree" if $reloc;
- mkdir($target) if (! -d $target);
- }
-
- my $fn = basename($what);
- my $pkg = $fn;
- $pkg =~ s/\.tar\.xz$//;
- mkdirhier("$tempdir");
- my $xzfile = "$tempdir/$fn";
- my $tarfile = "$tempdir/$fn"; $tarfile =~ s/\.xz$//;
- my $xzfile_quote = $xzfile;
- my $tarfile_quote = $tarfile;
- if (win32()) {
- $xzfile =~ s!/!\\!g;
- $tarfile =~ s!/!\\!g;
- $target =~ s!/!\\!g;
- }
- $xzfile_quote = "\"$xzfile\"";
- $tarfile_quote = "\"$tarfile\"";
- my $gotfiledone = 0;
- if (-r $xzfile) {
- # check that the downloaded file is not partial
- if ($whatsize >= 0) {
- # we have the size given, so check that first
- my $size = (stat $xzfile)[7];
- if ($size == $whatsize) {
- # we want to check also the md5sum if we have it present
- if ($whatmd5) {
- if (tlmd5($xzfile) eq $whatmd5) {
- $gotfiledone = 1;
- } else {
- tlwarn("Downloaded $what, size equal, but md5sum differs;\n",
- "downloading again.\n");
- }
- } else {
- # size ok, no md5sum
- tlwarn("Downloaded $what, size equal, but no md5sum available;\n",
- "continuing, with fingers crossed.");
- $gotfiledone = 1;
- }
- } else {
- tlwarn("Partial download of $what found, removing it.\n");
- unlink($tarfile, $xzfile);
- }
- } else {
- # ok no size information, hopefully we have md5 sums
- if ($whatmd5) {
- if (tlmd5($xzfile) eq $whatmd5) {
- $gotfiledone = 1;
- } else {
- tlwarn("Downloaded file, but md5sum differs, removing it.\n");
- }
- } else {
- tlwarn("Container found, but cannot verify size of md5sum;\n",
- "continuing, with fingers crossed.\n");
- $gotfiledone = 1;
- }
- }
- debug("Reusing already downloaded container $xzfile\n")
- if ($gotfiledone);
- }
- if (!$gotfiledone) {
- if ($what =~ m,http://|ftp://,) {
- # we are installing from the NET
- # download the file and put it into temp
- if (!download_file($what, $xzfile) || (! -r $xzfile)) {
- tlwarn("Downloading $what did not succeed.\n");
- return 0;
- }
- } else {
- # we are installing from local compressed media
- # copy it to temp
- copy($what, $tempdir);
- }
- }
- debug("un-xzing $xzfile to $tarfile\n");
- system("$xzdec < $xzfile_quote > $tarfile_quote");
- if (! -f $tarfile) {
- tlwarn("Unpacking $xzfile did not succeed.\n");
- return 0;
- }
- if (!TeXLive::TLUtils::untar($tarfile, $target, 1)) {
- tlwarn("untarring $tarfile failed, stopping install.\n");
- return 0;
- }
- # we remove the created .tlpobj it is recreated anyway in
- # install_packages above in the right place. This way we also
- # get rid of the $pkg.source.tlpobj which are useless
- unlink ("$target/tlpkg/tlpobj/$pkg.tlpobj")
- if (-r "$target/tlpkg/tlpobj/$pkg.tlpobj");
- if ($what =~ m,http://|ftp://,) {
- # we downloaded the original .tar.lzma from the net, so we keep it
- } else {
- # we are downloading it from local compressed media, so we can unlink it to save
- # disk space
- unlink($xzfile);
- }
- } else {
- tlwarn("Sorry, no idea how to install $what\n");
- return 0;
- }
- 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*(http://|ftp://)!) {
- $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)>
-
-Announces that the actions given in C<$tlpobj> should be executed
-after all packages have been unpacked.
-
-=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 "latex-updated")) {
- $::latex_updated = 1;
- return;
- }
- if (defined($type) && ($type eq "tex-updated")) {
- $::tex_updated = 1;
- 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) = @_;
- mkdirhier $to;
- if (-w $to) {
- debug("linking files from $from to $to\n");
- chomp (@files = `ls "$from"`);
- my $ret = 1;
- for my $f (@files) {
- # skip certain dangerous entries that should never be linked somewhere
- if ($f eq "man") {
- debug("not linking man into $to.\n");
- next;
- }
- unlink("$to/$f");
- if (system("ln -s \"$from/$f\" \"$to\"")) {
- tlwarn("Linking $f from $from to $to failed: $!\n");
- $ret = 0;
- }
- }
- return $ret;
- } else {
- tlwarn("destination $to not writable, no linking files in $from done.\n");
- return 0;
- }
-}
-
-sub remove_link_dir_dir {
- my ($from, $to) = @_;
- if ((-d "$to") && (-w "$to")) {
- debug("removing links from $from to $to\n");
- chomp (@files = `ls "$from"`);
- my $ret = 1;
- foreach my $f (@files) {
- next if (! -r "$to/$f");
- if ($f eq "man") {
- debug("not considering man in $to, it should not be from us!\n");
- next;
- }
- if ((-l "$to/$f") &&
- (readlink("$to/$f") =~ m;^$from/;)) {
- $ret = 0 unless unlink("$to/$f");
- } else {
- $ret = 0;
- tlwarn ("not removing $to/$f, not a link or wrong destination!\n");
- }
- }
- # trry to remove the destination directory, it might be empty and
- # we might have write permissions, ignore errors
- # `rmdir "$to" 2>/dev/null`;
- return $ret;
- } else {
- tlwarn ("destination $to not writable, no removal of links done!\n");
- return 0;
- }
-}
-
-sub add_remove_symlinks {
- my ($mode, $Master, $arch, $sys_bin, $sys_man, $sys_info) = @_;
- my $errors = 0;
- my $plat_bindir = "$Master/bin/$arch";
- return if win32();
- if ($mode eq "add") {
- $errors++ unless add_link_dir_dir($plat_bindir, $sys_bin);
- if (-d "$Master/texmf-dist/doc/info") {
- $errors++
- unless add_link_dir_dir("$Master/texmf-dist/doc/info", $sys_info);
- }
- } elsif ($mode eq "remove") {
- $errors++ unless remove_link_dir_dir($plat_bindir, $sys_bin);
- if (-d "$Master/texmf-dist/doc/info") {
- $errors++
- unless remove_link_dir_dir("$Master/texmf-dist/doc/info", $sys_info);
- }
- } else {
- die ("should not happen, unknown mode $mode in add_remove_symlinks!");
- }
- mkdirhier $sys_man if ($mode eq "add");
- if (-w $sys_man && -d "$Master/texmf-dist/doc/man") {
- debug("$mode symlinks for man pages in $sys_man\n");
- my $foo = `(cd "$Master/texmf-dist/doc/man" && echo *)`;
- chomp (my @mans = split (' ', $foo));
- foreach my $m (@mans) {
- my $mandir = "$Master/texmf-dist/doc/man/$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("destination of man symlink $sys_man not writable, "
- . "cannot $mode symlinks.\n");
- $errors++;
- }
- # we collected errors in $ret, so return the negation of it
- if ($errors) {
- info("$mode of symlinks failed $errors times, please see above messages.\n");
- return 0;
- } else {
- return 1;
- }
-}
-
-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<unpack($what, $targetdir>
-
-If necessary, downloads C$what>, and then unpacks it into C<$targetdir>.
-Returns the name of the unpacked package (determined from the name of C<$what>)
-in case of success, otherwise undefined.
-
-=cut
-
-sub unpack {
- my ($what, $target) = @_;
-
- if (!defined($what)) {
- tlwarn("TLUtils::unpack: nothing to unpack!\n");
- return;
- }
-
- # we assume that $::progs has been set up!
- my $wget = $::progs{'wget'};
- my $xzdec = TeXLive::TLUtils::quotify_path_with_spaces($::progs{'xzdec'});
- if (!defined($wget) || !defined($xzdec)) {
- tlwarn("_install_package: programs not set up properly, strange.\n");
- return;
- }
-
- my $type;
- if ($what =~ m,\.tar(\.xz)?$,) {
- $type = defined($what) ? "xz" : "tar";
- } else {
- tlwarn("TLUtils::unpack: don't know how to unpack this: $what\n");
- return;
- }
-
- my $tempdir = tl_tmpdir();
-
- # we are still here, so something was handed in and we have either .tar or .tar.xz
- my $fn = basename($what);
- my $pkg = $fn;
- $pkg =~ s/\.tar(\.xz)?$//;
- my $tarfile;
- my $remove_tarfile = 1;
- if ($type eq "xz") {
- my $xzfile = "$tempdir/$fn";
- $tarfile = "$tempdir/$fn"; $tarfile =~ s/\.xz$//;
- my $xzfile_quote = $xzfile;
- my $tarfile_quote = $tarfile;
- my $target_quote = $target;
- if (win32()) {
- $xzfile =~ s!/!\\!g;
- $tarfile =~ s!/!\\!g;
- $target =~ s!/!\\!g;
- }
- $xzfile_quote = "\"$xzfile\"";
- $tarfile_quote = "\"$tarfile\"";
- $target_quote = "\"$target\"";
- if ($what =~ m,http://|ftp://,) {
- # we are installing from the NET
- # download the file and put it into temp
- if (!download_file($what, $xzfile) || (! -r $xzfile)) {
- tlwarn("Downloading \n");
- tlwarn(" $what\n");
- tlwarn("did not succeed, please retry.\n");
- unlink($tarfile, $xzfile);
- return;
- }
- } else {
- # we are installing from local compressed files
- # copy it to temp
- TeXLive::TLUtils::copy($what, $tempdir);
- }
- debug("un-xzing $xzfile to $tarfile\n");
- system("$xzdec < $xzfile_quote > $tarfile_quote");
- if (! -f $tarfile) {
- tlwarn("TLUtils::unpack: Unpacking $xzfile failed, please retry.\n");
- unlink($tarfile, $xzfile);
- return;
- }
- unlink($xzfile);
- } else {
- $tarfile = "$tempdir/$fn";
- if ($what =~ m,http://|ftp://,) {
- if (!download_file($what, $tarfile) || (! -r $tarfile)) {
- tlwarn("Downloading \n");
- tlwarn(" $what\n");
- tlwarn("failed, please retry.\n");
- unlink($tarfile);
- return;
- }
- } else {
- $tarfile = $what;
- $remove_tarfile = 0;
- }
- }
- if (untar($tarfile, $target, $remove_tarfile)) {
- return "$pkg";
- } else {
- return;
- }
-}
-
-=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
- if (system($tar, win32() ? "xmf" : "xf", $tarfile) != 0) {
- tlwarn("untar: untarring $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)>
-
-Populate the global C<$::progs> hash containing the paths to the
-programs C<wget>, C<tar>, C<xzdec>. The C<$bindir> argument specifies
-the path to the location of the C<xzdec> 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.)
-
-Return 0 if failure, nonzero if success.
-
-=cut
-
-sub setup_programs {
- my ($bindir, $platform) = @_;
- my $ok = 1;
-
- $::progs{'wget'} = "wget";
- $::progs{'xzdec'} = "xzdec";
- $::progs{'xz'} = "xz";
- $::progs{'tar'} = "tar";
-
- if ($^O =~ /^MSWin(32|64)$/i) {
- $::progs{'wget'} = conv_to_w32_path("$bindir/wget/wget.exe");
- $::progs{'tar'} = conv_to_w32_path("$bindir/tar.exe");
- $::progs{'xzdec'} = conv_to_w32_path("$bindir/xz/xzdec.exe");
- $::progs{'xz'} = conv_to_w32_path("$bindir/xz/xz.exe");
- for my $prog ("xzdec", "wget") {
- my $opt = $prog eq "xzdec" ? "--help" : "--version";
- my $ret = system("$::progs{$prog} $opt >nul 2>&1"); # on windows
- if ($ret != 0) {
- warn "TeXLive::TLUtils::setup_programs (w32) failed"; # no nl for perl
- warn "$::progs{$prog} $opt failed (status $ret): $!\n";
- warn "Output is:\n";
- system ("$::progs{$prog} $opt");
- warn "\n";
- $ok = 0;
- }
- }
- } else {
- 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();
- }
- my $s = 0;
- $s += setup_unix_one('wget', "$bindir/wget/wget.$platform", "--version");
- $s += setup_unix_one('xzdec',"$bindir/xz/xzdec.$platform","--help");
- $s += setup_unix_one('xz', "$bindir/xz/xz.$platform", "notest");
- $ok = ($s == 3); # failure return unless all are present.
- }
-
- return $ok;
-}
-
-
-# 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 copy is not executable, GOTO fallback
-# - if the shipped one is not -x, copy it, set -x
-# . if the copy is -x and executable, use it
-# . if the copy is not executable, GOTO fallback
-# - if nothing shipped, GOTO fallback
-#
-# fallback:
-# if prog is found in PATH and can be executed, use it.
-#
-# Return 0 if failure, 1 if success.
-#
-sub setup_unix_one {
- my ($p, $def, $arg) = @_;
- our $tmp;
- my $test_fallback = 0;
- if (-r $def) {
- my $ready = 0;
- if (-x $def) {
- # checking only for the executable bit is not enough, we have
- # to check for actualy "executability" since a "noexec" mount
- # option may interfere, which is not taken into account by
- # perl's -x test.
- $::progs{$p} = $def;
- if ($arg ne "notest") {
- my $ret = system("$def $arg > /dev/null 2>&1" ); # we are on Unix
- if ($ret == 0) {
- $ready = 1;
- debug("Using shipped $def for $p (tested).\n");
- } else {
- ddebug("Shipped $def has -x but cannot be executed.\n");
- }
- } else {
- # do not test, just return
- $ready = 1;
- debug("Using shipped $def for $p (not tested).\n");
- }
- }
- if (!$ready) {
- # 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);
- $::progs{$p} = "$tmp/$bn";
- chmod(0755,$::progs{$p});
- # 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 $::progs{$p}) {
- # hmm, something is going really bad, not even the copy is
- # executable. Fall back to normal path element
- $test_fallback = 1;
- ddebug("Copied $p $::progs{$p} does not have -x bit, strange!\n");
- } else {
- # check again for executability
- if ($arg ne "notest") {
- my $ret = system("$::progs{$p} $arg > /dev/null 2>&1");
- if ($ret == 0) {
- # ok, the copy works
- debug("Using copied $::progs{$p} for $p (tested).\n");
- } else {
- # even the copied prog is not executable, strange
- $test_fallback = 1;
- ddebug("Copied $p $::progs{$p} has x bit but not executable, strange!\n");
- }
- } else {
- debug("Using copied $::progs{$p} for $p (not tested).\n");
- }
- }
- }
- } else {
- # hope that we can find in in the global PATH
- $test_fallback = 1;
- }
- if ($test_fallback) {
- # all our playing around and copying did not succeed, try the
- # fallback
- $::progs{$p} = $p;
- if ($arg ne "notest") {
- my $ret = system("$p $arg > /dev/null 2>&1");
- if ($ret == 0) {
- debug("Using system $p (tested).\n");
- } else {
- tlwarn("$0: Initialization failed (in setup_unix_one):\n");
- tlwarn("$0: could not find a usable $p.\n");
- tlwarn("$0: Please install $p and try again.\n");
- return 0;
- }
- } else {
- debug ("Using system $p (not tested).\n");
- }
- }
- return 1;
-}
-
-=item C<download_file( $relpath, $destination [, $progs ] )>
-
-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.
-
-The optional argument C<$progs> is a reference to a hash giving full
-paths to the respective programs, at least C<wget>. If C<$progs> is not
-given the C<%::progs> hash is consulted, and if this also does not exist
-we try a literal C<wget>.
-
-Downloading honors two environment variables: 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, typically it
-would end in C<-O>. Use with care.
-
-=cut
-
-sub download_file {
- my ($relpath, $dest, $progs) = @_;
- my $wget;
- if (defined($progs) && defined($progs->{'wget'})) {
- $wget = $progs->{'wget'};
- } elsif (defined($::progs{'wget'})) {
- $wget = $::progs{'wget'};
- } else {
- tlwarn ("download_file: Programs not set up, trying literal wget\n");
- $wget = "wget";
- }
- 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 {
- my $par = dirname ($dest);
- if (-r $filetoopen) {
- copy ($filetoopen, $par);
- return 1;
- }
- return 0;
- }
- }
- if ($relpath =~ /^(http|ftp):\/\//) {
- $url = $relpath;
- } else {
- $url = "$TeXLiveURL/$relpath";
- }
-
- my $wget_retry = 0;
- if (defined($::tldownload_server) && $::tldownload_server->enabled) {
- debug("persistent connection set up, trying to get $url (for $dest)\n");
- $ret = $::tldownload_server->get_file($url, $dest);
- if ($ret) {
- debug("downloading file via persistent connection succeeded\n");
- return $ret;
- } else {
- tlwarn("TLUtils::download_file: persistent connection ok,"
- . " but download failed: $url\n");
- tlwarn("TLUtils::download_file: retrying with wget.\n");
- $wget_retry = 1; # just so we can give another msg.
- }
- } else {
- if (!defined($::tldownload_server)) {
- debug("::tldownload_server not defined\n");
- } else {
- debug("::tldownload_server->enabled is not set\n");
- }
- debug("persistent connection not set up, using wget\n");
- }
-
- # try again.
- my $ret = _download_file($url, $dest, $wget);
-
- if ($wget_retry) {
- tlwarn("TLUtils::download_file: retry with wget "
- . ($ret ? "succeeded" : "failed") . ": $url\n");
- }
-
- return($ret);
-}
-
-sub _download_file {
- my ($url, $dest, $wgetdefault) = @_;
- if (win32()) {
- $dest =~ s!/!\\!g;
- }
-
- my $wget = $ENV{"TL_DOWNLOAD_PROGRAM"} || $wgetdefault;
- my $wgetargs = $ENV{"TL_DOWNLOAD_ARGS"}
- || "--user-agent=texlive/wget --tries=10 --timeout=$NetworkTimeout -q -O";
-
- debug("downloading $url using $wget $wgetargs\n");
- my $ret;
- if ($dest eq "|") {
- open(RETFH, "$wget $wgetargs - $url|")
- || die "open($url) via $wget $wgetargs failed: $!";
- # opening to a pipe always succeeds, so we return immediately
- return \*RETFH;
- } else {
- my @wgetargs = split (" ", $wgetargs);
- $ret = system ($wget, @wgetargs, $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/dvipdfm/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, $localconf)>
-
-=item C<create_updmap($tlpdb, $dest, $localconf)>
-
-=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 (-r "$localconf") {
- open FOO, "<$localconf"
- or die "strange, -r ok but cannot open $localconf: $!";
- my @tmp = <FOO>;
- close(FOO) || warn("Closing $localconf did not succeed: $!");
- @disabled = map { if (m/^$cc!(\S+)\s*$/) { $1 } else { }} @tmp;
- }
- return @disabled;
-}
-
-sub create_fmtutil {
- my ($tlpdb,$dest,$localconf) = @_;
- my @lines = $tlpdb->fmtutil_cnf_lines(
- get_disabled_local_configs($localconf, '#'));
- _create_config_files($tlpdb, "texmf-dist/web2c/fmtutil-hdr.cnf", $dest,
- $localconf, 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) = File::Temp::tempfile(
- "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;
- open(INFILE,"<$root/$headfile") or die("Cannot open $root/$headfile");
- my @lines = <INFILE>;
- push @lines, @$tlpdblinesref;
- close (INFILE);
- 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"
- or die "strange, -r ok but cannot open $localconf: $!";
- my @tmp = <FOO>;
- close (FOO);
- push @lines, @tmp;
- }
- if (@postlines) {
- push @lines, @postlines;
- }
- if ($#lines >= 0) {
- 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;
-}
-
-
-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)=(.*)$/) {
- $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;
- }
- # should not be reached at all
- $ret{"error"} = "Unknown format directive $p";
- return %ret;
- }
- return %ret;
-}
-
-
-=back
-
-=head2 Miscellaneous
-
-Ideas from Fabrice Popineau's C<FileUtils.pm>.
-
-=over 4
-
-=item C<sort_uniq(@list)>
-
-The C<sort_uniq> function sorts the given array and throws away multiple
-occurrences of elements. It returns a sorted and unified array.
-
-=cut
-
-sub sort_uniq {
- my (@l) = @_;
- my ($e, $f, @r);
- $f = "";
- @l = sort(@l);
- foreach $e (@l) {
- if ($e ne $f) {
- $f = $e;
- push @r, $e;
- }
- }
- return @r;
-}
-
-
-=item C<push_uniq(\@list, @items)>
-
-The C<push_uniq> function pushes the last elements on the list referenced
-by the first argument.
-
-=cut
-
-sub push_uniq {
- # can't we use $l as a reference, and then use my? later ...
- local (*l, @le) = @_;
- foreach my $e (@le) {
- if (! &member($e, @l)) {
- push @l, $e;
- }
- }
-}
-
-
-=item C<member($item, @list)>
-
-The C<member> function returns true if the the first argument is contained
-in the list of the remaining arguments.
-
-=cut
-
-sub member {
- my $what = shift;
- return scalar grep($_ eq $what, @_);
-}
-
-
-=item C<merge_into(\%to, \%from)>
-
-Merges the keys of %from into %to.
-
-=cut
-
-sub merge_into {
- my ($to, $from) = @_;
- foreach my $k (keys %$from) {
- if (defined($to->{$k})) {
- push @{$to->{$k}}, @{$from->{$k}};
- } else {
- $to->{$k} = [ @{$from->{$k}} ];
- }
- }
-}
-
-
-=item C<texdir_check($texdir)>
-
-Test whether installation with TEXDIR set to $texdir would succeed due to
-writing permissions.
-
-Writable or not, we will not allow installation to the root
-directory (Unix) or the root of a drive (Windows).
-
-=cut
-
-sub texdir_check {
- my $texdir = shift;
- return 0 unless defined $texdir;
- # convert to absolute/canonical, for safer parsing
- # tl_abs_path should work as long as grandparent exists
- $texdir = tl_abs_path($texdir);
- return 0 unless defined $texdir;
- # also reject the root of a drive/volume,
- # assuming that only the canonical form of the root ends with /
- return 0 if $texdir =~ m!/$!;
- my $texdirparent;
- my $texdirpparent;
-
- return dir_writable($texdir) if (-d $texdir);
- ($texdirparent = $texdir) =~ s!/[^/]*$!!;
- #print STDERR "Checking $texdirparent".'[/]'."\n";
- return dir_creatable($texdirparent) if -d dir_slash($texdirparent);
- # try another level up the tree
- ($texdirpparent = $texdirparent) =~ s!/[^/]*$!!;
- #print STDERR "Checking $texdirpparent".'[/]'."\n";
- return dir_creatable($texdirpparent) if -d dir_slash($texdirpparent);
- return 0;
-}
-
-
-# no newlines or spaces are added, multiple args are just concatenated.
-#
-sub logit {
- my ($out, $level, @rest) = @_;
- _logit($out, $level, @rest) unless $::opt_quiet;
- _logit('file', $level, @rest);
-}
-
-sub _logit {
- my ($out, $level, @rest) = @_;
- if ($::opt_verbosity >= $level) {
- # if $out is a ref/glob to STDOUT or STDERR, print it there
- if (ref($out) eq "GLOB") {
- print $out @rest;
- } else {
- # we should log it into the logfile, but that might be not initialized
- # so either print it to the filehandle $::LOGFILE, or push it onto
- # the to be printed log lines @::LOGLINES
- if (defined($::LOGFILE)) {
- print $::LOGFILE @rest;
- } else {
- push (@::LOGLINES, join ("", @rest));
- }
- }
- }
-}
-
-
-=item C<info ($str1, $str2, ...)>
-
-Write a normal informational message, the concatenation of the argument
-strings. The message will be written unless C<-q> was specified. If
-the global C<$::machinereadable> is set (the C<--machine-readable>
-option to C<tlmgr>), then output is written to stderr, else to stdout.
-If the log file (see L<process_logging_options>) is defined, it also
-writes there.
-
-It is best to use this sparingly, mainly to give feedback during lengthy
-operations and for final results.
-
-=cut
-
-sub info {
- my $str = join("", @_);
- my $fh = ($::machinereadable ? \*STDERR : \*STDOUT);
- logit($fh, 0, $str);
- for my $i (@::info_hook) {
- &{$i}($str);
- }
-}
-
-
-=item C<debug ($str1, $str2, ...)>
-
-Write a debugging message, the concatenation of the argument strings.
-The message will be omitted unless C<-v> was specified. If the log
-file (see L<process_logging_options>) is defined, it also writes there.
-
-This first level debugging message reports on the overall flow of
-work, but does not include repeated messages about processing of each
-package.
-
-=cut
-
-sub debug {
- my $str = "D:" . join("", @_);
- return if ($::opt_verbosity < 1);
- logit(\*STDOUT, 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(\*STDOUT, 2, $str);
- for my $i (@::ddebug_hook) {
- &{$i}($str);
- }
-}
-
-=item C<dddebug ($str1, $str2, ...)>
-
-Write the deepest debugging message, the concatenation of the argument
-strings. The message will be omitted unless C<-v -v -v> was specified.
-If the log file (see L<process_logging_options>) is defined, it also
-writes there.
-
-This third level debugging message reports messages about processing
-each line of any tlpdb files read, in addition to the first and second
-levels.
-
-=cut
-
-sub dddebug {
- my $str = "DDD:" . join("", @_);
- return if ($::opt_verbosity < 3);
- logit(\*STDOUT, 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.
-
-=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, then exits with exit code 1.
-
-=cut
-
-sub tldie {
- tlwarn(@_);
- exit(1);
-}
-
-=item C<debug_hash ($label, hash))>
-
-Write LABEL followed by HASH elements, all on one line, to stderr.
-If HASH is a reference, it is followed.
-
-=cut
-
-sub debug_hash {
- my ($label) = shift;
- my (%hash) = (ref $_[0] && $_[0] =~ /.*HASH.*/) ? %{$_[0]} : @_;
-
- my $str = "$label: {";
- my @items = ();
- for my $key (sort keys %hash) {
- my $val = $hash{$key};
- $key =~ s/\n/\\n/g;
- $val =~ s/\n/\\n/g;
- push (@items, "$key:$val");
- }
- $str .= join (",", @items);
- $str .= "}";
-
- warn "$str\n";
-}
-
-
-=item C<process_logging_options ($texdir)>
-
-This function handles the common logging options for TeX Live scripts.
-It should be called before C<GetOptions> for any program-specific option
-handling. For our conventional calling sequence, see (for example) the
-L<tlpfiles> script.
-
-These are the options handled here:
-
-=over 4
-
-=item B<-q>
-
-Omit normal informational messages.
-
-=item B<-v>
-
-Include debugging messages. With one C<-v>, reports overall flow; with
-C<-v -v> (or C<-vv>), also reports per-package processing; with C<-v -v
--v> (or C<-vvv>), also reports each line read from any tlpdb files.
-Further repeats of C<-v>, as in C<-v -v -v -v>, are accepted but
-ignored. C<-vvvv> is an error.
-
-The idea behind these levels is to be able to specify C<-v> to get an
-overall idea of what is going on, but avoid terribly voluminous output
-when processing many packages, as we often are. When debugging a
-specific problem with a specific package, C<-vv> can help. When
-debugging problems with parsing tlpdb files, C<-vvv> gives that too.
-
-=item B<-logfile> I<file>
-
-Write all messages (informational, debugging, warnings) to I<file>, in
-addition to standard output or standard error. In TeX Live, only the
-installer sets a log file by default; none of the other standard TeX
-Live scripts use this feature, but you can specify it explicitly.
-
-=back
-
-See also the L<info>, L<debug>, L<ddebug>, and L<tlwarn> functions,
-which actually write the messages.
-
-=cut
-
-sub process_logging_options {
- $::opt_verbosity = 0;
- $::opt_quiet = 0;
- my $opt_logfile;
- my $opt_Verbosity = 0;
- my $opt_VERBOSITY = 0;
- # check all the command line options for occurrences of -q and -v;
- # do not report errors.
- my $oldconfig = Getopt::Long::Configure(qw(pass_through permute));
- GetOptions("logfile=s" => \$opt_logfile,
- "v+" => \$::opt_verbosity,
- "vv" => \$opt_Verbosity,
- "vvv" => \$opt_VERBOSITY,
- "q" => \$::opt_quiet);
- Getopt::Long::Configure($oldconfig);
-
- # verbosity level, forcing -v -v instead of -vv is too annoying.
- $::opt_verbosity = 2 if $opt_Verbosity;
- $::opt_verbosity = 3 if $opt_VERBOSITY;
-
- # open log file if one was requested.
- if ($opt_logfile) {
- open(TLUTILS_LOGFILE, ">$opt_logfile") || die "open(>$opt_logfile) failed: $!\n";
- $::LOGFILE = \*TLUTILS_LOGFILE;
- $::LOGFILENAME = $opt_logfile;
- }
-}
-
-=pod
-
-This function takes a single argument I<path> and returns it with
-C<"> chars surrounding it on Unix. On Windows, the C<"> chars are only
-added if I<path> a few 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 defined $pabs) {
- $pabs = $p;
- tlwarn ("sorry, could not determine absolute path of $p!\n".
- "using original path instead");
- }
- $pabs =~ s!/!\\!g;
- $pabs = quotify_path_with_spaces($pabs);
- return($pabs);
-}
-
-=pod
-
-The next two functions are meant for user input/output in installer menus.
-They help making the windows user happy by turning slashes into backslashes
-before displaying a path, and our code happy by turning backslashes into forwars
-slashes after reading a path. They both are no-ops on Unix.
-
-=cut
-
-sub native_slashify {
- my ($r) = @_;
- $r =~ s!/!\\!g if win32();
- return $r;
-}
-
-sub forward_slashify {
- my ($r) = @_;
- $r =~ s!\\!/!g if win32();
- return $r;
-}
-
-=item C<setup_persistent_downloads()>
-
-Set up to use persistent connections using LWP/TLDownload, that is look
-for a download server. Return the TLDownload object if successful, else
-false.
-
-=cut
-
-sub setup_persistent_downloads {
- if ($TeXLive::TLDownload::net_lib_avail) {
- ddebug("setup_persistent_downloads has net_lib_avail set\n");
- $::tldownload_server = TeXLive::TLDownload->new;
- if (!defined($::tldownload_server)) {
- ddebug("TLUtils:setup_persistent_downloads: failed to get ::tldownload_server\n");
- } else {
- ddebug("TLUtils:setup_persistent_downloads: got ::tldownload_server\n");
- }
- return $::tldownload_server;
- }
- return 0;
-}
-
-
-=item C<query_ctan_mirror()>
-
-Return a particular mirror given by the generic CTAN auto-redirecting
-default (specified in L<$TLConfig::TexLiveServerURL>) if we get a
-response, else the empty string.
-
-Neither C<TL_DOWNLOAD_PROGRAM> nor <TL_DOWNLOAD_ARGS> is honored (see
-L<download_file>), since certain options have to be set to do the job
-and the program has to be C<wget> since we parse the output.
-
-=cut
-
-sub query_ctan_mirror {
- my $wget = $::progs{'wget'};
- if (!defined ($wget)) {
- tlwarn("query_ctan_mirror: Programs not set up, trying wget\n");
- $wget = "wget";
- }
-
- # we need the verbose output, so no -q.
- # do not reduce retries here, but timeout still seems desirable.
- my $mirror = $TeXLiveServerURL;
- my $cmd = "$wget $mirror --timeout=$NetworkTimeout -O "
- . (win32() ? "nul" : "/dev/null") . " 2>&1";
-
- #
- # since we are reading the output of wget to find a mirror
- # we have to make sure that the locale is unset
- my $saved_lcall;
- if (defined($ENV{'LC_ALL'})) {
- $saved_lcall = $ENV{'LC_ALL'};
- }
- $ENV{'LC_ALL'} = "C";
- # we try 3 times to get a mirror from mirror.ctan.org in case we have
- # bad luck with what gets returned.
- my $max_trial = 3;
- my $mhost;
- for (my $i = 1; $i <= $max_trial; $i++) {
- my @out = `$cmd`;
- # analyze the output for the mirror actually selected.
- foreach (@out) {
- if (m/^Location: (\S*)\s*.*$/) {
- (my $mhost = $1) =~ s,/*$,,; # remove trailing slashes since we add it
- return $mhost;
- }
- }
- sleep(1);
- }
-
- # reset LC_ALL to undefined or the previous value
- if (defined($saved_lcall)) {
- $ENV{'LC_ALL'} = $saved_lcall;
- } else {
- delete($ENV{'LC_ALL'});
- }
-
- # we are still here, so three times we didn't get a mirror, give up
- # and return undefined
- return;
-}
-
-=item C<check_on_working_mirror($mirror)>
-
-Check if MIRROR is functional.
-
-=cut
-
-sub check_on_working_mirror {
- my $mirror = shift;
-
- my $wget = $::progs{'wget'};
- if (!defined ($wget)) {
- tlwarn ("check_on_working_mirror: Programs not set up, trying wget\n");
- $wget = "wget";
- }
- $wget = quotify_path_with_spaces($wget);
- #
- # the test is currently not completely correct, because we do not
- # use the LWP if it is set up for it, but I am currently too lazy
- # to program it,
- # so try wget and only check for the return value
- # please KEEP the / after $mirror, some ftp mirrors do give back
- # an error if the / is missing after ../CTAN/
- my $cmd = "$wget $mirror/ --timeout=$NetworkTimeout -O "
- . (win32() ? "nul" : "/dev/null")
- . " 2>" . (win32() ? "nul" : "/dev/null");
- my $ret = system($cmd);
- # if return value is not zero it is a failure, so switch the meanings
- return ($ret ? 0 : 1);
-}
-
-=item C<give_ctan_mirror_base()>
-
- 1. get a mirror (retries 3 times to contact mirror.ctan.org)
- - if no mirror found, use one of the backbone servers
- - if it is an http server return it (no test is done)
- - if it is a ftp server, continue
- 2. if the ftp mirror is good, return it
- 3. if the ftp mirror is bad, search for http mirror (5 times)
- 4. if http mirror is found, return it (again, no test,)
- 5. if no http mirror is found, return one of the backbone servers
-
-=cut
-
-sub give_ctan_mirror_base {
- my @backbone = qw!http://www.ctan.org/tex-archive
- http://www.tex.ac.uk/tex-archive
- http://dante.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!^http://!) { # 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!^http://!) {
- 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;
-}
-
-sub tlmd5 {
- my ($file) = @_;
- if (-r $file) {
- open(FILE, $file) || die "open($file) failed: $!";
- binmode(FILE);
- my $md5hash = Digest::MD5->new->addfile(*FILE)->hexdigest;
- close(FILE);
- return $md5hash;
- } else {
- tlwarn("tlmd5, given file not readable: $file\n");
- return "";
- }
-}
-
-#
-# compare_tlpobjs
-# returns a hash
-# $ret{'revision'} = "leftRev:rightRev" if revision differ
-# $ret{'removed'} = \[ list of files removed from A to B ]
-# $ret{'added'} = \[ list of files added from A to B ]
-#
-sub compare_tlpobjs {
- my ($tlpA, $tlpB) = @_;
- my %ret;
- my @rem;
- my @add;
-
- my $rA = $tlpA->revision;
- my $rB = $tlpB->revision;
- if ($rA != $rB) {
- $ret{'revision'} = "$rA:$rB";
- }
- if ($tlpA->relocated) {
- $tlpA->replace_reloc_prefix;
- }
- if ($tlpB->relocated) {
- $tlpB->replace_reloc_prefix;
- }
- my @fA = $tlpA->all_files;
- my @fB = $tlpB->all_files;
- my %removed;
- my %added;
- for my $f (@fA) { $removed{$f} = 1; }
- for my $f (@fB) { delete($removed{$f}); $added{$f} = 1; }
- for my $f (@fA) { delete($added{$f}); }
- @rem = sort keys %removed;
- @add = sort keys %added;
- $ret{'removed'} = \@rem if @rem;
- $ret{'added'} = \@add if @add;
- return %ret;
-}
-
-#
-# compare_tlpdbs
-# return several hashes
-# @{$ret{'removed_packages'}} = list of removed packages from A to B
-# @{$ret{'added_packages'}} = list of added packages from A to B
-# $ret{'different_packages'}->{$package} = output of compare_tlpobjs
-#
-sub compare_tlpdbs {
- my ($tlpdbA, $tlpdbB, @add_ignored_packs) = @_;
- my @ignored_packs = qw/00texlive.installer 00texlive.image/;
- push @ignored_packs, @add_ignored_packs;
-
- my @inAnotinB;
- my @inBnotinA;
- my %diffpacks;
- my %do_compare;
- my %ret;
-
- for my $p ($tlpdbA->list_packages()) {
- my $is_ignored = 0;
- for my $ign (@ignored_packs) {
- if (($p =~ m/^$ign$/) || ($p =~ m/^$ign\./)) {
- $is_ignored = 1;
- last;
- }
- }
- next if $is_ignored;
- my $tlpB = $tlpdbB->get_package($p);
- if (!defined($tlpB)) {
- push @inAnotinB, $p;
- } else {
- $do_compare{$p} = 1;
- }
- }
- $ret{'removed_packages'} = \@inAnotinB if @inAnotinB;
-
- for my $p ($tlpdbB->list_packages()) {
- my $is_ignored = 0;
- for my $ign (@ignored_packs) {
- if (($p =~ m/^$ign$/) || ($p =~ m/^$ign\./)) {
- $is_ignored = 1;
- last;
- }
- }
- next if $is_ignored;
- my $tlpA = $tlpdbA->get_package($p);
- if (!defined($tlpA)) {
- push @inBnotinA, $p;
- } else {
- $do_compare{$p} = 1;
- }
- }
- $ret{'added_packages'} = \@inBnotinA if @inBnotinA;
-
- for my $p (sort keys %do_compare) {
- my $tlpA = $tlpdbA->get_package($p);
- my $tlpB = $tlpdbB->get_package($p);
- my %foo = compare_tlpobjs($tlpA, $tlpB);
- if (keys %foo) {
- # some diffs were found
- $diffpacks{$p} = \%foo;
- }
- }
- $ret{'different_packages'} = \%diffpacks if (keys %diffpacks);
-
- return %ret;
-}
-
-sub tlnet_disabled_packages {
- my ($root) = @_;
- my $disabled_pkgs = "$root/tlpkg/dev/tlnet-disabled-packages.txt";
- my @ret;
- if (-r $disabled_pkgs) {
- open (DISABLED, "<$disabled_pkgs") || die "Huu, -r but cannot open: $?";
- while (<DISABLED>) {
- chomp;
- next if /^\s*#/;
- next if /^\s*$/;
- $_ =~ s/^\s*//;
- $_ =~ s/\s*$//;
- push @ret, $_;
- }
- close(DISABLED) || warn ("Cannot close tlnet-disabled-packages.txt: $?");
- }
- return @ret;
-}
-
-sub report_tlpdb_differences {
- my $rret = shift;
- my %ret = %$rret;
-
- if (defined($ret{'removed_packages'})) {
- info ("removed packages from A to B:\n");
- for my $f (@{$ret{'removed_packages'}}) {
- info (" $f\n");
- }
- }
- if (defined($ret{'added_packages'})) {
- info ("added packages from A to B:\n");
- for my $f (@{$ret{'added_packages'}}) {
- info (" $f\n");
- }
- }
- if (defined($ret{'different_packages'})) {
- info ("different packages from A to B:\n");
- for my $p (keys %{$ret{'different_packages'}}) {
- info (" $p\n");
- for my $k (keys %{$ret{'different_packages'}->{$p}}) {
- if ($k eq "revision") {
- info(" revision differ: $ret{'different_packages'}->{$p}->{$k}\n");
- } elsif ($k eq "removed" || $k eq "added") {
- info(" $k files:\n");
- for my $f (@{$ret{'different_packages'}->{$p}->{$k}}) {
- info(" $f\n");
- }
- } else {
- info(" unknown differ $k\n");
- }
- }
- }
- }
-}
-
-#############################################
-#
-# 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 "File \"$file\" doesn't exist.\n" 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;
-}
-
-
-=back
-=cut
-1;
-__END__
-
-=head1 SEE ALSO
-
-The modules L<TeXLive::TLPSRC>, L<TeXLive::TLPOBJ>,
-L<TeXLive::TLPDB>, L<TeXLive::TLTREE>, and the
-document L<Perl-API.txt> and the specification in the TeX Live
-repository trunk/Master/tlpkg/doc/.
-
-=head1 AUTHORS AND COPYRIGHT
-
-This script and its documentation were written for the TeX Live
-distribution (L<http://tug.org/texlive>) and both are licensed under the
-GNU General Public License Version 2 or later.
-
-=cut
-
-### Local Variables:
-### perl-indent-level: 2
-### tab-width: 2
-### indent-tabs-mode: nil
-### End:
-# vim:set tabstop=2 expandtab: #