Cleaner tl_abs_path

git-svn-id: svn://tug.org/texlive/trunk@40580 c570f23f-e606-0410-a88d-b1316a301751

1 files 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<tl_abs_path($path)>
 
-# 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;