
package require snit

proc set! { varName args } {
    
    upvar 1 $varName v
    if { [llength $args] == 0 && ![info exists v] } {
	return ""
    }
    return [uplevel 1 [list set $varName {*}$args]]
}

proc info_fullargs { procname } {
    set ret ""
    foreach arg [uplevel 1 [list info args $procname]] {
	if { [uplevel 1 [list info default $procname $arg value]] } {
	    upvar 1 value value
	    lappend ret [list $arg $value]
	} else {
	    lappend ret $arg
	}
    }
    return $ret
}

namespace eval cu {}
namespace eval cu::file {}

# for tclIndex to work 
proc cu::menubutton_button { args } {}

snit::widgetadaptor cu::menubutton_button {
    option -command ""
    option -image ""
    option -text ""

    delegate method * to hull
    delegate option * to hull
    delegate option -_image to hull as -image
    delegate option -_text to hull as -text

    variable xmin
    variable is_button_active 1
    variable press_after ""
    
    constructor args {
	installhull using ttk::menubutton -style Toolbutton
	bind $win <ButtonPress-1> [mymethod BP1 %x %y]
	bind $win <ButtonRelease-1> [mymethod BR1 %x %y]
	bind $win <Down> [list ttk::menubutton::Popdown %W]
	bind $win <Motion> [mymethod check_cursor %x %y]
	bind $win <Configure> [mymethod  _calc_xmin]

	$self configurelist $args
    }
    onconfigure -image {img} {
	set options(-image) $img

	if { $options(-text) ne "" } {
	    $self configure -_image $img
	    return
	} 
	set new_img [cu::add_down_arrow_to_image $img]
	$self configure -_image $new_img
	bind $win <Destroy> +[list image delete $new_img]
    }
    onconfigure -text {value} {
	set options(-text) $value

	if { $options(-text) ne "" } {
	    $self configure -style ""
	    if { $options(-image) ne "" } {
		$self configure -_image $options(-image)
	    }
	}
	$self configure -_text $value
    }
    method _calc_xmin {} {
	if { [winfo width $win] > 1 } {
	    set xmin  [expr {[winfo width $win]-12}]
	} else {
	    set xmin  [expr {[winfo reqwidth $win]-12}]
	}
    }
    method give_is_button_active_var {} {
	return [myvar is_button_active]
    }
    method BP1 { x y } {
	if { !$is_button_active } { return }
	
	if { $x < $xmin && $options(-command) ne "" } {
	    $win instate !disabled {
		catch { tile::clickToFocus $win }
		catch { ttk::clickToFocus $win }
		$win state pressed
	    }
	    set press_after [after 700 [mymethod BP1_after]]
	    return -code break
	}
    }
    method BP1_after {} {
	set press_after ""
	$win instate {pressed !disabled} {
	    ttk::menubutton::Pulldown $self
	}
    }
    method BR1 { x y } {
	if { !$is_button_active } { return }
	
	if { $press_after ne "" } {
	    after cancel $press_after
	}
	if { $press_after ne "" && $x < $xmin && $options(-command) ne "" } {
	    $win instate {pressed !disabled} {
		$win state !pressed
		uplevel #0 $options(-command)
	    }
	    set press_after ""
	    return -code break
	}
	set press_after ""
    }
    method check_cursor { x y } {
	if { $x < $xmin } {
	    $win configure -cursor ""
	} else {
	    $win configure -cursor bottom_side
	}
    }
}

