# Simple Dialog routines
# (c) Wallis Consulting

# DESCRIPTION:	Create a generic dialog.
# INPUT:	w - dialog name
#		title - dialog title
#		fields - fields
# RETURN:	1 if dialog already exists
#		0 if it doesn't
proc dm_MakeDlg {w title fields} {
	global Dm_Pref Dm_Path Dm_Spin Dm_Radio

	if [catch {toplevel $w}] {
		raise $w
		return 1
	}
	wm transient $w .
	if {$title != ""} {
		wm title $w "$Dm_Pref(progName) - $title"
	}
	wm protocol $w WM_DELETE_WINDOW "$w.fb.cancel invoke"

	frame $w.f -relief raised -bd 1
	set i 0

	foreach field $fields {

	label $w.f.l$i -text [rlindex field 1]: -justify right
	grid $w.f.l$i -row $i -column 0 -sticky e
	set sticky w
	switch [set opt [rlindex field 0]] {
	Entry {
		entry $w.f.v$i
	}
	EntryUnit {
		frame $w.f.v$i
		entry $w.f.e$i
		label $w.f.u$i -text [rlindex field 2]
		pack $w.f.e$i $w.f.u$i -side left -in $w.f.v$i
	}
	Label {
		label $w.f.v$i -text [rlindex field 2]
	}
	Spin {
		entry $w.f.v$i -width 5 -textvariable [rlindex field 3]
		frame $w.f.f$i
		dm_MakeSpin $w.f.s$i $w.f.v$i [rlindex field 2]\
			[rlindex field 4]
		bind $w.f.v$i <FocusOut> "dm_CheckSpin $w.f.v$i"
		pack $w.f.v$i $w.f.s$i -side left -in $w.f.f$i
		if {[set lab [rlindex field 5]] != ""} {
			pack [label $w.f.f$i.l -text $lab] -side right
		}

		# Otherwise value and menubar disappear!
		grid $w.f.f$i -row $i -column 1 -sticky w
		raise $w.f.v$i
		incr i
		continue
	}
	ComboMenu -
	Combo {
		entry $w.f.v$i
		if {$opt == "Combo"} {
			button $w.f.mb$i -bitmap @$Dm_Path/bitmaps/pulldown.xbm
		} else {
			menubutton $w.f.mb$i -bitmap @$Dm_Path/bitmaps/pulldown.xbm\
				-menu $w.f.mb$i.m -takefocus 1\
				-highlightthickness 1 -relief raised
			menu $w.f.mb$i.m
		}
		frame $w.f.f$i
		pack $w.f.v$i -side left -fill x -expand 1 -in $w.f.f$i
		pack $w.f.mb$i -side right -in $w.f.f$i

		# Otherwise value and menubutton disappear!
		grid $w.f.f$i -row $i -column 1 -sticky w
		raise $w.f.v$i
		raise $w.f.mb$i
		incr i
		continue
	}
	Radio -
	RadioBitmap {
		frame $w.f.v$i -class FRadio
		if {[set numCols [rlindex field 3]]==""} {
			set numCols 3
		}
		set k 0
		foreach j [rlindex field 2] {
			radiobutton $w.f.v$i.r$k -value $k -variable Dm_Radio($w.f.v$i)
			if {$opt=="Radio"} {
				$w.f.v$i.r$k config -text $j
			} else {
				$w.f.v$i.r$k config -bitmap @$Dm_Path/bitmaps/$j
			}
			grid $w.f.v$i.r$k -row [expr $k/$numCols]\
				-column [expr $k%$numCols] -sticky w
			incr k
		}
	}
	Check {
		frame $w.f.v$i -class FRadio
		if {[set numCols [rlindex field 3]]==""} {
			set numCols 3
		}
		set k 0
		foreach j [rlindex field 2] {
			checkbutton $w.f.v$i.c$k -variable Dm_Radio($w.f.v$i.c$k) -text $j
			grid $w.f.v$i.c$k -row [expr $k/$numCols]\
				-column [expr $k%$numCols] -sticky w
			incr k
		}
	}
	List {
		listbox $w.f.v$i -width 60
	}
	}
	grid $w.f.v$i -row $i -column 1 -sticky $sticky
	incr i
	}
	pack $w.f -ipadx 4 -ipady 4 -fill x -expand 1

	frame $w.fb -class FBtn
	button $w.fb.ok
	bind $w.fb.ok <1> "focus $w.fb.ok"
	button $w.fb.cancel -command "destroy $w"
	button $w.fb.help -state disabled
	pack $w.fb.ok $w.fb.cancel $w.fb.help -side left
	pack $w.fb -pady 5

	label $w.status -bd 0 -foreground red -justify left
	pack $w.status -anchor w

	wm geom $w "+[winfo pointerx .]+[winfo pointery .]"
	wm resizable $w 0 0

	# Default action is to press ok
	bind $w <Return> "focus $w.fb.ok; update; $w.fb.ok invoke"
	bind $w <Escape> "$w.fb.cancel invoke"
	return 0
}

