bindings.tcl

This Source-Navigator, an IDE for C/C++/Fortran/Java/Tcl/PHP/Python and a host of other languages.

# Copyright (c) 2000, Red Hat, Inc.
# 
# This file is part of Source-Navigator.
# 
# Source-Navigator is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 2, or (at your option)
# any later version.
# 
# Source-Navigator is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
# 
# You should have received a copy of the GNU General Public License along
# with Source-Navigator; see the file COPYING.  If not, write to
# the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
# MA 02111-1307, USA.
# 
# bindings.tcl - Bindings?
# Copyright (C) 1998 Cygnus Solutions.

# tkTreeTableUpDown --
#
# Moves the location cursor (active element) up or down by one element,
# and changes the selection if we're in browse or extended selection
# mode.
#
# Arguments:
# w -           The listbox widget.
# amount -      +1 to move down one item, -1 to move back one item.

proc sn_bindings {} {
    global sn_windows_to_check

    bind Listbox <3> {sn_listbox_post_menu %W %X %Y}
    bind Listbox <Control-3> {sn_listbox_post_menu %W %X %Y}
    bind Listbox <Shift-3> {sn_listbox_post_menu %W %X %Y}
    bind Canvas <2> {%W scan mark %x %y}
    bind Canvas <B2-Motion> {%W scan dragto %x %y}

    #Failed Button bindings from Tk
    bind Button <Tab> {focus [tk_focusNext %W]}
    bind Button <Shift-Tab> {focus [tk_focusPrev %W]}

    #failed checkbutton bindings from Tk
    bind Checkbutton <Tab> {focus [tk_focusNext %W]}
    bind Checkbutton <Shift-Tab> {focus [tk_focusPrev %W]}

    #failed radio button bindings from Tk
    bind Radiobutton <Tab> {focus [tk_focusNext %W]}
    bind Radiobutton <Shift-Tab> {focus [tk_focusPrev %W]}

    #bind alt-key to  traversale to buttons, check/radio buttons,
    #Text+Entry
    #The binding must be before the default "MENU-BINDING",
    #when it doesn't proceed, it call the menu binding
    set obindings [bind all <Alt-Key>]
    bind all <Alt-Key> "if {\[sn_execute_alt_accelerator %W %K\] == 0} {
					break
				}
				${obindings}"

    # reset to list of windows where we do need checks
    set sn_windows_to_check ""

    auto_load tkTextSetup

    sn_entry_default_bindings Entry

    sn_text_default_bindings Text

    sn_canv_goto_bindings Canvas

    sn_treetable_bindings TreeTable

    sn_init_keybindings
}

proc sn_listbox_post_menu {w x y} {
    set m .sn_pop_menu_listbox
    # It has to be destroyed because we might have problems with "tk_popup"!
    catch {destroy ${m}}

    menu ${m} -tearoff 0 -postcommand "sn_listbox_post_menu_update ${m} ${w}"
    wm overrideredirect ${m} 1

    tk_popup ${m} ${x} ${y}
}

proc sn_listbox_post_menu_update {m w} {
    ${m} delete 0 end
    set sel_size [llength [${w} curselection]]

    ${m} add command -label [format [get_indep String ListSize] [${w} size]\
      ${sel_size}]
}

# This seems to be a duplicate of the ide_treetable in libgui tree.tcl

proc sn_treetable args {
    set frame [lindex ${args} 0]

    set tree ${frame}.tree

    scrollbar ${frame}.x -orient horiz -command " ${tree} xview "
    scrollbar ${frame}.y -command " ${tree} yview "

    set args [lreplace ${args} 0 0 -yscrollcommand "${frame}.y set"\
      -xscrollcommand "${frame}.x set"]

    eval treetable ${tree} ${args}

    focus $tree

    return ${tree}
}

