1# -*- tcl -*- 2# <20190708.1108.23> 3 4# The mount command in this code is designed to set up 5# "emulation" of a Virtual File System (VFS) in filerunner. 6# We call this a TYPE II VFS. 7# This code is table driven in that the actual things done 8# to set up a VFS (i.e. the VFS mount instructions) 9# are found by searching a list of VFS mount instructions 10# for a match with the current selection. 11# If there is no selection, an attempt is made 12# to find the right instructions using the contents of the 13# current 'dir' entry. If there is ambiguity over which 14# panel to use, the user will be directed to the "Etc" 15# menu for the desired panel. 16 17# The format of a 'VFS mount instruction' is detailed 18# in the configuration instructions in the config.tcl file 19# (so we only have to type the description once). 20# As per the introduction in the frVFS.tcl file, this code 21# ONLY deals with Type II VFS mounts. 22 23# 24proc CmdMountFindRule {file config} { 25 set found 0 26 foreach configEnt $config { 27 foreach pat [lindex $configEnt 1] { 28 if {[string match $pat $file]} { 29 if {$pat == "*"} { 30 array set info [lindex $configEnt 0] 31 if {![info exists info(-dirsonly)] ||\ 32 ([string is true -strict $info(-dirsonly)] &&\ 33 [file isdir $file])} { 34 return $configEnt 35 } 36 } else { 37 return $configEnt 38 } 39 } 40 } 41 } 42 return {} 43} 44# 45# This code fetches the "rule" for the given file and attempts 46# to set it up as a VFS type II 47# 48# This code must always return either -code error or {} 49# 50proc CmdMountSetUp {inst file} { 51 global config glob 52 lassign $file fileOnly fileType fileSize 53 if {[set setUp [CmdMountFindRule $fileOnly $config(vfsII,config)]] == {}} { 54 PopInfo [_ "No mount rule found for %s" $fileOnly] 55 return {} 56 } 57 set options [list -mount -use -location -display -dirsonly\ 58 -readonly -umount -okerror] 59 foreach op $options { 60 set $op {} 61 } 62 foreach {op val} [lindex $setUp 0] { 63 set r [lsearch -glob -all $options $op*] 64 if {[llength $r] != 1} { 65 PopInfo [_ "%s in rule %s not found exactly once.\ 66 \nShould be one of %s" $op $setUp $options] 67 return {} 68 } 69 set [lindex $options $r] $val 70 } 71 # frputs -use fileOnly config(cmd,${-use},extensions) 72 if {${-use} != {}} { 73 if {[info exists config(cmd,${-use},extensions)]} { 74 set -mount [list exec {*}[lindex [CmdMountFindRule $fileOnly\ 75 $config(cmd,${-use},extensions)] 0]] 76 } 77 } 78 if {[set -mount] == {}} { 79 PopInfo [_ "Mount rule %s refers to a non-existent %s rule"\ 80 $setUp ${-mount}] 81 return {} 82 } 83 # frputs -mount 84 set -readonly [string is true -strict ${-readonly}] 85 86 # if {!${-readonly} && ${-umount} == {}} { 87 # PopInfo "Mount rule $setUp must define unmout unless \"readonly\" \ 88 # is true." 89 # return 90 # } 91 # set up the promised variables 92 set frTmp $glob(conf_dir)/typeIImounts 93 set file $fileOnly 94 set pwd [pwd] 95 set opwd $glob([Opposite $inst],pwd) 96 set tail [file tail $fileOnly] 97 set ext [file ext $fileOnly] 98 set nil {} 99 # frputs -location 100 101 if {[IsVFS $fileOnly]} { 102 set file $glob(tmpdir)/$tail 103 set pwd $glob(tmpdir) 104 } 105 if {${-location} == {}} { 106 set -location $pwd 107 } 108 # now do replacement on location 109 set -location [file norm [subst {*}$::stOps ${-location}]] 110 if {[IsVFS ${-location}]} { 111 PopInfo [_ "Don't know how to handle VFS location in mount rule %s." $setUp] 112 return {} 113 } 114 if {${-location} != {}} { 115 # If location is nil (i.e. forced to {}) do not create a dir 116 if {![file exists ${-location}/${tail}VFS]} { 117 set r [Try { file mkdir ${-location}/${tail}VFS } "" 1] 118 if {$r} { 119 return -code \ 120 error [_ "Failed to create directory: \"location\" %s/%sVFS." ${-location} ${tail}] 121 } 122 } else { 123 PopInfo [_ "There is already a file at %s" ${-location}/${tail}VFS] 124 return {} 125 } 126 } 127 # Looks good so far, lets do the deed. 128 if {[IsVFS $fileOnly]} { 129 set file [MoveToTmp $fileOnly $fileType $fileSize] 130 } 131 # now we unarc the file to 'location' 132 if {${-location} != {}} { 133 cd ${-location}/${tail}VFS 134 } 135 lassign [frECF [list {*}[subst {*}$::stOps ${-mount}]]\ 136 [list $file] -alterr {}] r mess fn 137 cd $pwd 138 if {$r != 0 && [string match ${-okerror} $mess]} { 139 set r 0 140 } 141 set rr 0 142 if {${-display} != {} && $r == 0} { 143 set -display [subst {*}$::stOps ${-display}] 144 set rr [catch {addDN [list ${-location}/${tail}VFS "${-display}: ${tail}VFS"]} mess] 145 } 146 if {$r != 0 || $rr != 0} { 147 # clean up 148 if {${-location} != {}} { 149 file delete -force ${-location}/${tail}VFS 150 } 151 if {$r != 0} { 152 if {[set first [string first "mount" $mess]] != -1} { 153 154 return -code error [string range $mess $first end] 155 } 156 return -code error "frECF error: $mess in $fn" 157 } else { 158 return -code error "Bad Display name: $mess" 159 } 160 } 161 # All seems well. Collect the unmount info and save it... 162 # We put this in a small file in the fr temp area... 163 lappend ::vfsMounts [list [expr {${-location} == {} ? "$file" : \ 164 "${-location}/${tail}VFS"}]\ 165 [list readonly ${-readonly}\ 166 displayname [list ${-display}: ${tail}VFS]\ 167 unmount ${-umount}\ 168 original $fileOnly\ 169 created ${-location}\ 170 actual $file]] 171 putVFScontrol 172 173 # Finally, lets display the new mount 174 if { ${-location} != {}} { 175 NewPwd $glob(selected) ${-location}/${tail}VFS 176 UpdateIf ${-location}/${tail}VFS 177 } 178 UpdateWindow $glob(selected) 179 return {} 180} 181 182 183proc getVFScontrol {} { 184 global glob vfsMounts 185 set vfsMounts {} 186 set mountsFile $glob(conf_dir)/currentMounts.tcl 187 if {![file exist $mountsFile]} { 188 return 0 189 } 190 set r [catch [list source $mountsFile] out] 191 if {$r != 0} { 192 Log [_ "Failed to source VFS control file (%s) :\n%s" $mountsFile $out] 193 return 0 194 } 195 return 1 196} 197 198proc putVFScontrol {} { 199 global glob vfsMounts 200 set mountsFile $glob(conf_dir)/currentMounts.tcl 201 set r [catch {open $mountsFile w} fid] 202 if {$r != 0} { PopError [_ "Saving \"mounts\" file : %s" $fid]; return "" } 203 204 putsTrim $fid {# This file is built and maintained by filerunner to keep 205 # track of current "Type II VFS" mounts on the system. 206 } 207 AddConf $fid ::vfsMounts 1 {} 208 close $fid 209} 210# 211# which should be either CmdUmountSetDown or CmdUmountSetUp 212proc CmdMountCor {which} { 213 global glob config 214 215 set fileList {} 216 if {![info exists glob(selected)] || \ 217 [set inst $glob(selected)] == {} ||\ 218 [set selList [$glob(listbox,$inst).file curselection]] == {}} { 219 # Nothing is selected. Could be we are to use the current pwd. 220 if {[info exists glob(whichdir)]} { 221 set inst $glob(whichdir) 222 set fileList [DNtoDir [$glob(win,$inst).entry_dir get]] 223 } else { 224 return 225 } 226 } else { 227 if {[llength $selList] != 1} { 228 # since we mess with the display, just do one at a time. 229 PopInfo [_ "Please select just 1 file."] 230 return {} 231 } 232 lassign [lindex $glob($inst,filelist) $selList] s file type size 233 set fileList [list [list [URL norm $glob($inst,pwd)/[DNtoDirTail $file]]\ 234 $type $size]] 235 } 236 #cd $pwd 237 while {$fileList != {}} { 238 # We do this sort for the un mount case. Should not hurt the mount... 239 set fileList [lsort -command {apply {{a b} { 240 expr {[string length [lindex $a 0]] - [string length [lindex $b 0]]} 241 }}} $fileList] 242 set r [catch "$which $inst [list [lindex $fileList end]]" ouch] 243 if {$r != 0} { 244 PopError $ouch 245 return {} 246 } 247 set fileList [lreplace $fileList end end {*}$ouch] 248 } 249} 250 251 252# Take a Type II VFS apart... 253# Here "file" must be the start or within a VFS type II mount 254# If the mount was readonly, we just delete the files, 255# otherwise we apply the "-unmount" script saved on SetUp 256# 257# This routine returns {} or a list of VFS mounts that should 258# be removed first. 259 260proc CmdUmountSetDown {inst file} { 261 global glob vfsMounts 262 lassign $file fileOnly fileType fileSize 263 264 # First read the Type II VFS control file 265 getVFScontrol 266 # We get a bit less literal here. Will dismount if 267 # $file is in a mounted VFS. At the same time, we 268 # allow nested mounts so only allow if this is the 269 # longest path. 270 set possible {} 271 set fLen 0 272 set newMounts {} 273 foreach {pathinfo} $vfsMounts { 274 lassign $pathinfo path info 275 set len [string length $path] 276 if {[string compare -length $len $path $fileOnly] == 0} { 277 if {$len > $fLen} { 278 set possible $path 279 set possInfo $info 280 set fLen $len 281 } 282 } else { 283 lappend newMounts $pathinfo 284 } 285 } 286 if {$fLen > 0} { 287 # found one. Make sure it is not a parent of another 288 set removeFirst {} 289 foreach {pathinfo} $vfsMounts { 290 lassign $pathinfo path info 291 set len 292 if {[string compare -length $fLen $possible $path] == 0 &&\ 293 [string length $path] > $fLen} { 294 lappend removeFirst [list $path] 295 } 296 } 297 if {$removeFirst != {}} { 298 set mess [_ "The following VFS mounts must be un-mounted first:\n"] 299 foreach mount $removeFirst { 300 append mess "[dirToDN $mount] ($mount)\n" 301 } 302 append mess [_ "Remove all these as well as %s (%s)?" [dirToDN $possible] $possible] 303 set r [yesNoCancel . [_ "Umount several"] $mess] 304 if {$r == 0} { 305 # s/he said yes... 306 return [lappend removeFirst [list $possible]] 307 } else { 308 return {} 309 } 310 } 311 } else { 312 PopInfo [_ "$fileOnly is not, nor within, a VFS mount."] 313 return {} 314 } 315 array set mountInfo $possInfo 316 set pwd [pwd] 317 if {[info exists mountInfo(unmount)] && $mountInfo(unmount) != {}} { 318 # We have an unmount command... 319 cd $possible 320 lassign [frECF [list {*}[subst {*}$::stOps $mountInfo(unmount)]]\ 321 [list $mountInfo(original)]] r mess fn 322 cd $pwd 323 if {$r != 0} { 324 return -code error "frECF error: $mess in $fn" 325 } 326 if {$mountInfo(actual) != $mountInfo(original)} { 327 # We need to move the result back to its actual location 328 if {[file exists $mountInfo(original)]} { 329 cd [file dir $mountInfo(original)] 330 set type [expr {[file isdirectory $mountInfo(orginal)] ? "d" : "f"}] 331 CopyCore [list $mountInfo(original) $type [file size $mountInfo(orginal)]]\ 332 [file dir $mountInfo(actual)] $glob(selected) 0 0 cp 333 } 334 } 335 } 336 # delete this name 337 if {[info exists mountInfo(displayname)] && \ 338 [string index $mountInfo(displayname) 0] != ":"} { 339 delDN [dirToDN $possible] 340 } 341 set vfsMounts $newMounts 342 putVFScontrol 343 set file $mountInfo(original) 344 set file [URL dir $file] 345 if {[info exists mountInfo(created)] && $mountInfo(created) != {}} { 346 file delete -force $possible 347 } 348 if {$file != $glob($inst,pwd)} { 349 NewPwd $inst $file 350 } 351 ForceUpdate 352 return {} 353} 354 355proc CmdMount {} { 356 CmdMountCor "CmdMountSetUp" 357} 358proc CmdUMount { } { 359 CmdMountCor "CmdUmountSetDown" 360} 361# This commad should be called on start up. 362# It gets the VFS control file and verifies that VFS 363# mounts listed there are still around. If so it sets up 364# the display name. If not, it removes any dangling history 365# and rewrites the control file to show its gone. 366# 367proc CmdMountOnStart {} { 368 global vfsMounts 369 if {![getVFScontrol]} {return} 370 set newVFSmount {} 371 foreach {locdatum} [lsort -unique -index 0 $vfsMounts] { 372 lassign $locdatum loc datum 373 if {[file exists $loc]} { 374 array set datemInfo $datum 375 if {[info exists datemInfo(displayname)] &&\ 376 [string index $datemInfo(displayname) 0] != ":"} { 377 addDN [list $loc $datemInfo(displayname)] 378 } 379 lappend newVFSmount $locdatum 380 } 381 } 382 set vfsMounts $newVFSmount 383 putVFScontrol 384} 385