# DESCRIPTION:	Override default error message (release only)
# INPUT:	err - error message
proc xbgerror err {
	dm_Prompt .err $err Continue
}

# DESCRIPTION:	Prompt user for action
# INPUT:	w - window name
#		msg - message
#		args - buttons
proc dm_Prompt {w msg args} {
	global Dm_Pref

	toplevel $w
	wm withdraw $w
	wm transient $w .
	wm title $w $Dm_Pref(progName)
	wm geom $w "+[winfo pointerx .]+[winfo pointery .]"

	if {$w == ".err"} {
		label $w.l -bitmap error -fg red
		bell
	} else {
		label $w.l -bitmap questhead -fg red
	}
	label $w.m -text $msg -justify left
	frame $w.fBtn
	set i 0
	foreach but $args {
		button $w.fBtn.b$i -text $but -command "set Dm_Pref(button) $i"
		pack $w.fBtn.b$i -side left -pady 5
		incr i
	}

	grid $w.l -column 0 -row 0 -pady 5 -padx 5
	grid $w.m -column 1 -row 0 -sticky w
	grid $w.fBtn -column 0 -columnspan 2 -row 1

	bind $w <Return> {[focus -lastfor %W] invoke}

	focus $w.fBtn.b0
	dm_OnScreen $w
	tkwait visibility $w
	grab $w
	vwait Dm_Pref(button)
	grab release $w
	catch {destroy $w}
	return $Dm_Pref(button)
}

# DESCRIPTION:	Busy cursor on/off.  Recursively walk window child heirarchy.
# INPUT:	w - window
# 		on - true/false
proc dm_BusyCursor {w {on 1}} {
	if $on {set c watch} else {set c ""}
	foreach i [winfo children $w] {
		catch {$i config -cursor $c}
		if {[set class [winfo class $i]] == "Frame" || $class == "Toplevel"} {
			dm_BusyCursor $i $on
		}
	}
}

# DESCRIPTION:	Make a numeric spin button
# INPUT:	w - frame name
#		e - entry field associated with buttons
#		min - minimum value
#		max - maximum value
proc dm_MakeSpin {w e min {max 0}} {
	global Dm_Path Dm_Spin

	frame $w -bd 0
	set Dm_Spin($e.min) $min
	set Dm_Spin($e.max) $max
	set Dm_Spin($e.interval) 500

	button $w.u -bitmap @$Dm_Path/bitmaps/up.xbm\
		-highlightthickness 0 -takefocus 0
	button $w.d -bitmap @$Dm_Path/bitmaps/down.xbm\
		-highlightthickness 0 -takefocus 0
	bind $w.u <1> "tkButtonDown %W; dm_DoSpin $e %W 1; break"
	bind $w.d <1> "tkButtonDown %W; dm_DoSpin $e %W -1; break"
	pack $w.u -side top
	pack $w.d -side bottom
}