##########################################################################
## bindings for the new treetable widget                                ##
##########################################################################
proc tkTreeTableUpDown {w amount} {
    global tkPriv
    ${w} activate [expr [${w} index active] + ${amount}] ${amount}
    ${w} see active
    switch [${w} cget -selectmode] {
        browse {
                ${w} selection clear 0 end
                #			$w selection set active
            }
        extended {
                ${w} selection clear 0 end
                #			$w selection set active
                if {[string compare [${w} index active] ""] != 0} {
                    ${w} selection anchor active
                    set tkPriv(listboxPrev) [${w} index active]
                }
                set tkPriv(listboxSelection) {}
            }
    }
}

proc sn_treetable_bindings {t} {
    #the keybindings to the treetable are compatible to
    #those of listbox.
    bind ${t} <1> {
		if [winfo exists %W] {
			focus %W
			tkListboxBeginSelect %W [%W index @%x,%y]
		}
	}

    bind TreeTable <Double-1> {
	}

    bind ${t} <B1-Motion> {
		set tkPriv(x) %x
		set tkPriv(y) %y
		catch {tkListboxMotion %W [%W index @%x,%y]}
	}
    bind ${t} <ButtonRelease-1> {
		tkCancelRepeat
		%W activate @%x,%y
	}
    bind ${t} <Shift-1> {
		tkListboxBeginExtend %W [%W index @%x,%y]
	}
    bind ${t} <Control-1> {
		tkListboxBeginToggle %W [%W index @%x,%y]
	}
    bind ${t} <B1-Leave> {
		set tkPriv(x) %x
		set tkPriv(y) %y
		tkListboxAutoScan %W
	}
    bind ${t} <B1-Enter> {
		tkCancelRepeat
	}

    bind ${t} <Up> {
		tkTreeTableUpDown %W -1
	}


    if {[string equal "unix" $::tcl_platform(platform)]} {
        bind ${t} <Button-4> {
            %W yview scroll -5 units
        }
        bind ${t} <Shift-Button-4> {
            %W yview scroll -1 units
        }
        bind ${t} <Control-Button-4> {
            %W xview scroll -10 units
        }
        bind ${t} <Button-5> {
            %W yview scroll 5 units
        }
        bind ${t} <Shift-Button-5> {
            %W yview scroll 1 units
        }
        bind ${t} <Control-Button-5> {
            %W xview scroll 10 units
        }
    } else {
        bind ${t} <MouseWheel> {
            %W yview scroll [expr {- (%D / 120) * 4}] units
        }
    }

  bind ${t} <Shift-Up> {
		tkListboxExtendUpDown %W -1
	}
    bind ${t} <Down> {
		tkTreeTableUpDown %W 1
	}
    bind ${t} <Shift-Down> {
		tkListboxExtendUpDown %W 1
	}
    bind ${t} <Left> {
		%W xview scroll -1 units
	}
    bind ${t} <Control-Left> {
		%W xview scroll -1 pages
	}
    bind ${t} <Right> {
		%W xview scroll 1 units
	}
    bind ${t} <Control-Right> {
		%W xview scroll 1 pages
	}
    bind ${t} <Prior> {
		%W yview scroll -1 pages
		%W activate @0,0
	}
    bind ${t} <Next> {
		%W yview scroll 1 pages
		%W activate @0,0
	}
    bind ${t} <Control-Prior> {
		%W xview scroll -1 pages
	}
    bind ${t} <Control-Next> {
		%W xview scroll 1 pages
	}
    bind ${t} <Home> {
		%W xview moveto 0
	}
    bind ${t} <End> {
		%W xview moveto 1
	}
    bind ${t} <Control-Home> {
		%W activate 0
		%W see 0
		%W selection clear 0 end
		%W selection set 0
	}
    bind ${t} <Shift-Control-Home> {
		tkListboxDataExtend %W 0
	}
    bind ${t} <Control-End> {
		%W activate end
		%W see end
		%W selection clear 0 end
		%W selection set end
	}
    bind ${t} <Shift-Control-End> {
		tkListboxDataExtend %W end
	}
    bind ${t} <F16> {
		if {[selection own -displayof %W] == "%W"} {
			clipboard clear -displayof %W
			clipboard append -displayof %W [selection get -displayof %W]
    		}
	}
    bind ${t} <space> {
		tkListboxBeginSelect %W [%W index active]
	}
    bind ${t} <Select> {
		tkListboxBeginSelect %W [%W index active]
	}
    bind ${t} <Control-Shift-space> {
		tkListboxBeginExtend %W [%W index active]
	}
    bind ${t} <Shift-Select> {
		tkListboxBeginExtend %W [%W index active]
	}
    bind ${t} <Escape> {
		tkListboxCancel %W
	}
    bind ${t} <Control-slash> {
		tkListboxSelectAll %W
	}
    bind ${t} <Control-backslash> {
		if {[%W cget -selectmode] != "browse"} {
			%W selection clear 0 end
		}
	}

    bind ${t} <2> {
		%W scan mark %x %y
	}
    bind ${t} <B2-Motion> {
		%W scan dragto %x %y
	}

    #other bindings added to default listbox bindings
    bind ${t} <Key> {sn_tree_table_search_region %W %A %s}
    bind ${t} <3> {sn_listbox_post_menu %W %X %Y}
    bind ${t} <Control-3> {sn_listbox_post_menu %W %X %Y}
    # Sun Home
    bind ${t} <Any-F27> [bind ${t} <Home>]
    # Sun End
    bind ${t} <Any-R13> [bind ${t} <End>]
    # Sun Next
    bind ${t} <Any-R15> [bind ${t} <Next>]
    # Sun Prior
    bind ${t} <Any-R9> [bind ${t} <Prior>]

    bind ${t} <Tab> {focus [tk_focusNext %W]}
    bind ${t} <Shift-Tab> {focus [tk_focusPrev %W]}
}
proc sn_tree_table_search_in_widget {w a beg {end end}} {
    if {[${w} size] > 20000} {
        ${w} config -cursor watch
        update idletasks
    }
    set res [${w} search -nocase -begins -- ${a} ${beg} ${end}]
    ${w} config -cursor {}
    if {${res} == ""} {
        return -1
    }
    ${w} activate ${res}
    return ${res}
}