snit::widgetadaptor cu::combobox {
    option -valuesvariable ""
    option -textvariable ""
    option -statevariable ""
    option -values ""
    option -dict ""
    option -dictvariable ""

    variable _translated_textvariable ""

    delegate method * to hull
    delegate option * to hull
    delegate option -_values to hull as -values
    delegate option -_textvariable to hull as -textvariable

    constructor args {
	installhull using ttk::combobox

	cu::add_contextual_menu_to_entry $win init
	bind $win <<ComboboxSelected>> [mymethod combobox_selected]
	$self configurelist $args
    }
    destructor {
	catch {
	    if { $options(-valuesvariable) ne "" } {
		upvar #0 $options(-valuesvariable) v
		trace remove variable v write "[mymethod _changed_values_var];#"
	    }
	    if { $options(-dictvariable) ne "" } {
		upvar #0 $options(-dictvariable) v
		trace remove variable v write "[mymethod _changed_values_var];#"
	    }
	    if { $options(-textvariable) ne "" } {
		upvar #0 $options(-textvariable) v
		trace remove variable v write "[mymethod _written_textvariable];#"
	    }
	    if { $options(-statevariable) ne "" } {
		upvar #0 $options(-statevariable) v
		trace remove variable v write "[mymethod _written_statevariable];#"
		trace remove variable v read "[mymethod _read_statevariable];#"
	    }
	}
    }
    onconfigure -textvariable {value} {
	set options(-textvariable) $value
	$self configure -_textvariable [myvar _translated_textvariable]

	upvar #0 $options(-textvariable) v
	trace add variable v write "[mymethod _written_textvariable];#"
	trace add variable [myvar _translated_textvariable] write \
	    "[mymethod _read_textvariable];#"
	if { [info exists v] } {
	    $self _written_textvariable
	}
    }
    onconfigure -dictvariable {value} {
	set options(-dictvariable) $value
	$self _changed_values_var
	upvar #0 $options(-dictvariable) v
	trace add variable v write "[mymethod _changed_values_var];#"
    }
    onconfigure -statevariable {value} {
	set options(-statevariable) $value

	upvar #0 $options(-statevariable) v
	trace add variable v write "[mymethod _written_statevariable];#"
	trace add variable v read "[mymethod _read_statevariable];#"
	if { [info exists v] } {
	    set v $v
	}
    }
    onconfigure -valuesvariable {value} {
	set options(-valuesvariable) $value

	upvar #0 $options(-valuesvariable) v

	if { $options(-dictvariable) ne "" } {
	    upvar #0 $options(-dictvariable) vd
	    if { [info exists vd] } {
		set dict $vd
	    } else {
		set dict ""
	    }
	} else {
	    set dict $options(-dict)
	}
	if { ![info exists v] } {
	    set v ""
	    foreach value [$self cget -_values] {
		catch { 
		    set value [dict get [dict_inverse $dict] $value]
		}
		lappend v $value
	    }
	} else {
	    set vtrans ""
	    foreach value $v {
		catch { set value [dict get $dict $value] }
		lappend vtrans $value
	    }
	    $self configure -_values $vtrans
	}
	trace add variable v write "[mymethod _changed_values_var];#"
    }
    onconfigure -dict {value} {
	set options(-dict) $value
	$self _changed_values_var
    }
    onconfigure -values {values} {
	if { $options(-valuesvariable) ne "" } {
	    upvar #0 $options(-valuesvariable) v
	    set v $values
	} else {
	    if { $options(-dictvariable) ne "" } {
		upvar #0 $options(-dictvariable) vd
		if { [info exists vd] } {
		    set dict $vd
		} else {
		    set dict ""
		}
	    } else {
		set dict $options(-dict)
	    }
	    set vtrans ""
	    foreach value $values {
		catch { set value [dict get $dict $value] }
		lappend vtrans $value
	    }
	    $self configure -_values $vtrans
	}
    }
    oncget -values {
	set v ""
	foreach value [$self cget -_values] {
#             catch {
#                 set value [dict get [dict_inverse $options(-dict)] $value]
#             }
	    lappend v $value
	}
	return $v
    }
    method _changed_values_var {} {
	if { $options(-valuesvariable) ne "" } {
	    upvar #0 $options(-valuesvariable) v
	} else {
	    set v [$self cget -values]
	}
	if { $options(-dictvariable) ne "" } {
	    upvar #0 $options(-dictvariable) vd
	    if { [info exists vd] } {
		set dict $vd
	    } else {
		set dict ""
	    }
	} else {
	    set dict $options(-dict)
	}
	set vtrans ""
	foreach value $v {
	    catch { set value [dict get $dict $value] }
	    lappend vtrans $value
	}
	$self configure -_values $vtrans
	$self _written_textvariable
    }
    method _written_textvariable { args } {

	set optional {
	    { -force_dict "" 0 }
	}
	set compulsory ""
	parse_args $optional $compulsory $args

	upvar #0 $options(-textvariable) v
	if { ![info exists v] } { return }
	set value $v
	if { $options(-dictvariable) ne "" } {
	    upvar #0 $options(-dictvariable) vd
	    if { [info exists vd] } {
		set dict $vd
	    } else {
		set dict ""
	    }
	} else {
	    set dict $options(-dict)
	}
	if { $force_dict || [$self instate readonly] } {
	    catch { set value [dict get $dict $value] }
	}
	if { $_translated_textvariable ne $value } {
	    set _translated_textvariable $value
	}
    }
    method _read_textvariable {} {
	upvar #0 $options(-textvariable) v
	set value $_translated_textvariable
	if { $options(-dictvariable) ne "" } {
	    upvar #0 $options(-dictvariable) vd
	    if { [info exists vd] } {
		set dict $vd
	    } else {
		set dict ""
	    }
	} else {
	    set dict $options(-dict)
	}
	catch {
	    set value [dict get [dict_inverse $dict] $value]
	}
	if { ![info exists v] || $v ne $value } {
	    set v $value
	}
    }
    method _written_statevariable {} {
	upvar #0 $options(-statevariable) v
	$self state $v
    }
    method _read_statevariable {} {
	upvar #0 $options(-statevariable) v
	set v [$self state]
    }
    method combobox_selected {} {
	if { ![$self instate readonly] } {
	    $self _written_textvariable -force_dict
	}
    }
}

################################################################################
# cu::multiline_entry
################################################################################