# DESCRIPTION:	Increment/decrement spin button.  We use the tkPriv array to
#		determine if the button continues to be depressed.  See the
#		tk library file button.tcl for details.  Initially, there is
#		a half-second delay so that individual presses incr/decr once.
# INPUT:	w - button name
#		n - increment amount
proc dm_DoSpin {w b n} {
	global tkPriv Dm_Spin

	if {$tkPriv(buttonWindow)!=$b} {
		# Reset interval
		set Dm_Spin($w.interval) 500
		return
	}

	upvar #0 [$w cget -textvariable] val
	if {$n<0 && $val<=$Dm_Spin($w.min)} return
	if {$n>0 && $Dm_Spin($w.max) && $val>=$Dm_Spin($w.max)} return
	catch {incr val $n}
	after $Dm_Spin($w.interval) dm_DoSpin $w $b $n

	# go faster
	set Dm_Spin($w.interval) 50
}

# DESCRIPTION:	Ensure that bounded integer fields are correct.
proc dm_CheckSpin {w} {
	global Dm_Spin

	upvar #0 [$w cget -textvariable] val
	if {$val < $Dm_Spin($w.min)} {
		set val $Dm_Spin($w.min)
		bell
	} elseif {$val > $Dm_Spin($w.max)} {
		set val $Dm_Spin($w.max)
		bell
	}
}

# DESCRIPTION:	Build an option menu.
# INPUT:	w - widget name
#		access - read-write?
#		el - menu item list (label-value pairs)
proc dm_OptionMenu {w access el} {
	global Dm_Radio

	menubutton $w -anchor w -menu $w.m
	menu $w.m
	if {$access=="read-write"} {
		$w config -relief raised -indicatoron 1
	} else {
		# Disable menu access
		bind $w <1> {break}
		bind $w <2> {break}
		$w config -padx 0 -pady 0
	}

	set i 0
	foreach e $el {
		set val [rlindex e 0]
		set lab [rlindex e 1]
		$w.m add radiobutton -label $lab\
			-variable Dm_Radio($w)\
			-value $val\
			-command "$w config -text $lab"
		incr i
	}
}

# DESCRIPTION:	Create a drop-down list.
# INPUT:	w - list
# 		target - entry field that would receive selection.
proc dm_CreateDropList {w target} {
	global Dm_DropListTarget

	set Dm_DropListTarget($w.l) $target
	if [winfo exists $w] return

	toplevel $w -highlightthickness 1
	wm withdraw $w
	wm overrideredirect $w 1
	wm transient $w [winfo toplevel $target]
	listbox $w.l -yscroll "$w.sv set" -width [$target cget -width]
	bind $w.l <ButtonRelease-1> {
		catch {
			$Dm_DropListTarget(%W) delete 0 end
			$Dm_DropListTarget(%W) insert 0 [%W get [%W curselection]]
			focus $Dm_DropListTarget(%W)
		}
		set Dm_DropListTarget(%W) [set Dm_DropListTarget(%W)]
	}
	scrollbar $w.sv -command "$w.l yview"
	pack $w.sv -side right -fill y
	pack $w.l -expand 1 -fill both

	# Modify variable with current value so that vwait can complete.
	bind $w.l <Escape> "set Dm_DropListTarget($w.l) [set Dm_DropListTarget($w.l)]"
	bind $w.l <Return> [bind $w.l <Escape>]
	bind $w <ButtonRelease-1> [bind $w.l <Escape>]

	# Break after Scrollbar binding so that event isn't seen at toplevel.  (That
	# would dismiss window when we scrolled.)
	bind $w.sv <ButtonRelease-1> {tkScrollButtonUp %W %x %y; break}
}