proc sn_tree_table_search_region {w a state} {

    #accept only ascii-characters
    if {[string compare ${a} ""] == 0 || [string length ${a}] > 1} {
        return -1
    }
    #returns if alt-key is pressed (reserved for menu)
    if {[expr {${state} & 8}] == 8} {
        return -1
    }

    upvar #0 ${w}-pat pat

    append pat ${a}
    set srch ${pat}
    set off [${w} index active]
    if {[string compare ${off} ""] == 0} {
        set sel 0
    } else {
        set sel [expr ${off} + 1]
    }
    # Search from the selection!
    set off [sn_tree_table_search_in_widget ${w} ${srch} ${sel}]

    if {${off} == -1 && ${sel} != 0} {
        # 	Search until the selection!
        set off [sn_tree_table_search_in_widget ${w} ${srch} 0 ${sel}]
    }
    if {${off} == -1} {
        if {[string length ${pat}] > 1} {
            set pat ${a}
            set srch ${pat}

            # Search from the selection!
            set off [sn_tree_table_search_in_widget ${w} ${srch} ${sel}]
            if {${off} == -1} {
                # 	Search until the selection!
                set off [sn_tree_table_search_in_widget ${w} ${srch} 0 ${sel}]
            }
        }
        if {${off} == -1} {
            set pat ""
            bell -displayof ${w}
            ${w} selection clear 0 end
            return 1
        }
    }
    ${w} activate ${off}
    ${w} activate ${off}
    ${w} yview see ${off}

    return 0
}
###########################################################################
## END of definitions for new treetable widget                           ##
###########################################################################