snit::widget cu::multiline_entry {
    option -textvariable ""
    option -takefocus 0 ;# option used by the tab standard bindings
    option -values ""
    option -valuesvariable ""
    option -state ""
    option -justify ""
    option -height ""

    hulltype frame

    variable text
    variable updating 0
    
    variable toctree
    variable fnames ""
    variable no_active_items ""
    variable no_active_values ""
    variable cmd_items ""
    
    delegate method * to text
    delegate method _insert to text as insert
    delegate option * to text
    delegate option -_state to text as -state
    delegate option -_height to text as -height
    
    delegate method tree_item to toctree as item
    delegate option -columns_list to toctree
    
    constructor args {

	$hull configure -background #a4b97f -bd 0
	install text using text $win.t -wrap word -width 40 -height 3 -borderwidth 0 -highlightthickness 0
	
	cu::add_contextual_menu_to_entry $text init

	grid $text -padx 1 -pady 1 -sticky nsew
	grid columnconfigure $win 0 -weight 1
	grid rowconfigure $win 0 -weight 1

	bind $self <Configure> [mymethod _check_configure]
	bind $text <Tab> "[bind all <Tab>] ; break"
	bind $text <<PrevWindow>> "[bind all <<PrevWindow>>] ; break"
	bind $text <KeyPress> [mymethod keypress]
	bindtags $text [list $win $text [winfo class $win] [winfo class $text] [winfo toplevel $text] all]
	bind $win <FocusIn> [list focus $text]
	$self configurelist $args
    }
    destructor {
	$self _clean_traces
    }
    onconfigure -state {value} {
	set options(-state) $value
	$self _update_state
    }
    onconfigure -height {value} {
	set options(-height) $value
	
	$self configure -_height [lindex $value 0]
    }
    onconfigure -textvariable {value} {
	$self _clean_traces
	set options(-textvariable) $value

	set cmd "[mymethod _check_textvariable_read] ;#"
	trace add variable $options(-textvariable) read $cmd
	set cmd "[mymethod _check_textvariable_write] ;#"
	trace add variable $options(-textvariable) write $cmd
	$self _check_textvariable_write
    }
    onconfigure -values {value} {
	set options(-values) $value
	
	if { $options(-values) ne "" || $options(-valuesvariable) ne "" } {
	    $self activate_menubutton

	    $self tree_item delete all
	    $self tree_insert end [_ "(Clear)"] "" 0
	    foreach i $value {
		$self tree_insert end $i $i 0
	    }
	} elseif { ![winfo exists $win.b] } {
	    destroy $win.b
	}
    }
    onconfigure -valuesvariable {value} {
	set options(-valuesvariable) $value

	
	if { $options(-values) ne "" || $options(-valuesvariable) ne "" } {
	    $self activate_menubutton
	}
	upvar #0 $options(-valuesvariable) v

	if { [info exists v] } {
	    $self _changed_values_var
	    trace add variable v write "[mymethod _changed_values_var];#"
	} elseif { ![winfo exists $win.b] } {
	    destroy $win.b
	}
    }
    method activate_menubutton {} {

	if { [winfo exists $win.b] } { return }

	if { [info command ::cu::multiline_entry::nav1downarrow16] eq "" } {
	    image create photo ::cu::multiline_entry::nav1downarrow16 -data {
		R0lGODlhEAAQAIAAAPwCBAQCBCH5BAEAAAAALAAAAAAQABAAAAIYhI+py+0PUZi0zmTtypflV0Vd
		RJbm6fgFACH+aENyZWF0ZWQgYnkgQk1QVG9HSUYgUHJvIHZlcnNpb24gMi41DQqpIERldmVsQ29y
		IDE5OTcsMTk5OC4gQWxsIHJpZ2h0cyByZXNlcnZlZC4NCmh0dHA6Ly93d3cuZGV2ZWxjb3IuY29t
		ADs=
	    }
	}
	ttk::menubutton $win.b -image ::cu::multiline_entry::nav1downarrow16 -style Toolbutton
	
	bind $win.b <ButtonPress-1> [mymethod BP1 %x %y]
	bind $win.b <ButtonRelease-1> [mymethod BR1 %x %y]
	
	set toctree $win.b.m
	cu::_menubutton_tree_helper $toctree -parent $win \
	    -button1handler [mymethod press] -returnhandler [mymethod press_return]
	wm withdraw $toctree
	
	bind  $win.b.m <space> [mymethod post]
	bind  $win.b.m <Return> [mymethod post]
	
	bind $toctree <<ComboboxSelected>> [mymethod endpost]
	
	grid $win.b -row 0 -column 1 -padx "0 1" -pady 1 -sticky wns
    }
    method give_win {} {
	return $text
    }
    method give_tree {} {
	return $toctree
    }
    method set_text { txt } {
	focus $text
	update idletasks
	$text delete 1.0 end
	$text insert end $txt
	$text tag add sel 1.0 end-1c
	$self _check_configure
	$self _update_state
    }
    method insert { args } {
	$self _insert {*}$args
	$self _check_configure
	$self _update_state
    }
    method keypress {} {
	after idle [mymethod _check_configure]
	after idle [mymethod _update_state]
    }
    method _update_state {} {
	
	switch $options(-state) {
	    disabled {
		$self configure -_state disabled -foreground grey -highlightthickness 0
		grid configure $text -padx 1 -pady 1
	    }
	    readonly {
		$self configure -_state disabled -foreground black -highlightthickness 0
		grid  configure $text -padx 0 -pady 0
	    }
	    default {
		$self configure -_state normal -foreground black -highlightthickness 1
		grid  configure $text -padx 1 -pady 1
	    }
	}
	if { $options(-justify) ne "" } {
	    $self tag configure justify -justify $options(-justify)
	    $self tag add justify 1.0 end
	}
    }
    method _clean_traces {} {
	if { $options(-textvariable) ne "" } {
	    set cmd "[mymethod _check_textvariable_read] ;#"
	    trace remove variable $options(-textvariable) read $cmd
	    set cmd "[mymethod _check_textvariable_write] ;#"
	    trace remove variable $options(-textvariable) write $cmd
	}
	if { $options(-valuesvariable) ne "" } {
	    upvar #0 $options(-valuesvariable) v
	    trace remove variable v write "[mymethod _changed_values_var];#"
	}
    }
    method BP1 { x y } {
       $self post
    }
    method BR1 { x y } {
	$win.b instate {pressed !disabled} {
	    $win.b state !pressed
	}
	return -code break
    }
    method press_return { t ids } {
	$self press $t $ids [list item [lindex $ids 0] column 0 elem e_text_sel] "" ""
    }
    method press { t ids identify x y } {
	set id [lindex $ids 0]
	
	if { ![regexp {item \S+ column \S+ elem (\S+)} $identify {} elem] } {
	    return
	}
	if { $elem eq "e_image_r" } {
	    return [$self clear_tree_entry $id]
	}
	if { [dict exists $cmd_items $id] } {
	    if { ![dict exists $no_active_items $id] } { 
		$self action LBCancel
	    }
	    uplevel #0 [dict get $cmd_items $id] $id
	    return
	}
	if { [dict exists $no_active_items $id] } { return }
	
	$self set_text [dict get $fnames $id]
	#uplevel #0 $options(-command) [list [dict get $fnames $id]]
	$toctree unpost
    }
    method clear_tree_entry { id } {
	set txt [dict get $fnames $id]
	if { $options(-textvariable) ne "" } {
	    upvar #0 $options(-valuesvariable) v
	    set ipos [lsearch -exact $v $txt]
	    set v [lreplace $v $ipos $ipos]
	} else {
	    error "error in clear_tree_entry. not implemented"
	}
    }
    method post {} {
	$win.b instate !disabled {
	    catch { tile::clickToFocus $win.b }
	    catch { ttk::clickToFocus $win.b }
	    $win.b state pressed
	    set x [winfo rootx $win]
	    set y [expr {[winfo rooty $win]+[winfo height $win]}]
	    $toctree deiconify $x $y [expr {[winfo width $win]-0}]
	}
    }
    method endpost {} {
	$win.b instate {pressed !disabled} {
	    $win.b state !pressed
	}
	event generate $win.b <<ComboboxSelected>>
    }
    method _check_textvariable_read {} {
	if { $updating } { return }
	upvar #0 $options(-textvariable) v
	set v [$text get 1.0 end-1c]
    }
    method _check_textvariable_write {} {
	upvar #0 $options(-textvariable) v
	$text delete 1.0 end
	set updating 1
	if { [info exists v] } {
	    $text insert end $v
	}
	set updating 0
	$self _check_configure
	$self _update_state
    }
    method _changed_values_var {} {
	if { $options(-valuesvariable) ne "" } {
	    upvar #0 $options(-valuesvariable) v
	    
	    $self tree_item delete all
	    $self tree_insert end [_ "(Clear)"] "" 0
	    foreach i $v {
		$self tree_insert end $i $i 0
	    }
	}
    }
    method _check_configure {} {
	
	if { [winfo width $win] <= 1 } { return }
	if { [llength $options(-height)] < 2 } { return }
	set ds [$win count -displaylines 1.0 end]
	lassign $options(-height) min max
	if { $ds < $min } { set ds $min }
	if { $ds > $max } { set ds $max }
	if { $ds != [$win cget -_height] } {
	    $win configure -_height $ds
	}
    }
    method tree_insert { args } {
	set optional {
	    { -image image "" }
	    { -collapse boolean 0 }
	    { -active boolean 1 }
	    { -command cmd "" }
	}
	set compulsory "idx name fullname parent"
	parse_args $optional $compulsory $args

	if { $image eq "" } {
	    set image appbook16
	} elseif { $image eq "-" } {
	    set image ""
	}
	if { [$self cget -columns_list] eq "" } {
	    set data [list [list $image $name]]
	} else {
	    set data [list [list $image [lindex $name 0]]]
	    lappend data {*}[lrange $name 1 end]
	}
	set id [$toctree insert $idx $data $parent]
	if { $collapse } {
	    $toctree item collapse $id
	}
	if { !$active } {
	    dict set no_active_items $id ""
	    dict set no_active_values $fullname ""
	}
	if { ![info exists cmd_items] } {
	    set cmd_items ""
	}
	if { $command ne "" } {
	    dict set cmd_items $id $command
	}
	dict set fnames $id $fullname
	
	$toctree item style set $id 0 imagetextimage
	$toctree item element configure $id 0 e_text_sel -text $name
	$toctree item element configure $id 0 e_image -image $image
	catch {
	    $toctree item element configure $id 0 e_image_r -image [cu::get_image actitemdelete16]
	}
	return $id
    }
}

