# -*- tcl -*- 
# <20240117.1300.45>

# The mount command in this code is designed to set up
# "emulation" of a Virtual File System (VFS) in filerunner.
# We call this a TYPE II VFS.
# This code is table driven in that the actual things done
# to set up a VFS (i.e. the VFS mount instructions) 
# are found by searching a list of VFS mount instructions
# for a match with the current selection. 
# If there is no selection, an attempt is made
# to find the right instructions using the contents of the
# current 'dir' entry. If there is ambiguity over which
# panel to use, the user will be directed to the "Etc"
# menu for the desired panel.

# The format of a 'VFS mount instruction' is detailed
# in the configuration instructions in the config.tcl file
# (so we only have to type the description once).
# As per the introduction in the frVFS.tcl file, this code
# ONLY deals with Type II VFS mounts.

#
proc CmdMountFindRule {file config} {
  set found 0
  foreach configEnt $config {
    foreach pat [lindex $configEnt 1] {
      if {[string match $pat $file]} {
	if {$pat == "*"} {
	  array set info [lindex $configEnt 0]
	  if {![info exists info(-dirsonly)] ||\
		  ([string is true -strict $info(-dirsonly)] &&\
		       [file isdir $file])} {
	    return $configEnt
	  }
	} else {
	  return $configEnt
	}
      }
    }
  }
  return {}
}
#
# Here is a little memory pool
namespace eval VfsMountShare {
  variable {}
}

# This code fetches the "rule" for the given file and attempts
# to set it up as a VFS type II
#
# This code must always return either -code error or {}
#
proc CmdMountSetUp {inst file} {
  global config glob
  lassign $file fileOnly fileType fileSize
  if {[set setUp [CmdMountFindRule $fileOnly $config(vfsII,config)]] == {}} {
    PopInfo  [_ "No mount rule found for %s" $fileOnly]
    return {}
  }
  set options [list -mount -use -location -display -dirsonly\
		   -readonly -umount -okerror]
  foreach op $options {
    set $op {}
  }
  foreach {op val} [lindex $setUp 0] {
    set r [lsearch -glob -all $options $op*]
    if {[llength $r] != 1} {
      PopInfo [_ "%s in rule %s not found exactly once.\
                \nShould be one of %s" $op $setUp $options]
      return {}
    }
    set [lindex $options $r] $val
  }
  # frputs -use fileOnly config(cmd,${-use},extensions)
  if {${-use} != {}} {
    if {[info exists config(cmd,${-use},extensions)]} {
      set -mount [list exec {*}[lindex [CmdMountFindRule $fileOnly\
					 $config(cmd,${-use},extensions)] 0]]
       }
    }
  if {[set -mount] == {}} {
    PopInfo [_ "Mount rule %s refers to a non-existent %s rule"\
		 $setUp ${-mount}]
    return {}
  }
  #   frputs -mount
  set -readonly [string is true -strict ${-readonly}]
  
  # set up the promised variables
  set frTmp $glob(conf_dir)/typeIImounts
  set file $fileOnly
  set pwd [pwd]
  set opwd $glob([Opposite $inst],pwd)
  set tail [file tail $fileOnly]
  set ext [file ext $fileOnly]
  set nil {}
  # frputs -location

  if {[IsVFS $fileOnly]} {
    set file $glob(tmpdir)/$tail
    set pwd $glob(tmpdir)
  }
  if {${-location} == {}} {
    set -location $pwd
  }
  # now do replacement on location
  set -location [file norm [subst {*}$::stOps ${-location}]]
  if {[IsVFS ${-location}]} {
    PopInfo [_ "Don't know how to handle VFS location in mount rule %s." $setUp]
    return {}
  }
  if {${-location} != {}} {
    # If location is nil (i.e. forced to {}) do not create a dir
    if {![file exists ${-location}/${tail}VFS]} {
      set r  [Try { file mkdir ${-location}/${tail}VFS } "" 1]
      set dName ${-location}/${tail}VFS
      if {$r} {
	return -code \
	    error [_ "Failed to create directory: \"location\" %s/%sVFS." \
		       ${-location} ${tail}]
      }
    } else {
      PopInfo  [_ "There is already a file at %s" ${-location}/${tail}VFS]
      return {}
    }
  } else {
    set dName $file
  }
  # Looks good so far, lets do the deed.
  if {[IsVFS $fileOnly]} {
    set file [MoveToTmp $fileOnly $fileType $fileSize]
  }
  # now we unarc the file to 'location'
  if {${-location} != {}} {
    cd ${-location}/${tail}VFS
  }
  lassign [frECF [list {*}[subst {*}$::stOps ${-mount}]]\
	       [list $file] -alterr {}] r mess fn
  cd $pwd
  if {$r != 0 &&\
          ([string match ${-okerror} $mess] ||\
               [IsKnownError $mess "returnError"])} {
    set r 0
  }
  set rr 0
  if {${-display} != {} && $r == 0} {
    set -display [subst {*}$::stOps ${-display}]
    frputs -display tail
    set rr [catch {addDN [list $dName "${-display}"]} mess]
    frputs mess
  }
  if {$r != 0 || $rr != 0} {
    # clean up
    if {${-location} != {}} {
      file delete -force ${-location}/${tail}VFS
    }
    if {$r != 0} {
      if {[set first [string first "mount" $mess]] != -1} {
	
	return -code error [string range $mess $first end]
      }
      return -code error "frECF error: $mess in $fn"
    } else {
      return -code error "Bad Display name: $mess"
    }
  }
  # All seems well. Collect the unmount info and save it...
  # We put this in a small file in the fr temp area...
  lappend ::vfsMounts  [list [expr {${-location} == {} ? "$file" : \
					"${-location}/${tail}VFS"}]\
			    [list readonly   ${-readonly}\
				 displayname [list ${-display}: ${tail}VFS]\
				 unmount     ${-umount}\
				 original    $fileOnly\
				 created     ${-location}\
				 actual      $file]]
  putVFScontrol
  
  # Finally, lets display the new mount
  if { ${-location} != {}} {
    NewPwd $glob(selected) ${-location}/${tail}VFS
    UpdateIf ${-location}/${tail}VFS
  }
  UpdateWindow $glob(selected)
  return {}
}


