# miscellaneous useful stuff
#
# Hume Smith  hclsmith@glinx.com

package provide HCLS 1.05

#
#
#

namespace eval HCLS {

#
# Quoters
#

namespace eval quote {
namespace export {[a-z]*}
variable cache
array set cache {}

#
# sigh... of course, some (not all! eg subst, new regsub) of these can be
# done simply by putting \ in front of everything.  but that's somehow not
# as elegent.  It's certainly not as much fun.
#

# 1999 Aug 26
# - reworked so that Backsolidus-guard creates the procs instead of being
#  called by them... which should speed them up noticeably

if {![catch {string map {} {}}]} {
# string map
proc Backsolidus-guard {name bag} {
	array set x {\\ \\\\}
	foreach c [split $bag {}] { set x($c) \\$c }
	proc $name str "string map [list [array get x]] \$str"
}} elseif {[catch {regexp {[\]} {}}]} {
# new REs
proc Backsolidus-guard {name bag} {
	# crickey... this is getting self-referential :)
	::regsub -all {[\\\[\]\-\^]} \\$bag {\\&} bag
	proc $name str "[list ::regsub -all \[$bag\]] \$str {\\\\&} str\nset str"
}
} else {
# old REs
proc Backsolidus-guard {name bag} {
	array set x {- 0 ] 0 ^ 0 \\ 1}
	foreach c [split $bag {}] { set x($c) 1 }
	set pat \[
	if {$x(])} { append pat ] }
	unset x(])
	set tail {}
	if {$x(^)} { append tail ^ }
	unset x(^)
	if {$x(-)} { append tail - }
	unset x(-)
	append tail ]
	
	append pat [join [array names x] {}] $tail

	proc $name str "[list ::regsub -all $pat] \$str {\\\\&} str\nset str"
}}


