Posted to tcl by schelte at Fri Jan 12 10:17:51 GMT 2024view raw

  1. if {[dict exists [namespace ensemble configure file -map] home]} return
  2.  
  3. namespace eval file {
  4. if {[namespace parent] ne "::"} {
  5. # Replacement only for the parent namespace
  6. interp alias {} [namespace current]::file {} file
  7. } elseif {[namespace which file] ne "[namespace current]::file"} {
  8. # Move the original file command into the current namespace, so we
  9. # can still use it to implement the replacement
  10. rename file file
  11. }
  12. # Create a version of the file command that works the same as Tcl 8.7/9.0
  13. namespace ensemble create -map {
  14. atime {filenamearg atime}
  15. attributes {filenamearg attributes}
  16. channels {file channels}
  17. copy {filenameargs copy}
  18. delete {filenameargs delete}
  19. dirname dirname
  20. executable {filenamearg executable}
  21. exists {filenamearg exists}
  22. extension {file extension}
  23. home home
  24. isdirectory {filenamearg isdirectory}
  25. isfile {filenamearg isfile}
  26. join filejoin
  27. link {filenameargs link}
  28. lstat {filestat lstat}
  29. mkdir {filenameargs mkdir}
  30. mtime {filenamearg mtime}
  31. nativename {filenamearg nativename}
  32. normalize normalize
  33. owned {filenamearg owned}
  34. pathtype pathtype
  35. readable {filenamearg readable}
  36. readlink {filenamearg readlink}
  37. rename {filenameargs rename}
  38. rootname {file rootname}
  39. separator {file separator}
  40. size {filenamearg size}
  41. split filesplit
  42. stat {filestat stat}
  43. system {filenamearg system}
  44. tail filetail
  45. tempdir tempdir
  46. tempfile {file tempfile}
  47. tildeexpand tildeexpand
  48. type {filenamearg type}
  49. volumes {file volumes}
  50. writable {filenamearg writable}
  51. }
  52.  
  53. proc protect {name} {
  54. return [regsub {^~} $name {./&}]
  55. }
  56.  
  57. proc pathtype {name} {
  58. if {[string index $name 0] eq "~"} {
  59. return relative
  60. } else {
  61. tailcall file pathtype $name
  62. }
  63. }
  64.  
  65. proc filejoin {args} {
  66. set rc ""
  67. foreach arg $args {
  68. if {[pathtype $arg] ne "relative"} {
  69. set rc $arg
  70. } elseif {[string index $rc end] in {/ ""}} {
  71. append rc [string trimright $arg /]
  72. } else {
  73. append rc / [string trimright $arg /]
  74. }
  75. }
  76. return [regsub -all //+ $rc /]
  77. }
  78.  
  79. proc normalize {name} {
  80. tailcall file normalize [filejoin [pwd] $name]
  81. }
  82.  
  83. proc filenamearg {cmd file args} {
  84. tailcall file $cmd [protect $file] {*}$args
  85. }
  86.  
  87. proc filenameargs {cmd args} {
  88. set opt 1
  89. set args [lmap arg $args {
  90. if {$opt && [string index $arg 0] eq "-"} {
  91. if {$arg eq "--"} {set opt 0}
  92. set arg
  93. } else {
  94. set opt 0
  95. protect $arg
  96. }
  97. }]
  98. tailcall file $cmd {*}$args
  99. }
  100.  
  101. proc filestat {cmd name {var ""}} {
  102. if {[llength [info level 0]] > 3} {
  103. tailcall file $cmd [protect $name] $var
  104. } else {
  105. file $cmd [protect $name] stat
  106. return [array get stat]
  107. }
  108. }
  109.  
  110. proc filesplit {name} {
  111. return [lmap part [file split $name] {regsub {^\./} $part {}}]
  112. }
  113.  
  114. proc dirname {name} {
  115. tailcall file dirname [filejoin . $name]
  116. }
  117.  
  118. proc filetail {name} {
  119. set rc [file tail [filejoin . $name]]
  120. return [regsub {^./} $rc {}]
  121. }
  122.  
  123. proc home {user} {
  124. tailcall file normalize ~$user
  125. }
  126.  
  127. proc tildeexpand {name} {
  128. tailcall file normalize $name
  129. }
  130.  
  131. proc tempdir {{template tcl}} {
  132. close [file tempfile name]
  133. file delete $name
  134. set tmpdir [file dirname $name]
  135. while 1 {
  136. set rnd [binary format I [expr {int(rand() * 0x100000000)}]]
  137. set str [string range [binary encode base64 $rnd]]
  138. if {[string is alnum $str]} {
  139. set name [filejoin $tmpdir [string cat $template _ $str]]
  140. if {![catch {file mkdir $name}]} {
  141. file attributes $name -permissions go-rwx
  142. break
  143. }
  144. }
  145. }
  146. return $name
  147. }
  148. }
  149.  

Comments

Posted by schelte at Fri Jan 12 10:26:25 GMT 2024 [text] [code]

This code can be loaded in a namespace to only update the file command for that namespace, or in the global namespace to make the file command behave like it does in Tcl 8.7/9 for the whole application.