w32 uninstaller fix; UNC paths; tl_abs_path

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

2 files changed, 156 insertions, 72 deletions

diff --git a/Master/tlpkg/TeXLive/TLUtils.pm b/Master/tlpkg/TeXLive/TLUtils.pm
index 5a5f76a75e0..b3f7d8c3d47 100644
--- a/Master/tlpkg/TeXLive/TLUtils.pm
+++ b/Master/tlpkg/TeXLive/TLUtils.pm
@@ -50,6 +50,7 @@ C<TeXLive::TLUtils> -- utilities used in the TeX Live infrastructure
   TeXLive::TLUtils::dirname($path);
   TeXLive::TLUtils::basename($path);
   TeXLive::TLUtils::dirname_and_basename($path);
+  TeXLive::TLUtils::tl_abs_path($path);
   TeXLive::TLUtils::dir_writable($path);
   TeXLive::TLUtils::dir_creatable($path);
   TeXLive::TLUtils::mkdirhier($path);
@@ -137,6 +138,7 @@ BEGIN {
     &dirname
     &basename
     &dirname_and_basename
+    &tl_abs_path
     &dir_writable
     &dir_creatable
     &mkdirhier
@@ -543,26 +545,62 @@ sub run_cmd {
 
 =over 4
 
-=item C<dirname($path)>
+=item C<dirname_and_basename($path)>
 
-Return C<$path> with its trailing C</component> removed.
+Return both C<dirname> and C<basename>.  Example:
+
+  ($dirpart,$filepart) = dirname_and_basename ($path);
 
 =cut
 
-sub dirname {
+sub dirname_and_basename {
   my $path=shift;
+  my ($share, $base) = ("", "");
   if (win32) {
     $path=~s!\\!/!g;
   }
+  # do not try to make sense of paths ending with /..
+  return (undef, undef) if $path =~ m!/\.\.$!;
   if ($path=~m!/!) {   # dirname("foo/bar/baz") -> "foo/bar"
-    $path=~m!(.*)/.*!; # works because of greedy matching
-    return $1;
+    # eliminate `/.' path components
+    while ($path =~ s!/\./!/!) {};
+    # UNC path? => first split in $share = //xxx/yy and $path = /zzzz
+    if (win32() and $path =~ m!^(//[^/]+/[^/]+)(.*)$!) {
+      ($share, $path) = ($1, $2);
+      if ($path =~ m!^/?$!) {
+        $path = $share;
+        $base = "";
+      } elsif ($path =~ m!(/.*)/(.*)!) {
+        $path = $share.$1;
+        $base = $2;
+      } else {
+        $base = $path;
+        $path = $share;
+      }
+      return ($path, $base);
+    }
+    # not a UNC path
+    $path=~m!(.*)/(.*)!; # works because of greedy matching
+    return ((($1 eq '') ? '/' : $1), $2);
   } else {             # dirname("ignore") -> "."
-    return ".";
+    return (".", $path);
   }
 }
 
 
+=item C<dirname($path)>
+
+Return C<$path> with its trailing C</component> removed.
+
+=cut
+
+sub dirname {
+  my $path = shift;
+  my ($dirname, $basename) = dirname_and_basename($path);
+  return $dirname;
+}
+
+
 =item C<basename($path)>
 
 Return C<$path> with any leading directory components removed.
@@ -570,34 +608,51 @@ Return C<$path> with any leading directory components removed.
 =cut
 
 sub basename {
-  my $path=shift;
-  if (win32) {
-    $path=~s!\\!/!g;
-  }
-  if ($path=~m!/!) {  # basename("foo/bar") -> "bar"
-    $path=~m!.*/(.*)!;
-    return $1;
-  } else {            # basename("ignore") -> "ignore"
-    return $path;
-  }
+  my $path = shift;
+  my ($dirname, $basename) = dirname_and_basename($path);
+  return $basename;
 }
 
 
-=item C<dirname_and_basename($path)>
-
-Return both C<dirname> and C<basename>.  Example:
+=item C<tl_abs_path($path)>
 
-  ($dirpart,$filepart) = dirname_and_basename ($path);
+# Other than Cwd::abs_path, tl_abs_path also works
+# if only the grandparent exists.
 
 =cut
 
-sub dirname_and_basename {
-  my $path=shift;
+sub tl_abs_path {
+  my $path = shift;
   if (win32) {
     $path=~s!\\!/!g;
   }
-  $path=~/(.*)\/(.*)/;
-  return ("$1", "$2");
+  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;
+  }
 }
 
 
@@ -615,14 +670,16 @@ sub dir_slash {
 
 # test whether subdirectories can be created in the argument
 sub dir_creatable {
-  $path=shift;
+  my $path=shift;
   #print STDERR "testing $path\n";
   $path =~ s!\\!/!g if win32;
+  return 0 unless -d $path;
   $path =~ s!/$!!;
-  return 0 unless -d dir_slash($path);
   #print STDERR "testing $path\n";
   my $i = 0;
-  while (-e $path . "/" . $i) { $i++; }
+  my $too_large = 100000;
+  while ((-e $path . "/" . $i) and $i<$too_large) { $i++; }
+  return 0 if $i>=$too_large;
   my $d = $path."/".$i;
   #print STDERR "creating $d\n";
   return 0 unless mkdir $d;
@@ -653,12 +710,14 @@ a fileserver.
 # real Program Files. Ugh.
 
 sub dir_writable {
-  $path=shift;
-  return 0 unless -d dir_slash($path);
+  my $path=shift;
+  return 0 unless -d $path;
   $path =~ s!\\!/!g if win32;
   $path =~ s!/$!!;
   my $i = 0;
-  while (-e $path . "/" . $i) { $i++; }
+  my $too_large = 100000;
+  while ((-e $path . "/" . $i) and $i<$too_large) { $i++; }
+  return 0 if $i>=$too_large;
   my $f = $path."/".$i;
   return 0 unless open TEST, ">".$f;
   my $written = 0;
@@ -3077,22 +3136,24 @@ 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 the system drive (Windows).
+directory (Unix) or the root of a drive (Windows).
 
 =cut
 
 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
+  $texdir = tl_abs_path($texdir);
+  return 0 unless defined $texdir;
+  # also reject the root of a drive/volume,
+  # assuming that only the canonical form of the root ends with /
+  return 0 if $texdir =~ m!/$!;
   my $texdirparent;
   my $texdirpparent;
-  $texdir =~ s!/$!!; # remove final slash
-  #print STDERR "Checking $texdir".'[/]'."\n";
-  # disallow unix root
-  return 0 if $texdir eq "";
-  # disallow w32 systemdrive root
-  return 0 if (win32() and $texdir eq $ENV{SystemDrive});
-
-  return dir_writable($texdir) if (-d dir_slash($texdir));
+
+  return dir_writable($texdir) if (-d $texdir);
   ($texdirparent = $texdir) =~ s!/[^/]*$!!;
   #print STDERR "Checking $texdirparent".'[/]'."\n";
   return  dir_creatable($texdirparent) if -d dir_slash($texdirparent);
@@ -3402,16 +3463,16 @@ would be considered part of the filename.
 
 sub conv_to_w32_path {
   my $p = shift;
-  $p =~ s!/!\\!g;
   # we need absolute paths, too
-  if ($p !~ m!^.:!) {
-    my $cwd = `cd`;
-    die "sorry, could not find current working directory via cd?!" if ! $cwd;
-    chomp($cwd);
-    $p = "$cwd\\$p";
-  }
-  $p = quotify_path_with_spaces($p);
-  return($p);
+  my $pabs = tl_abs_path($p);
+  if (not defined $pabs) {
+    $pabs = $p;
+    tlwarn ("sorry, could not determine absolute path of $p!\n".
+      "using original path instead");
+  }
+  $pabs =~ s!/!\\!g;
+  $pabs = quotify_path_with_spaces($pabs);
+  return($pabs);
 }
 
 =pod
diff --git a/Master/tlpkg/TeXLive/TLWinGoo.pm b/Master/tlpkg/TeXLive/TLWinGoo.pm
index 36e71de0fab..a922fca9c16 100644
--- a/Master/tlpkg/TeXLive/TLWinGoo.pm
+++ b/Master/tlpkg/TeXLive/TLWinGoo.pm
@@ -1,6 +1,6 @@
 # $Id$
 # TeXLive::TLWinGoo.pm - Windows nastiness
-# Copyright 2008-2012 Siep Kroonenberg, Norbert Preining
+# Copyright 2008-2013 Siep Kroonenberg, Norbert Preining
 # This file is licensed under the GNU General Public License version 2
 # or any later version.
 
@@ -289,6 +289,7 @@ sub reg_country {
   }
 }
 
+
 =pod
 
 =back
@@ -1203,19 +1204,14 @@ the job.
 =cut
 
 sub create_uninstaller {
-  my ($tdfw, $tdsvfw, $tdscfw) = @_;
+  my $td_fw = shift;
   # TEXDIR, TEXMFSYSVAR, TEXMFSYSCONFIG
-  $tdfw =~ s![\\/]$!!;
-  my $td = $tdfw;
+  $td_fw =~ s![\\/]$!!;
+  my $td = $td_fw;
   $td =~ s!/!\\!g;
 
-  $tdsvfw =~ s![\\/]$!!;
-  my $tdsv = $tdsvfw;
-  $tdsv =~ s!/!\\!g;
-
-  $tdscfw =~ s![\\/]$!!;
-  my $tdsc = $tdscfw;
-  $tdsc =~ s!/!\\!g;
+  my $tdmain = `$td\\bin\\win32\\kpsewhich -var-value=TEXMFMAIN`;
+  chomp $tdmain;
 
   my $uninst_key = $Registry -> Open((admin() ? "LMachine" : "CUser") .
     "/software/microsoft/windows/currentversion/",
@@ -1227,14 +1223,33 @@ sub create_uninstaller {
   $k->{'/DisplayVersion'} = $::TeXLive::TLConfig::ReleaseYear;
   $k->{'/URLInfoAbout'} = "http://www.tug.org/texlive";
 
-  mkdirhier("$tdfw/tlpkg/installer"); # wasn't this done yet?
-  if (open UNINST, ">$tdfw/tlpkg/installer/uninst.bat") {
+  mkdirhier("$td_fw/tlpkg/installer"); # wasn't this done yet?
+  if (open UNINST, ">$td_fw/tlpkg/installer/uninst.bat") {
     print UNINST <<UNEND;
 \@echo off
 setlocal
 path $td\\tlpkg\\tlperl\\bin;$td\\bin\\win32;%path%
 set PERL5LIB=$td\\tlpkg\\tlperl\\lib
-perl.exe \"$td\\texmf\\scripts\\texlive\\uninstall-win32.pl\"
+rem Clean environment from other Perl variables
+set PERL5OPT=
+set PERLIO=
+set PERLIO_DEBUG=
+set PERLLIB=
+set PERL5DB=
+set PERL5DB_THREADED=
+set PERL5SHELL=
+set PERL_ALLOW_NON_IFS_LSP=
+set PERL_DEBUG_MSTATS=
+set PERL_DESTRUCT_LEVEL=
+set PERL_DL_NONLAZY=
+set PERL_ENCODING=
+set PERL_HASH_SEED=
+set PERL_HASH_SEED_DEBUG=
+set PERL_ROOT=
+set PERL_SIGNALS=
+set PERL_UNICODE=
+
+perl.exe \"$tdmain\\scripts\\texlive\\uninstall-win32.pl\"
 if errorlevel 1 goto :eof
 rem test for taskkill and try to stop exit tray menu
 taskkill /? >nul 2>&1
@@ -1246,22 +1261,19 @@ UNEND
 ;
   close UNINST;
   } else {
-    warn "Cannot open $tdfw/tlpkg/installer/uninst.bat for append";
+    warn "Cannot open $td_fw/tlpkg/installer/uninst.bat for append";
   }
 
   # We could simply delete everything under the root at one go,
   # but this might be catastrophic if TL doesn't have its own root.
-  if (open UNINST2, ">$tdfw/tlpkg/installer/uninst2.bat") {
+  if (open UNINST2, ">$td_fw/tlpkg/installer/uninst2.bat") {
     print UNINST2 <<UNEND2;
 rmdir /s /q \"$td\\bin\"
 rmdir /s /q \"$td\\readme-html.dir\"
 rmdir /s /q \"$td\\readme-txt.dir\"
 if exist \"$td\\temp\" rmdir /s /q \"$td\\temp\"
-rmdir /s /q \"$td\\texmf\"
 rmdir /s /q \"$td\\texmf-dist\"
 rmdir /s /q \"$td\\tlpkg\"
-rmdir /s /q \"$tdsc\"
-rmdir /s /q \"$tdsv\"
 del /q \"$td\\README.*\"
 del /q \"$td\\LICENSE.*\"
 if exist \"$td\\doc.html\" del /q \"$td\\doc.html\"
@@ -1272,17 +1284,28 @@ del /q \"$td\\install-tl*.*\"
 del /q \"$td\\tl-tray-menu.exe\"
 rem del /q \"$td\\texlive.profile\"
 del /q \"$td\\release-texlive.txt\"
-set test=
-for \%\%f in (\"$td\\*.*\") do \@set test=nonempty
-if x\%test\%==x rd \"$td\"
+UNEND2
+;
+    for my $d ('TEXMFSYSVAR', 'TEXMFSYSCONFIG') {
+      my $kd = `$td\\bin\\win32\\kpsewhich -var-value=$d`;
+      chomp $kd;
+      print UNINST2 "rmdir /s /q \"", $kd, "\"\r\n";
+    }
+    if ($td !~ /^.:$/) {
+      print UNINST2 <<UNEND3;
+for \%\%f in (\"$td\\*\") do goto :done
+for /d \%\%f in (\"$td\\*\") do goto :done
+rd \"$td\"
+:done
 \@echo Done uninstalling TeXLive.
 \@pause
 del \"%0\"
-UNEND2
+UNEND3
 ;
+    }
     close UNINST2;
   } else {
-    warn "Cannot open $tdfw/tlpkg/installer/uninst2.bat for writing";
+    warn "Cannot open $td_fw/tlpkg/installer/uninst2.bat for writing";
   }
 }