From d20450d8193e6ede2232f74ef4a33e8c4e36008b Mon Sep 17 00:00:00 2001 From: Karl Berry Date: Wed, 25 Dec 2019 22:50:12 +0000 Subject: doc,sync git-svn-id: svn://tug.org/texlive/trunk@53231 c570f23f-e606-0410-a88d-b1316a301751 --- Build/source/texk/tests/TeXLive/TLUtils.pm | 132 ++++++++++++++++++++--------- 1 file changed, 90 insertions(+), 42 deletions(-) (limited to 'Build/source/texk/tests') diff --git a/Build/source/texk/tests/TeXLive/TLUtils.pm b/Build/source/texk/tests/TeXLive/TLUtils.pm index 33863f6869f..f66bee26754 100644 --- a/Build/source/texk/tests/TeXLive/TLUtils.pm +++ b/Build/source/texk/tests/TeXLive/TLUtils.pm @@ -5,7 +5,7 @@ package TeXLive::TLUtils; -my $svnrev = '$Revision: 53076 $'; +my $svnrev = '$Revision: 53225 $'; my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown"; sub module_revision { return $_modulerevision; } @@ -88,6 +88,7 @@ C - utilities used in TeX Live infrastructure 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_str($label, HASH); # stringified HASH 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 @@ -215,7 +216,8 @@ BEGIN { &SshURIRegex ); @EXPORT = qw(setup_programs download_file process_logging_options - tldie tlwarn info log debug ddebug dddebug debug_hash + tldie tlwarn info log debug ddebug dddebug debug + debug_hash_str debug_hash win32 xchdir xsystem run_cmd system_pipe sort_archs); } @@ -830,7 +832,7 @@ sub dir_creatable { 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 +looks at mode and uid/gid, which on Windows always returns true and even on Unix is not always good enough for directories mounted from a fileserver. @@ -1317,6 +1319,7 @@ sub collapse_dirs { my $item = "$d/$dirent"; # prepend directory for comparison if (! exists $seen{$item}) { + ddebug(" no collapse of $d because of: $dirent\n"); $ok_to_collapse = 0; last; # no need to keep looking after the first. } @@ -1333,21 +1336,25 @@ sub collapse_dirs { =item C -returns all the directories from which all content will be removed +Returns all the directories from which all content will be removed. +Here is the idea: + +=over 4 + +=item create a hashes by_dir listing all files that should be removed + by directory, i.e., key = dir, value is list of files + +=item 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 + +=item return this removal list + +=back =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; @@ -2557,10 +2564,10 @@ sub setup_one { sub setup_system_one { my ($p, $arg) = @_; my $nulldev = nulldev(); - debug("trying to set up system $p, arg $arg\n"); + ddebug("trying to set up system $p, arg $arg\n"); my $ret = system("$p $arg >$nulldev 2>&1"); if ($ret == 0) { - debug("program $p found in the path\n"); + debug("program $p found in path\n"); $::progs{$p} = $p; return(1); } else { @@ -3288,6 +3295,8 @@ sub parse_AddFormat_line { Logging and debugging messages. +=over 4 + =item C Internal routine to write message to both C<$out> (references to @@ -3461,14 +3470,19 @@ sub tldie { } } -=item C +=item C + +Return LABEL followed by HASH elements, followed by a newline, as a +single string. If HASH is a reference, it is followed (but no recursive +derefencing). -Write LABEL followed by HASH elements, all on one line, to stderr. -If HASH is a reference, it is followed. +=item C + +Write the result of C to stderr. =cut -sub debug_hash { +sub debug_hash_str { my ($label) = shift; my (%hash) = (ref $_[0] && $_[0] =~ /.*HASH.*/) ? %{$_[0]} : @_; @@ -3484,7 +3498,11 @@ sub debug_hash { $str .= join (",", @items); $str .= "}"; - warn "$str\n"; + return "$str\n"; +} + +sub debug_hash { + warn &debug_hash_str(@_); } =item C @@ -3611,15 +3629,20 @@ sub sort_uniq { =item C -The C function pushes the last argument @ITEMS to the $LIST -referenced by the first argument, if they are not already in the list. +The C function pushes each element in the last argument +@ITEMS to the $LIST referenced by the first argument, if it is not +already in the list. =cut sub push_uniq { my ($l, @new_items) = @_; for my $e (@new_items) { - if (! &member($e, @$l)) { + # turns out this is one of the most-used functions when updating the + # tlpdb, with hundreds of thousands of calls. So let's write it out + # to eliminate the sub overhead. + #if (! &member($e, @$l)) { + if (! scalar grep($_ eq $e, @$l)) { push (@$l, $e); } } @@ -3656,38 +3679,67 @@ sub merge_into { =item C -Test whether installation with TEXDIR set to $texdir would succeed due to -writing permissions. +Test whether installation with TEXDIR set to $texdir should be ok, e.g., +would be a creatable directory. Return 1 if ok, 0 if not. Writable or not, we will not allow installation to the root directory (Unix) or the root of a drive (Windows). +We also do not allow paths containing various special characters, and +print a message about this if second argument WARN is true. (We only +want to do this for the regular text installer, since spewing output in +a GUI program wouldn't be good; the generic message will have to do for +them.) + =cut sub texdir_check { - my $texdir = shift; - return 0 unless defined $texdir; + my ($orig_texdir,$warn) = @_; + return 0 unless defined $orig_texdir; + # convert to absolute, for safer parsing. + # also replaces backslashes with slashes on w32. # The return value may still contain symlinks, # but no unnecessary terminating '/'. - $texdir = tl_abs_path($texdir); + my $texdir = tl_abs_path($orig_texdir); return 0 unless defined $texdir; - # also reject the root of a drive, + + # 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 + + # Unfortunately we have lots of special characters. + # On Windows, backslashes are normal but will already have been changed + # to slashes by tl_abs_path. And we should only check for : on Unix. + my $colon = win32() ? "" : ":"; + if ($texdir =~ /[,$colon;\\{}\$]/) { + if ($warn) { + print " !! TEXDIR value has problematic characters: $orig_texdir\n"; + print " !! (such as comma, colon, semicolon, backslash, braces\n"; + print " !! and dollar sign; sorry)\n"; + } + # although we could check each character individually and give a + # specific error, it seems plausibly useful to report all the chars + # that cause problems, regardless of which was there. Simpler too. + return 0; + } + # w32: for now, reject the root of a samba share return 0 if win32() && $texdir =~ m!^//[^/]+/[^/]+$!; - my $texdirparent; - my $texdirpparent; + # if texdir already exists, make sure we can write into it. return dir_writable($texdir) if (-d $texdir); - ($texdirparent = $texdir) =~ s!/[^/]*$!!; + + # if texdir doesn't exist, make sure we can write the parent. + (my $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!/[^/]*$!!; + return dir_creatable($texdirparent) if -d dir_slash($texdirparent); + + # ditto for the next level up the tree + (my $texdirpparent = $texdirparent) =~ s!/[^/]*$!!; #print STDERR "Checking $texdirpparent".'[/]'."\n"; return dir_creatable($texdirpparent) if -d dir_slash($texdirpparent); + + # doesn't look plausible. return 0; } @@ -4657,12 +4709,8 @@ sub array_to_json { my $ret = "[" . join(",", map { encode_json(\$_) } @$hr) . "]"; return($ret); } - - - =back =cut - 1; __END__ -- cgit v1.2.3