#!/usr/local/bin/wish
global env gv db

set gv(version)		"Visual Database (Version 0.5 05feb97)"
set gv(program)		vdb
set gv(iconname)	[string toupper $gv(program)]
set gv(top)		.$gv(program)
set gv(author)		"John van Gulik"

proc errmess { pw {msg ""} } {
	global env gv
	pack [label .errmess -text $msg] -side top -expand true -fill both
	pack [button .ok -text "OK" -command "destroy .ok"] -side top
	tkwait window .ok
}

##############################################################################
#####	Set the required environment variables
##############################################################################

if {[info exists env(HOME)] && $env(HOME)=="/"} {set env(HOME) "/root"}

if {$tcl_platform(platform)=="windows"} {
	if {![info exists env(TKAPPS)]} {
		set env(TKAPPS) /TKAPPS
	}
	if {![file isdirectory $env(TKAPPS)]} {
		errmess . "Directory $env(TKAPPS) not found"
		exit 1
	}
} elseif {$tcl_platform(platform)=="unix"} {
	if {![info exists env(TKAPPS)]} {
		if {[file isdirectory $env(HOME)/TKAPPS]} {
			set env(TKAPPS) $env(HOME)/TKAPPS
		} elseif {[file isdirectory /opt/TKAPPS]} {
			set env(TKAPPS) /opt/TKAPPS
		} elseif {[file isdirectory /apps/TKAPPS]} {
			set env(TKAPPS) /apps/TKAPPS
		} else {
			set env(TKAPPS) /usr/local/TKAPPS
		}
	}
	if {![file isdirectory $env(TKAPPS)]} {
		errmess . "Directory $env(TKAPPS) not found"
		exit 1
	}
} else {
	errmess . "This application is not supported under $tcl_platform(platform)"
	exit 1
}

set auto_path [linsert $auto_path 0 $env(TKAPPS)/lib]

#wm withdraw .

standard_startup $gv(program) $gv(version)

##############################################################################
#####	Set required variables and options
##############################################################################

set gv(scrollpos)	left
set gv(dateformat)	"%a %b %d %H%M%S %Z %Y"

##############################################################################
#####	SUBROUTINES
##############################################################################

proc vdb_mkindex { win dbname } {
	global env gv db

	foreach name [array names db $dbname.header.*] { unset db($name) }

	set savedir [pwd]
	cd $db($dbname.file)

	set files [lsort [glob -nocomplain *]]
	if {[llength $files]<1} {return}

	foreach field $db($dbname.fields) {
		catch {f_delete .index.$field} junk
		if {$db($dbname.$field.index)!="true"} {continue}
		set gv(status) "...making index for field $field"
		update idletasks
		catch {f_touch .index.$field} junk
		set cmd "exec grep -i -e \"^${field}:\" $files /dev/null | cut -d: -f1,3 > .index.${field}"
		catch {eval $cmd} junk

		if {$db($dbname.$field.header)!="true"} {continue}
		set gv(status) "...loading indexes for field $field"
		update idletasks
		set fp [open .index.${field} r]
		while {[gets $fp line]>=0} {
			set fields [split $line ":"]
			set key [lindex $fields 0]
			set value [join [lrange $fields 1 end] ":"]
			append db($dbname.header.$key.$field) " $value"
		}
		close $fp
	}

	set gv(status) "...generating header listing"
	update idletasks
	set fp [open .header w]
	foreach key $files {
		set header ""
		foreach field $db($dbname.fields) {
			if {$db($dbname.$field.header)!="true"} {continue}
			if {[info exists db($dbname.header.$key.$field)]} {
				set value [string trim $db($dbname.header.$key.$field)]
			} else {
				set value ""
			}
			set n $db($dbname.$field.length)
			append header [format "%-${n}.${n}s " $value]
		}
		set db($dbname.header.$key) $header
		puts $fp "$key:$header"
	}
	close $fp

	cd $savedir

	set gv(status) "Done"

	return
}

