diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2020-02-16 12:25:29 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2020-02-16 12:25:29 +0000 |
commit | f477a01bac446954cbea3b58a3ceb69f4f876d7a (patch) | |
tree | 6f00d9f9c669623efdd02836de8285e398d3940a /Master/tlpkg | |
parent | 2a7dcf428e2d49c39e57849152ebd8fb99124271 (diff) |
Real test for writability of directory rather than 'file writable'
git-svn-id: svn://tug.org/texlive/trunk@53801 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg')
-rwxr-xr-x | Master/tlpkg/installer/install-tl-gui.tcl | 5 | ||||
-rw-r--r-- | Master/tlpkg/tltcl/tltcl.tcl | 24 |
2 files changed, 26 insertions, 3 deletions
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"} { |