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

set gv(version)		"Directory Services (Version 1.7.2 14may96)"
set gv(program)		vdir
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(dbdir)		nuad
set gv(dirsite)		$env(SITE)
set gv(whois.host)	$env(WHOSERVER)
set gv(whois.port)	$env(WHOPORT)

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

proc dir_schema { } {
	global env gv

	if {[winfo exists $gv(top).field]} {
		foreach child [winfo children $gv(top).field] { destroy $child }
	} else {
		pack [frame $gv(top).field] \
			-side top -fill x
	}

	foreach temp {name num access title type length range} {
		set gv(schema.$temp) {}
	}
	set gv(schema.numfields) 0
	set res [query $gv(whois.host) $gv(whois.port) site=$gv(dirsite):db=$gv(dbdir):flag=schema]
	set i 0
	foreach line [split $res "\n"] {
		if {[string range $line 0 5]=="Query="} {continue}
		incr i
		if {$i<2} {continue}
		set fields [split $line ":"]
		if {[llength $fields]<4} {continue}
		lappend gv(schema.name) "[lindex $fields 0]"
		lappend gv(schema.num) "[lindex $fields 1]"
		lappend gv(schema.access) "[lindex $fields 2]"
		lappend gv(schema.title) "[lindex $fields 3]"
		lappend gv(schema.type) "[lindex $fields 4]"
		lappend gv(schema.length) "[lindex $fields 5]"
		lappend gv(schema.range) "[lindex $fields 6]"
	}
	set gv(schema.numfields)   [expr [llength $gv(schema.name)]-1]

	set prevname "[string tolower [lindex $gv(schema.name) $gv(schema.numfields)]]"
	set j 0
	for {set i 0} {$i <= $gv(schema.numfields) } {incr i} {
		incr j
		if { $j > $gv(schema.numfields) } { set j 0 }
		set name "[string tolower [lindex $gv(schema.name) $i ]]"
		set nextname "[string tolower [lindex $gv(schema.name) $j ]]"
		
		if {[lindex $gv(schema.type) $i]=="list"} {
			pack [ frame $gv(top).field.$name ] \
				-side top -expand true -fill both
			pack [ label $gv(top).field.$name.lbl -width 40 -anchor w \
				-text "[lindex $gv(schema.title) $i ]" ] \
				-side left
			pack [ scrollbar $gv(top).field.$name.yscroll \
				-command "$gv(top).field.$name.list yview" ] \
				-side left -fill y
			pack [ listbox $gv(top).field.$name.list -relief sunken -width 10 -height 4 \
				-yscroll "$gv(top).field.$name.yscroll set" ] \
				-side left -expand true -fill both
			pack [ label $gv(top).field.$name.pnt -width 5 -text "<--" ] \
				-side left
			pack [ entry $gv(top).field.$name.ent -relief sunken ] \
				-side left -expand true -fill x

			bind $gv(top).field.$name.list <Any-Enter> {focus %W}
			bind $gv(top).field.$name.list <Any-BackSpace> \
				"listdelete $gv(top).field.$name.list"
			bind $gv(top).field.$name.list <Any-Delete> \
				"listdelete $gv(top).field.$name.list"
			bind $gv(top).field.$name.ent <Any-Enter> {focus %W}
			bind $gv(top).field.$name.ent <Return> \
				"listaddsort $gv(top).field.$name.list \[$gv(top).field.$name.ent get\] ; \
				$gv(top).field.$name.ent delete 0 end"
			bind_help $gv(top).field.$name.list $gv(top).help \
				"[lindex $gv(schema.title) $i ] (use Delete Key to remove items)"
			bind_help $gv(top).field.$name.ent $gv(top).help \
				"Hit return to add entry"
		} else {
			pack [ frame $gv(top).field.$name ] \
				-side top -fill x
			pack [ label $gv(top).field.$name.lbl -width 40 -anchor w \
				-text "[lindex $gv(schema.title) $i ]" ] \
				-side left
			pack [ entry $gv(top).field.$name.ent -relief sunken ] \
				-side left -expand true -fill x

			bind $gv(top).field.$name.ent <Any-Enter> {focus %W}
			bind $gv(top).field.$name.ent <Return> \
				"focus $gv(top).field.$nextname.ent"
			bind_help $gv(top).field.$name.ent $gv(top).help \
				"[lindex $gv(schema.title) $i ]"
		}
		bind $gv(top).field.$name.ent <Shift-Tab> "focus $gv(top).field.$prevname.ent ; break"
		bind $gv(top).field.$name.ent <Tab> "focus $gv(top).field.$nextname.ent ; break"
		set prevname $name
	}
}

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
}

