diff options
| -rw-r--r-- | Master/tlpkg/TeXLive/TLUtils.pm | 157 | ||||
| -rw-r--r-- | 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<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"; } } |