#
#
# Test wish interface functions
#
#

func /* {args} {}
func proc {args} {eval func [slice $args 1]}

proc join {dot lst} {
	set ret [index $lst 0]
	foreach [slice $lst 1] {
		set ret "${ret}${dot}$i"
	}
	set ret
}

/* {
	Event loop processing

	quit		- Blobal variable set to terminate eventloop processing
	evQuit		- Command that gui elements can call to set the quit variable
	
	idle 		- callback from eventloop every <n> ms
	ev n		- call eventloop a maximum number of time or until quit is true
	eventloop n	- call event until quit is truem, callback idle every <n>ms

} */


set _tkidle [list]

proc TkIdle {} {
if not [count $_tkidle] {return 0}

	set cmd [index $_tkidle 0]
	set global _tkidle [slice $_tkidle 1]

	eval $cmd
}


proc after {args} {

	if not [streq [index $args 1] idle] {
		error "after: Only after events may be queued"
	}
	append global _tkidle [slice $args 2]
}

proc idle {n} {}


proc ev {n} {
	set global quit 0
	while {$n > 0 && ! $quit} {
		event
		inc n -1
		idle n
	}
}

proc ntime {} {
	set fd [open /dev/time 0]
	set data [read $fd 100]
	close $fd
	index $data 1
}

proc eventloop {tm} {
	local _c
	local previous-catcher
	set global quit 0

	if [streq $tm {}] {set tm 1000}
	set tm [expr $tm * 1000000]
	set _c 0
    set previous-catcher [catcher]
    catcher {print Callback  failed: $args}
	while { ! $quit } {
		set st [ntime]
		while {[expr  [ntime] - $st] < $tm  && ! $quit} {
			event
			TkIdle
		}
		event
		idle [inc _c]
	}
    catcher $previous-catcher
}


proc evQuit {args} {
	set global quit 1
}

set global TkWidgets [list root toplevel 0]

proc tkwidget {w} {
	set addr [indexof $TkWidgets $w]
	if [streq $addr {}] { return {} }
	inc addr 2
	index $TkWidgets $addr
}

proc tkwin {w} {
	set win [split $w .]
	if [expr ( [count $win] < 2 ) || ( [streq [index $win 0] {}] == 0 ) ] {
		error "widget name does not begin with ."
	} 
	if [expr [count $win] == 2] {
		set pwin root
		set wid $w
	} {
		set wid .[index $win [expr [count $win] - 1]]
		set win [slice $win 1 [expr [count $win] - 1]]
		set pwin .[join . $win]
	}
	list $pwin $wid
}

proc tktoplevel {w} {
	set addr [wm id $w]
	toplevel $addr
}

proc tkcfg {args} {
	set w [index $args 1]
	set addr [wm id $w]
	eval cfgwidget $addr [slice $args 2]
}

proc tkpack {w} {
	set addr [wm id $w]
	pack $addr
}


proc tkpanel {all} {
	set type [index $all 0]
	set name [index $all 1]
#	set parent [index $all 2]
	lmap [tkwin $name] parent wid

	set addr [indexof $TkWidgets $parent]
	if [streq $addr {}] {
		print "${type}: parent unknown {$parent}"
		error
	}
	inc addr 2
	set addr [index $TkWidgets $addr]
	if [streq $type listbox] {set type list}
	set addr [eval widget $name $addr $type [slice $all 2]]

	append global TkWidgets $name
	append global TkWidgets $type
	append global TkWidgets $addr

	list "$type $name $name $addr"
}

foreach {entry label listbox edit message frame group button radiobutton checkbutton slider scrollbar textedit menu popup} {
	proc $i {args} {tkpanel $args}
}

proc wm {cmd a1 a2 a3 a4 a5 a6 a7 a8 a9 a10} {
local fd

if [streq $cmd id] {
	set ret [tkwidget $a1]
	if [streq $ret {}] {
	  print "tkwidget window unknown {$w}"
	  print "W: $TkWidgets"
	  errror "Not found"
	}
	return $ret
}

if [streq $cmd exists] {
	set ret [tkwidget $a1]
	if [streq $ret {}] { return 0 }
	return 1
}

if [streq $cmd hide] {
	store /dev/wctl hide
	return
}
if [streq $cmd unhide] {
	store /dev/wctl unhide
	return
}
if [streq $cmd current] {
	store /dev/wctl current
	return
}
if [streq $cmd resize] {
	store /dev/wctl current
	store /dev/wctl "resize -r $a1 $a2 $a3 $a4 "
	return
}
if [streq $cmd move] {
	store /dev/wctl current
	store /dev/wctl "move -minx $a1 -miny $a2 "
	return
}

if [streq $cmd sizeof] {
	set wid [tkwidget $a1]
	set bb [config $wid bbox]
	list [expr [index $bb 3] - [index $bb 1]] [expr [index $bb 4] - [index $bb 2]]
}

}


func puts {args} { eval print [slice $args 1] }

list