proc dir_search { } {
	global env gv

	if {![info exists gv(schema.numfields)]} {return}

	for {set i 0} {$i <= $gv(schema.numfields) } {incr i} {
		set name "[string tolower [lindex $gv(schema.name) $i ]]"
		$gv(top).field.$name.ent delete 0 end
		if {[lindex $gv(schema.type) $i]=="list"} {
			$gv(top).field.$name.list delete 0 end
		}
		set valuelist($name) ""
	}

	set key $gv(searchstring)
	regsub -all {[	]} $key { } key
	regsub -all { } $key {+} key
	regsub -all {\[} $key {\\[} key
	regsub -all {\]} $key {\\]} key
	set res [query $gv(whois.host) $gv(whois.port) site=$gv(dirsite):db=$gv(dbdir):$key]

	set res [split $res "\n"]
	foreach line $res {
		if {[string range $line 0 5]=="Query="} {continue}
		if {[lindex [split $line] 0]!=1} {
			set gv(status) $line
			$gv(top).results.txt delete 1.0 end
			foreach line $res {
				$gv(top).results.txt insert insert "$line\n"
			}
			return
		}
		break
	}

	set gv(status) [lang "Single entry located" "Une seule entre trouv"]
	$gv(top).results.txt delete 1.0 end

	set i 0
	foreach line $res {
		if {[string range $line 0 5]=="Query="} {continue}
		incr i
		if {$i<2} {continue}
		set name [string trim [lindex [split $line ":"] 0]]
		if {$name==""} {continue}
		set value [string trim [lindex [split $line ":"] 1]]
		set j [lsearch -exact $gv(schema.name) $name]
		set name [string tolower $name]
		$gv(top).results.txt insert end $line
		if {$j<0} {
			$gv(top).results.txt insert end "   << unknown field\n"
			continue
		}
		$gv(top).results.txt insert end "\n"
		append valuelist($name) " $value"
	}
	foreach name [array names valuelist] {
		if {[winfo exists $gv(top).field.$name.list]} {
			foreach value $valuelist($name) {
				set value [string trim $value]
				if {"x$value"=="x"} { continue }
				$gv(top).field.$name.list insert end $value
			}
			listaddsort $gv(top).field.$name.list
		} else {
			$gv(top).field.$name.ent insert end [string trim $valuelist($name)]
		}
	}
}

proc dir_clear { } {
	global env gv

	if {![info exists gv(schema.numfields)]} {return}

	for {set i 0} {$i <= $gv(schema.numfields)} {incr i} {
		set name "[string tolower [lindex $gv(schema.name) $i ]]"
		$gv(top).field.$name.ent delete 0 end
		if {[winfo exists $gv(top).field.$name.list]} {
			$gv(top).field.$name.list delete 0 end
		}
	}
}