proc vdb_open { filename } {
	global env gv db

	if {$filename==""} {return}

	if {![file exists $filename.schema] \
		|| ![file readable $filename.schema]} {
		errmess $gv(top) "Schema file $filename.schema not accessible"
		return
	}

	if {![file exists $filename] \
		|| ![file isdirectory $filename] \
		|| ![file readable $filename]} {
		errmess $gv(top) "Database directory $filename not accessible"
		return
	}

	set dbname [file tail $filename]
	if {[winfo exists $gv(top).db]} {
		destroy $gv(top).db
	}

	set db($dbname.file) $filename
	set db($dbname.fields) {}

	set fp [open $filename.schema r]
	while {[gets $fp line]>=0} {
		if {[string index $line 0]=="#"} {continue}
		set fields [split $line ":"]
		if {[llength $fields]<2} {continue}
		set field [lindex $fields 0]
		lappend db($dbname.fields) $field
		set db($dbname.$field.seqnum) [lindex $fields 1]
		set db($dbname.$field.access) [lindex $fields 2]
		set db($dbname.$field.title) [lindex $fields 3]
		set db($dbname.$field.type) [lindex $fields 4]
		set db($dbname.$field.length) [lindex $fields 5]
		set db($dbname.$field.range) [lindex $fields 6]
		set db($dbname.$field.update) [lindex $fields 7]
		set db($dbname.$field.index) [lindex $fields 8]
		set db($dbname.$field.header) [lindex $fields 9]
	}
	close $fp

	#
	#	Create the frame to view the database
	#
	set win $gv(top).db
	pack [frame $win] \
		-side top -expand true -fill both

	pack [frame $win.b1] \
		-side top -fill x
	pack [button $win.b1.search -text [lang "Search :" "Chercher :"] \
		-command "vdb_action $win $dbname search" ] \
		-side left
	pack [entry $win.b1.ent -relief sunken -textvariable db($dbname.search) ] \
		-side left -expand true -fill x
	pack [button $win.b1.clear -text [lang "Clear" "Nettoyer"] \
		-command "vdb_action $win $dbname clear" ] \
		-side left
	pack [button $win.b1.update -text [lang "Update" "Mettre  jour"] \
		-command "vdb_action $win $dbname update" ] \
		-side left
	pack [button $win.b1.create -text [lang "Create" "Crer"] \
		-command "vdb_action $win $dbname create" ] \
		-side left
	pack [button $win.b1.delete -text [lang "Delete" "Effacer"] \
		-command "vdb_action $win $dbname delete" ] \
		-side left
	pack [button $win.b1.index -text [lang "Rebuild Indexes" "FRENCH"] \
		-command "vdb_action $win $dbname index" ] \
		-side left
	pack [button $win.b1.close -text "Close" -command "destroy $win"] \
		-side left

	bind $win.b1.ent <Key-Return> "vdb_action $win $dbname search"

	bind_help $win.b1.search $gv(top).help \
		[lang "Search the database" "Rechercher la base de donne"]
	bind_help $win.b1.ent $gv(top).help \
		[lang "Enter string to search for (Press Enter to search)" "Entrer le texte  rechercher (retour pour dbuter)"]
	bind_help $win.b1.clear $gv(top).help \
		[lang "Clear all fields" "Nettoyer les champs"]
	bind_help $win.b1.update $gv(top).help \
		[lang "Update the entry" "Envoyer une demande de mise  jour"]
	bind_help $win.b1.create $gv(top).help \
		[lang "Create a new entry" "Envoyer une demande de cration"]
	bind_help $win.b1.delete $gv(top).help \
		[lang "Delete the entry" "Envoyer une demande d'effacement"]


	set jumplist $win.b1.ent
	foreach field $db($dbname.fields) {
		frame $win.$field
		if {$db($dbname.$field.update)=="true"} { pack $win.$field -side top -fill x }

		pack [label $win.$field.title -width 40 -anchor w \
			-textvariable db($dbname.$field.title)] \
			-side left

		if {$db($dbname.$field.type)=="list"} {
			pack [scrollbar $win.$field.yscroll \
				-command "$win.$field.list yview" ] \
				-side left -fill y
			pack [listbox $win.$field.list -relief sunken -width 20 -height 5 \
				-yscroll "$win.$field.yscroll set" \
				-selectmode extended] \
				-side left -expand true -fill both
			if {$db($dbname.$field.update)=="true"} {lappend jumplist $win.$field.list}

			if {[llength $db($dbname.$field.range)]>0} {
				pack [menubutton $win.$field.pick -text "Select..." \
					-menu $win.$field.pick.m] \
					-side left
				menu $win.$field.pick.m
				foreach value $db($dbname.$field.range) {
					$win.$field.pick.m add command -label $value \
						-command "listaddsort $win.$field.list \"$value\""
				}
			} else {
				pack [label $win.$field.pnt -width 5 -text "<--" ] \
					-side left
				pack [entry $win.$field.ent -relief sunken -width 20 \
					-textvariable gv($win.$field.ent)] \
					-side left
				lappend jumplist $win.$field.ent
				bind $win.$field.ent <Key-Return> \
					"listaddsort $win.$field.list \[$win.$field.ent get\] ; \
					$win.$field.ent delete 0 end"
				bind_help $win.$field.ent $gv(top).help \
					"Hit return to add entry"
			}

			bind $win.$field.list <1> {focus %W}
			bind $win.$field.list <Any-BackSpace> \
				"listdelete $win.$field.list"
			bind $win.$field.list <Any-Delete> \
				"listdelete $win.$field.list"

			bind_help $win.$field.list $gv(top).help \
				"$db($dbname.$field.title) (use Delete Key to remove items)"
		} elseif {$db($dbname.$field.type)=="text"} {
			pack [scrollbar $win.$field.yscroll \
				-command "$win.$field.text yview" ] \
				-side left -fill y
			pack [text $win.$field.text -relief sunken \
				-wrap word -width 20 -height 10 \
				-yscroll "$win.$field.yscroll set" ] \
				-side left -expand true -fill both
			if {$db($dbname.$field.update)=="true"} {lappend jumplist $win.$field.text}

			bind_help $win.$field.text $gv(top).help \
				"$db($dbname.$field.title)"
		} elseif {$db($dbname.$field.type)=="label"} {
			pack [label $win.$field.ent -relief sunken -anchor w \
				-textvariable gv($win.$field.ent)] \
				-side left -expand true -fill x

			bind_help $win.$field.ent $gv(top).help \
				"$db($dbname.$field.title)"
		} else {
			pack [entry $win.$field.ent -relief sunken \
				-textvariable gv($win.$field.ent)] \
				-side left -expand true -fill x
			if {$db($dbname.$field.update)=="true"} {lappend jumplist $win.$field.ent}

			if {$db($dbname.$field.type)=="select"} {
				$win.$field.ent configure -state disabled
			}

			bind_help $win.$field.ent $gv(top).help \
				"$db($dbname.$field.title)"

			if {[llength $db($dbname.$field.range)]>0} {
				pack [menubutton $win.$field.pick -text "Select..." \
					-menu $win.$field.pick.m] \
					-side left
				menu $win.$field.pick.m
				foreach value $db($dbname.$field.range) {
					$win.$field.pick.m add command -label $value \
						-command "set gv($win.$field.ent) \"$value\""
				}
			}
		}
	}

	# bind the jump list
	set n [llength $jumplist]
	for {set i 0} {$i<$n} {incr i} {
		set j [expr $i - 1]
		if {$j<0} {set j [expr $n - 1]}
		set k [expr $i + 1]
		if {$k>=$n} {set k 0}
		bind [lindex $jumplist $i] <Shift-Key-Tab> \
			"focus [lindex $jumplist $j] ; break"
		bind [lindex $jumplist $i] <Key-Tab> \
			"focus [lindex $jumplist $k] ; break"
	}

	pack [frame $win.search] \
		-side top -expand true -fill both
	pack [scrollbar $win.search.xscroll -orient horizontal \
		-command "$win.search.list xview"] \
		-side bottom -fill x
	pack [scrollbar $win.search.yscroll -command "$win.search.list yview"] \
		-side $gv(scrollpos) -fill y
	pack [listbox $win.search.list -height 10 -relief sunken \
		-selectmode single \
		-yscroll "$win.search.yscroll set" \
		-xscroll "$win.search.xscroll set" ] \
		-expand true -fill both
	bind_help $win.search $gv(top).help \
		[lang "Results of the search" "Rsultat de recherche"]

	bind $win.search.list <1> \
		"focus %W ; \
		vdb_load $win $dbname \[%W get \[%W nearest %y\]\]"
	bind $win.search.list <Key-Return> \
		"set i \[%W index active\]; \
		%W selection clear 0 end ; \
		%W selection set \$i ; \
		vdb_load $win $dbname \[%W get \$i\]"
	bind $win.search.list <Key-Select> \
		"set i \[%W index active\]; \
		%W selection clear 0 end ; \
		%W selection set \$i ; \
		vdb_load $win $dbname \[%W get \$i\]"
	bind $win.search.list <Key-space> \
		"set i \[%W index active\]; \
		%W selection clear 0 end ; \
		%W selection set \$i ; \
		vdb_load $win $dbname \[%W get \$i\]"
	bind $win.search.list <Key-Delete> \
		"set i \[%W index active\]; \
		%W delete \$i"
	bind $win.search.list <Key-BackSpace> \
		"set i \[%W index active\]; \
		%W delete \$i"
	bind $win.search.list <Key-Up> \
		"+vdb_load $win $dbname \[%W get \[%W index active\]\]"
	bind $win.search.list <Key-Down> \
		"+vdb_load $win $dbname \[%W get \[%W index active\]\]"


	if {[file exists $db($dbname.file)/.header]} {
		set gv(status) "...loading headers"
		update idletasks
		set fp [open $db($dbname.file)/.header r]
		set res [split [read -nonewline $fp] "\n"]
		close $fp
		foreach line $res {
			set fields [split $line ":"]
			set db($dbname.header.[lindex $fields 0]) [join [lrange $fields 1 end] ":"]
		}
	}

	set gv(status) "Done"
	return
}