proc getVFScontrol {} {
  global glob vfsMounts
  set vfsMounts {}
  set mountsFile $glob(conf_dir)/currentMounts.tcl
  if {![file exist $mountsFile]} {
    return 0
  }
  set r [catch [list source $mountsFile] out]
  if {$r != 0} {
    Log [_ "Failed to source VFS control file (%s) :\n%s" $mountsFile $out]
    return 0
  }
  return 1
}

proc putVFScontrol {} {
  global glob vfsMounts
  set mountsFile $glob(conf_dir)/currentMounts.tcl
  set r [catch {open $mountsFile w} fid]
  if {$r != 0} { PopError [_ "Saving \"mounts\" file : %s" $fid]; return "" }
  
  puts $fid "# This file is built and maintained by filerunner to keep\
    \n# track of current \"Type II VFS\" mounts on the system.
  "
  AddConf $fid ::vfsMounts 1 {}
  close $fid
}  
#
# which should be either CmdUmountSetDown or CmdUmountSetUp
proc CmdMountCor {which} {
  global glob config
  set VfsMountShare::(left,pwd) $glob(left,pwd)
  set VfsMountShare::(right,pwd) $glob(right,pwd)
  set fileList {}
  if {![info exists glob(selected)] || \
	  [set inst $glob(selected)] == {} ||\
	  [set selList [$glob(listbox,$inst).file curselection]] == {}} {
    # Nothing is selected. Could be we are to use the current pwd.
    if {[info exists glob(whichdir)]} {
      set inst $glob(whichdir)
      set fileList [DNtoDir [$glob(win,$inst).entry_dir get]]
    } else {
      return
    }
  } else {
    if {[llength $selList] != 1} {
      # since we mess with the display, just do one at a time.
      PopInfo [_ "Please select just 1 file."]
      return {}
    }
    lassign [lindex  $glob($inst,filelist) $selList] s file type size
    set fileList [list [list [URL norm $glob($inst,pwd)/[DNtoDirTail $file]]\
			    $type $size]]
  }
  #cd $pwd
  while {$fileList != {}} {
    # We do this sort for the un mount case. Should not hurt the mount...
    set fileList [lsort -command {apply {{a b} {
      expr {[string length [lindex $a 0]] - [string length [lindex $b 0]]}
    }}} $fileList]
    set r [catch "$which $inst [list [lindex $fileList end]]" ouch]
    if {$r != 0} {
      if {"CmdUmountSetDown" == $which} {
	append ouch "\nPossibly some working directory is in the mounted tree."
      }
      # Recovet the pwds
      frputs ouch
      foreach lr {left right} {
	NewPwd $lr $VfsMountShare::($lr,pwd)
      }
      frputs
      ForceUpdate
      frputs ouch
      PopError $ouch
      return {}
    }
    set fileList [lreplace $fileList end end {*}$ouch]
  }
}

		  
# Take a Type II VFS apart...
# Here "file" must be the start or within a VFS type II mount
# If the mount was readonly, we just delete the files,
# otherwise we apply the "-unmount" script saved on SetUp
#
# This routine returns {} or a list of VFS mounts that should
# be removed first.

