From 7a0f7465f8b6477162a651ca785541070f716ede Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Sun, 17 Apr 2016 21:36:05 +0000 Subject: Cleaner tl_abs_path git-svn-id: svn://tug.org/texlive/trunk@40580 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/TeXLive/TLUtils.pm | 105 ++++++++++++++++++++++------------------ 1 file changed, 58 insertions(+), 47 deletions(-) diff --git a/Master/tlpkg/TeXLive/TLUtils.pm b/Master/tlpkg/TeXLive/TLUtils.pm index bd9f50108b5..b6d5ce480b5 100644 --- a/Master/tlpkg/TeXLive/TLUtils.pm +++ b/Master/tlpkg/TeXLive/TLUtils.pm @@ -646,8 +646,8 @@ sub basename { =item C -# Other than Cwd::abs_path, tl_abs_path also works -# if only the grandparent exists. +# Other than Cwd::abs_path, tl_abs_path also works if the argument does not +# yet exist as long as the path does not contain '..' components. =cut @@ -656,33 +656,34 @@ sub tl_abs_path { if (win32) { $path=~s!\\!/!g; } - my $ret; - eval {$ret = Cwd::abs_path($path);}; # eval needed for w32 - return $ret if defined $ret; - # $ret undefined: probably the parent does not exist. - # But we also want an answer if only the grandparent exists. - my ($parent, $base) = dirname_and_basename($path); - return undef unless defined $parent; - eval {$ret = Cwd::abs_path($parent);}; - if (defined $ret) { - if ($ret =~ m!/$! or $base =~ m!^/!) { - $ret = "$ret$base"; - } else { - $ret = "$ret/$base"; - } - return $ret; - } else { - my ($pparent, $pbase) = dirname_and_basename($parent); - return undef unless defined $pparent; - eval {$ret = Cwd::abs_path($pparent);}; - return undef unless defined $ret; - if ($ret =~ m!/$!) { - $ret = "$ret$pbase/$base"; - } else { - $ret = "$ret/$pbase/$base"; - } - return $ret; + if (-e $path) { + $path = Cwd::abs_path($path); + } elsif ($path eq '.') { + $path = Cwd::getcwd(); + } else{ + # collapse /./ components + $path =~ s!/\./!/!g; + # no support for .. path components or for win32 long-path syntax + # (//?/ path prefix) + die "Unsupported path syntax" if $path =~ m!/\.\./! || $path =~ m!/\.\.$! + || $path =~ m!^\.\.!; + die "Unsupported path syntax" if win32() && $path =~ m!^//\?/!; + if ($path !~ m!^(.:)?/!) { # relative path + if (win32() && $path =~ /^.:/) { # drive letter + my $dcwd; + # starts with drive letter: current dir on drive + $dcwd = Cwd::getdcwd ($1); + $dcwd .= '/' unless $dcwd =~ m!/$!; + return $dcwd.$path; + } else { # relative path without drive letter + my $cwd = Cwd::getcwd(); + $cwd .= '/' unless $cwd =~ m!/$!; + return $cwd . $path; + } + } # else absolute path } + $path =~ s!/$!! unless $path =~ m!^(.:)?/$!; + return $path; } @@ -704,13 +705,19 @@ sub dir_creatable { #print STDERR "testing $path\n"; $path =~ s!\\!/!g if win32; return 0 unless -d $path; - $path =~ s!/$!!; + $path .= '/' unless $path =~ m!/$!; #print STDERR "testing $path\n"; - my $i = 0; - my $too_large = 100000; - while ((-e $path . "/" . $i) and $i<$too_large) { $i++; } - return 0 if $i>=$too_large; - my $d = $path."/".$i; + my $d; + for my $i (1..100) { + $d = ""; + # find a non-existent dirname + $d = $path . int(rand(1000000)); + last unless -e $d; + } + if (!$d) { + tlwarn("Cannot find available testdir name\n"); + return 0; + } #print STDERR "creating $d\n"; return 0 unless mkdir $d; return 0 unless -d $d; @@ -729,10 +736,6 @@ 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 @@ -743,14 +746,19 @@ sub dir_writable { my ($path) = @_; return 0 unless -d $path; $path =~ s!\\!/!g if win32; - $path =~ s!/$!!; + $path .= '/' unless $path =~ m!/$!; my $i = 0; - my $too_large = 100000; - while ((-e "$path/$i") && $i < $too_large) { - $i++; + my $f; + for my $i (1..100) { + $f = ""; + # find a non-existent filename + $f = $path . int(rand(1000000)); + last unless -e $f; + } + if (!$f) { + tlwarn("Cannot find available testfile name\n"); + return 0; } - return 0 if $ i >= $too_large; - my $f = "$path/$i"; return 0 if ! open (TEST, ">$f"); my $written = 0; $written = (print TEST "\n"); @@ -3006,13 +3014,16 @@ directory (Unix) or the root of a drive (Windows). sub texdir_check { my $texdir = shift; return 0 unless defined $texdir; - # convert to absolute/canonical, for safer parsing - # tl_abs_path should work as long as grandparent exists + # 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/volume, + # 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; -- cgit v1.2.3