From 5a2af5e099455faf50af26f6762ba119ad2ae3d0 Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Fri, 10 May 2013 12:56:49 +0000 Subject: w32 uninstaller fix; UNC paths; tl_abs_path git-svn-id: svn://tug.org/texlive/trunk@30367 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/TeXLive/TLUtils.pm | 157 +++++++++++++++++++++++++++------------ Master/tlpkg/TeXLive/TLWinGoo.pm | 71 ++++++++++++------ 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 -- 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 +=item C -Return C<$path> with its trailing C removed. +Return both C and C. 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 + +Return C<$path> with its trailing C removed. + +=cut + +sub dirname { + my $path = shift; + my ($dirname, $basename) = dirname_and_basename($path); + return $dirname; +} + + =item C 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 - -Return both C and C. Example: +=item C - ($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 <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 <