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

set gv(version)		"TkCustom (Version 1.2 09jul96)"
set gv(program)		tkcustom
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(widgets)		{default Button Radiobutton Checkbutton \
			Entry Listbox Text Message Label Canvas \
			Menu Menubutton Scale Scrollbar}
set gv(options)		{font cursor background foreground \
			activeBackground activeForeground \
			selectBackground selectForeground \
			alarmBackground alarmForeground \
			insertBackground troughColor}

set gv(d.font)			""
set gv(d.cursor)		""
set gv(d.background)		""
set gv(d.foreground)		""
set gv(d.activebackground)	""
set gv(d.activeforeground)	""
set gv(d.selectbackground)	""
set gv(d.selectforeground)	""
set gv(d.alarmbackground)	""
set gv(d.alarmforeground)	""
set gv(d.insertbackground)	""
set gv(d.troughcolor)		""

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

proc font_select { {pw ""} {ew ""} } {
	global env fontname

	set cnt 0
	while {[winfo exists $pw.font$cnt]} { incr cnt }

	set w $pw.font$cnt

	set fontname ""

	toplevel $w
	wm title $w "Font Chooser $cnt"
	wm minsize $w 100 100
	wm protocol $w WM_DELETE_WINDOW "destroy $w"

	pack [frame $w.font -bd 2] \
		-side top -expand true -fill both
	pack [scrollbar $w.font.yscroll -command "$w.font.list yview"] \
		-side left -fill y
	pack [listbox $w.font.list -yscroll "$w.font.yscroll set" -relief sunken \
		-width 70 -height 30 ] \
		-expand true -fill both

	bind $w.font.list <Any-1> "set index \[$w.font.list nearest %y\] ; \
		set fontname \[$w.font.list get \$index\] ; \
		$w.test configure -font \$fontname"

	pack [frame $w.b1] \
		-side top -expand true -fill x
	pack [button $w.b1.normal -text "Normal" -width 10 \
		-command "cust_font_load $w.font.list normal"] \
		-side left -expand true -fill x
	pack [button $w.b1.all -text "All fonts" -width 10 \
		-command "cust_font_load $w.font.list all"] \
		-side left -expand true -fill x

	pack [label $w.test -text "Test string" ] \
		-side top -fill x -ipadx 10 -ipady 10

	pack [frame $w.b2 -bd 2] \
		-side top -expand true -fill x
	pack [button $w.b2.cancel -text "Cancel" -width 10 \
		-command "set fontname {} ; destroy $w"] \
		-side left -expand true -fill x -padx 10 -pady 10 -ipadx 10 -ipady 10
	pack [button $w.b2.ok -text "OK" -width 10 \
		-command "set fontname \$fontname ; destroy $w"] \
		-side left -expand true -fill x -padx 10 -pady 10 -ipadx 10 -ipady 10

	cust_font_load $w.font.list normal

	if {$ew!="" && [winfo exists $ew]} {
		$w.b2.ok configure -command "if {\$fontname!=\"\"} {
				$ew delete 0 end ; \
				$ew insert end \$fontname \
			} ; \
			destroy $w"
	} else {
		tkwait window $w
		return "$fontname"
	}

}

proc cust_font_load { lw type } {
	global env

	$lw delete 0 end
	if {$type=="all"} {
		set fp [open "| xlsfonts | sort | uniq" r]
		while {[gets $fp line]>=0} {
			set name [string trim $line]
			if {$name==""} { continue }
			$lw insert end $name
		}
		close $fp
	} else {
		set fp [open $env(TKAPPS)/etc/fonts r]
		while {[gets $fp line]>=0} {
			set name [split [string trim $line] ":"]
			if {[llength $name]==1} {
				$lw insert end $name
			} else {
				set part1 [lindex $name 0]
				set part3 [lindex $name 2]
				foreach part2 [lindex $name 1] {
					$lw insert end "$part1$part2$part3"
				}
			}
		}
		close $fp
	}
}