proc sn_tree_table_remove {w} {
    foreach s [lsort -decreasing -integer [${w} curselection]] {
        ${w} remove ${s}
    }
}

proc sn_treetable_scroll {lb which} {
    set cur [${lb} nearest 0]
    set sel [lindex [${lb} curselection] 0]
    if {${sel} == ""} {
        set sel 0
    }
    set hg [winfo height ${lb}]
    if {${hg} == 1} {
        set hg [winfo reqheight ${lb}]
    }

    set last [${lb} nearest ${hg}]
    set sz [${lb} size]
    set disp [expr "(${last} - ${cur}) + 1"]

    switch -- ${which} {
        Up {
                incr sel -1
                set cur [expr "${cur} <= 0 ? ${cur} : ${cur} - 1"]
            }
        Down {
                incr sel 1
                incr cur
                set newend [expr "${cur} + ${disp}"]
                if {${newend} >= ${sz}} {
                    set cur [expr "${sz} - ${disp}"]
                }
            }
        PgUp {
                incr cur "-${disp}"
                incr sel "-${disp}"
                if {${cur} < 0} {
                    set cur 0
                }
            }
        PgDn {
                incr cur ${disp}
                incr sel ${disp}
                set newend [expr "${cur} + ${disp}"]
                if {${newend} > ${sz}} {
                    set cur [expr "${sz} - ${disp}"]
                }
            }
        Home {
                set cur 0
                set sel 0
            }
        End {
                set cur [expr "${sz} - ${disp}"]
                set sel end
            }
        default {
                error "Unknown scroll request '${lb} ${which}'."
            }
    }
    ${lb} yview ${cur}
    ${lb} select from ${sel}
    ${lb} select to ${sel}
}

proc sn_entry_default_bindings {entry} {
    global sn_options

    bind ${entry} <Control-a> {tkEntrySetCursor %W 0}
    bind ${entry} <Control-b> {tkEntrySetCursor %W [expr [%W index insert] - 1]}
    bind ${entry} <Control-d> [bind ${entry} <Delete>]
    bind ${entry} <Control-e> {tkEntrySetCursor %W end}
    bind ${entry} <Control-f> {tkEntrySetCursor %W [expr [%W index insert] + 1]}
    bind ${entry} <Control-h> {tkEntryBackspace %W}
    bind ${entry} <Control-k> {%W delete insert end}
    bind ${entry} <Control-t> {tkEntryTranspose %W}
    bind ${entry} <Control-u> {
	    %W delete 0 end
	    %W xview 0
	}
    bind ${entry} <Meta-b> {
		tkEntrySetCursor %W [string wordstart [%W get] [expr [%W index insert] - 1]]
	}
    bind ${entry} <Meta-d> {
		%W delete insert [string wordend [%W get] [%W index insert]]
	}
    bind ${entry} <Meta-f> {
		%W delete [string wordstart [%W get] [expr [%W index insert] - 1]] insert
	}

    #add a hook for the french keyboard. "~" and "," work
    #bugy on windows, they are bound on AltGr-e' and AltGr-e`
    bind ${entry} <Alt-Control-KeyPress> {+
				if {%k == 55} {
					tkEntryInsert %W "`"
					break
				}
				if {%k == 50} {
					tkEntryInsert %W "~"
					break
				}
			}
}

# returns 1 if it could insert the digit otherwise 0.

proc sn_entry_insert_digit {w a scale {check 0} {bell 1}} {

    set input_char "0123456789eE.-"
    if {${check} == 0} {
        append input_char "NULnul!=<>|"
    }
    if {${a} == ","} {
        set a "."
    }
    if {[string first ${a} ${input_char}] == -1} {
        if {${a} != "" && ${bell}} {
            bell
        }
        return 0
    }
    switch -- ${a} {
        "." {
                if {${scale} == "0" || [string first "." [${w} get]] != -1} {
                    if {${a} != "" && ${bell}} {
                        bell