proc vdb_action {win dbname action} {
	global env gv db

	set keyfield [lindex $db($dbname.fields) 0]
	set keyvalue [string trim [$win.$keyfield.ent get]]

	if {$action=="index"} {
		vdb_mkindex $win $dbname
		return
	} elseif {$action=="clear"} {
		vdb_clear $win $dbname
		set db($dbname.search) {}
		return
	} elseif {$action=="search"} {
		$win.search.list delete 0 end

		vdb_clear $win $dbname

		set db($dbname.search) [string trim $db($dbname.search)]

		# search for an exact match with the key
		if {[file exists $db($dbname.file)/$db($dbname.search)]} {
			vdb_load $win $dbname $db($dbname.search)
			return
		}

		# search the key fields
		set searchlist [split $db($dbname.search) ":"]
		set matchlist {}
		set gv(status) "...looking for matches (fast) (Please Wait)"
		update idletasks
		foreach searchstring $searchlist {
			if {"x$searchstring"=="x"} {continue}
			set fields [split $searchstring "="]
			set field [lindex $fields 0]
			if {[llength $fields]==1 || "x$field"=="x"} {
				set field "\[^:\]"
				set value [lindex $fields 0]
				set files [glob -nocomplain $db($dbname.file)/.index.*]
			} else {
				if {![file exists $db($dbname.file)/.index.$field]} {
					errmess $win "Cannot search on field $field"
					return
				}
				set value [join [lrange $fields 1 end] "="]
				set files $db($dbname.file)/.index.$field
			}
			foreach file $files {
				set gv(status) "...looking for matches in [file tail $file]"
				update idletasks
				if {[catch {exec $gv(program:grep) $value $file} res]} {
					errmess $win $res
					return
				}
				if {[llength $res]<1} {continue}
				foreach line $res {
					set key [lindex [split $line ":"] 0]
					lappend matchlist $key
				}
			}
		}
		set gv(status) "...sorting matches and deduping"
		update idletasks
		set matchlist [luniq [lsort $matchlist]]
		set gv(status) "Total matches found = [llength $matchlist]"
		update idletasks

		# search the files
		if {[llength $matchlist]==0 \
			&& [yesno $win "No matches found\nSearch all raw records?"]} {
			set savedir [pwd]
			cd $db($dbname.file)
			set gv(status) "...looking for matches (slow) (Please Wait)"
			update idletasks
			foreach file [lsort [glob -nocomplain *]] {
				if {[catch {exec $gv(program:grep) $db($dbname.search) $file} res]} {
					errmess $win $res
					return
				}
				if {[llength $res]>0} {
					lappend matchlist $file
				}
			}
			cd $savedir
			set matchlist [luniq [lsort $matchlist]]
		}

		#
		#       Load the listbox
		#
		foreach match $matchlist {
			if {[info exists db($dbname.header.$match)]} {
				$win.search.list insert end $db($dbname.header.$match)
			} else {
				$win.search.list insert end $match
			}
		}

		if {[llength $matchlist]<=0} {
			set gv(status) "No matches found for $db($dbname.search)"
			return
		} 
		set gv(status) "Found [llength $matchlist] match(es)"

		if {[llength $matchlist]==1} {
			vdb_load $win $dbname [lindex $matchlist 0]
		}

		return
	}

	# check for a key field present
	if {$keyvalue==""} {
		errmess $win "ERROR - no $keyfield field specified"
		return
	}

	if {$action=="delete"} {
		if {![yesno $win "Delete the entry $keyvalue ?"]} {
			set gv(status) "Cancelled"
			return
		}
		if {![file exists $db($dbname.file)/$keyvalue]} {
			errmess $win "Record $keyvalue not found"
			return
		}
		if {[catch {exec rm $db($dbname.file)/$keyvalue} res]} {
			errmess $win "ERROR deleting record $keyvalue\n$res"
		} else {
			set gv(status) "Record $keyvalue deleted"
		}
		return
	}

	if {$action=="create"} {
		if {[file exists $db($dbname.file)/$keyvalue]} {
			errmess $win "Record $keyvalue already exists\nPlease use the Update button instead"
			return
		}
		if {![yesno $win "Create the entry $keyvalue ?"]} {
			set gv(status) "Cancelled"
			return
		}
	} elseif {$action=="update"} {
		if {![file exists $db($dbname.file)/$keyvalue]} {
			errmess $win "Record $keyvalue not found\nPlease use the Create button instead"
			return
		}
	}

	if {$action=="create" || $action=="update"} {
		set gv($win.lastmod.ent) [clock format [clock seconds] -format $gv(dateformat)]
		set fp [open $db($dbname.file)/$keyvalue w]
		foreach field $db($dbname.fields) {
			if {$db($dbname.$field.type)=="text"} {
				set value [string trim [$win.$field.text get 1.0 end] "\n"]
				foreach line [split $value "\n"] {
					puts $fp "$field:$line"
				}
			} elseif {$db($dbname.$field.type)=="list"} {
				foreach line [$win.$field.list get 0 end] {
					puts $fp "$field:$line"
				}
			} else {
				set value [string trim $gv($win.$field.ent)]
				puts $fp "$field:$value"
			}
		}
		if {[catch {close $fp} res]} {
			errmess $win "ERROR updating record $keyvalue\n$res"
		} else {
			set gv(status) "Record $keyvalue updated"
		}
		return
	}

	set gv(status) "Action $action (key=$keyvalue) (database=$dbname)"

	return
}