################################################################################
#    menubutton_tree
################################################################################

snit::widget cu::_menubutton_tree_helper {
    option -parent ""
    option -columns_list ""
    hulltype toplevel
    
    delegate method * to tree
    delegate option * to tree

    variable tree
    variable marker_resize_xy0

    constructor args {
	wm overrideredirect $win 1

	package require fulltktree
	set columns [list [list 20 "" left imagetext 1]]
	set tree [fulltktree $win.tree -height 50 -has_sizegrip 1 \
		-columns $columns -expand 1]
	
	grid $tree -sticky nsew
	grid columnconfigure $win 0 -weight 1
	grid rowconfigure $win 0 -weight 1
	
	$self configure -bd 1 -relief solid -background white
	$self configurelist $args

	grid configure $tree.t -rowspan 2

	bind $win <ButtonPress-1> [mymethod check_unpost %x %y]
	bind $win <Escape> "[mymethod unpost] ; break"
    }
    onconfigure -columns_list { value } {
	if { $value eq $options(-columns_list) } { return }
	set options(-columns_list) $value

	set columns ""
	set idx 0
	foreach i $options(-columns_list) {
	    lassign $i name dict
	    if { $idx == 0 } {
		set type imagetext
	    } else {
		set type text
	    }
	    foreach "opt default" [list len 10 justify left is_editable 1 expand ""] {
		set $opt [dict_getd $dict $opt $default]
	    }
	    lappend columns [list $len $name $justify $type $is_editable $expand]
	    incr idx
	}
	$tree configure -expand 0 -columns $columns
    }
    method deiconify { x y min_width } {
		
	set n [$tree index last]
	if { $n < 7 } { set n 7 }
	if { $n > 15 } { set n 15 }
	if { [$tree cget -itemheight] != 0 } {
	    set h [expr {[$tree cget -itemheight]*$n}]
	} else {
	    set h [expr {[$tree cget -minitemheight]*$n}]
	}
	$tree configure -height $h
	set wi [winfo width $win]
	if { $wi < $min_width } { set wi $min_width }
	if { $wi+$x > [winfo screenwidth $win] } {
	    set wi [expr {[winfo screenwidth $win]-$x}]
	}
	if { $y+$h+10 > [winfo screenheight $win] } {
	    set h [expr {[winfo screenheight $win]-$y-10}]
	}
	wm geometry $win ${wi}x$h+$x+$y
	update
	wm deiconify $win
	focus $tree
	grab -global $win
    }
    method check_unpost { x y } {
	if { $x < 0 || $x > [winfo width $win] || 
	    $y < 0 || $y > [winfo height $win] } {
	    $self unpost
	}
    }
    method unpost {} {
	
	$tree close_search_label

	grab release $win
	wm withdraw $win
	event generate $win <<ComboboxSelected>> 
    }
}

################################################################################
#    cu::adapt_text_length
################################################################################

# remember to grid the label to fill all space. For example with -sticky ew
proc cu::adapt_text_length { args } {
    foreach w $args {
	bind $w <Configure> [list cu::_adapt_text_length_do $w]
    }
}

proc cu::_adapt_text_length_do { w } {
    if { [winfo width $w] > 1 } {
	$w configure -wraplength [winfo width $w] -justify left
    }
}

################################################################################
#    add_contextual_menu_to_entry
################################################################################

proc cu::add_contextual_menu_to_entry { w what args } {
    switch $what {
	init {
	    bind $w <ButtonRelease-3> [list cu::add_contextual_menu_to_entry $w post %X %Y]
	}
	post {
	    lassign $args x y
	    set menu $w.menu
	    catch { destroy $menu }
	    menu $menu -tearoff 0
	    foreach i [list cut copy paste --- select_all --- clear] \
		txt [list [_ "Cut"] [_ "Copy"] [_ "Paste"] --- [_ "Select all"] --- [_ "Clear"]] {
		if { $i eq "---" } {
		    $menu add separator
		} else {
		    $menu add command -label $txt -command [list cu::add_contextual_menu_to_entry $w $i]
		}
	    }
	    tk_popup $menu $x $y
	}
	clear {
	    if { [winfo class $w] eq "Text" } {
		$w delete 1.0 end
	    } else {
		$w delete 0 end
	    }
	}
	cut {
	    event generate $w <<Cut>>
	}
	copy {
	    event generate $w <<Copy>>
	}
	paste {
	    event generate $w <<Paste>>
	}
	select_all {
	    if { [winfo class $w] eq "Text" } {
		$w tag add sel 1.0 end-1c
	    } else {
		$w selection range 0 end
	    }
	}
    }
}