# DESCRIPTION:	Display a drop-down list window.
# INPUT:	w - list
proc dm_ShowDropList {w} {
	global Dm_DropListTarget

	set x [winfo rootx $Dm_DropListTarget($w.l)]
	set y [winfo rooty $Dm_DropListTarget($w.l)]
	incr y [winfo height $Dm_DropListTarget($w.l)]
	wm geom $w +$x+$y
	wm deiconify $w
	raise $w
	focus $w.l
	grab $w
	vwait Dm_DropListTarget($w.l)
	grab release $w
	wm withdraw $w
}

# DESCRIPTION:	Floating Radio box
# INPUT:	w - widget name
#		type - color or image
#		list - image names
proc dm_RadioBox {w type {list ""}} {
	global Dm_Radio Dm_Pref Dm_GrSymbol

	if ![winfo exists $w] {
		toplevel $w -highlightthickness 1
		wm overrideredirect $w 1
		wm geom $w +[expr [winfo pointerx .]-4]+[expr [winfo pointery .]-4]
		set i 0
		if {$type == "color"} {
			foreach c $Dm_Pref(colors) {
				radiobutton $w.r$i -indicatoron 0 -width 1 -bg $c\
					-bd 0 -variable Dm_Radio($w) -value $c\
					-selectcolor $c
				bind $w.r$i <Enter> "$w.l config -text $c"
				grid $w.r$i -row [expr $i/12] -column [expr $i%12]
				incr i
			}
			set row [expr ($i/12)+1]
			grid [label $w.l -anchor w] -row $row -column 0 -columnspan 12\
				-sticky we
		} else {
			foreach o $list {
				radiobutton $w.r$i -indicatoron 0\
					-image $Dm_GrSymbol($o) -value $o\
					-variable Dm_Radio($w) -selectcolor ""
				pack $w.r$i -side right
				incr i
			}
		}

		bind $w <ButtonRelease-1> "set Dm_Radio($w) [set Dm_Radio($w)]"
	} else {
		wm geom $w +[expr [winfo pointerx .]-4]+[expr [winfo pointery .]-4]
		wm deiconify $w
		raise $w
	}

	focus $w
	grab $w
	vwait Dm_Radio($w)
	grab release $w
	wm withdraw $w
}

# Create a multi list box
proc MultiListbox:create {w args} {
	global MultiListbox

	frame $w -relief sunken
	frame $w.header -bd 1 -relief raised -highlightthickness 0

	scrollbar $w.sh -orient horizontal -command "MultiListbox:op $w xview"
	pack $w.sh -side bottom -fill y -anchor e
	scrollbar $w.s -command "MultiListbox:op $w yview"
	pack $w.header -side top -anchor nw -fill x

	set MultiListbox($w.lists) {}
	set i -1
	foreach opt $args {
		incr i
		listbox $w.list$i -bd 0 -yscrollcommand "$w.s set" -xscrollcommand "$w.sh set"\
			-highlightthickness 0 -exportselection 0
		eval $w.list$i config [lindex $opt 1]
		pack [label $w.header.h$i -text [lindex $opt 0] -anchor w -bd 0\
			 -highlightthickness 0 -width [$w.list$i cget -width]] -side left
		bind $w.list$i <1> "MultiListbox:select %W %x %y"
		bind $w.list$i <2> break
		bind $w.list$i <B1-Motion> break
		lappend MultiListbox($w.lists) $w.list$i
	}

	eval pack [lrange $MultiListbox($w.lists) 0 [expr $i-1]] -side left -fill both
	pack $w.list$i -side left -fill both -expand 1
	pack $w.s -side right -fill y
}

proc MultiListbox:op {w op args} {
	global MultiListbox

	foreach l $MultiListbox($w.lists) {
		eval $l $op $args
	}
}

proc MultiListbox:select {w x y} {
	global MultiListbox

	set el [$w index @$x,$y]
	foreach l $MultiListbox([winfo parent $w].lists) {
		$l selection clear 0 end
		$l selection set $el
		$l selection anchor $el
	}
}