proc vdb_clear {win dbname} {
	global env gv db

	foreach field $db($dbname.fields) {
		if {[winfo exists $win.$field.text]} {
			$win.$field.text delete 1.0 end
		}
		if {[winfo exists $win.$field.list]} {
			$win.$field.list delete 0 end
		}
		if {[winfo exists $win.$field.ent]} {
			set gv($win.$field.ent) ""
		}
	}
	return
}

proc vdb_load {win dbname record} {
	global env gv db

	vdb_clear $win $dbname

	set record [lindex [split $record] 0]

	set fp [open $db($dbname.file)/$record r]
	while {[gets $fp line]>=0} {
		set fields [split $line ":"]
		if {[llength $fields]<2} {continue}
		set field [lindex $fields 0]
		set value [join [lrange $fields 1 end] ":"]
		if {![winfo exists $win.$field]} { continue }
		if {$db($dbname.$field.type)=="text"} {
			$win.$field.text insert end "$value\n"
		} elseif {$db($dbname.$field.type)=="list"} {
			$win.$field.list insert end $value
		} else {
			append gv($win.$field.ent) "$value "
		}
	}
	close $fp
	return
}

proc listdelete { lw } {
	global env gv

	set indexlist [$lw curselection]
	foreach index [lsort -decreasing $indexlist] {
		$lw delete $index
	}
}

