texlive[53801] Master: Real test for writability of directory rather

commits+siepo at tug.org commits+siepo at tug.org
Sun Feb 16 13:25:29 CET 2020


Revision: 53801
          http://tug.org/svn/texlive?view=revision&revision=53801
Author:   siepo
Date:     2020-02-16 13:25:29 +0100 (Sun, 16 Feb 2020)
Log Message:
-----------
Real test for writability of directory rather than 'file writable'

Modified Paths:
--------------
    trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl
    trunk/Master/tlpkg/installer/install-tl-gui.tcl
    trunk/Master/tlpkg/tltcl/tltcl.tcl

Modified: trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl
===================================================================
--- trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl	2020-02-16 11:58:25 UTC (rev 53800)
+++ trunk/Master/texmf-dist/scripts/tlshell/tlshell.tcl	2020-02-16 12:25:29 UTC (rev 53801)
@@ -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 @@
     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 @@
     # 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 @@
   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]]

Modified: trunk/Master/tlpkg/installer/install-tl-gui.tcl
===================================================================
--- trunk/Master/tlpkg/installer/install-tl-gui.tcl	2020-02-16 11:58:25 UTC (rev 53800)
+++ trunk/Master/tlpkg/installer/install-tl-gui.tcl	2020-02-16 12:25:29 UTC (rev 53801)
@@ -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 @@
   ### 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 [file exists $d] {
       if {! [file isdirectory $d]} {
         return 0
-      } elseif {! [file writable $d]} {
+      } elseif {! [dir_writable $d]} {
         return 0
       } else {
         return 1

Modified: trunk/Master/tlpkg/tltcl/tltcl.tcl
===================================================================
--- trunk/Master/tlpkg/tltcl/tltcl.tcl	2020-02-16 11:58:25 UTC (rev 53800)
+++ trunk/Master/tlpkg/tltcl/tltcl.tcl	2020-02-16 12:25:29 UTC (rev 53801)
@@ -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 @@
   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"} {



More information about the tex-live-commits mailing list.