proc dir_send {subject} {
	global env gv

	$gv(top).results.txt delete 1.0 end

	# check for a key field present
	set name "[string tolower [lindex $gv(schema.name) 0 ]]"
	set contents [$gv(top).field.$name.ent get]
	if { $contents == "" } {
		$gv(top).results.txt insert 1.0 "ERROR - no $name field specified"
		return
	}

	if {$subject=="delete"} {
		set type [string toupper $gv(dbdir)]
		if {![yesno $gv(top) "Delete the entry $contents in the $type database ?"]} {
			$gv(top).results.txt insert 1.0 "Cancelled"
			return
		}
	}

	set recipients "$gv(dbdir)@$env(SITE)"

	$gv(top).results.txt insert end "From: $env(USER)\n"
	$gv(top).results.txt insert end "To: $recipients\n"
	$gv(top).results.txt insert end "Date: [clock format [clock seconds]]\n"
	$gv(top).results.txt insert end "Subject: $subject\n"
	$gv(top).results.txt insert end "Classification: UNCLASSIFIED\n"
	$gv(top).results.txt insert end "\n"
	$gv(top).results.txt insert end "\n"
	for {set i 0} {$i <= $gv(schema.numfields)} {incr i} {
		set name [string tolower [lindex $gv(schema.name) $i]]
		if {[lindex $gv(schema.type) $i]=="list"} {
			set n [$gv(top).field.$name.list size]
			for {set j 0} {$j<$n} {incr j} {
				set contents [string trim [$gv(top).field.$name.list get $j]]
				$gv(top).results.txt insert end "$name :$contents\n"
			}
		} else {
			set contents [string trim [$gv(top).field.$name.ent get]]
			$gv(top).results.txt insert end "$name :$contents\n"
		}
	}

	set res [sendmail_send $recipients [$gv(top).results.txt get 1.0 end]]
	if {$res!=""} {
		errmess $gv(top) $res
	} else {
		set gv(status) [lang "$subject request sent" "$subject envoy"]
	}

	return
}

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

# start off in the user's home directory
cd $env(HOME)

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] \
	-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) ] \
        -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 "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.query -text [lang "Enter your query string :" "FRENCH"] ] \
	-side left
pack [ entry $gv(top).b2.ent -relief sunken -textvariable gv(searchstring) ] \
	-side left -expand true -fill x
pack [ button $gv(top).b2.search -text [lang "Search" "Chercher"] \
	-command "dir_search" ] \
	-side left
pack [ button $gv(top).b2.clear -text [lang "Clear" "Nettoyer"] \
	-command "set gv(searchstring) \"\" ; dir_clear" ] \
	-side left
pack [ button $gv(top).b2.update -text [lang "Update" "Mettre  jour"] \
	-command "dir_send update" ] \
	-side left
pack [ button $gv(top).b2.create -text [lang "Create" "Crer"] \
	-command "dir_send create" ] \
	-side left
pack [ button $gv(top).b2.delete -text [lang "Delete" "Effacer"] \
	-command "dir_send delete" ] \
	-side left
pack [ button $gv(top).b2.undelete -text [lang "Undelete" "FRENCH"] \
	-command "dir_send undelete" ] \
	-side left

bind $gv(top).b2.ent <Tab> "focus $gv(top).b2.ent"
bind $gv(top).b2.ent <Return> "dir_search"

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

pack [ frame $gv(top).db ] \
	-side top -fill x
pack [ radiobutton $gv(top).db.nuad -text "NUAD" -variable gv(dbdir) -value nuad \
	-command "dir_schema" ] \
	-side left -expand true -fill x
pack [ radiobutton $gv(top).db.list -text "LIST" -variable gv(dbdir) -value list \
	-command "dir_schema" ] \
	-side left -expand true -fill x

#
#       load the schema information
#

dir_schema

pack [frame $gv(top).results] \
	-side top -expand true -fill both
pack [ scrollbar $gv(top).results.yscroll -command "$gv(top).results.txt yview"] \
	-side $gv(scrollpos) -fill y
pack [ text $gv(top).results.txt -yscroll "$gv(top).results.yscroll set" \
	-height 10 -wrap none -relief sunken ] \
	-expand true -fill both
bind_help $gv(top).results $gv(top).help \
	[lang "Results of the query" "Rsultat de recherche"]

# preload the search field
if {$gv(dbdir)=="nuad"} {set gv(searchstring) $env(USER)}

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