################################################################################
#     cu::text_entry_bindings
################################################################################

proc cu::text_entry_bindings { w } {

    if { ![info exists ::control] } {
	if { $::tcl_platform(platform) eq "windows" } {
	    set ::control Control
	} elseif { [tk windowingsystem] eq "aqua" } {
	    set ::control Command
	} else {
	    set ::control Control
	}
    }
    # "backslash" and "c" are here to help with a problem in Android VNC
    bind $w <$::control-backslash> "[list cu::text_entry_insert $w];break"
    bind $w <$::control-less> "[list cu::text_entry_insert $w];break"
    foreach "acc1 acc2 c" [list plus "" {[]} c "" {{}} ccedilla "" {{}} 1 "" || 1 1 \\ 3 "" {#}] {
	set cmd "[list cu::text_entry_insert $w $c];break"
	if { $acc2 eq "" } {
	    set k2 ""
	} else {
	    set k2 <KeyPress-$acc2>
	}
	bind $w <$::control-less><KeyPress-$acc1>$k2 $cmd
	bind $w <$::control-backslash><KeyPress-$acc1>$k2 $cmd
    }
    
    if { $::tcl_platform(platform) ne "windows" } {
	foreach "ev k" [list braceleft \{ braceright \} bracketleft \[ bracketright \] backslash \\ \
		bar | at @ numbersign # asciitilde ~] {
	    # EuroSign €
	    # they are class bindings so as search in text widgets can continue working
	    bind Text <$ev> "[list tk::TextInsert %W $k]; break"
	    bind TEntry <$ev> "[list ttk::entry::Insert %W $k]; break"
	    bind TCombobox <$ev> "[list ttk::entry::Insert %W $k]; break"
	    bind Entry <$ev> "[list tk::EntryInsert %W $k]; break"
	}
    }
}

proc cu::text_entry_insert { w { what "" } } {
    variable last_text_enty_bindings
    
    if { ![info exists last_text_enty_bindings] } {
	set last_text_enty_bindings ""
    }
    set list [list "{}" "\[\]" "||" "\\" "#"]
    set t [clock milliseconds]
    lassign [dict_getd $last_text_enty_bindings $w ""] time d
    
    if { $d eq "" } { set d "{}" }
    if { $time ne "" && $t < $time+3000 } {
	if { [winfo class $w] eq "Text" } {
	    set idx [$w search $d insert-1c]
	    if { [$w compare $idx == insert-1c] } {
		if { [string length $d] == 1 } {
		    $w delete insert-1c
		} else {
		    $w delete insert-1c insert+1c
		}
	    }
	} else {
	    set idx [$w index insert]
	    if { $idx > 0 } {
		set idx1 [expr {$idx-1}]
		set idx2 [expr {$idx-1+[string length $d]}]
		set txt [string range [$w get] $idx1 $idx2]
		if { [string equal $d $txt] } {
		    $w delete $idx1 $idx2
		}
	    }
	}
	if { $what eq "" } {
	    set ipos [lsearch -exact $list $d]
	    incr ipos
	    if { $ipos >= [llength $list] } {
		set ipos 0
	    }
	    set d [lindex $list $ipos]
	}
    }
    if { $what ne "" } {
	set d $what
    }
    if { [winfo class $w] eq "Text" } {
	set idx [$w index insert]
	$w insert insert $d
	$w mark set insert "$idx+1c"
    } else {
	set idx [$w index insert]
	$w insert insert $d
	$w icursor [expr {$idx+1}]
    }
    dict set last_text_enty_bindings $w [list $t $d]
}

################################################################################
#     cu::text operations on text widget
################################################################################

namespace eval cu::text {}

proc cu::text::get_selection_or_word { args } {
    
    set optional {
	{ -return_range boolean 0 }
    }
    set compulsory "text idx"
    parse_args $optional $compulsory $args
    
    set range [$text tag ranges sel]
    if { $range != "" && [$text compare [lindex $range 0] <= $idx] && \
	[$text compare [lindex $range 1] >= $idx] } {
	if { $return_range } {
	    return $range
	} else {
	    return [$text get {*}$range]
	}
    } else {
	if { $idx != "" } {
	    set var ""
	    set idx0 $idx
	    set char [$text get $idx0]
	    if { [regexp {[\s,;]} $char] } {
		set c [$text get "$idx0-1c"]
		if { [string is wordchar $c] } {
		    set idx [$text index "$idx0-1c"]
		    set idx0 $idx
		    set char [$text get $idx0]
		}
	    }
	    while { [string is wordchar $char] } {
		#  || $char == "(" || $char == ")"
		set var $char$var
		set idx0 [$text index $idx0-1c]
		if { [$text compare $idx0 <= 1.0] } { break }
		set char [$text get $idx0]
	    }
	    set idx1 [$text index $idx+1c]
	    set char [$text get $idx1]
	    while { [string is wordchar $char] } {
		#  || $char == "(" || $char == ")"
		append var $char
		set idx1 [$text index $idx1+1c]
		if { [$text compare $idx1 >= end-1c] } { break }
		set char [$text get $idx1]
	    }
	    if { ![regexp {[^()]*\([^\)]+\)} $var] } {
		set var [string trimright $var "()"]
	    }
	} else { set var "" }
    }
    if { $return_range } {
	return [list [$text index "$idx0+1c"] [$text index "$idx1"]]
    } else {
	return $var
    }
}

################################################################################
#    store preferences
################################################################################

