texlive[48226] Master/tlpkg/TeXLive/TLUtils.pm: setup_programs:
commits+preining at tug.org
commits+preining at tug.org
Thu Jul 19 03:29:47 CEST 2018
Revision: 48226
http://tug.org/svn/texlive?view=revision&revision=48226
Author: preining
Date: 2018-07-19 03:29:46 +0200 (Thu, 19 Jul 2018)
Log Message:
-----------
setup_programs: prefer system versions, simplify code
Modified Paths:
--------------
trunk/Master/tlpkg/TeXLive/TLUtils.pm
Modified: trunk/Master/tlpkg/TeXLive/TLUtils.pm
===================================================================
--- trunk/Master/tlpkg/TeXLive/TLUtils.pm 2018-07-19 01:29:33 UTC (rev 48225)
+++ trunk/Master/tlpkg/TeXLive/TLUtils.pm 2018-07-19 01:29:46 UTC (rev 48226)
@@ -2344,16 +2344,18 @@
=cut
sub setup_programs {
- my ($bindir, $platform) = @_;
+ my ($bindir, $platform, $tlfirst) = @_;
my $ok = 1;
+ debug("setup_programs: preferring " . ($tlfirst ? "TL" : "system") . " versions\n");
+
my $isWin = ($^O =~ /^MSWin/i);
if ($isWin) {
- setup_windows_one('tar', "$bindir/tar.exe", "--version", 1);
+ setup_one("w32", 'tar', "$bindir/tar.exe", "--version", $tlfirst);
$platform = "exe";
} else {
- # tar needs to be provided by the system!
+ # tar needs to be provided by the system, we not even check!
$::progs{'tar'} = "tar";
if (!defined($platform) || ($platform eq "")) {
@@ -2372,7 +2374,7 @@
# do not warn on errors
push @working_downloaders, $dltype if
setup_one(($isWin ? "w32" : "unix"), $defprog,
- "$bindir/$dltype/$defprog.$platform", "--version", 1);
+ "$bindir/$dltype/$defprog.$platform", "--version", $tlfirst);
}
$::progs{'working_downloaders'} = [ @working_downloaders ];
my @working_compressors;
@@ -2379,7 +2381,7 @@
for my $defprog (sort {$Compressors{$a}{'priority'} <=> $Compressors{$b}{'priority'}} keys %Compressors) {
# do not warn on errors
if (setup_one(($isWin ? "w32" : "unix"), $defprog,
- "$bindir/$defprog/$defprog.$platform", "--version", 1)) {
+ "$bindir/$defprog/$defprog.$platform", "--version", $tlfirst)) {
push @working_compressors, $defprog;
# also set up $::{'compressor'} if not already done
# this selects the first one, but we might reset this depending on
@@ -2422,7 +2424,7 @@
$::progs{'compressor'} = $ENV{'TEXLIVE_COMPRESSOR'};
}
- if ($::opt_verbosity >= 2) {
+ if ($::opt_verbosity >= 1) {
require Data::Dumper;
use vars qw($Data::Dumper::Indent $Data::Dumper::Sortkeys
$Data::Dumper::Purity); # -w pain
@@ -2436,149 +2438,120 @@
}
sub setup_one {
- my ($what, $p, $def, $arg, $donotwarn) = @_;
- if ($what eq "unix") {
- return(setup_unix_one($p, $def, $arg, $donotwarn));
+ my ($what, $p, $def, $arg, $tlfirst) = @_;
+ my $setupfunc = ($what eq "unix") ? \&setup_unix_tl_one : \&setup_windows_tl_one ;
+ if ($tlfirst) {
+ if (&$setupfunc($p, $def, $arg)) {
+ return(1);
+ } else {
+ return(setup_system_one($p, $arg));
+ }
} else {
- return(setup_windows_one($p, $def, $arg, $donotwarn));
+ if (setup_system_one($p, $arg)) {
+ return(1);
+ } else {
+ return(&$setupfunc($p, $def, $arg));
+ }
}
}
-sub setup_windows_one {
- my ($p, $def, $arg, $donotwarn) = @_;
+sub setup_system_one {
+ my ($p, $arg) = @_;
+ my $nulldev = nulldev();
+ my $ret = system("$p $arg >$nulldev 2>&1");
+ if ($ret == 0) {
+ debug("program $p found in the path\n");
+ $::progs{$p} = $p;
+ return(1);
+ } else {
+ return(0);
+ }
+}
+
+sub setup_windows_tl_one {
+ my ($p, $def, $arg) = @_;
debug("(w32) trying to set up $p, default $def, arg $arg\n");
- my $ready = 0;
+
if (-r $def) {
my $prog = conv_to_w32_path($def);
my $ret = system("$prog $arg >nul 2>&1"); # on windows
if ($ret == 0) {
$::progs{$p} = $prog;
- $ready = 1;
+ return(1);
} else {
tlwarn("Setting up $p with $def as $prog didn't work\n");
system("$prog $arg");
+ return(0);
}
} else {
debug("Default program $def not readable?\n");
+ return(0);
}
- return($ready) if ($ready);
- # still here, try plain name without any specification
- debug("trying to test for plain prog name $p\n");
- $ret = system("$p $arg >nul 2>&1");
- if ($ret == 0) {
- debug("program $p seems to be in the path!\n");
- $::progs{$p} = $p;
- return(1);
- }
- return(0);
}
-
# setup one prog on unix using the following logic:
# - if the shipped one is -x and can be executed, use it
# - if the shipped one is -x but cannot be executed, copy it. set -x
# . if the copy is -x and executable, use it
-# . if the 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, $donotwarn) = @_;
+sub setup_unix_tl_one {
+ my ($p, $def, $arg) = @_;
our $tmp;
- my $test_fallback = 0;
- ddebug("trying to set up $p, default $def, arg $arg\n");
+ debug("(unix) trying to set up $p, default $def, arg $arg\n");
if (-r $def) {
- my $ready = 0;
if (-x $def) {
ddebug("default $def has executable permissions\n");
# we have to check for actual "executability" since a "noexec"
# mount option may interfere, which is not taken into account by -x.
- $::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, "
- . "trying tmp copy.\n");
- }
+ my $ret = system("'$def' $arg >/dev/null 2>&1" ); # we are on Unix
+ if ($ret == 0) {
+ $::progs{$p} = $def;
+ debug("Using shipped $def for $p (tested).\n");
+ return(1);
} else {
- # do not test, just return
- $ready = 1;
- debug("Using shipped $def for $p (not tested).\n");
+ ddebug("Shipped $def has -x but cannot be executed, "
+ . "trying tmp copy.\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");
+ # we are still here
+ # out of some reasons we couldn't execute the shipped program
+ # try to copy it to a temp directory and make it executable
+ #
+ # create tmp dir only when necessary
+ $tmp = TeXLive::TLUtils::tl_tmpdir() unless defined($tmp);
+ # probably we are running from uncompressed media and want to copy it to
+ # some temporary location
+ copy($def, $tmp);
+ my $bn = basename($def);
+ my $tmpprog = "$tmp/$bn";
+ chmod(0755,$tmpprog);
+ # we do not check the return value of chmod, but check whether
+ # the -x bit is now set, the only thing that counts
+ if (! -x $tmpprog) {
+ # hmm, something is going really bad, not even the copy is
+ # executable. Fall back to normal path element
+ ddebug("Copied $p $tmpprog does not have -x bit, strange!\n");
+ return(0);
+ } else {
+ # check again for executability
+ my $ret = system("$tmpprog $arg > /dev/null 2>&1");
+ if ($ret == 0) {
+ # ok, the copy works
+ debug("Using copied $tmpprog for $p (tested).\n");
+ $::progs{$p} = $tmpprog;
+ return(1);
} else {
- # 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?!\n");
- }
- } else {
- debug("Using copied $::progs{$p} for $p (not tested).\n");
- }
+ # even the copied prog is not executable, strange
+ ddebug("Copied $p $tmpprog has x bit but not executable?!\n");
+ return(0);
}
}
} else {
- # hope that we can find in the global PATH
- $test_fallback = 1;
+ # default program is not readable
+ return(0);
}
- if ($test_fallback) {
- # all our playing around and copying did not succeed, try PATH.
- $::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 {
- if ($donotwarn) {
- debug("$0: initialization of $p failed but ignored!\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;
}
More information about the tex-live-commits
mailing list