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/tlpkg/tltcl/tltcl.tcl | 24 +++++++++++++++++++++++-
 1 file changed, 23 insertions(+), 1 deletion(-)

(limited to 'Master/tlpkg/tltcl')

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