proc cu::store_program_preferences { args } {

    set optional {
	{ -valueName name "" }
    }
    set compulsory "program_name data"

    parse_args $optional $compulsory $args

    if { $valueName eq "" } {
	set valueNameF IniData
    } else {
	set valueNameF IniData_$valueName
    }

    if { $::tcl_platform(platform) eq "windows" && $::tcl_platform(os) ne "Windows CE" } {
	set key "HKEY_CURRENT_USER\\Software\\Compass\\$program_name"
	package require registry
	registry set $key $valueNameF $data
    } else {
	package require tdom
	if { $::tcl_platform(os) eq "Windows CE" } {
	    set dir [file join / "Application Data" Compass $program_name]
	    file mkdir $dir
	    set file [file join $dir prefs]
	} elseif { [info exists ::env(HOME)] } {
	    set file [file normalize ~/.compass_${program_name}_prefs]
	} else {
	    set file [file normalize [file join /tmp compass_${program_name}_prefs]]
	}
	set err [catch { tDOM::xmlReadFile $file } xml]
	if { $err } { set xml "<preferences/>" }
	set doc [dom parse $xml]
	set root [$doc documentElement]
	set domNode [$root selectNodes "pref\[@n=[xpath_str $valueNameF]\]"]
	if { $domNode ne "" } { $domNode delete }
	set p [$root appendChildTag pref]
	$p setAttribute n $valueNameF
	$p appendChildText $data

	set fout [open $file w]
	fconfigure $fout -encoding utf-8
	puts $fout [$doc asXML]
	close $fout
    }
}
proc cu::get_program_preferences { args } {

    set optional {
	{ -valueName name "" }
	{ -default default_value "" }
    }
    set compulsory "program_name"

    parse_args $optional $compulsory $args

    if { $valueName eq "" } {
	set valueNameF IniData
    } else {
	set valueNameF IniData_$valueName
    }

    set data $default
    if { $::tcl_platform(platform) eq "windows" && $::tcl_platform(os) ne "Windows CE" } {
	set key "HKEY_CURRENT_USER\\Software\\Compass\\$program_name"
	package require registry
	set err [catch { registry get $key $valueNameF } data]
	if { $err } {
	    set data $default
	}
    } else {
	package require tdom
	if { $::tcl_platform(os) eq "Windows CE" } {
	    set dir [file join / "Application Data" Compass $program_name]
	    file mkdir $dir
	    set file [file join $dir prefs]
	} elseif { [info exists ::env(HOME)] } {
	    set file [file normalize ~/.compass_${program_name}_prefs]
	} else {
	    set file [file normalize [file join /tmp compass_${program_name}_prefs]]
	}
	set err [catch { tDOM::xmlReadFile $file } xml]
	if { !$err } {
	    set doc [dom parse $xml]
	    set root [$doc documentElement]
	    set domNode [$root selectNodes "pref\[@n=[xpath_str $valueNameF]\]"]
	    if { $domNode ne "" } {
		set data [$domNode text]
	    }
	}
    }
    return $data
}

################################################################################
#    cu::set_window_geometry u::give_window_geometry
################################################################################

proc cu::give_window_geometry { w } {

    regexp {(\d+)x(\d+)([-+])([-\d]\d*)([-+])([-\d]+)} [wm geometry $w] {} width height m1 x m2 y
    if { $::tcl_platform(platform) eq "unix" } {
	# note: this work in ubuntu 9.04
	incr x -4
	incr y -24
    }
    return ${width}x$height$m1$x$m2$y
}

proc cu::set_window_geometry { w geometry } {

    if { ![regexp {(\d+)x(\d+)([-+])([-\d]\d*)([-+])([-\d]+)} $geometry {} width height m1 x m2 y] } {
	regexp {(\d+)x(\d+)} $geometry {} width height
	lassign [list 0 0 + +] x y m1 m2
    }
    if { $x < 0 } { set x 0 }
    if { $y < 0 } { set y 0 }
    if { $x > [winfo screenwidth $w]-100 } { set x [expr {[winfo screenwidth $w]-100}] }
    if { $y > [winfo screenheight $w]-100 } { set y [expr {[winfo screenheight $w]-100}] }
    
    if { $m2 eq "+" && $y+$height > [winfo screenheight $w] } {
	if { $y > 0.5*[winfo screenheight $w] } {
	    set y [expr {round(0.5*[winfo screenheight $w])}]
	}
	set height [expr {[winfo screenheight $w]-$y}]
    }
    wm geometry $w ${width}x$height$m1$x$m2$y
}

proc cu::create_tooltip_toplevel { args } {

    set optional {
	{ -withdraw "" 0 }
    }
    set compulsory "b"
    parse_args $optional $compulsory $args

    toplevel $b -class Tooltip
    if { $withdraw } {
	wm withdraw $b
    }
    if {[tk windowingsystem] eq "aqua"} {
	::tk::unsupported::MacWindowStyle style $b help none
    } else {
	wm overrideredirect $b 1
    }
    catch {wm attributes $b -topmost 1}
    # avoid the blink issue with 1 to <1 alpha on Windows
    catch {wm attributes $b -alpha 0.99}
    wm positionfrom $b program
    if { [tk windowingsystem]  eq "x11" } {
	set focus [focus]
	focus -force $b
	raise $b
	if { $focus ne "" } {
	    after 100 [list focus -force $focus]
	}
    }
    return $b
}

proc cu::give_widget_background { w } {
 
    set err [catch { $w cget -background } bgcolor]
    if { $err } {
	set err [catch {
		set style [$w cget -style]
		if { $style eq "" } {
		    set style [winfo class $w]
		}
		set bgcolor [ttk::style lookup $style -background]
	    }]
	if { $err } {
	    if { $::tcl_platform(platform) eq "windows" } {
		set bgcolor SystemButtonFace
	    } else {
		set bgcolor grey
	    }
	}
    }
   return $bgcolor
}

################################################################################
#    add_down_arrow_to_image
################################################################################

