diff options
| -rwxr-xr-x | Master/texmf-dist/scripts/tlshell/tlshell.tcl | 8 | ||||
| -rwxr-xr-x | Master/tlpkg/installer/install-tl-gui.tcl | 5 | ||||
| -rw-r--r-- | Master/tlpkg/tltcl/tltcl.tcl | 24 |
3 files changed, 30 insertions, 7 deletions
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"} { |