
# This is the MSW registry interface. 
package require registry
package provide VFSregistry 1.0

namespace eval VFSregistry {
  variable commands
  variable debug 0
  variable os $::tcl_platform(platform)
  variable abortflag
  
  array set commands [list\
			  cd     ::VFSregistry::REGISTRYcd\
			  close  ::VFSregistry::REGISTRYclose\
			  delete ::VFSregistry::REGISTRYdelete\
			  get    ::VFSregistry::REGISTRYget\
			  isdir  ::VFSregistry::REGISTRYisDir\
			  link   ::VFSregistry::REGISTRYlink\
			  listF  ::VFSregistry::REGISTRYlistF\
			  live   ::VFSregistry::REGISTRYlive\
			  menu   ::VFSregistry::REGISTRYmenu\
			  mkdir  ::VFSregistry::REGISTRYmkdir\
			  open   ::VFSregistry::REGISTRYopen\
			  pwd    ::VFSregistry::REGISTRYpwd\
			  RcopyOk 3\
			  rename ::VFSregistry::REGISTRYrename\
			  reopen ::VFSregistry::REGISTRYopen\
			  rmdir  ::VFSregistry::REGISTRYdelete\
			  rmdirEmpty 1\
			  search ::VFSregistry::REGISTRY_DoSearch]
  
  # Support routines *********************************
  proc eId {n} {return "(registry $n): "}
    # ******************* all with names "REGISTRY_..."
  proc REGISTRYlog_user {} {
    upvar VFStok VFStok
    VFSglobal tmpdir
    variable debug
    exp_log_user $debug
    if {$debug} {
      exp_log_file -a $tmpdir/registry.log
    }
  }
  proc dproc {args} {}

  proc REGISTRYlog {mess} {
    upvar VFStok VFStok
    VFSglobal log
    eval [list {*}$log $mess]
  }

  # The open request. This is a MSW registry access VFS
  # As such, we only have user mode and elevated which are
  # global. Sooo.. we ignor user and password things.
  # ::Elevated is the system global, true if so.

  # Our basic URL is registry://local/
  # 'local' and 'localhost' refer to this machine.
  # A net address may be used to refer to another machine.
  # On windows 10 (and probably others) the remote registry service
  # must be on to allow remote access.
  
  proc REGISTRYopen {URL args} {
    VFSglobal tmpdir abortflag log op timeout root host pwd
    variable debug
    frputs args
    frputs  VFStok rq_timeout
    #  log_file -a REGISTRY-EXP-LOG
    set debug 0
    set timeout {}
    set abortflag ::[namespace current]::abtflag
    set timefmt "%d%m%y "
    set tmpdir "/tmp"
    set log ::[namespace current]::dproc
    # The VFSadd (set by IsVFS) may contain a user name
    # and a port lets seperate them

    set poss {timeout abortflag timefmt log debug tmpdir}
    foreach {opt value} [lindex $args 0] {
      set tar [lsearch -glob -all -inline $poss "$opt*"]
      if {$tar == {}} {continue}
      if {[llength $tar] != 1} {
	# puts "Here is tar >$tar<"
	error "[eId 1]REGISTRYopen: option ($opt) must be one of: $poss"
      }
      set $tar $value
    }
    # registery root is / followed by one of
    set root {
      HKEY_CLASSES_ROOT
      HKEY_CURRENT_USER
      HKEY_LOCAL_MACHINE
      HKEY_USERS
      HKEY_CURRENT_CONFIG
    }
    set host //$VFSadd/
    if {$VFSadd in {"localhost" "local"}} {
      set host "//[lindex [twapi::get_network_info -hostname] 1]/"
    }
    frputs host VFSadd
    # pelim done, lets see if we can talk...
    if {$VFSpath == {}} {
      set pwd ""
    } else {
      set pwd $VFSpath
    }
    return 0
  }
    
  

  proc REGISTRYcd {VFStok new_wd} {
    VFSglobal pwd host
    if {$new_wd in {"" /} } {
      set pwd ""
      return 1
    }
    frputs host new_wd
    set r [catch {fixCall "registry keys" $host$new_wd } re]
    if {$r == 0} {
      set pwd  $new_wd
      return 1
    }
    return -code error [eId 15]$re
  }
    
  proc REGISTRYisDir {VFStok dir} {
    set r [catch {REGISTRYcd $VFStok $dir} really]
    if {$r == 0 || [string match -nocase *permission* $really]} {
      return 1
    }
    return 0
  }
  
