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