proc listaddsort { lw {value {}} } {
	global env gv

	set contents $value
	set n [$lw size]
	for {set i 0} {$i<$n} {incr i} {
		lappend contents "[$lw get $i]"
	}

	set contents [luniq [lsort $contents]]

	$lw delete 0 end

	set i 0
	set index 0
	foreach line $contents {
		if {"x$line"=="x$value"} {set index $i}
		$lw insert end $line
		incr i
	}

	if {$index>0} {incr index -1}

	$lw yview $index
}

##############################################################################
#####	MAIN PROGRAM
##############################################################################

toplevel	$gv(top)
wm iconname	$gv(top) $gv(iconname)
wm iconbitmap	$gv(top) @$env(TKAPPS)/bitmaps/$gv(program).xbm
wm iconmask	$gv(top) @$env(TKAPPS)/bitmaps/$gv(program).msk
wm title	$gv(top) $gv(version)
wm minsize	$gv(top) 100 100
wm protocol	$gv(top) WM_DELETE_WINDOW exit

pack [label $gv(top).help -width 80] \
	-side bottom -fill x
bind_help $gv(top).help $gv(top).help \
	[lang "Help text" "Texte d'aide"]

pack [frame $gv(top).b1] \
	-side top -fill x
pack [menubutton $gv(top).b1.file -menu $gv(top).b1.file.m \
	-text [lang "File..." "Fichier..."] ] \
	-side left -fill y
