summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2013-05-10 12:56:49 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2013-05-10 12:56:49 +0000
commit5a2af5e099455faf50af26f6762ba119ad2ae3d0 (patch)
treed1931a9d105207564f16649e1d4508b61e8ccf1d
parent384f056ae2665f73aa1ce3529db4764cb7c3a077 (diff)
w32 uninstaller fix; UNC paths; tl_abs_path
git-svn-id: svn://tug.org/texlive/trunk@30367 c570f23f-e606-0410-a88d-b1316a301751
-rw-r--r--Master/tlpkg/TeXLive/TLUtils.pm157
-rw-r--r--Master/tlpkg/TeXLive/TLWinGoo.pm71
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";
}
}