diff options
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/TeXLive/TLUtils.pm')
-rw-r--r-- | systems/texlive/tlnet/tlpkg/TeXLive/TLUtils.pm | 97 |
1 files changed, 86 insertions, 11 deletions
diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TLUtils.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TLUtils.pm index 0f128ce8bb..16adc71ad1 100644 --- a/systems/texlive/tlnet/tlpkg/TeXLive/TLUtils.pm +++ b/systems/texlive/tlnet/tlpkg/TeXLive/TLUtils.pm @@ -1,4 +1,4 @@ -# $Id: TLUtils.pm 62112 2022-02-20 22:57:45Z preining $ +# $Id: TLUtils.pm 62822 2022-03-20 08:34:54Z siepo $ # TeXLive::TLUtils.pm - the inevitable utilities for TeX Live. # Copyright 2007-2022 Norbert Preining, Reinhard Kotucha # This file is licensed under the GNU General Public License version 2 @@ -8,7 +8,7 @@ use strict; use warnings; package TeXLive::TLUtils; -my $svnrev = '$Revision: 62112 $'; +my $svnrev = '$Revision: 62822 $'; my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown"; sub module_revision { return $_modulerevision; } @@ -40,8 +40,9 @@ C<TeXLive::TLUtils> - TeX Live infrastructure miscellany TeXLive::TLUtils::xchdir($dir); TeXLive::TLUtils::wsystem($msg,@args); TeXLive::TLUtils::xsystem(@args); - TeXLive::TLUtils::run_cmd($cmd); + TeXLive::TLUtils::run_cmd($cmd [, @envvars ]); TeXLive::TLUtils::system_pipe($prog, $infile, $outfile, $removeIn, @args); + TeXLive::TLUtils::diskfree($path); =head2 File utilities @@ -232,6 +233,7 @@ BEGIN { &xsystem &run_cmd &system_pipe + &diskfree &announce_execute_actions &add_symlinks &remove_symlinks @@ -502,7 +504,7 @@ sub platform_desc { 'amd64-midnightbsd'=> 'MidnightBSD on x86_64', 'amd64-netbsd' => 'NetBSD on x86_64', 'armel-linux' => 'GNU/Linux on ARM', - 'armhf-linux' => 'GNU/Linux on ARMv6/RPi', + 'armhf-linux' => 'GNU/Linux on RPi(32-bit) and ARMv7', 'hppa-hpux' => 'HP-UX', 'i386-cygwin' => 'Cygwin on Intel x86', 'i386-darwin' => 'MacOSX legacy (10.5-10.6) on Intel x86', @@ -731,16 +733,36 @@ sub xsystem { return $retval; } -=item C<run_cmd($cmd)> +=item C<run_cmd($cmd, @envvars)> Run shell command C<$cmd> and captures its output. Returns a list with CMD's output as the first element and the return value (exit code) as second. +If given, C<@envvars> is a list of environment variable name / value +pairs set in C<%ENV> for the call and reset to their original value (or +unset if not defined initially). + =cut sub run_cmd { my $cmd = shift; + my %envvars = @_; + my %envvarsSetState; + my %envvarsValue; + for my $k (keys %envvars) { + $envvarsSetState{$k} = exists $ENV{$k}; + $envvarsValue{$k} = $ENV{$k}; + $ENV{$k} = $envvars{$k}; + } my $output = `$cmd`; + for my $k (keys %envvars) { + if ($envvarsSetState{$k}) { + $ENV{$k} = $envvarsValue{$k}; + } else { + delete $ENV{$k}; + } + } + $output = "" if ! defined ($output); # don't return undef my $retval = $?; @@ -782,6 +804,51 @@ sub system_pipe { } } +=item C<diskfree($path)> + +If a POSIX compliant C<df> program is found, returns the number of Mb +free at C<$path>, otherwise C<-1>. If C<$path> does not exist, check +upwards for two levels for an existing parent, and if found, use it for +computing the disk space. + +=cut + +sub diskfree { + my $td = shift; + return (-1) if (! $::progs{"df"}); + # drop final / + $td =~ s!/$!!; + if (! -e $td) { + my $ptd = dirname($td); + if (-e $ptd) { + $td = $ptd; + } else { + my $pptd = dirname($ptd); + if (-e $pptd) { + $td = $pptd; + } + } + } + $td .= "/" if ($td !~ m!/$!); + return (-1) if (! -e $td); + debug("Checking for free diskspace in $td\n"); + my ($output, $retval) = run_cmd("df -P \"$td\"", POSIXLY_CORRECT => 1); + if ($retval == 0) { + # Output format should be this: + # Filesystem 512-blocks Used Available Capacity Mounted on + # /dev/sdb3 6099908248 3590818104 2406881416 60% /home + my ($h,$l) = split(/\n/, $output); + my ($fs, $nrb, $used, $avail, @rest) = split(' ', $l); + debug("disk space: used=$used (512-block), avail=$avail (512-block)\n"); + # $avail is in 512-byte blocks, so we need to divide by 2*1024 to + # obtain Mb. Require that at least 100M remain free. + return (int($avail / 2048)); + } else { + # error in running df -P out of whatever reason + return (-1); + } +} + =back =head2 File utilities @@ -1578,27 +1645,29 @@ sub time_estimate { return($remtime, $tottime); } - + =item C<install_packages($from_tlpdb, $media, $to_tlpdb, $what, $opt_src, $opt_doc, $retry, $continue)> 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). +C<$opt_src> and C<$opt_doc> specify whether srcfiles and docfiles should +be installed (currently implemented only for installation from +uncompressed media). If C<$retry> is trueish, retry failed packages a second time. If C<$continue> is trueish, installation failure of non-critical packages -will be ignored. +will be ignored (success is returned). Returns 1 on success and 0 on error. =cut sub install_packages { - my ($fromtlpdb,$media,$totlpdb,$what,$opt_src,$opt_doc, $opt_retry, $opt_continue) = @_; + my ($fromtlpdb,$media,$totlpdb,$what, + $opt_src,$opt_doc,$opt_retry,$opt_continue) = @_; my $container_src_split = $fromtlpdb->config_src_container; my $container_doc_split = $fromtlpdb->config_doc_container; my $root = $fromtlpdb->root; @@ -1677,7 +1746,7 @@ sub install_packages { if (!$fromtlpdb->install_package($package, $totlpdb)) { if ($opt_continue) { push @::installation_failed_packages, $package; - tlwarn("Failed to install $package, but continue anyway!\n"); + tlwarn("Failed to install $package, but continuing anyway!\n"); } else { return 0; } @@ -2616,6 +2685,8 @@ sub setup_programs { # tar needs to be provided by the system, we not even check! $::progs{'tar'} = "tar"; + setup_one("unix", "df", undef, "-P .", 0); + 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 @@ -2793,6 +2864,10 @@ sub setup_windows_tl_one { # . if the copy is -x and executable, use it sub setup_unix_tl_one { my ($p, $def, $arg) = @_; + if (!$def) { + debug("(unix) no default program for $p, no setup done\n"); + return(1); + } our $tmp; debug("(unix) trying to set up $p, default $def, arg $arg\n"); if (-r $def) { |