proc cursor_select { {pw ""} {ew ""} } {
	global env cursorname testtype

	set cnt 0
	while {[winfo exists $pw.cursor$cnt]} { incr cnt }

	set w $pw.cursor$cnt

	set cursorname ""
	set testtype "background"

	toplevel $w
	wm title $w "Cursor Chooser $cnt"
	wm protocol $w WM_DELETE_WINDOW "destroy $w"

	pack [frame $w.cursors -bd 2] \
		-side top -expand true -fill both
	pack [scrollbar $w.cursors.yscroll -command "$w.cursors.list yview"] \
		-side left -fill y
	pack [listbox $w.cursors.list -yscroll "$w.cursors.yscroll set" -relief sunken \
		-width 30 -height 30 ] \
		-expand true -fill both

	bind $w.cursors.list <Any-1> "set index \[$w.cursors.list nearest %y\] ; \
		set cursorname \[$w.cursors.list get \$index\] ; \
		$w.test configure -cursor \$cursorname"

	pack [frame $w.b2] \
		-side top -expand true -fill x
	pack [radiobutton $w.b2.fg -text "Set Foreground" \
		-variable testtype -value foreground ] \
		-side left -expand true -fill x
	pack [radiobutton $w.b2.bg -text "Set Background" \
		-variable testtype -value background ] \
		-side left -expand true -fill x

	pack [label $w.test -text "Test string" ] \
		-side top -fill x -ipadx 10 -ipady 10

	pack [frame $w.b1 -bd 2] \
		-side top -expand true -fill x
	pack [button $w.b1.cancel -text "Cancel" -width 10 \
		-command "set cursorname {} ; destroy $w"] \
		-side left -expand true -fill x -padx 10 -pady 10 -ipadx 10 -ipady 10
	pack [button $w.b1.ok -text "OK" -width 10 \
		-command "destroy $w"] \
		-side left -expand true -fill x -padx 10 -pady 10 -ipadx 10 -ipady 10

	# read the cursors from the database
	catch {f_read $env(TKAPPS)/etc/cursors} res
	foreach line [split $res "\n"] {
		set name [string trim [lindex [split $line ":"] 0]]
		if {$name==""} { continue }
		$w.cursors.list insert end $name
	}

	# if an entry widget supplied, fill it in when OK is pressed
	if {$ew!="" && [winfo exists $ew]} {
		$w.b1.ok configure -command "if {\$cursorname!=\"\"} {
				$ew delete 0 end ; \
				$ew insert end \$cursorname \
			} ; \
			destroy $w"
	} else {
		tkwait window $w
		return "$cursorname"
	}

}

proc color_select { {pw ""} {ew ""} } {
	global env colorname testtype

	set cnt 0
	while {[winfo exists $pw.color$cnt]} { incr cnt }

	set w $pw.color$cnt

	set colorname ""
	set testtype "background"

	toplevel $w
	wm title $w "Color Chooser $cnt"
	wm protocol $w WM_DELETE_WINDOW "destroy $w"

	pack [frame $w.rgb -bd 2] \
		-side top -expand true -fill both
	pack [scrollbar $w.rgb.yscroll -command "$w.rgb.list yview"] \
		-side left -fill y
	pack [listbox $w.rgb.list -yscroll "$w.rgb.yscroll set" -relief sunken \
		-width 30 -height 30 ] \
		-expand true -fill both

	bind $w.rgb.list <Any-1> "set index \[$w.rgb.list nearest %y\] ; \
		set colorname \[$w.rgb.list get \$index\] ; \
		$w.test configure -text \$colorname -\$testtype \$colorname"

	pack [frame $w.b2] \
		-side top -expand true -fill x
	pack [radiobutton $w.b2.fg -text "Set Foreground" \
		-variable testtype -value foreground ] \
		-side left -expand true -fill x
	pack [radiobutton $w.b2.bg -text "Set Background" \
		-variable testtype -value background ] \
		-side left -expand true -fill x

	pack [label $w.test -text "Test string" ] \
		-side top -fill x -ipadx 10 -ipady 10

	pack [frame $w.b1 -bd 2] \
		-side top -expand true -fill x
	pack [button $w.b1.cancel -text "Cancel" -width 10 \
		-command "set colorname {} ; destroy $w"] \
		-side left -expand true -fill x -padx 10 -pady 10 -ipadx 10 -ipady 10
	pack [button $w.b1.ok -text "OK" -width 10 \
		-command "destroy $w"] \
		-side left -expand true -fill x -padx 10 -pady 10 -ipadx 10 -ipady 10

	# read the colors from the database
	catch {f_read $env(TKAPPS)/etc/colors} res
	foreach line [split $res "\n"] {
		set name [string trim [lindex [split $line ":"] 0]]
		if {$name==""} { continue }
		$w.rgb.list insert end $name
	}

	# if an entry widget supplied, fill it in when OK is pressed
	if {$ew!="" && [winfo exists $ew]} {
		$w.b1.ok configure -command "if {\$colorname!=\"\"} {
				$ew delete 0 end ; \
				$ew insert end \$colorname \
			} ; \
			destroy $w"
	} else {
		tkwait window $w
		return "$colorname"
	}

}

proc cust_blank { } {
	global env gv

	foreach widget $gv(widgets) {
		set widgetname [string tolower $widget]
		foreach option $gv(options) {
			set optionname [string tolower $option]
			set gv($widgetname.$optionname) ""
		}
	}
}

proc cust_default { } {
	global env gv

	foreach widget $gv(widgets) {
		set widgetname [string tolower $widget]
		if {$widgetname=="default"} {
			foreach option $gv(options) {
				set optionname [string tolower $option]
				if {$gv($widgetname.$optionname)!=""} { continue }
				set gv($widgetname.$optionname) $gv(d.$optionname)
			}
		} else {
			foreach option $gv(options) {
				set optionname [string tolower $option]
				if {$gv($widgetname.$optionname)!=""} { continue }
				set gv($widgetname.$optionname) $gv(default.$optionname)
			}
		}
	}
}