pack [label $gv(top).b1.status -textvariable gv(status) -width 20] \
	-side left -expand true -fill x
pack [button $gv(top).b1.iconify -text [lang "Iconify" "Minimiser"] \
	-command "wm iconify $gv(top)"] \
	-side left
pack [button $gv(top).b1.exit -text [lang "Exit" "Abandonner"] \
	-command "exit"] \
	-side left

bind_help $gv(top).b1.file $gv(top).help \
	[lang "Standard menu" "Menu standard"]
bind_help $gv(top).b1.status $gv(top).help \
	[lang "Status messages" "Messages d'tat"]
bind_help $gv(top).b1.iconify $gv(top).help \
	[lang "Iconify window" "Minimiser cette fentre"]
bind_help $gv(top).b1.exit $gv(top).help \
	[lang "Close this window" "Fermer cette fentre"]

menu $gv(top).b1.file.m
$gv(top).b1.file.m add command -label [lang "Open" "Ouvrier"] \
	-command {vdb_open [getstring "Database name:" {}]}
$gv(top).b1.file.m add separator
$gv(top).b1.file.m add command -label [lang "Help" "Aide"] \
	-command "help $env(TKAPPS)/help/$gv(program)"
$gv(top).b1.file.m add command -label [lang "Fonts/Colors" "Fontes/Couleurs"] \
	-command "background tkcustom $gv(program)"
$gv(top).b1.file.m add command -label [lang "Iconify" "Minimiser"] \
	-command "wm iconify $gv(top)"
$gv(top).b1.file.m add command -label [lang "Exit" "Abandonner"] \
	-command "exit"

pack [frame $gv(top).b2 ] \
	-side top -fill x
pack [label $gv(top).b2._lab -text "Database : "] \
	-side left
foreach file [glob -nocomplain *.schema] {
	set filename [file rootname $file]
	set name [file tail $filename]
	pack [button $gv(top).b2.$name -text $name -command "vdb_open $filename" ] \
		-side left -expand true -fill x
	bind_help $gv(top).b2.$name $gv(top).help \
		[lang "Open the $name database" "FRENCH"]
}

set filename [lindex $argv 0]
if {$filename!=""} {vdb_open $filename}

wm withdraw .
if {[winfo exists .startup]} {destroy .startup}
if {[info exists gv(startup.id)]} {image delete $gv(startup.id)}