# Get listbox data as tab-seperated strings.  Index -1 is title.
proc MultiListbox:get {w index} {
	global MultiListbox

	if {$index == -1} {
		set str [$w.header.h0 cget -text]
		loop i 1 [llength $MultiListbox($w.lists)] {
			append str \t[$w.header.h$i cget -text]
		}
	} else {
		foreach l $MultiListbox($w.lists) {
			if [info exists str] {
				append str \t[$l get $index]
			} else {
				append str [$l get $index]
			}
		}
	}
	return $str
}

proc MultiListbox:insert {w str {index end}} {
	global MultiListbox

	foreach l $MultiListbox($w.lists) s $str {
		$l insert $index $s
	}
}

# DESCRIPTION:	Ensure the window is completely on screen
# INPUT:	w - window name
proc dm_OnScreen {w} {
	update idletasks;       # force geometry update

	set sWidth [winfo screenwidth .]
	set sHeight [winfo screenheight .]
	set width [winfo reqwidth $w]
	set height [winfo reqheight $w]
	set x [winfo pointerx .]
	set y [winfo pointery .]

	if {[expr $x+$width] > $sWidth} {
		set x [expr $sWidth-$width]
	}
	if {[expr $y+$height] > $sHeight} {
		set y [expr $sHeight-$height]
	}

	wm geom $w +$x+$y
	wm deiconify $w
}

# DESCRIPTION:  Validate numeric field (with ranges)
# INPUT:        e - entry field
#               lo - low value
#               hi - high value
proc doCheck {e {lo ""} {hi ""}} {
	set value [$e get]
	if {$lo == ""} {
		if [catch {format "%d" $value}] {
			$e delete 0 end
			$e insert 0 0
			bell
		} 
	} elseif {$value < $lo} {
		$e delete 0 end
		$e insert 0 $lo
		bell
	} elseif {$hi != "" && $value > $hi} {
		$e delete 0 end
		$e insert 0 $hi
		bell
	}
}

# DESCRIPTION:  Validate IP Address/Netmask.  Ignore empty fields.  Catch
#		'integer too large errors'.
# INPUT:        e - entry field
proc doCheckIPAddr {e} {
	set n -1
	if ![catch {if {[set ipAddr [$e get]] == ""} {set n 4}}] {
		if {$n == 4} return
		catch {
			# DNS name?
			if {[set ip [getIPAddr $ipAddr]] != $ipAddr} {
				# Found DNS name's IP address
				$e delete 0 end
				$e insert 0 $ip
				set ipAddr $ip
				return
			}
		}
		if {[set n [scan $ipAddr %d.%d.%d.%d a b c d]] == 4} {
			foreach i "$a $b $c $d" {
				if {$i < 0 || $i > 255} {
					[winfo toplevel $e].status config -text "Invalid IP address range"
					bell
					return
				}
			}
		}
	}

	if {$n != 4} {
		[winfo toplevel $e].status config -text "Bad IP address format: expect d.d.d.d"
		bell
        } else {
		# Clear out old message
		[winfo toplevel $e].status config -text ""
        }
}

# DESCRIPTION:  Validate Mac Address
# INPUT:        m - entry field
proc doCheckMacAddr {m} {
	set n -1
	if ![catch {if {[set addr [$m get]] == ""} {set n 6}}] {
		if {$n == -1 && [set n [scan $addr %x:%x:%x:%x:%x:%x a b c d e f]] == 6} {
			foreach i "$a $b $c $d $e $f" {
				if {$i < 0 || $i > 255} {
					set n -1
					break
				}
			}
		}
	}

        if {$n != 6} {
		[winfo toplevel $m].status config -text "Bad Mac address: expect x:x:x:x:x:x"
		bell
        } else {
		# Clear out old message
		[winfo toplevel $m].status config -text ""
	}
}