proc cust_save { } {
	global env gv

	regsub -all {[^-_.a-zA-Z0-9]} $gv(application) {} gv(application)

	if {$gv(application)==""} {return}

	if {![file isdirectory $env(HOME)/app-defaults]} {
		f_mkdir $env(HOME)/app-defaults
	}

	set fp [open $env(HOME)/app-defaults/$gv(application) w]
	foreach widget $gv(widgets) {
		set widgetname [string tolower $widget]
		if {$widgetname=="default"} {
			foreach option $gv(options) {
				set optionname [string tolower $option]
				set value [string trim $gv(default.$optionname)]
				if {$value==""} { continue }
				puts $fp "*$option: $value"
			}
		} else {
			foreach option $gv(options) {
				set optionname [string tolower $option]
				set value [string trim $gv($widgetname.$optionname)]
				if {$value==""} { continue }
				puts $fp "*$widget.$option: $value"
			}
		}
	}
	close $fp
}

proc cust_load { } {
	global env gv

	regsub -all {[^-_.a-zA-Z0-9]} $gv(application) {} gv(application)

	if {$gv(application)==""} {return}

	if {![file isdirectory $env(HOME)/app-defaults]} {
		f_mkdir $env(HOME)/app-defaults
	}

	set files {}
	if {[file readable $env(TKAPPS)/app-defaults/default.ini]} {
		lappend files $env(TKAPPS)/app-defaults/default.ini
	}
	if {[file readable $env(TKAPPS)/app-defaults/$gv(application)]} {
		lappend files $env(TKAPPS)/app-defaults/$gv(application)
	}
	if {[file readable $env(HOME)/app-defaults/default]} {
		lappend files $env(HOME)/app-defaults/default
	}
	if {[file readable $env(HOME)/app-defaults/$gv(application)]} {
		lappend files $env(HOME)/app-defaults/$gv(application)
	}

	cust_blank
	cust_default

	foreach filename $files {
		set fp [open $filename r]
		while {[gets $fp line]>=0} {
			set fields [split $line ":"]
			set field [string trim [string tolower [lindex $fields 0]]]
			set value [string trim [join [lrange $fields 1 end] ":"]]

			set field [split $field "*"]
			set application [lindex $field 0]
			set field [split [lindex $field 1] "."]

			if {[llength $field]==1} {
				set widget "default"
				set option $field
			} elseif {[llength $field]==2} {
				set widget [lindex $field 0]
				set option [lindex $field 1]
			} else {
				puts stdout "Unknown option : $line"
				continue
			}
			set widgetname [string tolower $widget]
			set optionname [string tolower $option]
			set gv($widgetname.$optionname) "$value"
		}
		close $fp
	}

	return
}

proc cust_show { } {
	global env gv

	foreach option $gv(options) {
		set optionname [string tolower $option]
		$gv(top).o.$optionname.ent configure \
			-textvariable gv($gv(widget).$optionname)
	}
}

##############################################################################
#####	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] \
	-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 file menu" "Menu standard du fichier"]
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.lab -text "Application: " ] \
	-side left
pack [entry $gv(top).b2.ent -textvariable gv(application) -relief sunken ] \
	-side left -expand true -fill x
pack [button $gv(top).b2.load -text [lang "Load" "FRENCH"] \
	-command "cust_load"] \
	-side left
pack [button $gv(top).b2.save -text [lang "Save" "FRENCH"] \
	-command "cust_save"] \
	-side left
bind $gv(top).b2.ent <Return>	"cust_load"


pack [frame $gv(top).w] \
	-side left -fill y
pack [label $gv(top).w.lab -text Widgets ] \
	-side top -fill x

foreach widget $gv(widgets) {
	set widgetname [string tolower $widget]
	pack [radiobutton $gv(top).w.$widgetname -variable gv(widget) \
		-value $widgetname -text $widget -anchor w -command "cust_show" ] \
		-side top -expand true -fill both
}

pack [frame $gv(top).o] \
	-side left -fill y
pack [label $gv(top).o.lab -text Options ] \
	-side top -fill x

foreach option $gv(options) {
	set optionname [string tolower $option]
	pack [frame $gv(top).o.$optionname -bd 2 -relief raised] \
		-side top -fill x
	pack [label $gv(top).o.$optionname.lab -width 20 -text $option -anchor w ] \
		-side left
	pack [entry $gv(top).o.$optionname.ent -width 50 -relief sunken ] \
		-side left -fill x
	pack [button $gv(top).o.$optionname.clear -text "Clear" \
		-command "$gv(top).o.$optionname.ent delete 0 end" ] \
		-side left
	if {$optionname=="font"} {
		pack [button $gv(top).o.$optionname.select -text "Select..." \
			-command "font_select $gv(top) $gv(top).o.$optionname.ent" ] \
			-side left
	} elseif {$optionname=="cursor"} {
		pack [button $gv(top).o.$optionname.select -text "Select..." \
			-command "cursor_select $gv(top) $gv(top).o.$optionname.ent" ] \
			-side left
	} else {
		pack [button $gv(top).o.$optionname.select -text "Select..." \
			-command "color_select $gv(top) $gv(top).o.$optionname.ent" ] \
			-side left
	}
}


if {[llength $argv]==1} {
	set gv(application) $argv
	cust_load
} else {
	cust_blank
	cust_default
}

set gv(widget) default
cust_show

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


