texlive[52482] Master/tlpkg/TeXLive/TLUtils.pm: TLUtils.pm
commits+karl at tug.org
commits+karl at tug.org
Tue Oct 22 00:51:21 CEST 2019
Revision: 52482
http://tug.org/svn/texlive?view=revision&revision=52482
Author: karl
Date: 2019-10-22 00:51:21 +0200 (Tue, 22 Oct 2019)
Log Message:
-----------
TLUtils.pm ($::LOGFILE): declare global to avoid warning.
(check_file_and_remove): rename from check_file, change caller.
(Logging): new pod section for logging, diagnostic, debugging fns.
(backtrace): new function to return call stack as string.
(copy): backtrace if ddebugging,
Modified Paths:
--------------
trunk/Master/tlpkg/TeXLive/TLUtils.pm
Modified: trunk/Master/tlpkg/TeXLive/TLUtils.pm
===================================================================
--- trunk/Master/tlpkg/TeXLive/TLUtils.pm 2019-10-21 21:01:14 UTC (rev 52481)
+++ trunk/Master/tlpkg/TeXLive/TLUtils.pm 2019-10-21 22:51:21 UTC (rev 52482)
@@ -39,7 +39,7 @@
TeXLive::TLUtils::wsystem($msg, at args);
TeXLive::TLUtils::xsystem(@args);
TeXLive::TLUtils::run_cmd($cmd);
- TeXLive::TLUtils::system_pipe($prog, $infile, $outfile, $removeIn, @extraargs);
+ TeXLive::TLUtils::system_pipe($prog, $infile, $outfile, $removeIn, @args);
=head2 File utilities
@@ -80,6 +80,19 @@
TeXLive::TLUtils::w32_remove_from_path($bindir, $multiuser);
TeXLive::TLUtils::setup_persistent_downloads();
+=head2 Logging and debugging
+
+ TeXLive::TLUtils::info($str1, ...); # output unless -q
+ TeXLive::TLUtils::debug($str1, ...); # output if -v
+ TeXLive::TLUtils::ddebug($str1, ...); # output if -vv
+ TeXLive::TLUtils::dddebug($str1, ...); # output if -vvv
+ TeXLive::TLUtils::log($str1, ...); # only to log file
+ TeXLive::TLUtils::tlwarn($str1, ...); # warn on stderr and log
+ TeXLive::TLUtils::tldie($str1, ...); # tlwarn and die
+ TeXLive::TLUtils::debug_hash($label, HASH); # warn stringified HASH
+ TeXLive::TLUtils::backtrace(); # return call stack as string
+ TeXLive::TLUtils::process_logging_options($texdir); # handle -q -v* -logfile
+
=head2 Miscellaneous
TeXLive::TLUtils::sort_uniq(@list);
@@ -115,7 +128,7 @@
# avoid -warnings.
our $PERL_SINGLE_QUOTE; # we steal code from Text::ParseWords
use vars qw(
- $::LOGFILENAME @::LOGLINES
+ $::LOGFILE $::LOGFILENAME @::LOGLINES
@::debug_hook @::ddebug_hook @::dddebug_hook @::info_hook
@::install_packages_hook @::warn_hook
$TeXLive::TLDownload::net_lib_avail
@@ -1118,6 +1131,10 @@
}
my $destdir=shift;
+ # while we're trying to figure out the versioned containers.
+ #debug("copy($infile, $destdir, filemode=$filemode)\n");
+ #debug("copy: backtrace:\n", backtrace(), "copy: end backtrace\n");
+
my $outfile;
my @stat;
my $mode;
@@ -1142,9 +1159,12 @@
die "mkdirhier($destdir) failed: $err\n" if ! $ret;
}
- if (-l "$infile") {
- symlink (readlink $infile, "$destdir/$filename")
- || die "symlink(readlink $infile, $destdir/$filename) failed: $!";
+ if (-l $infile) {
+ my $linktarget = readlink($infile);
+ my $dest = "$destdir/$filename";
+ debug("TLUtils::copy: doing symlink($linktarget,$dest)"
+ . " [from readlink($infile)]\n");
+ symlink($linktarget, $dest) || die "symlink($linktarget,$dest) failed: $!";
} else {
if (! open (IN, $infile)) {
warn "open($infile) failed, not copying: $!";
@@ -2102,14 +2122,21 @@
=pod
-=item C<check_file($what, $checksum, $checksize>
+=item C<check_file_and_remove($what, $checksum, $checksize>
-Remove C<$what> if either the given C<$checksum> or C<$checksize> does
-not agree. If a check argument is not given, that check is not performed.
+Remove the file C<$what> if either the given C<$checksum> or
+C<$checksize> for C<$what> does not agree with our recomputation using
+C<TLCrypto::tlchecksum> and C<stat>, respectively. If a check argument
+is not given, that check is not performed. If the checksums agree, the
+size is not checked. The return status is random.
+This unusual behavior (removing the given file) is because this is used
+for newly-downloaded files; see the calls in the C<unpack> routine
+(which is the only caller).
+
=cut
-sub check_file {
+sub check_file_and_remove {
my ($xzfile, $checksum, $checksize) = @_;
debug("check_file $xzfile, $checksum, $checksize\n");
if (!$checksum && !$checksize) {
@@ -2117,12 +2144,23 @@
"available for $xzfile, cannot check integrity");
return;
}
+
+ # The idea is that if one of the tests fail, we want to save a copy of
+ # the input file for debugging. But we can't just omit removing the
+ # file, since the caller depends on the removal. So we copy it to a
+ # new temporary directory, which we want to persist, so can't use tl_tmpdir.
+ my $check_file_tmpdir = undef;
+
# only run checksum tests if we can actually compute the checksum
if ($checksum && ($checksum ne "-1") && $::checksum_method) {
my $tlchecksum = TeXLive::TLCrypto::tlchecksum($xzfile);
if ($tlchecksum ne $checksum) {
- tlwarn("TLUtils::check_file: removing $xzfile, checksums differ:\n");
- tlwarn("TLUtils::check_file: TL=$tlchecksum, arg=$checksum\n");
+ tlwarn("TLUtils::check_file: checksums differ for $xzfile:\n");
+ tlwarn("TLUtils::check_file: tlchecksum=$tlchecksum, arg=$checksum\n");
+ (undef,$check_file_tmpdir) = File::temp::tempdir("tlcheckfileXXXXXXXX");
+ tlwarn("TLUtils::check_file: removing $xzfile, "
+ . "but saving copy in $check_file_tmpdir\n");
+ copy($xzfile, $check_file_tmpdir);
unlink($xzfile);
return;
} else {
@@ -2135,7 +2173,14 @@
my $filesize = (stat $xzfile)[7];
if ($filesize != $checksize) {
tlwarn("TLUtils::check_file: removing $xzfile, sizes differ:\n");
- tlwarn("TLUtils::check_file: TL=$filesize, arg=$checksize\n");
+ tlwarn("TLUtils::check_file: tlfilesize=$filesize, arg=$checksize\n");
+ if (!defined($check_file_tmpdir)) {
+ # the tmpdir should always be undefined, since we shouldn't get
+ # here if the checksums failed, but test anyway.
+ $check_file_tmpdir = File::temp::tempdir("tlcheckfileXXXXXXXX");
+ tlwarn("TLUtils::check_file: saving copy in $check_file_tmpdir\n");
+ copy($xzfile, $check_file_tmpdir);
+ }
unlink($xzfile);
return;
}
@@ -2150,10 +2195,11 @@
If necessary, downloads C$what>, and then unpacks it into C<$targetdir>.
C<@opts> is assigned to a hash and can contain the following
-options: C<tmpdir> (use this directory for downloaded files),
+keys: C<tmpdir> (use this directory for downloaded files),
C<checksum> (check downloaded file against this checksum),
C<size> (check downloaded file against this size),
C<remove> (remove temporary files after operation).
+
Returns a pair of values: in case of error return 0 and an additional
explanation, in case of success return 1 and the name of the package.
@@ -2203,18 +2249,18 @@
# we are installing from the NET
# check for the presence of $what in $tempdir
if (-r $containerfile) {
- check_file($containerfile, $checksum, $size);
+ check_file_and_remove($containerfile, $checksum, $size);
}
# if the file is now not present, we can use it
if (! -r $containerfile) {
# try download the file and put it into temp
if (!download_file($what, $containerfile)) {
- return(0, "downloading did not succeed");
+ return(0, "downloading did not succeed (download_file failed)");
}
# remove false downloads
- check_file($containerfile, $checksum, $size);
+ check_file_and_remove($containerfile, $checksum, $size);
if ( ! -r $containerfile ) {
- return(0, "downloading did not succeed");
+ return(0, "downloading did not succeed (check_file_and_remove failed)");
}
}
} else {
@@ -2222,7 +2268,7 @@
# copy it to temp
TeXLive::TLUtils::copy($what, $tempdir);
- check_file($containerfile, $checksum, $size);
+ check_file_and_remove($containerfile, $checksum, $size);
if (! -r $containerfile) {
return (0, "consistency checks failed");
}
@@ -3211,124 +3257,21 @@
return %ret;
}
-
=back
-=head2 Miscellaneous
+=head2 Logging
-Ideas from Fabrice Popineau's C<FileUtils.pm>.
+Logging and debugging messages.
-=over 4
+=item C<logit($out,$level, at rest)>
-=item C<sort_uniq(@list)>
+Internal routine to write message to both C<$out> (references to
+filehandle) and C<$::LOGFILE>, at level C<$level>, of concatenated items
+in C<@rest>. If the log file is not initialized yet, the message is
+saved to be logged later (unless the log file never comes into existence).
-The C<sort_uniq> function sorts the given array and throws away multiple
-occurrences of elements. It returns a sorted and unified array.
-
=cut
-sub sort_uniq {
- my (@l) = @_;
- my ($e, $f, @r);
- $f = "";
- @l = sort(@l);
- foreach $e (@l) {
- if ($e ne $f) {
- $f = $e;
- push @r, $e;
- }
- }
- return @r;
-}
-
-
-=item C<push_uniq(\@list, @new_items)>
-
-The C<push_uniq> function pushes the last argument @ITEMS to the $LIST
-referenced by the first argument, if they are not already in the list.
-
-=cut
-
-sub push_uniq {
- my ($l, @new_items) = @_;
- for my $e (@new_items) {
- if (! &member($e, @$l)) {
- push (@$l, $e);
- }
- }
-}
-
-=item C<member($item, @list)>
-
-The C<member> function returns true if the first argument
-is also inclued in the list of the remaining arguments.
-
-=cut
-
-sub member {
- my $what = shift;
- return scalar grep($_ eq $what, @_);
-}
-
-
-=item C<merge_into(\%to, \%from)>
-
-Merges the keys of %from into %to.
-
-=cut
-
-sub merge_into {
- my ($to, $from) = @_;
- foreach my $k (keys %$from) {
- if (defined($to->{$k})) {
- push @{$to->{$k}}, @{$from->{$k}};
- } else {
- $to->{$k} = [ @{$from->{$k}} ];
- }
- }
-}
-
-
-=item C<texdir_check($texdir)>
-
-Test whether installation with TEXDIR set to $texdir would succeed due to
-writing permissions.
-
-Writable or not, we will not allow installation to the root
-directory (Unix) or the root of a drive (Windows).
-
-=cut
-
-sub texdir_check {
- my $texdir = shift;
- return 0 unless defined $texdir;
- # convert to absolute, for safer parsing.
- # The return value may still contain symlinks,
- # but no unnecessary terminating '/'.
- $texdir = tl_abs_path($texdir);
- return 0 unless defined $texdir;
- # also reject the root of a drive,
- # assuming that only the canonical form of the root ends with /
- return 0 if $texdir =~ m!/$!;
- # win32: for now, reject the root of a samba share
- return 0 if win32() && $texdir =~ m!^//[^/]+/[^/]+$!;
- my $texdirparent;
- my $texdirpparent;
-
- return dir_writable($texdir) if (-d $texdir);
- ($texdirparent = $texdir) =~ s!/[^/]*$!!;
- #print STDERR "Checking $texdirparent".'[/]'."\n";
- return dir_creatable($texdirparent) if -d dir_slash($texdirparent);
- # try another level up the tree
- ($texdirpparent = $texdirparent) =~ s!/[^/]*$!!;
- #print STDERR "Checking $texdirpparent".'[/]'."\n";
- return dir_creatable($texdirpparent) if -d dir_slash($texdirpparent);
- return 0;
-}
-
-
-# no newlines or spaces are added, multiple args are just concatenated.
-#
sub logit {
my ($out, $level, @rest) = @_;
_logit($out, $level, @rest) unless $::opt_quiet;
@@ -3354,7 +3297,6 @@
}
}
-
=item C<info ($str1, $str2, ...)>
Write a normal informational message, the concatenation of the argument
@@ -3378,7 +3320,6 @@
}
}
-
=item C<debug ($str1, $str2, ...)>
Write a debugging message, the concatenation of the argument strings.
@@ -3400,7 +3341,6 @@
}
}
-
=item C<ddebug ($str1, $str2, ...)>
Write a deep debugging message, the concatenation of the argument
@@ -3496,7 +3436,7 @@
}
}
-=item C<debug_hash ($label, hash))>
+=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.
@@ -3521,7 +3461,26 @@
warn "$str\n";
}
-
+=item C<backtrace()>
+
+Return call(er) stack, as a string.
+
+=cut
+
+sub backtrace {
+ my $ret = "";
+
+ my ($line, $subr);
+ my $stackframe = 1; # skip ourselves
+ while ((undef,$filename,$line,$subr) = caller ($stackframe)) {
+ # the undef is for the package, which is already included in $subr.
+ $ret .= " -> ${filename}:${line}: ${subr}\n";
+ $stackframe++;
+ }
+
+ return $ret;
+}
+
=item C<process_logging_options ($texdir)>
This function handles the common logging options for TeX Live scripts.
@@ -3594,6 +3553,118 @@
}
}
+=back
+
+=head2 Miscellaneous
+
+Some ideas from Fabrice Popineau's C<FileUtils.pm>.
+
+=over 4
+
+=item C<sort_uniq(@list)>
+
+The C<sort_uniq> function sorts the given array and throws away multiple
+occurrences of elements. It returns a sorted and unified array.
+
+=cut
+
+sub sort_uniq {
+ my (@l) = @_;
+ my ($e, $f, @r);
+ $f = "";
+ @l = sort(@l);
+ foreach $e (@l) {
+ if ($e ne $f) {
+ $f = $e;
+ push @r, $e;
+ }
+ }
+ return @r;
+}
+
+
+=item C<push_uniq(\@list, @new_items)>
+
+The C<push_uniq> function pushes the last argument @ITEMS to the $LIST
+referenced by the first argument, if they are not already in the list.
+
+=cut
+
+sub push_uniq {
+ my ($l, @new_items) = @_;
+ for my $e (@new_items) {
+ if (! &member($e, @$l)) {
+ push (@$l, $e);
+ }
+ }
+}
+
+=item C<member($item, @list)>
+
+The C<member> function returns true if the first argument
+is also inclued in the list of the remaining arguments.
+
+=cut
+
+sub member {
+ my $what = shift;
+ return scalar grep($_ eq $what, @_);
+}
+
+=item C<merge_into(\%to, \%from)>
+
+Merges the keys of %from into %to.
+
+=cut
+
+sub merge_into {
+ my ($to, $from) = @_;
+ foreach my $k (keys %$from) {
+ if (defined($to->{$k})) {
+ push @{$to->{$k}}, @{$from->{$k}};
+ } else {
+ $to->{$k} = [ @{$from->{$k}} ];
+ }
+ }
+}
+
+=item C<texdir_check($texdir)>
+
+Test whether installation with TEXDIR set to $texdir would succeed due to
+writing permissions.
+
+Writable or not, we will not allow installation to the root
+directory (Unix) or the root of a drive (Windows).
+
+=cut
+
+sub texdir_check {
+ my $texdir = shift;
+ return 0 unless defined $texdir;
+ # convert to absolute, for safer parsing.
+ # The return value may still contain symlinks,
+ # but no unnecessary terminating '/'.
+ $texdir = tl_abs_path($texdir);
+ return 0 unless defined $texdir;
+ # also reject the root of a drive,
+ # assuming that only the canonical form of the root ends with /
+ return 0 if $texdir =~ m!/$!;
+ # win32: for now, reject the root of a samba share
+ return 0 if win32() && $texdir =~ m!^//[^/]+/[^/]+$!;
+ my $texdirparent;
+ my $texdirpparent;
+
+ return dir_writable($texdir) if (-d $texdir);
+ ($texdirparent = $texdir) =~ s!/[^/]*$!!;
+ #print STDERR "Checking $texdirparent".'[/]'."\n";
+ return dir_creatable($texdirparent) if -d dir_slash($texdirparent);
+ # try another level up the tree
+ ($texdirpparent = $texdirparent) =~ s!/[^/]*$!!;
+ #print STDERR "Checking $texdirpparent".'[/]'."\n";
+ return dir_creatable($texdirpparent) if -d dir_slash($texdirpparent);
+ return 0;
+}
+
=pod
This function takes a single argument I<path> and returns it with
@@ -4166,6 +4237,7 @@
return(@pieces);
}
+
=item C<mktexupd ()>
Append entries to C<ls-R> files. Usage example:
@@ -4263,7 +4335,7 @@
return $hash;
}
-
+
=item C<check_sys_user_mode($user,$sys,$tmfc, $tmfsc, $tmfv, $tmfsv)>
=cut
@@ -4315,6 +4387,7 @@
return ($texmfconfig, $texmfvar);
}
+
=item C<prepend_own_path()>
Prepend the location of the TeX Live binaries to the PATH environment
@@ -4336,7 +4409,7 @@
}
}
-
+
=item C<repository_to_array($r)>
Return hash of tags to urls for space-separated list of repositories
@@ -4377,6 +4450,7 @@
return %r;
}
+
=item C<encode_json($ref)>
Returns the JSON representation of the object C<$ref> is pointing at.
More information about the tex-live-commits
mailing list