proc cu::add_down_arrow_to_image { args } {
    variable add_down_arrow_to_image_delta
    
    set optional {
	{ -color color black }
	{ -w widget "" }
    }
    set compulsory "img"
    parse_args $optional $compulsory $args

    if {![info exists add_down_arrow_to_image_delta] } {
	set add_down_arrow_to_image_delta 7
    }
    if { $img ne "" } {
	set width [image width $img]
	set height [image height $img]
    } else {
	lassign [list 0 16] width height
    }
    set new_img [image create photo -width [expr {$width+$add_down_arrow_to_image_delta}] -height $height]
    if { $img ne "" } { $new_img copy $img -to 0 0 }
    set coords {
	-3 -1
	-4 -2 -3 -2 -2 -2
	-5 -3 -4 -3 -3 -3 -2 -3 -1 -3
    }
    foreach "x y" $coords {
	$new_img put $color -to [expr {$width+$add_down_arrow_to_image_delta+$x}] [expr {$height+$y}]
    }
    if { $w ne "" } {
	$w configure -image $new_img
	bind $w <Destroy> +[list image delete $new_img]
    }
    return $new_img
}

################################################################################
#    XML & xpath utilities
################################################################################

proc xpath_str { str } {
    
    foreach "strList type pos" [list "" "" 0] break
    while 1 {
	switch $type {
	    "" {
		set ret [regexp -start $pos -indices {['"]} $str idxs]
		if { !$ret } {
		    lappend strList "\"[string range $str $pos end]\""
		    break
		}
		set idx [lindex $idxs 0]
		switch -- [string index $str $idx] {
		    ' { set type apostrophe }
		    \" { set type quote }
		}
	    }
	    apostrophe {
		set ret [regexp -start $pos -indices {["]} $str idxs]
		if { !$ret } {
		    lappend strList "\"[string range $str $pos end]\""
		    break
		}
		set idx [lindex $idxs 0]
		lappend strList "\"[string range $str $pos [expr {$idx-1}]]\""
		set type quote
		set pos $idx
	    }
	    quote {
		set ret [regexp -start $pos -indices {[']} $str idxs]
		if { !$ret } {
		    lappend strList "'[string range $str $pos end]'"
		    break
		}
		set idx [lindex $idxs 0]
		lappend strList "'[string range $str $pos [expr {$idx-1}]]'"
		set type apostrophe
		set pos $idx
	    }
	}
    }
    if { [llength $strList] > 1 } {
	return "concat([join $strList ,])"
    } else {
	return [lindex $strList 0]
    }
}

proc format_xpath { string args } {
    set cmd [list format $string]
    foreach i $args {
	lappend cmd [xpath_str $i]
    }
    return [eval $cmd]
}

namespace eval ::dom::domNode {}

# args can be one or more tags
proc ::dom::domNode::appendChildTag { node args } {
    if { [::llength $args] == 0 } {
	error "error in appendChildTag. At list one tag"
    }
    ::set doc [$node ownerDocument]
    foreach tag $args {
	if { [string match "text() *" $tag] } {
	    ::set newnode [$doc createTextNode [lindex $tag 1]]
	    $node appendChild $newnode
	    ::set node $newnode
	} elseif { [string match "attributes() *" $tag] } {
	    foreach "n v" [lrange $tag 1 end] {
		$node setAttribute $n $v
	    }
	} else {
	    ::set newnode [$doc createElement $tag]
	    $node appendChild $newnode
	    ::set node $newnode
	}
    }
    return $newnode
}

proc ::dom::domNode::appendChildText { node text } {
    ::set doc [$node ownerDocument]
    foreach child [$node selectNodes text()] { $child delete }
    ::set newnode [$doc createTextNode $text]
    $node appendChild $newnode
    return $newnode
}

proc dict_getd { args } {
    
    set dictionaryValue [lindex $args 0]
    set keys [lrange $args 1 end-1]
    set default [lindex $args end]
    if { [dict exists $dictionaryValue {*}$keys] } {
	return [dict get $dictionaryValue {*}$keys]
    }
    return $default
}

proc linsert0 { args } {
    set optional {
	{ -max_len len "" }
	{ -remove_prefixes "" 0 }
    }
    set compulsory "list element"
    parse_args $optional $compulsory $args

    set ipos [lsearch -exact $list $element]
    if { $ipos != -1 } {
	set list [lreplace $list $ipos $ipos]
    }
    if { $remove_prefixes } {
	for { set i 0 } { $i < [llength $list] } { incr i } {
	    if { [string match "[lindex $list $i]*" $element] } {
		set list [lreplace $list $i $i]
		incr i -1
	    }
	}
    }
    set list [linsert $list 0 $element]
    if { $max_len ne "" } {
	set list [lrange $list 0 $max_len-1]
    }
    return $list
}

################################################################################
#     cu::file::execute, cu::kill and cu::ps
################################################################################

proc cu::kill { pid } {

    if { $::tcl_platform(platform) eq "windows" } {
	package require compass_utils::c
	return [cu::_kill_win $pid]
    } else {
	exec kill $pid 
    }
}

proc cu::ps { args } {

    if { $::tcl_platform(platform) eq "windows" } {
	package require compass_utils::c
	set ps_args ""
	foreach i $args {
	    if { $i eq "" } { continue }
	    if { ![string is integer -strict $i] } {
		if { ![regexp {^\*} $i] } {
		    set i "*$i"
		}
		if { ![regexp {\*$} $i] } {
		    set i "$i*"
		}
	    }
	    lappend ps_args $i
	}
	set ret [cu::_ps_win {*}$ps_args]
	catch { package require twapi }
	set retret ""
	foreach i $ret {
	    lassign $i cmd pid
	    if { [info command ::twapi::get_process_info] ne "" } {
		set d [twapi::get_process_info $pid -createtime -privilegedtime -workingset]
		if { [string is digit -strict [dict get $d -createtime]] } {
		    set start [clock format [twapi::large_system_time_to_secs [dict get $d -createtime]] \
		            -format "%H:%M:%S"]
		    set cputime [clock format [twapi::large_system_time_to_secs \
		                [dict get $d -privilegedtime]] -format "%H:%M:%S" -timezone :UTC]
		    set size [expr {[dict get $d -workingset]/1024}]
		    set i [list $cmd $pid $start $cputime $size]
		}
	    }
	    lappend retret $i
	}
	return $retret
    } else {
	# does not do exactly the same than in Windows
	#set err [catch { exec pgrep -l -f [lindex $args 0] } ret]
	#set retList  [split $ret \n]
	lassign $args pattern
	if { $pattern eq "" } {
	    set err [catch { exec ps -u $::env(USER) --no-headers -o pid,start,time,pcpu,size,cmd } ret]
	} elseif { [string is integer -strict $pattern] } {
	    set err [catch { exec ps --pid $pattern --no-headers -o pid,start,time,pcpu,size,cmd } ret]
	} else {
	    set err [catch { exec ps -u $::env(USER) --no-headers -o pid,start,time,pcpu,size,cmd | grep -i $pattern } ret]
	}        
	if { $err } {
	    return ""
	} else {
	    set retList ""
	    foreach line [split $ret \n] {
		regexp {(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(.*)} $line {} pid start cputime \
		    pcpu size cmd
		catch { format "%02.0f%%" $pcpu } pcpu
		if { $pattern ne "" && $cmd eq "grep -i $pattern" } { continue }

		set err [catch { clock scan $start -format "%H:%M:%S" } secs]
		if { $err } {
		    set secs [clock scan $start -format "%b"]
		}
		set start [clock format $secs -format "%Y-%m-%d %H:%M:%S"]
		lappend retList [list $cmd $pid $start "$cputime ($pcpu)" $size]
	    }
	    return $retList
	}
    }
}

proc cu::file::correct_name { file } {
    if { $::tcl_platform(platform) eq "windows" } {
	regsub -all {[:*?""<>|]} $file {_} file
    }
    return [string trim $file]
}

proc cu::file::execute { args } {
    
    set optional {
	{ -workdir directory "" }
	{ -wait boolean 0 }
	{ -hide_window boolean 0 }
    }
    set compulsory "what file"

    set args [parse_args -raise_compulsory_error 0 $optional $compulsory $args]

    switch -- $what {
	gid {
	    set exe [get_executable_path gid]
	    if { $exe eq "" } { return }
	    if { $wait || $hide_window } {
		set err [catch { package require twapi }]
		if { $err } { set has_twapi 0 } else { set has_twapi 1 }
	    }
	    if { !$wait || $has_twapi } { lappend args & }
	    set pid [exec $exe $file {*}$args]
	   
	    if { !$wait && !$hide_window } { return }
	    if { !$has_twapi } { return }

	    if { $hide_window } {
		foreach hwin [twapi::find_windows -pids $pid -visible true] {
		    twapi::hide_window $hwin
		}
	    }
	    if { $wait } {
		while { [twapi::process_exists $pid] } {
		    after 200
		}
	    }
	}
	emacs {
	    exec runemacs -g 100x72 &
	}
	wish {
	    set pwd [pwd]
	    cd [file dirname $file]
	    eval exec wish [list [file normalize $file]] $args &
	    cd $pwd
	}
	tkdiff {
	    set pwd [pwd]
	    cd [file dirname $file]
	    exec wish ~/myTclTk/tkcvs/bin/tkdiff.tcl -r [file tail $file] &
	    cd $pwd
	}
	start {
	    if { $::tcl_platform(platform) eq "unix" } {
		set programs [list xdg-open gnome-open]
		if { $::tcl_platform(os) eq "Darwin" } {
		    set programs [linsert $programs 0 open]
		}
		foreach i $programs {
		    if { [auto_execok $i] ne "" } {
		        exec $i $file &
		        return
		    }
		}
		error "could not open file '$file'"
	    } elseif { [regexp {[&]} $file] } {
		set bat [file join [file dirname $file] a.bat]
		set fout [open $bat w]
		puts $fout "start \"\" \"$file\""
		close $fout
		exec $bat 
		file delete $bat
	    } else {
		eval exec [auto_execok start] \"\" [list $file] {*}$args &
	    }
	}
	url {
	    if { [regexp {^[-\w.]+$} $file] } {
		set file http://$file
	    }
	    if { ![regexp {(?i)^\w+://} $file] && ![regexp {(?i)^mailto:} $file] } {
		set txt [_ "url does not begin with a known handler like: %s. Proceed?" \
		        "http:// ftp:// mailto:"]
		set retval [tk_messageBox -default ok -icon question -message $txt \
		        -type okcancel]
		if { $retval == "cancel" } { return }
	    }
	    if { $::tcl_platform(platform) eq "windows" } {
		exec rundll32 url.dll,FileProtocolHandler $file &
	    } else {
		set programs [list xdg-open gnome-open]
		if { $::tcl_platform(os) eq "Darwin" } {
		    set programs [linsert $programs 0 open]
		}
		foreach i $programs {
		    if { [auto_execok $i] ne "" } {
		        exec $i $file &
		        return
		    }
		}
		set cmdList ""
		foreach i [list firefox konqueror mozilla opera netscape] {
		    lappend cmdList "$i \"$file\""
		}
		exec sh -c [join $cmdList "||"] & 
	    }
	}
	exec {
	    if { $workdir ne "" } {
		set pwd [pwd]
		cd $workdir
	    }
	    set err [catch { exec $file {*}$args } errstring opts]
	    
	    if { $err && $::tcl_platform(platform) eq "windows" } {
		package require registry
		set key0 {HKEY_CLASSES_ROOT\Applications\%s\shell\open\command}
		set file [file root [file tail $file]].exe
		set key [format $key0 $file]
		set err [catch { registry get $key "" } value]
		if { !$err } {
		    set cmd [string map [list %1 [lindex $args 0]] $value]
		    regsub -all {\\} $cmd / cmd
		    set err [catch { exec {*}$cmd } errstring opts]
		}
	    }
	    
	    if { $workdir ne "" } { cd $pwd }
	    if { $err } {
		error $errstring [dict get $opts -errorinfo]
	    }
	}
	execList {
	    foreach i $file {
		if { [auto_execok [lindex $i 0]] ne "" } {
		    exec {*}$i &
		    return
		}
	    }
	  error "Could not execute files"
	}
	default {
	    if { $workdir ne "" } {
		set pwd [pwd]
		cd $workdir
	    }
	    set err [catch { exec $file {*}$args & } errstring]
	    if { $workdir ne "" } { cd $pwd }
	    if { $err } {
		error $errstring $::errorInfo
	    }
	}
    }  
}