- dir-writable test to TLUtils, now also used by Unix.

- install-menu-perltk: color back to black after selection of
  writable texdir
- TLWinGoo after mkdirhier: test for existence of created directory


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

5 files changed, 95 insertions, 56 deletions

diff --git a/Master/install-tl b/Master/install-tl
index 9aca143fdfa..5aa5cc98fc3 100755
--- a/Master/install-tl
+++ b/Master/install-tl
@@ -64,7 +64,6 @@ if (win32) {
     &admin
     &non_admin
     &reg_country
-    &dir_writable
     &expand_string
     &global_tmpdir
     &get_system_path
diff --git a/Master/texmf/scripts/texlive/uninstall-win32.pl b/Master/texmf/scripts/texlive/uninstall-win32.pl
index 4f69e7667aa..002e4983aab 100644
--- a/Master/texmf/scripts/texlive/uninstall-win32.pl
+++ b/Master/texmf/scripts/texlive/uninstall-win32.pl
@@ -41,7 +41,6 @@ $cancel->pack(-side => 'left' , -padx => "3m");
 sub doit {
   remove_texbindirs_from_path();
   unsetenv_reg("TEXBINDIR");
-  # unregister_script_type(".texlua");
   unregister_uninstaller();
   exit if is_vista();
   broadcast_env();
diff --git a/Master/tlpkg/TeXLive/TLUtils.pm b/Master/tlpkg/TeXLive/TLUtils.pm
index dfed24ad3e0..8e65670ea37 100644
--- a/Master/tlpkg/TeXLive/TLUtils.pm
+++ b/Master/tlpkg/TeXLive/TLUtils.pm
@@ -1,6 +1,6 @@
 # $Id$
 # The inevitable utilities for TeX Live.
-# 
+#
 # Copyright 2007, 2008 Norbert Preining, Reinhard Kotucha
 # This file is licensed under the GNU General Public License version 2
 # or any later version.
@@ -32,11 +32,12 @@ C<TeXLive::TLUtils> -- utilities used in the TeX Live infrastructure
   TeXLive::TLUtils::program_exists($program);
   TeXLive::TLUtils::get_system_tmpdir;
 
-=head2 File Utulities
+=head2 File Utilities
 
   TeXLive::TLUtils::dirname($path);
   TeXLive::TLUtils::basename($path);
   TeXLive::TLUtils::dirname_and_basename($path);
+  TeXLive::TLUtils::dir_writable($path);
   TeXLive::TLUtils::mkdirhier($path);
   TeXLive::TLUtils::copy($file, $target_dir);
   TeXLive::TLUtils::download_file( $path, $destination [, $progs ] );
@@ -85,6 +86,7 @@ BEGIN {
     &dirname
     &basename
     &dirname_and_basename
+    &dir_writable
     &mkdirhier
     &copy
     &install_package
@@ -423,6 +425,53 @@ sub dirname_and_basename {
 
 =pod
 
+=item C<dir_writable($path)>
+
+Tests whether its argument is writable by trying to write to
+it. This function is necessary because the built-in C<-w> test just
+looks at mode and uid/guid, which on Windows always returns true and
+even on Unix is not always good enough for directories mounted from
+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
+# the virtualized Program Files rather than fail to write to the
+# real Program Files. Ugh.
+
+sub dir_writable {
+  $path=shift;
+  return 0 unless -d $path;
+  $path =~ s!\\!/!g if win32;
+  $path =~ s!/$!!g;
+  my $i = 0;
+  while (-e $path . "/" . $i) { $i++; }
+  my $f = $path."/".$i;
+  if (win32) {
+    my $fb = $f;
+    $fb =~ s!/!\\!g;
+    return 0 if
+      system('copy /b ' . $ENV{'COMSPEC'} . ' "' . $fb . '" >nul 2>&1');
+    unlink $f if -e $f;
+    return 1;
+  } else {
+    return 0 unless open TEST, ">".$f;
+    my $written = 0;
+    $written = (print TEST "\n");
+    close TEST;
+    unlink $f;
+    return $written;
+  }
+}
+
+=pod
+
 =item C<mkdirhier($path, [$mode])>
 
 The function C<mkdirhier> does the same as the UNIX command C<mkdir -p>.
@@ -540,8 +589,8 @@ sub install_packages {
       die "STRANGE: $package not to be found in ", $fromtlpdb->root;
     }
     my $real_opt_doc = $opt_doc;
-    # if we install a package from the Documentation class we 
-    # reactivate the do_doc in any case. It should apply ONLY for fonts 
+    # if we install a package from the Documentation class we
+    # reactivate the do_doc in any case. It should apply ONLY for fonts
     # and macros!
     if ($tlpobj->category =~ m/documentation/i) {
       $real_opt_doc = 1;
@@ -660,7 +709,7 @@ sub install_package {
     #
     # in all other cases we create temp files .tar.lzma (or use the present
     # one), lzmadec them, and then call tar
-    
+
     my $fn = basename($what);
     mkdirhier("$target/temp");
     my $lzmafile = "$target/temp/$fn";
@@ -704,7 +753,7 @@ sub install_package {
 
 =item C<setup_programs( $bindir, $platform )>
 
-Sets up the global $::progs hash containing the pathes to the 
+Sets up the global $::progs hash containing the pathes to the
 programs C<wget>, C<tar>, C<lzmadec>. The C<$bindir> argument specifies
 the path to the location of the C<lzmadec> binaries, the C<$platform>
 gives the extension for the C<lzmadec> binary.
@@ -715,9 +764,9 @@ sub setup_programs {
   my ($bindir, $platform) = @_;
   $::progs{'wget'} = "wget";
   if (!defined($platform) || ($platform eq "")) {
-    # we assume that we run from the DVD, so we can call platform() and 
+    # we assume that we run from the DVD, so we can call platform() and
     # thus also the config.guess script
-    # but we have to setup $::installerdir because that stupid 
+    # but we have to setup $::installerdir because that stupid
     # platform script relies on it
     $::installerdir = "$bindir/../..";
     $platform = platform();
@@ -738,10 +787,10 @@ sub setup_programs {
 =item C<download_file( $path, $destination [, $progs ] )>
 
 Try to download the file given in C<$relpath> from either C<$TeXLiveURL>
-or C<TeXLiveAlternativeURL> into C<$destination>, which can be either 
+or C<TeXLiveAlternativeURL> into C<$destination>, which can be either
 a filename of simply C<|>. In the latter case a file handle is returned.
 
-The optional argument C<$progs> is a reference to a hash giving full pathes 
+The optional argument C<$progs> is a reference to a hash giving full pathes
 to the respective programs, at least C<wget>. In case that C<$progs> is not
 given the C<%::progs> is consulted, and if this also does not exist we
 try "wget".
@@ -749,7 +798,7 @@ try "wget".
 Downloading honors two environment variables C<TL_DOWNLOAD_PROGRAM> and
 C<TL_DOWNLOAD_ARGS>. The former overrides C<wget> (or what is given in the
 C<$progs> argument, the latter overrides the default wget arguments
-given in C<$TeXLive::TLConfig::DefaultWgetArgs>. 
+given in C<$TeXLive::TLConfig::DefaultWgetArgs>.
 
 C<TL_DOWNLOAD_ARGS> must be set up in a way that the place the output should
 go to is the first argument after the C<TL_DOWNLOAD_ARGS>. Use with care.
@@ -804,7 +853,7 @@ sub _download_file {
   debug("Trying to download $url\n");
   my $ret;
   if ($dest eq "|") {
-    open(RETFH, "$wget $wgetargs - $url|") or 
+    open(RETFH, "$wget $wgetargs - $url|") or
       die("Cannot open $url via wget for reading");
     # opening to a pipe always succeeds, so we return immediately
     return \*RETFH;
@@ -931,7 +980,7 @@ again.
 sub initialize_installer {
   &media;
   &platform;
-  $ENV{'WGETRC'}="$::installerdir/tlpkg/installer/wgetrc" 
+  $ENV{'WGETRC'}="$::installerdir/tlpkg/installer/wgetrc"
 }
 
 =pod
@@ -1176,18 +1225,10 @@ sub texdir_check {
   my ($texdir) = shift;                       # PATH/texlive/2008
   my $texdirparent = dirname($texdir);        # PATH/texlive
   my $texdirpparent = dirname($texdirparent); # PATH
-  if (win32()) {
-    if ( (TeXLive::TLWinGoo::dir_writable($texdirpparent)) ||
-         ( (-d $texdirparent) && (TeXLive::TLWinGoo::dir_writable($texdirparent)) ) ||
-         ( (-d $texdir) && (TeXLive::TLWinGoo::dir_writable($texdir)) ) ) {
-      return 1;
-    }
-  } else {
-    if ( (-w $texdirpparent) ||
-         ( (-d $texdirparent) && (-w $texdirparent) ) ||
-         ( (-d $texdir) && (-w $texdir) ) ) {
-      return 1;
-    }
+  if ( (dir_writable($texdirpparent)) ||
+       ( (-d $texdirparent) && (dir_writable($texdirparent)) ) ||
+       ( (-d $texdir) && (dir_writable($texdir)) ) ) {
+    return 1;
   }
   return 0;
 }
diff --git a/Master/tlpkg/TeXLive/TLWinGoo.pm b/Master/tlpkg/TeXLive/TLWinGoo.pm
index a44ca6a7c0d..7cf27f446b5 100644
--- a/Master/tlpkg/TeXLive/TLWinGoo.pm
+++ b/Master/tlpkg/TeXLive/TLWinGoo.pm
@@ -937,7 +937,7 @@ sub add_menu_shortcut {
     next; # fail silently and don't worry about it
   } elsif (not (-d $shpath)) {
     mkdirhier($shpath);
-    #return unless mkdirhier ($shpath);
+    return unless -d $shpath;
   }
   $shfile = $shpath.'/'.$name.'.lnk';
   $shc->Save($shfile);
@@ -1068,12 +1068,12 @@ sub unregister_uninstaller {
   $regkey_uninst = $Registry->Open(
     "CUser/software/microsoft/windows/currentversion/uninstall/",
     {Access => KEY_ALL_ACCESS()});
-  reg_delete_recurse($regkey_uninst, 'texlive') if $regkey_uninst;
+  reg_delete_recurse($regkey_uninst, 'texlive/') if $regkey_uninst;
   return unless admin();
   $regkey_uninst = $Registry->Open(
     "LMachine/software/microsoft/windows/currentversion/uninstall/",
     {Access => KEY_ALL_ACCESS()});
-  reg_delete_recurse($regkey_uninst, 'texlive') if $regkey_uninst;
+  reg_delete_recurse($regkey_uninst, 'texlive/') if $regkey_uninst;
 }
 
 =pod
diff --git a/Master/tlpkg/installer/install-menu-perltk.pl b/Master/tlpkg/installer/install-menu-perltk.pl
index f3afba912c1..d5cc655e320 100644
--- a/Master/tlpkg/installer/install-menu-perltk.pl
+++ b/Master/tlpkg/installer/install-menu-perltk.pl
@@ -265,7 +265,7 @@ sub run_menu {
 
   # further customization
   $fr->Label(-text => "------- $text{'dirsetup'} -------")->pack;
-  
+
   # texdir line
   my $ftexdir = $fr->Frame; $ftexdir->pack;
   $ftexdir->Label(-text => $labels{'texdir'}, -width => $a, -anchor => 'w')->pack(-side => 'left');
@@ -289,7 +289,7 @@ sub run_menu {
   $fhome->Label(-text => $labels{'texmfhome'}, -width => $a, -anchor => 'w')->pack(-side => 'left');
   $texmfhometext = $fhome->Label(-width => $b, -anchor => 'w')->pack(-side => 'left');
   $fhome->Button(-width => $c, -text => $text{'change'}, -command => sub { menu_edit_vars_value("TEXMFHOME"); })->pack(-side => 'left');
- 
+
 
   # Options
   $fr->Label(-text => "------- $text{'options'} -------")->pack;
@@ -299,30 +299,30 @@ sub run_menu {
   $fletter->Label(-text => $labels{'optletter'}, -width => $a, -anchor => 'w')->pack(-side => 'left');
   $fletter->Label(-width => $b, -anchor => 'w', -textvariable => \$letteryesno)->pack(-side => 'left');
   $fletter->Button(-width => $c, -text => $text{'toggle'}, -command => sub { toggle_and_set_opt_variable(\$vars{'option_letter'}, \$letteryesno); })->pack(-side => 'left');
-  
+
   my $ffmt = $fr->Frame; $ffmt->pack;
   $ffmt->Label(-text => $labels{'optfmt'}, -width => $a, -anchor => 'w')->pack(-side => 'left');
   $ffmt->Label(-width => $b, -anchor => 'w', -textvariable => \$fmtyesno)->pack(-side => 'left');
   $ffmt->Button(-width => $c, -text => $text{'toggle'}, -command => sub { toggle_and_set_opt_variable(\$vars{'option_fmt'}, \$fmtyesno); })->pack(-side => 'left');
-  
+
   if ($vars{'doc_splitting_supported'}) {
     my $fdoc = $fr->Frame; $fdoc->pack;
     $fdoc->Label(-text => $labels{'optdoc'}, -width => $a, -anchor => 'w')->pack(-side => 'left');
     $fdoc->Label(-width => $b, -anchor => 'w', -textvariable => \$docyesno)->pack(-side => 'left');
     $fdoc->Button(-width => $c, -text => $text{'toggle'}, -command => sub { toggle_and_set_opt_variable(\$vars{'option_doc'}, \$docyesno); })->pack(-side => 'left');
   }
-  
+
   if ($vars{'src_splitting_supported'}) {
     my $fsrc = $fr->Frame; $fsrc->pack;
     $fsrc->Label(-text => $labels{'optsrc'}, -width => $a, -anchor => 'w')->pack(-side => 'left');
     $fsrc->Label(-width => $b, -anchor => 'w', -textvariable => \$srcyesno)->pack(-side => 'left');
     $fsrc->Button(-width => $c, -text => $text{'toggle'}, -command => sub { toggle_and_set_opt_variable(\$vars{'option_src'}, \$srcyesno); })->pack(-side => 'left');
   }
-  
+
   if (unix()) {
     # Symlinks
     $fr->Label(-text => "------- $text{'sysint'} -------")->pack;
-    
+
     my $fsym = $fr->Frame; $fsym->pack;
     $fsym->Label(-text => $labels{'symlink'}, -width => $a, -anchor => 'w')->pack(-side => 'left');
     $symlinktext = $fsym->Label(-width => $b, -anchor => 'w')->pack(-side => 'left');
@@ -333,7 +333,7 @@ sub run_menu {
   my $f3 = $fr->Frame;
   $f3->Button(
     -text    => $text{'install'},
-    -command => sub { do_installation(); 
+    -command => sub { do_installation();
       $return = $MENU_ALREADYDONE;
       $fr->Dialog(-text => $text{'finished'}, -buttons => [ $text{'finbut'} ])->Show;
       $mw->destroy },
@@ -358,13 +358,13 @@ sub menu_edit_vars_value {
   my $entry = $sw->Entry(-textvariable => $val, -width => 60);
   $entry->pack;
   my $f = $sw->Frame;
-  $f->Button(-text => $text{'ok'}, 
+  $f->Button(-text => $text{'ok'},
      -command => sub { $val = $entry->get; callback_edit_directories($key,$val) ; $sw->destroy })->pack(-side => 'left');
-  $f->Button(-text => $text{'cancel'}, 
+  $f->Button(-text => $text{'cancel'},
      -command => sub { $sw->destroy })->pack(-side => 'right');
   $f->pack(-expand => 'x');
 }
-    
+
 sub menu_select_scheme {
   my $sw = $mw->Toplevel(-title => $labels{'scheme'});
   my @schemes;
@@ -398,9 +398,9 @@ sub menu_select_scheme {
   $f2r->pack(-side => 'right');
   $f2->pack;
   my $f3 = $sw->Frame;
-  $f3->Button(-text => $text{'ok'}, 
+  $f3->Button(-text => $text{'ok'},
      -command => sub { callback_select_scheme($selected) ; $sw->destroy })->pack(-side => 'left');
-  $f3->Button(-text => $text{'cancel'}, 
+  $f3->Button(-text => $text{'cancel'},
      -command => sub { $sw->destroy })->pack(-side => 'right');
   $f3->pack(-expand => 'x');
 }
@@ -434,9 +434,9 @@ sub menu_select_standard_collections {
   $fd->Button(-text => $text{'selectnone'},
     -command => sub { deselect_collections(\%lvars, @collections_std) })->pack(-side => 'right');
   $fc->pack(-expand => 'x');
-  $fc->Button(-text => $text{'ok'}, 
+  $fc->Button(-text => $text{'ok'},
      -command => sub { %vars = %lvars; callback_select_collection() ; $sw->destroy })->pack(-side => 'left');
-  $fc->Button(-text => $text{'cancel'}, 
+  $fc->Button(-text => $text{'cancel'},
      -command => sub { $sw->destroy })->pack(-side => 'right');
 }
 
@@ -471,7 +471,7 @@ sub menu_select_lang_collections {
     -command => sub { select_collections(\%lvars, @collections_lang) })->pack(-side => 'left');
   $f1langB->Button(-text => $text{'selectnone'},
     -command => sub { deselect_collections(\%lvars, @collections_lang) })->pack(-side => 'right');
-  
+
   my $f1docT = $f1doc->Frame; $f1docT->pack;
   my $f1docL = $f1doc->Frame; $f1docL->pack;
   $f1docT->Label(-text => $text{'selectdoc'})->pack;
@@ -495,9 +495,9 @@ sub menu_select_lang_collections {
   $f1docB->Button(-text => $text{'selectnone'},
     -command => sub { deselect_collections(\%lvars, @collections_lang_doc) })->pack(-side => 'right');
   my $f2 = $sw->Frame; $f2->pack(-expand => 'x');
-  $f2->Button(-text => $text{'ok'}, 
+  $f2->Button(-text => $text{'ok'},
      -command => sub { %vars = %lvars; callback_select_collection() ; $sw->destroy })->pack(-side => 'left');
-  $f2->Button(-text => $text{'cancel'}, 
+  $f2->Button(-text => $text{'cancel'},
      -command => sub { $sw->destroy })->pack(-side => 'right');
 }
 
@@ -520,13 +520,13 @@ sub menu_select_symlink {
       $vars{'sys_bin'} = $lbin;
       $vars{'sys_info'} = $linfo;
       $vars{'sys_man'} = $lman;
-    } 
+    }
     $vars{'option_symlinks'} = $osym;
     menu_update_texts();
   }
   set_unset_buttons();
   my $sw = $mw->Toplevel(-title => $labels{'symlink'});
-  $sw->Checkbutton(-variable => \$osym, 
+  $sw->Checkbutton(-variable => \$osym,
                    -text => $text{'createsym'},
 		   -command => sub { set_unset_buttons(); } )->pack;
   my $fbin = $sw->Frame;
@@ -545,9 +545,9 @@ sub menu_select_symlink {
   $infob->pack(-side => 'right');
   $finfo->pack(-expand => 'x');
   my $f2 = $sw->Frame; $f2->pack(-expand => 'x');
-  $f2->Button(-text => $text{'ok'}, 
+  $f2->Button(-text => $text{'ok'},
      -command => sub { return_callback(); $sw->destroy })->pack(-side => 'left');
-  $f2->Button(-text => $text{'cancel'}, 
+  $f2->Button(-text => $text{'cancel'},
      -command => sub { $sw->destroy })->pack(-side => 'right');
 }
 
@@ -570,9 +570,9 @@ sub menu_select_binsystems {
   $f2l->pack(-side => 'left');
   $f2->pack;
   my $f3 = $sw->Frame;
-  $f3->Button(-text => $text{'ok'}, 
+  $f3->Button(-text => $text{'ok'},
      -command => sub { callback_select_systems() ; $sw->destroy })->pack(-side => 'left');
-  $f3->Button(-text => $text{'cancel'}, 
+  $f3->Button(-text => $text{'cancel'},
      -command => sub { $sw->destroy })->pack(-side => 'right');
   $f3->pack(-expand => 'x');
 }
@@ -604,7 +604,7 @@ sub menu_set_collections_text {
 
 sub menu_set_pathes_text {
   if (TeXLive::TLUtils::texdir_check($vars{'TEXDIR'})) {
-    menu_set_text($texdirtext, "$vars{'TEXDIR'}");
+    menu_set_text($texdirtext, "$vars{'TEXDIR'}", -foreground => "black");
   } else {
     menu_set_text($texdirtext, $text{'notwritable'}, -foreground => "red");
   }
@@ -613,7 +613,7 @@ sub menu_set_pathes_text {
     menu_set_text($texmfsysvartext, "$vars{'TEXMFSYSVAR'}");
   } elsif ("$vars{'TEXMFSYSVAR'}" =~ m;^$vars{'TEXDIR'};) {
     if (TeXLive::TLUtils::texdir_check($vars{'TEXDIR'})) {
-      menu_set_text($texmfsysvartext, "$vars{'TEXMFSYSVAR'}");
+      menu_set_text($texmfsysvartext, "$vars{'TEXMFSYSVAR'}", -foreground => "black");
     } else {
       menu_set_text($texmfsysvartext, $text{'changetexdir'}, -foreground => "red");
     }