proc CmdUmountSetDown {inst file} {
  global glob vfsMounts
  lassign $file fileOnly fileType fileSize

  # First read the Type II VFS control file
  getVFScontrol
  # We get a bit less literal here. Will dismount if
  # $file is in a mounted VFS. At the same time, we
  # allow nested mounts so only allow if this is the
  # longest path.
  set possible {}
  set fLen 0
  set newMounts {}
  foreach {pathinfo} $vfsMounts {
    lassign $pathinfo path info
    set len [string length $path]
    if {[string compare -length $len $path $fileOnly] == 0} {
      if {$len > $fLen} {
	set possible $path
	set possInfo $info
	set fLen $len
      }
    } else {
      lappend newMounts $pathinfo
    }
  }
  if {$fLen > 0} {
    # found one. Make sure it is not a parent of another
    set removeFirst {}
    foreach {pathinfo} $vfsMounts {
      lassign $pathinfo path info
      set len 
      if {[string compare -length $fLen $possible $path] == 0 &&\
	      [string length $path] > $fLen} {
	lappend removeFirst [list $path]
      }
    }
    if {$removeFirst != {}} {
      set mess [_ "The following VFS mounts must be un-mounted first:\n"]
      foreach mount $removeFirst {
	append mess "[dirToDN $mount] ($mount)\n"
      }
      append mess [_ "Remove all these as well as %s (%s)?" [dirToDN $possible] $possible]
      set r [yesNoCancel . [_ "Umount several"] $mess]
      if {$r == 0} {
	# s/he said yes...
	return [lappend removeFirst [list $possible]]
      } else {
	return {}
      }
    }
  } else {
    PopInfo [_ "$fileOnly is not, nor within, a VFS mount."]
    return {}
  }
  array set mountInfo $possInfo
  set pwd [pwd]
  if {[info exists mountInfo(unmount)] && $mountInfo(unmount) != {}} {
    # We have an unmount command...
    cd $possible
    frputs possible mountInfo(unmount) mountInfo(original)
    lassign [frECF [list {*}[subst {*}$::stOps $mountInfo(unmount)]]\
		 [list $mountInfo(original)]] r mess fn
    cd $pwd
    if {$r != 0 && ![IsKnownError $mess "returnError"]} {
      return -code error "frECF error: $mess in $fn"
    }
    if {$mountInfo(actual) != $mountInfo(original)} {
      # We need to move the result back to its actual location
      if {[file exists $mountInfo(original)]} {
	cd [file dir $mountInfo(original)]
	set type [expr {[file isdirectory  $mountInfo(orginal)] ? "d" : "f"}]
	CopyCore [list $mountInfo(original) $type [file size $mountInfo(orginal)]]\
	    [file dir $mountInfo(actual)] $glob(selected) 0 0 cp
      }
    }
  }
  # delete this name
  if {[info exists mountInfo(displayname)] && \
	  [string index $mountInfo(displayname) 0] != ":"} {
    delDN [dirToDN $possible]
  }
  set vfsMounts $newMounts
  set file $mountInfo(original)
  set file [URL dir $file]
  # make sure we are not holding up a delete by having a pane in the object
  if {$file != $glob($inst,pwd)} {
    NewPwd $inst $file
  }
  set opInst [Opposite $inst]
  if {[string equal -nocase -length [string length $file] $file $glob($opInst,pwd)]} {
    NewPwd $opInst $file
  }
  if {[info exists mountInfo(created)] && $mountInfo(created) != {}} {
    frputs "pwd=[pwd]< " possible mountInfo(created) file opInst glob($opInst,pwd)
    file delete -force $possible
  }
  ForceUpdate
  putVFScontrol
  return {}
}  