# DESCRIPTION:  Check that argument supplied by caller is indeed a number
# INPUT:        value - possible number
#               predicate - expression containing 'value'
# RETURN:       number
proc dm_CheckInteger {value {predicate 0}} {
	if [catch {format "%d" $value}] {
		error "Expected Integer"
	}
	if [expr $predicate] {
		eval error "$predicate"
	}
	return $value
}

# DESCRIPTION:	Create tooltip bindings for button
proc dm_ToolTipBind {w} {
	bind $w <Enter> {set Dm_ToolTipTimer [after 1000 dm_ToolTip %W]}
	bind $w <Leave> dm_ToolTipHide
}

# DESCRIPTION:	Show (or create) tooltip
# INPUT:	w - button
proc dm_ToolTip {w} {
	global Dm_ToolTipTimer

	if ![winfo exists .toolTip] {
		toplevel .toolTip
		pack [label .toolTip.l -bd 1 -relief raised]
		wm overrideredirect .toolTip 1
		set map 0
	} else {
		set map 1
	}
	.toolTip.l config -text [$w cget -text]
	set x [winfo rootx $w]
	set y [winfo rooty $w]
	wm geom .toolTip +[incr x [winfo width $w]]+[incr y [winfo height $w]]
	if $map {wm deiconify .toolTip; raise .toolTip [winfo toplevel $w]}
	set Dm_ToolTipTimer [after 5000 dm_ToolTipHide]
}
 
# DESCRIPTION:	Hide (or cancel) tooltip
proc dm_ToolTipHide {} {
	global Dm_ToolTipTimer

	catch {wm withdraw .toolTip}
	catch {after cancel $Dm_ToolTipTimer}
}

# DESCRIPTION:	Call browser to display context sensitive help.
# INPUT:	url - URL containing help.
proc dm_Help {url} {
	global tcl_platform Dm_Path

	if {$tcl_platform(platform) == "windows"} {
		regsub : $Dm_Path | location
		dm_Browse file:///$location/$url
	} else {
		dm_Browse file:$Dm_Path/$url
	}
}

# DESCRIPTION:	Call browser with URL
proc dm_Browse {url} {
	global Dm_Status Dm_Path Dm_Pref tcl_platform

	if {$tcl_platform(platform) == "windows"} {
		if {[info commands dde] == ""} {
			catch {load $Dm_Path/bin/dde.dll}
			if [string match *iexplore.exe $Dm_Pref(browser)] {
				set Dm_Pref(dde) iexplore; # (2.0 uses mosaic)
			} else {
				set Dm_Pref(dde) NETSCAPE
			}
		}
		
		if {$Dm_Pref(dde) == "iexplore"} {
			# Internet Explorer can't use sublinks; remove them.
			if {[set sublinkPos [string last # $url]] != -1} {
				incr sublinkPos -1
				set url [string range $url 0 $sublinkPos]
			}
		}

		# Use DDE to contact running browser, else exec browser.
		if [catch {dde exec $Dm_Pref(dde) WWW_OpenURL $url}] {
			if [catch {set rc [exec $Dm_Pref(browser) $url &]} err] {
				# See if browser is available...
				if ![file exists  $Dm_Pref(browser)] {
					dm_Prompt .err "Can't find Browser in $Dm_Pref(browser).\n(Please update this in $Dm_Path/dm.ini)" Continue
				} else {
					dm_Prompt .err $err Continue
				}
			}
		} else {
			set Dm_Status "displaying help page in browser..."
		}
		return
	}

	if [catch {set rc [exec netscape -remote openURL($url)]} err] {
		if ![string match "*not running*" $err] {
			set Dm_Status $err; bell
		} else {
			if [catch {set rc [exec netscape $url &]} err] {
				set Dm_Status $err; bell
			}
			set Dm_Status "Starting netscape..."
		}
	}
}

# Windows Tk hangs on exit when grandchildren are visible
proc dm_transient {w parent} {
	global tcl_platform

	if {$tcl_platform(platform) == "unix"} {
		wm transient $w $parent
	} else {
		wm transient $w .
	}
}