  proc REGISTRYrename {VFStok  old new} {
    # current name old change to new
    if {!$::Elevated} {
      return -code error "Must be elevated to go here!"
    }
    return -code error [eId 16]$re
    return ""
  }

  proc REGISTRYdelete {VFStok filename} {
    # rm in toolbox and busybox both support -r
    # so we use this for files and dirs, always
    # with the -r
    if {!$::Elevated} {
      return -code error "Must be elevated to go here!"
    }

    return [REGISTRYsingle $VFStok  rm -r $filename] 
  }

  proc REGISTRYmkdir { VFStok dir } {
    # create dir mkdir,dir
    if {!$::Elevated} {
      return -code error "Must be elevated to go here!"
    }
    set re [REGISTRYsingle $VFStok  mkdir $dir] 
    if {$re != "" } {
      return -code error [eId 17]$re
    }
    return 0
  }
  
  proc REGISTRYlive { VFStok } {
    VFSglobal pwd host
    # we just require a simple transation to prove life..
    set r [catch {registry key [file native $host$pwd]}]
  return [expr {$r == 0 ? 1 : 0}]
  }

  proc REGISTRYpwd {VFStok} {
    VFSglobal pwd host
    # Want the real pwd, NOT the one registry thinks it is..
    return [URL norm $VFStok/$pwd]
  }

  # call frECF to format the calls...
  # First a routine to convert to the right format
  proc fixPath {path} {
    frputs path
    return [regsub -all "$::optionalSlash|/" $path {\\\\}]
  }
  

  proc fixCall {base args} {
    frputs arg
    return [eval [frECF "$base %m" [list {*}$args] -f 1 -m {VFSregistry::fixPath}]]
  }
  # this routine formats a list to look like a "ls" listing.
  # type should be one of {key value}
  # key are formated to look like directories
  # value are formated to look like files
  #        addition info is provided for values
  #        type {binary none sz expand_sz dword dword_big_endian link multi_sz resource_list}
  #             a numeric type is also possible
  
  proc REGISTRYformat {type list {add {}}} {
    set rtn {}
    foreach ent $list {
      frputs add ent
      if {$ent == {}} {continue}
      if {$type == "key"} {
	lappend rtn [list file [regsub -all {/} $ent $::optionalSlash] type d]
      } else {
	# protect weirdness
	#try this
	set ent [regsub {^\{(.*)\}$} $ent {{{\1}}}]
	#set ent [list $ent]
	set val [fixCall "registry get" $add $ent]
	set typ [fixCall "registry type" $add $ent]
	set ent [regsub {^\{(\{.*\})\}} $ent {\1}]
	# Change back & forward slashes to things that look the same
	# but aren't
	set ent [regsub -all  {/}  $ent $::optionalSlash]
	set ent [regsub -all {\\}  $ent $::optionalBackSlash]
	lappend rtn [list file $ent type n link $val flags $typ]
      }
    }
    return $rtn
  }
  
  proc REGISTRYlistF {URL args} {
    VFSglobal root pwd host
    if {$VFSpath == ""} {
      return [REGISTRYformat key $root]
    }
    frputs pwd host VFSpath
    set regRq [fixCall "registry keys" $host$VFSpath ]
    set keyRtn [REGISTRYformat key  $regRq]
    set regVal [fixCall "registry values" $host$VFSpath]
    return [concat $keyRtn [REGISTRYformat value $regVal $host$VFSpath]]
  }


  proc REGISTRY_DoSearch { VFStok filename } {
    return -code error "[eId 19]Search not supported ... yet"
  }


  proc REGISTRYlink { VFStok  exist new opt} {
    frputs exist new
    set lop [expr {$opt == "r" ? "-sr" : "-s"}]
    set re [REGISTRYsingle $VFStok ln -s [FixFileName $exist -+ &] $new]
    if {$re == ""} {
      return ""
    }
    return -code error [eId 23]$re
  }

  proc REGISTRYget {args} {
    REGISTRYnot get
  }

  proc REGISTRYmenu {URL} {
    return [list [list -label "Find Reg Entry" -command {::regfind::buildWindow $inst}]]
  }

  proc REGISTRYnot {what} {
    PopWarn "$what not supported. Try \"Etc\" menu."
    return -code error "$what not supported. Try \"Etc\" menu."
  }

  proc REGISTRYclose {VFStok} {}

}
# clean up any left over trash
# This allows us to source new code without using old data

foreach {openReg v} [array get ::VFSvars::open registry:*] {
  VFSclose $openReg
}
