From f477a01bac446954cbea3b58a3ceb69f4f876d7a Mon Sep 17 00:00:00 2001
From: Siep Kroonenberg <siepo@cybercomm.nl>
Date: Sun, 16 Feb 2020 12:25:29 +0000
Subject: Real test for writability of directory rather than 'file writable'

git-svn-id: svn://tug.org/texlive/trunk@53801 c570f23f-e606-0410-a88d-b1316a301751
---
 Master/texmf-dist/scripts/tlshell/tlshell.tcl |  8 ++++----
 Master/tlpkg/installer/install-tl-gui.tcl     |  5 +++--
 Master/tlpkg/tltcl/tltcl.tcl                  | 24 +++++++++++++++++++++++-
 3 files changed, 30 insertions(+), 7 deletions(-)

(limited to 'Master')

diff --git a/Master/texmf-dist/scripts/tlshell/tlshell.tcl b/Master/texmf-dist/scripts/tlshell/tlshell.tcl
index 66476199bb1..4ddc53509ea 100755
--- a/Master/texmf-dist/scripts/tlshell/tlshell.tcl
+++ b/Master/texmf-dist/scripts/tlshell/tlshell.tcl
@@ -1,6 +1,6 @@
 #!/usr/bin/env wish
 
-# Copyright 2017-2019 Siep Kroonenberg
+# Copyright 2017-2020 Siep Kroonenberg
 
 # This file is licensed under the GNU General Public License version 2
 # or any later version.
@@ -85,7 +85,7 @@ proc do_debug {s} {
     file mkdir ${::instroot}/temp
     set dbg [open "${::instroot}/temp/mydbglog" a]
     puts $dbg "TCL: $s"
-    close $dbg
+    chan close $dbg
     # Track debug output in the log dialog if it is running:
     if [winfo exists .tllg.dbg.tx] {
       .tllg.dbg.tx configure -state normal
@@ -107,7 +107,7 @@ proc maketemp {ext} {
     # create empty file. although we just want a name,
     # we must make sure that it can be created.
     set fid [open $fname w]
-    close $fid
+    chan close $fid
     if {! [file exists $fname]} {error "Cannot create temporary file"}
     if {$::tcl_platform(platform) eq "unix"} {
       file attributes $fname -permissions 0600
@@ -2390,7 +2390,7 @@ proc initialize {} {
   populate_main
 
   # testing writablilty earlier led to sizing problems
-  if {! [file writable $::instroot]} {
+  if {! [dir_writable $::instroot]} {
     set ans [tk_messageBox -type yesno -icon warning -message \
          [__ "%s is not writable. You can probably not do much.
   Are you sure you want to continue?" $::instroot]]
diff --git a/Master/tlpkg/installer/install-tl-gui.tcl b/Master/tlpkg/installer/install-tl-gui.tcl
index 4234f183125..cd9001ea836 100755
--- a/Master/tlpkg/installer/install-tl-gui.tcl
+++ b/Master/tlpkg/installer/install-tl-gui.tcl
@@ -1,6 +1,6 @@
 #!/usr/bin/env wish
 
-# Copyright 2018, 2019 Siep Kroonenberg
+# Copyright 2018-2020 Siep Kroonenberg
 
 # This file is licensed under the GNU General Public License version 2
 # or any later version.
@@ -1177,6 +1177,7 @@ if {$::tcl_platform(platform) ne "windows"} {
   ### symlinks into standard directories ###
 
   # 'file writable' is only a check of unix permissions
+  # use proc dir_writable instead
   proc dest_ok {d} {
     if {$d eq ""} {return 0}
     set its 1
@@ -1184,7 +1185,7 @@ if {$::tcl_platform(platform) ne "windows"} {
     if [file exists $d] {
       if {! [file isdirectory $d]} {
         return 0
-      } elseif {! [file writable $d]} {
+      } elseif {! [dir_writable $d]} {
         return 0
       } else {
         return 1
diff --git a/Master/tlpkg/tltcl/tltcl.tcl b/Master/tlpkg/tltcl/tltcl.tcl
index b0b8d1c19d5..11f237b18ce 100644
--- a/Master/tlpkg/tltcl/tltcl.tcl
+++ b/Master/tlpkg/tltcl/tltcl.tcl
@@ -1,6 +1,6 @@
 #!/usr/bin/env wish
 
-# Copyright 2018 Siep Kroonenberg
+# Copyright 2018-2020 Siep Kroonenberg
 
 # This file is licensed under the GNU General Public License version 2
 # or any later version.
@@ -543,6 +543,28 @@ proc native_slashify {s} {
   return $r
 }
 
+# test whether a directory is writable.
+# 'file writable' merely tests permissions, which may not be good enough
+proc dir_writable {d} {
+  for {set x 0} {$x<100} {incr x} {
+    set y [expr {int(10000*rand())}]
+    set newfile [file join $::instroot $y]
+    if [file exists $newfile] {
+      continue
+    } else {
+      set fid [open $newfile w]
+      chan close $fid
+      if [file exists $newfile] {
+        file delete $newfile
+        return 1
+      } else {
+        return 0
+      }
+    }
+  }
+  return 0
+}
+
 # unix: choose_dir replacing native directory browser
 
 if {$::tcl_platform(platform) eq "unix"} {
-- 
cgit v1.2.3