diff options
Diffstat (limited to 'Build')
-rw-r--r-- | Build/source/texk/tests/ChangeLog | 4 | ||||
-rw-r--r-- | Build/source/texk/tests/TeXLive/TLConfig.pm | 297 | ||||
-rw-r--r-- | Build/source/texk/tests/TeXLive/TLUtils.pm | 3864 | ||||
-rw-r--r-- | Build/source/texk/tests/common-test.pl | 7 | ||||
-rwxr-xr-x | Build/source/texk/tetex/tests/updmap-cmdline-test.pl | 12 |
5 files changed, 4178 insertions, 6 deletions
diff --git a/Build/source/texk/tests/ChangeLog b/Build/source/texk/tests/ChangeLog index 6e996a57d4c..e1c3cbd0f89 100644 --- a/Build/source/texk/tests/ChangeLog +++ b/Build/source/texk/tests/ChangeLog @@ -1,3 +1,7 @@ +2011-10-02 Karl Berry <karl@tug.org> + + * TeXLive: new subdir for TL*.pm copies to be used by tests. + 2010-04-11 Karl Berry <karl@tug.org> * common-test.pl (AFMFONTS): set also. diff --git a/Build/source/texk/tests/TeXLive/TLConfig.pm b/Build/source/texk/tests/TeXLive/TLConfig.pm new file mode 100644 index 00000000000..8825b33e800 --- /dev/null +++ b/Build/source/texk/tests/TeXLive/TLConfig.pm @@ -0,0 +1,297 @@ +# $Id: TLConfig.pm 23084 2011-06-22 03:07:01Z preining $ +# TeXLive::TLConfig.pm - module exporting configuration values +# Copyright 2007, 2008, 2009, 2010, 2011 Norbert Preining +# This file is licensed under the GNU General Public License version 2 +# or any later version. + +package TeXLive::TLConfig; + +my $svnrev = '$Revision: 23084 $'; +my $_modulerevision; +if ($svnrev =~ m/: ([0-9]+) /) { + $_modulerevision = $1; +} else { + $_modulerevision = "unknown"; +} +sub module_revision { + return $_modulerevision; +} + +BEGIN { + use Exporter (); + use vars qw( @ISA @EXPORT_OK @EXPORT ); + @ISA = qw(Exporter); + @EXPORT_OK = qw( + $ReleaseYear + @MetaCategories + @NormalCategories + @Categories + $MetaCategoriesRegexp + $CategoriesRegexp + $DefaultCategory + $DefaultContainerFormat + $DefaultContainerExtension + $InfraLocation + $DatabaseName + $PackageBackupDir + $BlockSize + $Archive + $TeXLiveServerURL + $TeXLiveServerPath + $TeXLiveURL + @CriticalPackagesList + $CriticalPackagesRegexp + $WindowsMainMenuName + $RelocPrefix + $RelocTree + %TLPDBOptions + %TLPDBSettings + %TLPDBConfigs + $NetworkTimeout + ); + @EXPORT = @EXPORT_OK; +} + +# the year of our release, will be used in the location of the +# network packages, and in menu names, and other places. +$ReleaseYear = 2011; + +# users can upgrade from this year to the current year; maybe a spread +# of more than one year will be useful at some point, but not now. +$MinRelease = $ReleaseYear - 1; + +# Meta Categories do not ship files, but only call for other packages. +our @MetaCategories = qw/Collection Scheme/; +our $MetaCategoriesRegexp = '(Collection|Scheme)'; +# +# Normal Categories contain actial files and do not depend on other things. +our @NormalCategories = qw/Package TLCore ConTeXt/; +# +# list of all Categories +our @Categories = (@MetaCategories, @NormalCategories); + +# repeat, as a regexp. +our $CategoriesRegexp = '(Collection|Scheme|Package|TLCore|ConTeXt)'; + +our $DefaultCategory = "Package"; + +# location of various infra files (texlive.tlpdb, .tlpobj etc) +# relative to a root (e.g., the Master/, or the installation path) +our $InfraLocation = "tlpkg"; +our $DatabaseName = "texlive.tlpdb"; + +# location of backups in default autobackup setting (under tlpkg) +our $PackageBackupDir = "$InfraLocation/backups"; + +our $BlockSize = 4096; + +our $Archive = "archive"; +our $TeXLiveServerURL = "http://mirror.ctan.org"; +# from 2009 on we try to put them all into tlnet directly without any +# release year since we hope that we can switch over to 2010 on the fly +# our $TeXLiveServerPath = "systems/texlive/tlnet/$ReleaseYear"; +our $TeXLiveServerPath = "systems/texlive/tlnet"; +our $TeXLiveURL = "$TeXLiveServerURL/$TeXLiveServerPath"; + +# Relocatable packages. +our $RelocTree = "texmf-dist"; +our $RelocPrefix = "RELOC"; + +our @CriticalPackagesList = qw/texlive.infra/; +our $CriticalPackagesRegexp = '^(texlive\.infra)'; +if ($^O =~ /^MSWin(32|64)$/i) { + push (@CriticalPackagesList, "tlperl.win32"); + $CriticalPackagesRegexp = '^(texlive\.infra|tlperl\.win32$)'; +} + +# the way we package things on the web +our $DefaultContainerFormat = "xz"; +our $DefaultContainerExtension = "tar.$DefaultContainerFormat"; + +# archive (not user) settings. +our %TLPDBConfigs = ( + "container_split_src_files" => 1, + "container_split_doc_files" => 1, + "container_format" => $DefaultContainerFormat, + "minrelease" => $MinRelease, + "release" => $ReleaseYear, +); + +# definition of the option strings and their value types +# possible types are: +# - u: url +# - b: boolean, saved as 0/1 +# - p: path (local path) +# - n: natural number +# it allows n:[a]..[b] +# if a is empty start at -infty +# if b is empty end at +infty +# so "n:.." is equivalent to "n" + +# $TLPDBOptions{"option"}->[0] --> type +# ->[1] --> default value +# ->[2] --> tlmgr name +# ->[3] --> tlmgr description +# the "option" is the value in the TLPDB + +our %TLPDBOptions = ( + "autobackup" => + [ "n:-1..", 1, "autobackup", + "Number of backups to keep" ], + "backupdir" => + [ "p", $PackageBackupDir, "backupdir", + "Directory for backups" ], + "create_formats" => + [ "b", 1, "formats", + "Create formats on installation" ], + "desktop_integration" => + [ "b", 1, "desktop_integration", + "Create Start menu shortcuts (w32)" ], + "file_assocs" => + [ "n:0..2", 1, "fileassocs", + "Change file associations (w32)" ], + "install_docfiles" => + [ "b", 1, "docfiles", + "Install documentation files" ], + "install_srcfiles" => + [ "b", 1, "srcfiles", + "Install source files" ], + "location" => + [ "u", "__MASTER__", "repository", + "Default package repository" ], + "post_code" => + [ "b", 1, "postcode", + "Run postinst code blobs" ], + "sys_bin" => + [ "p", "/usr/local/bin", "sys_bin", + "Destination for symlinks for binaries" ], + "sys_info" => + [ "p", "/usr/local/info", "sys_info", + "Destination for symlinks for info docs" ], + "sys_man" => + [ "p", "/usr/local/man", "sys_man", + "Destination for symlinks for man pages" ], + "w32_multi_user" => + [ "b", 0, "multiuser", + "Install for all users (w32)" ], + "generate_updmap" => + [ "b", 0, "generate_updmap", + "Run tlmgr generate updmap after maps have changed" ], +); + + +our %TLPDBSettings = ( + "platform" => [ "s", "Main platform for this computer" ], + "available_architectures" => [ "l", "All available/installed architectures" ] +); + +our $WindowsMainMenuName = "TeX Live $ReleaseYear"; + +# +# timeout for network connections (wget, LWP) in seconds +our $NetworkTimeout = 30; + +1; + + +=head1 NAME + +C<TeXLive::TLConfig> -- TeX Live Configurations + +=head1 SYNOPSIS + + use TeXLive::TLConfig; + +=head1 DESCRIPTION + +The L<TeXLive::TLConfig> module contains definitions of variables +configuring all of TeX Live. + +=over 4 + +=head1 EXPORTED VARIABLES + +All of the following variables are pulled into the callers namespace, +i.e., are declared with C<EXPORT> (and C<EXPORT_OK>). + +=item C<@TeXLive::TLConfig::MetaCategories> + +The list of meta categories, i.e., those categories whose packages only +depend on other packages, but don't ship any files. Currently +C<Collection> and <Scheme>. + +=item C<@TeXLive::TLConfig::NormalCategories> + +The list of normal categories, i.e., those categories whose packages do +ship files. Currently C<TLCore>, C<Package>, C<ConTeXt>. + +=item C<@TeXLive::TLConfig::Categories> + +The list of all categories, i.e., the union of the above. + +=item C<$TeXLive::TLConfig::CategoriesRegexp> + +A regexp matching any category. + +=item C<$TeXLive::TLConfig::DefaultCategory> + +The default category used when creating new packages. + +=item C<$TeXLive::TLConfig::InfraLocation> + +The subdirectory with various infrastructure files (C<texlive.tlpdb>, +tlpobj files, ...) relative to the root of the installation; currently +C<tlpkg>. + +=item C<$TeXLive::TLConfig::BlockSize> + +The assumed block size, currently 4k. + +=item C<$TeXLive::TLConfig::Archive> +=item C<$TeXLive::TLConfig::TeXLiveURL> + +These values specify where to find packages. + +=item C<$TeXLive::TLConfig::TeXLiveServerURL> +=item C<$TeXLive::TLConfig::TeXLiveServerPath> + +C<TeXLiveURL> is concatenated from these values, with a string between. +The defaults are respectively, C<http://mirror.ctan.org> and +C<systems/texlive/tlnet/>. + +=item C<@TeXLive::TLConfig::CriticalPackagesList> +=item C<@TeXLive::TLConfig::CriticalPackagesRegexp> + +A list of all those packages which we do not update regularly since they +are too central, currently texlive.infra and (for Windows) tlperl.win32. + +=item C<$TeXLive::TLConfig::RelocTree> + +The texmf-tree name that can be relocated, defaults to C<texmf-dist>. + +=item C<$TeXLive::TLConfig::RelocPrefix> + +The string that replaces the C<RelocTree> in the tlpdb if a package is +relocated, defaults to C<RELOC>". + +=back + +=head1 SEE ALSO + +The modules L<TeXLive::TLUtils>, L<TeXLive::TLPSRC>, +L<TeXLive::TLPDB>, L<TeXLive::TLTREE>, L<TeXLive::TeXCatalogue>. + +=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: # diff --git a/Build/source/texk/tests/TeXLive/TLUtils.pm b/Build/source/texk/tests/TeXLive/TLUtils.pm new file mode 100644 index 00000000000..ea26a1ed41d --- /dev/null +++ b/Build/source/texk/tests/TeXLive/TLUtils.pm @@ -0,0 +1,3864 @@ +# $Id: TLUtils.pm 23990 2011-09-17 07:40:33Z preining $ +# TeXLive::TLUtils.pm - the inevitable utilities for TeX Live. +# Copyright 2007, 2008, 2009, 2010, 2011 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: 23990 $'; +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::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::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 + $::machinereadable + $::no_execute_actions + $::regenerate_all_formats + $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 + &dir_writable + &dir_creatable + &mkdirhier + &rmtree + © + &touch + &collapse_dirs + &removed_dirs + &install_package + &install_packages + &make_var_skeleton + &make_local_skeleton + &create_fmtutil + &create_updmap + &create_language_dat + &create_language_def + &create_language_lua + &parse_AddFormat_line + &parse_AddHyphen_line + &sort_uniq + &push_uniq + &texdir_check + &member + "ewords + "ify_path_with_spaces + &conv_to_w32_path + &native_slashify + &forward_slashify + &conv_to_w32_path + &untar + &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?)freebsd/amd64-$1freebsd/; + 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/; # alphaev56 or whatever + $CPU =~ s/powerpc64/powerpc/; # we don't distinguish ppc64 + $CPU =~ s/mips64el/mipsel/; # we don't distinguish mips64 and 32 el + + 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 never want to guess x86_64-darwin even if config.guess + # does, because Leopard can be 64-bit but our x86_64-darwin + # binaries will only run on Snow Leopard. + $CPU = "universal"; + } elsif ($CPU =~ /^i.86$/) { + $CPU = "i386"; # 586, 686, whatever + } + + unless (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', + 'alphaev5-osf' => 'DEC Alphaev5 OSF', + 'amd64-freebsd' => 'x86_64 with FreeBSD', + 'amd64-kfreebsd' => 'x86_64 with GNU/FreeBSD', + '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/FreeBSD', + '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', + '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(32|64)$/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 aleady 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($path)> + +Return C<$path> with its trailing C</component> removed. + +=cut + +sub dirname { + my $path=shift; + if (win32) { + $path=~s!\\!/!g; + } + if ($path=~m!/!) { # dirname("foo/bar/baz") -> "foo/bar" + $path=~m!(.*)/.*!; # works because of greedy matching + return $1; + } else { # dirname("ignore") -> "." + return "."; + } +} + + +=item C<basename($path)> + +Return C<$path> with any leading directory components removed. + +=cut + +sub basename { + my $path=shift; + if (win32) { + $path=~s!\\!/!g; + } + if ($path=~m!/!) { # basename("foo/bar") -> "bar" + $path=~m!.*/(.*)!; + return $1; + } else { # basename("ignore") -> "ignore" + return $path; + } +} + + +=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; + if (win32) { + $path=~s!\\!/!g; + } + $path=~/(.*)\/(.*)/; + return ("$1", "$2"); +} + + +=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 { + $path=shift; + #print STDERR "testing $path\n"; + $path =~ s!\\!/!g if win32; + $path =~ s!/$!!; + return 0 unless -d dir_slash($path); + #print STDERR "testing $path\n"; + my $i = 0; + while (-e $path . "/" . $i) { $i++; } + 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 { + $path=shift; + return 0 unless -d dir_slash($path); + $path =~ s!\\!/!g if win32; + $path =~ s!/$!!; + my $i = 0; + while (-e $path . "/" . $i) { $i++; } + 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 { + open TMP, ">>$file" && close TMP + or warn "Can't update timestamps of $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->cancel_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'}; + + &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'}; + + # 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'}; + + &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)?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/doc/info") { + $errors++ unless add_link_dir_dir("$Master/texmf/doc/info", $sys_info); + } + } elsif ($mode eq "remove") { + $errors++ unless remove_link_dir_dir($plat_bindir, $sys_bin); + if (-d "$Master/texmf/doc/info") { + $errors++ unless remove_link_dir_dir("$Master/texmf/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/doc/man") { + debug("$mode symlinks for man pages in $sys_man\n"); + my $foo = `(cd "$Master/texmf/doc/man" && echo *)`; + chomp (my @mans = split (' ', $foo)); + foreach my $m (@mans) { + my $mandir = "$Master/texmf/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<untar($tarfile, $targetdir, $remove_tarfile)> + +Unpacke 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; +} + + +# Return contents of FNAME as a string, converting all of CR, LF, and +# CRLF to just LF. +# +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"; + } + if (defined($::tldownload_server) && $::tldownload_server->enabled) { + debug("persistent connection set up, trying to get file.\n"); + if (($ret = $::tldownload_server->get_file($url, $dest))) { + debug("downloading file via permanent connection succeeded\n"); + return $ret; + } else { + tlwarn("permanent server connection set up, but downloading did not succeed!"); + tlwarn("Retrying with wget.\n"); + } + } 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"); + } + my $ret = _download_file($url, $dest, $wget); + 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=shift; + + 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. + +=cut + +sub make_local_skeleton { + my $prefix=shift; + + mkdirhier "$prefix/tex/latex/local"; + mkdirhier "$prefix/tex/plain/local"; + mkdirhier "$prefix/dvips/local"; + mkdirhier "$prefix/bibtex/bib/local"; + mkdirhier "$prefix/bibtex/bst/local"; + mkdirhier "$prefix/fonts/tfm/local"; + mkdirhier "$prefix/fonts/vf/local"; + mkdirhier "$prefix/fonts/source/local"; + mkdirhier "$prefix/fonts/type1/local"; + mkdirhier "$prefix/metapost/local"; + 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/web2c/fmtutil-hdr.cnf", $dest, + $localconf, 0, '#', \@lines); +} + +sub create_updmap { + my ($tlpdb,$dest,$localconf) = @_; + my @tlpdblines = $tlpdb->updmap_cfg_lines( + get_disabled_local_configs($localconf, '#')); + # we do not use _create_config_files here because we want to + # parse the $localconf file for the five options in updmap.cfg + #_create_config_files($tlpdb, "texmf/web2c/updmap-hdr.cfg", $dest, + # $localconf, 0, '#', \@tlpdblines); + my $headfile = "texmf/web2c/updmap-hdr.cfg"; + my $root = $tlpdb->root; + my @lines; + my @localconflines; + my %configs; + if (-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 @bla = <FOO>; + close(FOO); + for my $l (@bla) { + my ($k, $v, @rest) = split(' ', $l); + if (check_updmap_config_value($k, $v, $localconf)) { + $configs{$k} = $v; + } else { + push @localconflines, $l; + } + } + } + # + # read the -hdr file and replace the options if given in the local + # config file + open(INFILE,"<$root/$headfile") or die("Cannot open $root/$headfile"); + for my $l (<INFILE>) { + my ($k, $v, @rest) = split(' ', $l); + if (check_updmap_config_value($k, $v, "$root/$headfile")) { + if (defined($configs{$k})) { + push @lines, "$k $configs{$k}\n"; + } else { + push @lines, $l; + } + } else { + push @lines, $l; + } + } + close (INFILE); + + # add the lines from the tlpdb + push @lines, @tlpdblines; + + # add additional local config lines + push @lines, @localconflines; + + if ($#lines >= 0) { + open(OUTFILE,">$dest") + or die("Cannot open $dest for writing: $!"); + + printf OUTFILE "# Generated by %s on %s\n", "$0", scalar localtime; + print OUTFILE @lines; + close(OUTFILE) || warn "close(>$dest) failed: $!"; + } +} + +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; + } + } 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/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/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/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 (-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 the system drive (Windows). + +=cut + +sub texdir_check { + my $texdir = shift; + my $texdirparent; + my $texdirpparent; + $texdir =~ s!/$!!; # remove final slash + #print STDERR "Checking $texdir".'[/]'."\n"; + # disallow unix root + return 0 if $texdir eq ""; + # disallow w32 systemdrive root + return 0 if (win32() and $texdir eq $ENV{SystemDrive}); + + return dir_writable($texdir) if (-d dir_slash($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; + $p =~ s!/!\\!g; + # we need absolute paths, too + if ($p !~ m!^.:!) { + my $cwd = `cd`; + die "sorry, could not find current working directory via cd?!" if ! $cwd; + chomp($cwd); + $p = "$cwd\\$p"; + } + $p = quotify_path_with_spaces($p); + return($p); +} + +=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->cancel_reloc_prefix; + } + if ($tlpB->relocated) { + $tlpB->cancel_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 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 / + if (substr($path, 0, length("$db/")) eq "$db/") { + # we appended a / because otherwise "texmf" is recognized as a + # substring of "texmf-dist". + my $path='./' . substr($path, length("$db/")); + my ($dir, $file); + $_=$path; + ($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: # diff --git a/Build/source/texk/tests/common-test.pl b/Build/source/texk/tests/common-test.pl index c2ab99c78a2..b720b064988 100644 --- a/Build/source/texk/tests/common-test.pl +++ b/Build/source/texk/tests/common-test.pl @@ -3,6 +3,9 @@ # Common definitions for Perl tests in TeX Live. We want to use Perl to # have a chance of running the tests on Windows. +# absolute path +chomp (my $TL_TESTS_DIR = `cd "$srcdir/../tests" && pwd`); + # srcdir must be a sibling dir to kpathsea, e.g., web2c. $ENV{"TEXMFCNF"} = "$srcdir/../kpathsea"; $ENV{"AFMFONTS"} @@ -22,6 +25,10 @@ sub test_run { # want to run out of the build dir. I think. die "$0: no program $prog in " . `pwd` if ! -x $prog; + # use local pm files and kpsewhich. + $ENV{"PERL5LIB"} = $TL_TESTS_DIR; + $ENV{"PATH"} = "../kpathsea:$ENV{PATH}"; + # Won't be copyable with weird names, but should get the info across. print "$0: running ", $prog, join (" ", @args), "\n"; diff --git a/Build/source/texk/tetex/tests/updmap-cmdline-test.pl b/Build/source/texk/tetex/tests/updmap-cmdline-test.pl index 1fd6f4d21fe..3875fb760e6 100755 --- a/Build/source/texk/tetex/tests/updmap-cmdline-test.pl +++ b/Build/source/texk/tetex/tests/updmap-cmdline-test.pl @@ -1,5 +1,5 @@ #!/usr/bin/env perl -# $Id: bibtex-openout-test.pl 17384 2010-03-08 18:49:47Z karl $ +# $Id$ # Public domain. Originally written 2011, Karl Berry. # Check that updmap can parse various cmdline invocations. @@ -10,11 +10,11 @@ require "$srcdir/../tests/common-test.pl"; exit (&main ()); sub main { - my $ret = &test_run ("$srcdir/updmap.pl", "-n", "--quiet", - #"--enable", "Map=foo" - ); + my $ret = &test_run ("$srcdir/updmap.pl", "--version"); - # The test fails if the program succeeded. Could also check the output. - my $bad = ($ret == 0); + # we aren't going to fix this in the current updmap.pl. + # "foo", "--enable Map" + # "-n", "--quiet", + my $bad = $ret != 0; return $bad; } |