proc CmdMount {} {
  CmdMountCor "CmdMountSetUp"
}
proc CmdUMount { } {
  CmdMountCor "CmdUmountSetDown"
}

proc fsDev {file} {
  file stat $file vals
  return $vals(dev)
}

# This commad should be called on start up.
# It gets the VFS control file and verifies that VFS
# mounts listed there are still around. If so it sets up
# the display name. If not, it removes any dangling history
# and rewrites the control file to show its gone.
#
proc CmdMountOnStart {} {
  if {![getVFScontrol]} {return}
  # We have work to do but do not want to hang things up
  # so we push things to the background and take our time
  Try {
    doMountOnStart
    if {[info exists message]} {
      doDeferedMessages $message
    }
  }
}

proc doMountOnStart {} {
  global vfsMounts
  startProc "start restoring mounts"
  set newVFSmount {}
  foreach {locdatum} [lsort -unique -index 0 $vfsMounts] {
    lassign $locdatum loc datum
    array set datemInfo $datum
    # Here we attempt to remount the fs assuming it may
    # have been unmounted due to a reboot. But first, we
    # only do this to 'mount' objects.
    if {[file exists $loc] &&\
            [regsub { umount } $datemInfo(unmount) { timeout 10 mount } cm]} {
      # There is an unmount so it is a good bet we have a mount object
      startProc "restoring $datemInfo(original)"
      # Here we check if we can axcess with out undo wait
      set type {}
      if {[catch {exec timeout 10 ls -d $loc} wh] == 0 &&\
              [set type [file type $loc]] == "directory" &&\
              ($loc == $datemInfo(original) ||\
                   [catch {exec timeout 10 ls -d $datemInfo(original)} wh] == 0)} {
        # We now know we can access the the mount dir (datemInfo(original))
        # now we can test if we have a mounted fs or not.
        # Test if we can safely do this...
        # there are 3 possible results here:
        # mount point is up, connected and remote is responding
        # mount point is up and not connected
        # mount point is down implies connected and remote is not responding
        # but this last is the other branch of the if...
        #
        # 
        # mount point is up... check if mounted
        if {[set parent [fsDev $datemInfo(original)/..]] == \
                [fsDev $datemInfo(original)]} {
 
           # Dev is the same implies not mounted.
            
          set cm [subst [regsub -- {-l} $cm {}]]
          set r [catch {{*}$cm $datemInfo(original)} dah]
          # This gives a false error so don't even look
          if {[fsDev $datemInfo(original)] == $parent} {
              startProc "$cm $datemInfo(original) down ->$dah"
              lappend ::messages \
                  "Failed to mount '$datemInfo(original)' 
                   \nThe host appears to be down."
          } else {
            startProc "newly mounted and up $dah"
          }
        } else {
          startProc "mounted and up"
          # dev differs -> mounted just check the display name
        }
      } else {
        # Either the host is down or we don't have a dir. If is not a dir
        # we captured that in type
        startProc "host down $type"
        if {$type in {{} "directory"}} {
          
          startProc "$wh $datemInfo(original) down"
           # Host is down, it it mounted?
          if {$type != {} &&\
                  [fsDev $datemInfo(original)/..] == [fsDev $datemInfo(original)]} {
            # host is down and not mouted
            lappend ::messages \
                "File system mouted at '$datemInfo(original)' is not mounted
                        \nand the host appears to be down."
          } else {
            # host is down but mounted
            lappend ::messages \
                "File system mouted at '$datemInfo(original)' is mounted but\
                   \nthe host appears to be down."
          }
        }
        # not a mount object
        startProc "$datemInfo(original) done"

      }
    }
    # Not a mount object, check for display name in all cases
    if {[info exists datemInfo(displayname)] &&\
            [string index $datemInfo(displayname) 0] != ":"} {
      addDN [list $loc $datemInfo(displayname)]
    }
    lappend newVFSmount $locdatum
  }
  set vfsMounts $newVFSmount
  startProc "rewriteing VFScontrol file"
  putVFScontrol
}