# [string match [HCLS::quote::match $str1] $str2] == ![string compare $str1 $str2]
Backsolidus-guard match {\*?[}

# it's quite tricky to explain what this does,
# and tildes are probably still a problem
Backsolidus-guard glob {\*?[{}}

# regsub x x [HCLS::quote:regsub $str] x; set str
#	equivalent to
# set x $str
Backsolidus-guard regsub {\&}

# ![string compare $str1 $str2] == [regexp [HCLS::quote::regexp $str1] $str2]
Backsolidus-guard regexp {{$^.?+*\|()[]}}

# 0==[string compare [subst [subst-quote $str]] $str]
Backsolidus-guard subst {[\$}


# dunno how to describe this formally
proc bind str { string map {% %%} $str }
if {[catch {bind %}]} {
proc bind str {
	::regsub -all % $str %% str
	set str
}}

# i wonder if i can do one for eval?


} ;# namespace quote

#
#
#

proc apply {level args} {
	set v ::[new-variable {}]
	set n 0
	set cmd {}
	foreach lst $args {
		foreach i $lst {
			append cmd { $} $v ( $n )
			set ${v}($n) $i
			incr n
		}
	}
	if {$n} {
		catch {incr level}
		set err [catch {uplevel $level $cmd} ret]
		unset $v
		if {$err} {
			return -code error -errorinfo "$ret\n    while executing\n\"[join $args]\"" -errorcode $::errorCode $ret
		} {
			set ret
		}
	}
}

#
#
#

# construct abbreviation map
namespace export abbr-map
# 1999 Jun 18
proc abbr-map {lst} {
	array set collided {}
	foreach i $lst {
		for {set j [string length $i]} {$j} {incr j -1} {
			set a [string range $i 0 $j]
			if {[info exists map($a)]} {
				set collided($a) {}
			} else {
				set map($a) $i
			}
		}
	}

	# remove what collided
	foreach a [array names collided] { unset map($a) }

	# ensure a string always maps to itself
	foreach i $lst { set map($i) $i }

	# i considered ordering the result so string map could be used...
	# but it's really not as useful for this as i'd first thought. 
	# so i don't bother.
	array get map
}

#
#
#

# eval the code, and do cleanup when it finishes.
# the code and cleanup are eval'ed in the caller's level.
namespace export unwind-protect
# 1999 Jun 6
#fixme: it's very hard for the cleanup to know whether an error occurred.
# perhaps nulling the error variables before calling the cleanup can be
# -some- sort of hint everything is fine.
proc unwind-protect {code clean} {
	global errorInfo errorCode

	#fixme: exit is still an escape; but i think it works to rename it
	set err [catch {uplevel 1 $code} ret]

	# remember them in case errors in the cleanup overwrite them
	set errI $errorInfo
	set errC $errorCode

	#fixme: do something with an error thrown here
	catch {uplevel 1 $clean}

	if {$err} {
		# it would be marvellous if I could remove the stuff
		# about unwind-protect from errorInfo... but
		# what i want to remove is added -after- we
		# leave here.
		return -code error -errorinfo $errI -errorcode $errC $ret
	}
	set ret
}

#
#
#

# returns a variable name not used in level $level (default #0, global) and
# makes local variable $local point to it.  since i don't know whether the
# variable will be used as an array, i don't try to make it exist; therefore, be
# sure to set it right away so another newvariable doesn't conflict with it.
# the upvar works even though the variable doesn't exist.
namespace export new-variable
# 1996 Jul 12
# 1996 Nov 23
# - slightly twiddled and expanded comment
# 1999 Jun 18
# - contorted the name a bit more
# - swapped fmt and level
# - persistent serial number should speed seeks by reducing autocollision
#fixme: as I gain understanding of namespaces... I'm thinking the new variable
# should be in the namespace current at the level in question, instead
# of in the temporary space.
variable nvSerial 0
proc new-variable {local {level #0} {fmt _%X_neW_NaNnY_MouSe_VariaBULL_}} {
	variable nvSerial
	while {[uplevel $level [list info exists [set x [format $fmt [incr nvSerial]]]]]} { }
	uplevel 1 [list upvar $level $x $local]
	set x
}

#
#
#

# "lambda"-like thing
namespace export anonymous
# 1999 Jun 21
# - created
# 1999 Jun 26
# - used two uplevels instead of one, in the vague hope of
#  maybe saving on bytecompiling
# - moved more arg processing into the lower context to preserve
#  object references
# 1999 Jul 12
# - third generation; the variable-setting code is a now function of
#  the variable spec only, and therefore cacheable and only one step
#  away from being its own thing
# 1999 Sep 1
# - fixed an embarrassing g*n bug
proc anonymous args {
	# this gives us a pretty clean variable context
	eval Anonymous-x $args
}
proc Anonymous-x {vars code args} {
	variable anonCache

	if {![info exists anonCache($vars)]} {
		set anonCache($vars) [Anonymous-x-setup $vars]
	}
	uplevel 1 $anonCache($vars)
	uplevel 1 $code
}
proc Anonymous-x-setup {spec} {
	append cmd {set args [lrange $args 2 end]} \n
	set n 0
	set n1 0
	set n2 0
	set hasargs 0
	set defs {}
	set vars {}
	foreach vs $spec {
		set v [lindex $vs 0]
		if {$hasargs} { error {"args" must be last} }
		if {{args}=="$v"} {
			set hasargs 1
		} elseif {[llength $vs]==2} {
			lappend vars $v
			lappend defs [lindex $vs 1]
			incr n2
		} else {
			lappend vars $v
			lappend defs {}
			incr n1
		}
		incr n
	}
	append cmd {switch [llength $args]}
	set i 0
	while {$i < $n1-1} {
		append cmd "\\\n " $i { -}
		incr i
	}
	if {$n1} {
		append cmd "\\\n " $i { {return -code error {Too few arguments}}}
		incr i
	}
	while {$i < $n1+$n2} {
		append cmd "\\\n " $i " \{lappend args " [lrange $defs $i end] \}
		incr i
	}
	if {$hasargs} {
		#fixme: eliminate this - this gets around a degeneracy I somehow
		# managed to miss
		if {!$i} { append cmd { {}} }
	} {
		append cmd "\\\n " $i { {}}
		append cmd "\\\n default {return -code error {Too many arguments}}"
	}
	append cmd \n

	if {[llength $vars]} {
		append cmd "foreach \{" $vars "\} \$args break\n"
	}

	if {$hasargs} {
		if {$n1+$n2} {
			append cmd {set args [lrange $args } [expr {$n1+$n2}] { end]}
		}
	} {
		append cmd {unset args}
	}

	#puts $spec\n$cmd\n
	set cmd
}

#
# Tk stuff
#

if {[info exists tk_version]} {

#
#
#

# register a shortcut
# (only works if the underline and text are constant).
# there should be a "break" in each action, but it isn't forced.
# there is no test for duplicate shortcuts.
# if $w2 is missing or null, it defaults to $w
# if $w2 names a window, code is created according to that window's class.
# otherwise it is the code for the binding.
namespace export shortcut
# 1999 Jan 7
# - clevered up a bit
proc shortcut {w {w2 {}}} {
	if {![catch {$w cget -underline} u]
	 && -1 < $u
	 && ![catch {$w cget -text} t]
	 && $u < [string length $t]} {
		if {![string length $w2]} { set w2 $w }
		if {[winfo exists $w2]} {
			switch -- [winfo class $w2] {
			Listbox { set action "
				[list focus $w2]
				[list $w2 see active]
				break" }
			Scale { set action [list focus $w2] }
			Entry { set action "
				[list focus $w2]
				[list $w2 selection range 0 end]
				[list $w2 icursor end]
				[list tkEntrySeeInsert $w2]
				break" }
			Checkbutton -
			Radiobutton -
			Button { set action "
				[list $w2 invoke]
				break" }
			default {
				return -code error "There's no default shortcut for class [winfo class $w2]" }
			}
		} else {
			set action $w2
		}

		bind [winfo toplevel $w] <Alt-[string tolower [string index $t $u]]> $action
	}
}

#
#
#

# build 7.6 and 8.0 menu bars using the ODB
namespace export buildMenubar
# 1997 Aug 19
if {$tk_version < 8} {
proc buildMenubar {tl kn args} {
	if {[string compare . $tl]} { set mb $tl.menubar } { set mb .menubar }
	frame $mb
	upvar 1 $kn key
	set pack pack
	foreach {id lst} $args {
		set w $mb.$id
		lappend pack [menubutton $w -menu [set x $w.!]]
		menu $x
		buildMenubar-x $w $x key $id/ $lst
		set v [option get $w label Label]
		if {[string length $v]} { $w config -text $v }
	}
	lappend pack -side left
	eval $pack

	pack $mb -fill x
	if {{} != "[set x [lindex [pack slaves $tl] 0]]"} { pack $mb -before $x }
}
proc buildMenubar-x {optw menu var base lst} {
	upvar 1 $var key
	set key($base) $menu
	set n [$menu cget -tearoff]
	foreach i $lst {
		set opts() {}
		set type [lindex $i 0]
		set nocas [string compare cascade $type]
		set name [lindex $i 1]
		if {{} != "$name"} {
			set noname 0
			set key($base$name) [list $menu $n]
			set sow [frame $optw.$name -class Menu]
		} else {
			set noname 1
		}
		$menu add $type
		if {!$noname} {
			foreach od [$menu entryconfig $n] {
				set cv [lindex $od 4]
				set od [lindex $od 0]
				set on [string range $od 1 end]
				set oc [string toupper [string index $od 1]][string range $od 2 end]
				if {[string compare {} [set v [option get $sow $on $oc]]]} {
					set opts($od) $v
				}
		}}
		if {$nocas} {
			array set opts [lrange $i 2 end]
		} elseif {$noname} {
			error "name required to cascade"
		} else {
			set opts(-menu) [menu $menu.$name]
			buildMenubar-x $sow $opts(-menu) key $base$name/ [lrange $i 2 end]
		}
		if {!$noname} { destroy $sow }
		eval [list $menu entryconfig $n] [array get opts -*]
		unset opts
		incr n
	}
} } else {
proc buildMenubar {tl kn args} {
	if {[string compare . $tl]} { set mb $tl.menubar } { set mb .menubar }
	menu $mb
	$tl config -menu $mb

	upvar 1 $kn key
	# rebuild the args as a menu list
	foreach {id lst} $args { lappend x [concat [list cascade $id] $lst] }
	buildMenubar-x $mb key {} $x
}
proc buildMenubar-x {menu var base lst} {
	upvar 1 $var key
	set n [$menu cget -tearoff]
	foreach i $lst {
		set opts() {}
		set type [lindex $i 0]
		set nocas [string compare cascade $type]
		set name [lindex $i 1]
		if {{} != "$name"} { set key($base$name) [list $menu $n] }
		set sub [menu $menu.$name]
		$menu add $type
		foreach {od - - - cv} [eval concat [$menu entryconfig $n]] {
			set on [string range $od 1 end]
			set oc [string toupper [string index $od 1]][string range $od 2 end]
			if {[string compare {} [set v [option get $sub $on $oc]]]} {
				set opts($od) $v
			}
		}
		if {$nocas} {
			destroy $sub
			array set opts [lrange $i 2 end]
		} else {
			set opts(-menu) $sub
			set key($base$name/) $sub
			buildMenubar-x $sub key $base$name/ [lrange $i 2 end]
		}
		eval [list $menu entryconfig $n] [array get opts -*]
		unset opts
	
		incr n
	}
} }

#
#
#

# this procedure applies ODB-controlled padding to a GM tree
namespace export odb-padding
# 1999 Jun 12
proc odb-padding {master} {
	foreach s [pack slaves $master] {
		pack config $s\
		 -ipadx [option get $s internalPaddingX InternalPaddingX]\
		 -ipady [option get $s internalPaddingY InternalPaddingY]\
		 -padx [option get $s externalPaddingX ExternalPaddingX]\
		 -pady [option get $s externalPaddingY ExternalPaddingY]
		odb-padding $s
	}
	foreach s [grid slaves $master] {
		grid config $s\
		 -ipadx [option get $s internalPaddingX InternalPaddingX]\
		 -ipady [option get $s internalPaddingY InternalPaddingY]\
		 -padx [option get $s externalPaddingX ExternalPaddingX]\
		 -pady [option get $s externalPaddingY ExternalPaddingY]
		odb-padding $s
	}
	foreach s [place slaves $master] {
		odb-padding $s
	}
}
option add *InternalPaddingX 0 widgetDefault
option add *InternalPaddingY 0 widgetDefault
option add *ExternalPaddingX 0 widgetDefault
option add *ExternalPaddingY 0 widgetDefault

#
#
#

namespace export optionMenu
if {$tk_version>=8} {
	# in 8.0, they switched to radiobuttons
	# and left the indicators showing
	proc optionMenu args {
		set m [uplevel 1 tk_optionMenu $args]
		for {set i [$m index last]} {$i>=0} {incr i -1} {
			$m entryconfig $i -indicatoron 0
		}
		set m
	}
} elseif {$tk_version>=4.1} {
	# in 4.1, the padding was no longer hardcoded
	proc optionMenu args {eval tk_optionMenu $args}
} else {
	# tk_optionMenu is a nice addition, but
	# it has disgusting hardcoded padding
	proc optionMenu {w args} {
		set r [eval [list tk_optionMenu $w] $args]
		set x [option get $w padX Pad]
		if {[string length $x]} {$w config -padx $x}
		set x [option get $w padY Pad]
		if {[string length $x]} {$w config -pady $x}
		set r
	}
}}

#
#
#

} ;# namespace HCLS

#
# eof
#