summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2016-04-17 21:36:05 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2016-04-17 21:36:05 +0000
commit7a0f7465f8b6477162a651ca785541070f716ede (patch)
tree5fcea8e0a12fb873f0ed01815e4bc1a940029e16
parent79cb67fb8f977be6c733a2d307e747318a9db570 (diff)
Cleaner tl_abs_path
git-svn-id: svn://tug.org/texlive/trunk@40580 c570f23f-e606-0410-a88d-b1316a301751
-rw-r--r--Master/tlpkg/TeXLive/TLUtils.pm105
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;