# OpenPBS (Portable Batch System) v2.3 Software License # # Copyright (c) 1999-2000 Veridian Information Solutions, Inc. # All rights reserved. # # --------------------------------------------------------------------------- # For a license to use or redistribute the OpenPBS software under conditions # other than those described below, or to purchase support for this software, # please contact Veridian Systems, PBS Products Department ("Licensor") at: # # www.OpenPBS.org +1 650 967-4675 sales@OpenPBS.org # 877 902-4PBS (US toll-free) # --------------------------------------------------------------------------- # # This license covers use of the OpenPBS v2.3 software (the "Software") at # your site or location, and, for certain users, redistribution of the # Software to other sites and locations. Use and redistribution of # OpenPBS v2.3 in source and binary forms, with or without modification, # are permitted provided that all of the following conditions are met. # After December 31, 2001, only conditions 3-6 must be met: # # 1. Commercial and/or non-commercial use of the Software is permitted # provided a current software registration is on file at www.OpenPBS.org. # If use of this software contributes to a publication, product, or # service, proper attribution must be given; see www.OpenPBS.org/credit.html # # 2. Redistribution in any form is only permitted for non-commercial, # non-profit purposes. There can be no charge for the Software or any # software incorporating the Software. Further, there can be no # expectation of revenue generated as a consequence of redistributing # the Software. # # 3. Any Redistribution of source code must retain the above copyright notice # and the acknowledgment contained in paragraph 6, this list of conditions # and the disclaimer contained in paragraph 7. # # 4. Any Redistribution in binary form must reproduce the above copyright # notice and the acknowledgment contained in paragraph 6, this list of # conditions and the disclaimer contained in paragraph 7 in the # documentation and/or other materials provided with the distribution. # # 5. Redistributions in any form must be accompanied by information on how to # obtain complete source code for the OpenPBS software and any # modifications and/or additions to the OpenPBS software. The source code # must either be included in the distribution or be available for no more # than the cost of distribution plus a nominal fee, and all modifications # and additions to the Software must be freely redistributable by any party # (including Licensor) without restriction. # # 6. All advertising materials mentioning features or use of the Software must # display the following acknowledgment: # # "This product includes software developed by NASA Ames Research Center, # Lawrence Livermore National Laboratory, and Veridian Information # Solutions, Inc. # Visit www.OpenPBS.org for OpenPBS software support, # products, and information." # # 7. DISCLAIMER OF WARRANTY # # THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND. ANY EXPRESS # OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT # ARE EXPRESSLY DISCLAIMED. # # IN NO EVENT SHALL VERIDIAN CORPORATION, ITS AFFILIATED COMPANIES, OR THE # U.S. GOVERNMENT OR ANY OF ITS AGENCIES BE LIABLE FOR ANY DIRECT OR INDIRECT, # INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, # OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF # LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING # NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, # EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. # # This license will be governed by the laws of the Commonwealth of Virginia, # without reference to its choice of law rules. # ###################################################################################### # The procedures below defines customized bindings for some of the widgets. ###################################################################################### # listbox_non_contiguous_selection: procedure used in pre-4.0 Tk for simulating # non-contiguous selection in listboxes. Non-contiguous items that are selected will # appear "contiguously". ###################################################################################### proc listbox_non_contiguous_selection { W cur_selection new_selection } { if {[string compare $cur_selection ""] == 0} { $W select from $new_selection $W yview $new_selection return } if {[string compare $new_selection "end"] == 0} { set new_selection [expr [$W size] - 1] } set max_cur_selection [ lintmax $cur_selection ] set min_cur_selection [ lintmin $cur_selection ] set topview $min_cur_selection if { $new_selection > $max_cur_selection } { set new_element [$W get $new_selection] $W delete $new_selection set new_position [expr $max_cur_selection+1] $W insert $new_position $new_element $W select adjust $new_position } elseif { $new_selection < $min_cur_selection } { set new_element [$W get $new_selection] $W delete $new_selection set new_position [expr $min_cur_selection-1] $W insert $new_position $new_element $W select adjust $new_position set topview $new_position } $W yview $topview } # bind_listbox_single_select: binds a listbox to allow only one item selection at a # time. proc bind_listbox_single_select widget_name { global tk_version if {$tk_version < 4.0} { bind $widget_name {;} bind $widget_name {;} bind $widget_name {;} bind $widget_name <2> {;} bind $widget_name {;} } else { $widget_name configure -selectmode single } } # bind_listbox_readonly: binds a listbox to be in browse mode proc bind_listbox_readonly widget_name { global tk_version if {$tk_version >= 4.0} { bindtags $widget_name [list $widget_name] } bind $widget_name <1> {;} bind $widget_name {;} bind $widget_name {;} bind $widget_name {;} bind $widget_name {;} bind $widget_name <2> {;} bind $widget_name {;} } # bind_text_readonly: binds a text widget to be read-only. proc bind_text_readonly widget_name { global tk_version if {$tk_version >= 4.0} { bindtags $widget_name [list $widget_name] } bind $widget_name <1> {;} bind $widget_name {;} bind $widget_name {;} bind $widget_name {;} bind $widget_name {;} bind $widget_name {;} bind $widget_name {;} bind $widget_name {;} bind $widget_name {;} bind $widget_name {;} bind $widget_name {;} } # bind_entry_readonly: binds an entry to be read only. proc bind_entry_readonly widget_name { $widget_name configure -state disabled } # register_dependency: registers a set of bindings for the main listboxes: hostsListbox, # jobsListbox, and queuesListbox. proc register_dependency {} { global queuesListbox jobsListbox hostsListbox \ HOSTS_LISTBOX_KEY QUEUES_LISTBOX_KEY JOBS_LISTBOX_KEY \ hostsSelMode queuesSelMode jobsSelMode \ hostsSelected queuesSelected jobsSelected tk_version if { $tk_version >= 4.0 } { bindtags $queuesListbox [list all Listbox $queuesListbox] bindtags $jobsListbox [list all Listbox $jobsListbox] bindtags $hostsListbox [list all Listbox $hostsListbox] } bind $queuesListbox <1> { if { $tk_version < 4.0 } { %W select from [%W nearest %y] } set queuesSelected \ [get_keyvals $queuesListbox $QUEUES_LISTBOX_KEY @ " " "select"] loadJobs if { [$queuesListbox size] == [llength [$queuesListbox curselection]]} { set queuesSelMode "Deselect All" } else { set queuesSelMode "Select All" } } bind $queuesListbox { if { $tk_version < 4.0 } { %W select to [%W nearest %y] } set queuesSelected \ [get_keyvals $queuesListbox $QUEUES_LISTBOX_KEY @ " " "select"] loadJobs if { [$queuesListbox size] == [llength [$queuesListbox curselection]]} { set queuesSelMode "Deselect All" } else { set queuesSelMode "Select All" } } bind $queuesListbox { if { $tk_version < 4.0 } { %W select adjust [%W nearest %y] } set queuesSelected \ [get_keyvals $queuesListbox $QUEUES_LISTBOX_KEY @ " " "select"] loadJobs if { [$queuesListbox size] == [llength [$queuesListbox curselection]]} { set queuesSelMode "Deselect All" } else { set queuesSelMode "Select All" } } bind $queuesListbox { if { $tk_version < 4.0 } { %W select to [%W nearest %y] } set queuesSelected \ [get_keyvals $queuesListbox $QUEUES_LISTBOX_KEY @ " " "select"] loadJobs if { [$queuesListbox size] == [llength [$queuesListbox curselection]]} { set queuesSelMode "Deselect All" } else { set queuesSelMode "Select All" } } bind $queuesListbox { if {$tk_version < 4.0} { set cur_selection [%W curselection] set new_selection [%W nearest %y] listbox_non_contiguous_selection %W $cur_selection $new_selection } set queuesSelected \ [get_keyvals $queuesListbox $QUEUES_LISTBOX_KEY @ " " "select"] loadJobs if { [$queuesListbox size] == [llength [$queuesListbox curselection]]} { set queuesSelMode "Deselect All" } else { set queuesSelMode "Select All" } } bind $queuesListbox { getQueuesDetail } bind $hostsListbox <1> { if { $tk_version < 4.0 } { %W select from [%W nearest %y] } set hostsSelected \ [get_keyvals $hostsListbox $HOSTS_LISTBOX_KEY "@" " " "select"] loadQueues if { [$hostsListbox size] == [llength [$hostsListbox curselection]]} { set hostsSelMode "Deselect All" } else { set hostsSelMode "Select All" } } bind $hostsListbox { if { $tk_version < 4.0 } { %W select to [%W nearest %y] } set hostsSelected \ [get_keyvals $hostsListbox $HOSTS_LISTBOX_KEY "@" " " "select"] loadQueues if { [$hostsListbox size] == [llength [$hostsListbox curselection]]} { set hostsSelMode "Deselect All" } else { set hostsSelMode "Select All" } } bind $hostsListbox { if {$tk_version < 4.0} { %W select adjust [%W nearest %y] } set hostsSelected \ [get_keyvals $hostsListbox $HOSTS_LISTBOX_KEY "@" " " "select"] loadQueues if { [$hostsListbox size] == [llength [$hostsListbox curselection]]} { set hostsSelMode "Deselect All" } else { set hostsSelMode "Select All" } } bind $hostsListbox { if { $tk_version < 4.0 } { %W select to [%W nearest %y] } set hostsSelected \ [get_keyvals $hostsListbox $HOSTS_LISTBOX_KEY "@" " " "select"] loadQueues if { [$hostsListbox size] == [llength [$hostsListbox curselection]]} { set hostsSelMode "Deselect All" } else { set hostsSelMode "Select All" } } bind $hostsListbox { if {$tk_version < 4.0} { set cur_selection [%W curselection] set new_selection [%W nearest %y] listbox_non_contiguous_selection %W $cur_selection $new_selection %W yview [lindex [%W curselection] 0] } set hostsSelected \ [get_keyvals $hostsListbox $HOSTS_LISTBOX_KEY "@" " " "select"] loadQueues if { [$hostsListbox size] == [llength [$hostsListbox curselection]] } { set hostsSelMode "Deselect All" } else { set hostsSelMode "Select All" } } bind $hostsListbox { getHostsDetail } bind $jobsListbox <1> { if { $tk_version < 4.0 } { %W select from [%W nearest %y] } set jobsSelected [get_keyvals $jobsListbox $JOBS_LISTBOX_KEY "@" " " "select"] if {[$jobsListbox size] == [llength [$jobsListbox curselection]]} { set jobsSelMode "Deselect All" } else { set jobsSelMode "Select All" } } bind $jobsListbox { getJobsDetail } bind $jobsListbox { if { $tk_version < 4.0 } { %W select to [%W nearest %y] } set jobsSelected [get_keyvals $jobsListbox $JOBS_LISTBOX_KEY "@" " " "select"] if {[$jobsListbox size] == [llength [$jobsListbox curselection]]} { set jobsSelMode "Deselect All" } else { set jobsSelMode "Select All" } } bind $jobsListbox { if {$tk_version < 4.0} { %W select adjust [%W nearest %y] } set jobsSelected [get_keyvals $jobsListbox $JOBS_LISTBOX_KEY "@" " " "select"] if { [$jobsListbox size] == [llength [$jobsListbox curselection]]} { set jobsSelMode "Deselect All" } else { set jobsSelMode "Select All" } } bind $jobsListbox { if { $tk_version < 4.0 } { %W select to [%W nearest %y] } set jobsSelected [get_keyvals $jobsListbox $JOBS_LISTBOX_KEY "@" " " "select"] if { [$jobsListbox size] == [llength [$jobsListbox curselection]] } { set jobsSelMode "Deselect All" } else { set jobsSelMode "Select All" } } bind $jobsListbox { if {$tk_version < 4.0} { set cur_selection [%W curselection] set new_selection [%W nearest %y] listbox_non_contiguous_selection %W $cur_selection $new_selection %W yview [lindex [%W curselection] 0] } set jobsSelected [get_keyvals $jobsListbox $JOBS_LISTBOX_KEY "@" " " "select"] if { [$jobsListbox size] == [llength [$jobsListbox curselection]]} { set jobsSelMode "Deselect All" } else { set jobsSelMode "Select All" } } } # register_trackjob_box: binds 'listbox' to perform the function of a trackjob box. proc register_trackjob_box {listbox} { global tk_version if {$tk_version >= 4.0} { bindtags $listbox [list all Listbox $listbox] } bind $listbox <1> { if { $tk_version < 4.0 } { %W select from [%W nearest %y] } set curIdx [%W curselection] if {[string compare $curIdx ""] != 0} { set jobid [%W get $curIdx] if {[string compare $jobid ""] != 0} { trackjob_show $jobid } } } } # register_default_action: specify the default action (a 'button' activation) when # the key is pressed in a dialog box given by 'toplevel'. proc register_default_action {toplevel button} { $button configure -relief ridge -borderwidth 3 bind $toplevel "catch {$button flash; $button invoke}" } # bind_entry_tab: procedure that causes the 'entry_name' widget to pass the input # focus to the 'next_entry_name' widget when the key is hit on the # former, or to 'prev_entry_name' when is pressed. proc bind_entry_tab {entry_name next_entry_name prev_entry_name {env 0}} { global next$entry_name global prev$entry_name global tk_version if {$tk_version >= 4.0} { bindtags $entry_name [list all Entry $entry_name] } set next$entry_name $next_entry_name set prev$entry_name $prev_entry_name if {$env} { bind $entry_name { focus ${next%W} ${next%W} delete 0 end if { [info exists env([%W get])] } { ${next%W} insert 0 $env([%W get]) } if {$tk_version >= 4.0} { ${next%W} xview moveto 1 } } bind $entry_name { focus ${next%W} ${next%W} delete 0 end if { [info exists env([%W get])] } { ${next%W} insert 0 $env([%W get]) } if {$tk_version >= 4.0} { ${next%W} xview moveto 1 } } } else { bind $entry_name { focus ${next%W} if {$tk_version >= 4.0} { ${next%W} xview moveto 1 } } bind $entry_name { focus ${next%W} if {$tk_version >= 4.0} { ${next%W} xview moveto 1 } } } bind $entry_name { focus ${prev%W} if {$tk_version >= 4.0} { ${prev%W} xview moveto 1 } } } # bind_entry_overselect: creates a set of bindings for a user-friendly entry widget. # This includes features such as overwriting selected text, copying and pasting # text solely using mouse buttons, use of basic editing keys: left and right # arrow keys. proc bind_entry_overselect {entry_name} { global tk_version if {$tk_version >= 4.0} { return } bind $entry_name <1> { %W icursor @%x %W select clear %W select from @%x if {[lindex [%W config -state] 4] == "normal"} { focus %W } } bind $entry_name { ## Overwrite the selected region - the selected text is treated as a unit. ## catch {%W delete sel.first sel.last} if {[string compare %A ""] != 0} { %W insert insert %A tk_entrySeeCaret %W } } bind $entry_name <2> { catch {%W insert insert [selection get]} selection clear %W tk_entrySeeCaret %W } bind $entry_name {%W scan dragto %y} bind $entry_name { ## Delete selection if any. if [catch {%W delete sel.first sel.last}] { tk_entryBackspace %W } tk_entrySeeCaret %W } bind $entry_name { ## Delete selection if any. if [catch {%W delete sel.first sel.last}] { tk_entryBackspace %W } tk_entrySeeCaret %W } bind $entry_name { ## Delete selection if any. if [catch {%W delete sel.first sel.last}] { tk_entryBackspace %W } tk_entrySeeCaret %W } bind $entry_name { %W delete sel.first sel.last tk_entrySeeCaret %W } bind $entry_name {%W delete 0 end} bind $entry_name { %W insert insert [selection get] tk_entrySeeCaret %W } bind $entry_name { tk_entryBackword %W tk_entrySeeCaret %W } bind $entry_name { set c [ expr [%W index insert] + 1] %W icursor $c %W select from $c tk_entrySeeCaret %W } bind $entry_name { set c [ expr [%W index insert] - 1] %W icursor $c %W select from $c tk_entrySeeCaret %W } } # bind_entry_shared_scrollbar: a special procedure that binds a "reserved" scrollbar # to 'entry_name. proc bind_entry_shared_scrollbar {entry_name shared_scrollbar} { global tk_version scroll$entry_name set scroll$entry_name $shared_scrollbar bind $entry_name <1> { %W icursor @%x %W select clear %W select from @%x if {[lindex [%W config -state] 4] == "normal"} { focus %W if {$tk_version < 4.0} { if {[lindex [%W configure -scrollcommand] 4] == ""} { %W configure -scrollcommand "${scroll%W} set" } ${scroll%W} configure -command "%W view" } else { if {[lindex [%W configure -xscrollcommand] 4] == ""} { %W configure -xscrollcommand "${scroll%W} set" } ${scroll%W} configure -command "%W xview" } } } } # bind_text_overselect: creates a set of bindings for a user-friendly text widget. # This includes features such as overwriting selected text, copying and pasting # text solely using mouse buttons, use of basic editing keys: left, right, up, # and down arrow keys. proc bind_text_overselect {text_widget} { global tk_version if {$tk_version >= 4.0} { bindtags $text_widget [list $text_widget all Text] bind $text_widget <1> { tkTextButton1 %W %x %y break } bind $text_widget { set tkPriv(x) %x set tkPriv(y) %y tkTextSelectTo %W %x %y break } bind $text_widget { set tkPriv(selectMode) word tkTextSelectTo %W %x %y catch {%W mark set insert sel.first} break } bind $text_widget { set tkPriv(selectMode) line tkTextSelectTo %W %x %y catch {%W mark set insert sel.first} break } bind $text_widget { tkTextResetAnchor %W @%x,%y set tkPriv(selectMode) char tkTextSelectTo %W %x %y break } bind $text_widget { set tkPriv(selectMode) word tkTextSelectTo %W %x %y break } bind $text_widget { set tkPriv(selectMode) line tkTextSelectTo %W %x %y break } bind $text_widget { set tkPriv(x) %x set tkPriv(y) %y tkTextAutoScan %W break } bind $text_widget { tkCancelRepeat break } bind $text_widget { tkCancelRepeat break } bind $text_widget <2> { %W scan mark %x %y set tkPriv(x) %x set tkPriv(y) %y set tkPriv(mouseMoved) 0 break } bind $text_widget { if {(%x != $tkPriv(x)) || (%y != $tkPriv(y))} { set tkPriv(mouseMoved) 1 } if $tkPriv(mouseMoved) { %W scan dragto %x %y } break } bind $text_widget { if !$tkPriv(mouseMoved) { catch { %W insert @%x,%y [selection get -displayof %W] } %W tag remove sel 0.0 end } break } return } bind $text_widget <1> { set tk_priv(selectMode) char %W mark set insert @%x,%y %W mark set anchor insert if {[lindex [%W config -state] 4] == "normal"} {focus %W} } bind $text_widget { set tk_priv(selectMode) word %W mark set insert "@%x,%y wordstart" tk_textSelectTo %W insert } bind $text_widget { set tk_priv(selectMode) line %W mark set insert "@%x,%y linestart" tk_textSelectTo %W insert } bind $text_widget {tk_textSelectTo %W @%x,%y} bind $text_widget <2> { catch {%W insert insert [selection get]} selection clear %W } bind $text_widget {%W scan dragto %y} bind $text_widget {%W insert insert \n; %W yview -pickplace insert} bind $text_widget { if [catch {%W delete sel.first sel.last}] { tk_textBackspace %W %W yview -pickplace insert } } bind $text_widget { if [catch {%W delete sel.first sel.last}] { tk_textBackspace %W %W yview -pickplace insert } } bind $text_widget { catch {%W delete sel.first sel.last}} bind $text_widget { %W insert insert [selection get] %W yview -pickplace insert } bind $text_widget { if [catch {%W delete sel.first sel.last}] { tk_textBackspace %W %W yview -pickplace insert } } bind $text_widget { set idx [regexp "(\[0-9]+)\\.(\[0-9]+)" [%W index insert] match l c] incr c %W mark set insert $l.$c %W mark set anchor insert if {[lindex [%W config -state] 4] == "normal"} {focus %W} } bind $text_widget { set idx [regexp "(\[0-9]+)\\.(\[0-9]+)" [%W index insert] match l c] incr c -1 %W mark set insert $l.$c %W mark set anchor insert if {[lindex [%W config -state] 4] == "normal"} {focus %W} } bind $text_widget { set idx [regexp "(\[0-9]+)\\.(\[0-9]+)" [%W index insert] match l c] incr l -1 %W mark set insert $l.$c %W mark set anchor insert if {[lindex [%W config -state] 4] == "normal"} {focus %W} } bind $text_widget { set idx [regexp "(\[0-9]+)\\.(\[0-9]+)" [%W index insert] match l c] incr l %W mark set insert $l.$c %W mark set anchor insert if {[lindex [%W config -state] 4] == "normal"} {focus %W} } bind $text_widget { catch {%W delete sel.first sel.last} if {"%A" != ""} { %W insert insert %A %W yview -pickplace insert } } } # register_spinbox: place an appropriate binding to 'entry_name' so that it # behaves like a spinbox entry. proc register_spinbox entry { global tk_version vlist.$entry if {$tk_version >= 4.0} { bindtags $entry [list all Entry $entry] } bind $entry { if {$tk_version < 4.0} { catch {%W delete sel.first sel.last} if {[string compare %A ""] != 0} { %W insert insert %A tk_entrySeeCaret %W } } set valueList ${vlist.%W} set sbox_var [%W get] if [regexp "(\[-0-9]+)-(\[-0-9]+)" $valueList match min max] { if { $min >= 0 } { if { ![regexp "^(\[0-9]+)$" $sbox_var match] || \ $sbox_var < $min || $sbox_var > $max } { %W delete 0 end } } else { set firstChar [string index $sbox_var 0] set restOfChar [string range $sbox_var 1 end] if { ![regexp "^(\[-0-9]+)$" $firstChar match] } { %W delete 0 end } elseif {[string compare $restOfChar ""] != 0} { if { ![regexp "^(\[0-9]+)$" $restOfChar match] || \ $sbox_var < $min || $sbox_var > $max } { %W delete 0 end } } } } elseif { ([lsearch -exact ". ^ $ \[ ] ( ) * + ? |" $sbox_var] != -1 && \ [lsearch -exact $valueList $sbox_var] == -1) || \ [lsearch -regexp $valueList "^${sbox_var}"] == -1 } { %W delete 0 end } } bind $entry { check_spinbox_value %W } } proc register_entry_fixsize {entry size} { global tk_version size.$entry set size.$entry $size if {$tk_version >= 4.0} { bindtags $entry [list all Entry $entry] } bind $entry { set size ${size.%W} set sbox_var [%W get] if {[string length $sbox_var] < $size} { if {$tk_version < 4.0} { catch {%W delete sel.first sel.last} if {[string compare %A ""] != 0} { %W insert insert %A tk_entrySeeCaret %W } } } else { if {$tk_version >= 4.0} { %W delete 0 end %W insert 0 [string range $sbox_var 0 [expr $size - 1]] } } } } proc bind_depend {mode listbox} { global tk_version PBS_JOBS_DETAIL_CMD global queuesListbox jobsListbox hostsListbox \ HOSTS_LISTBOX_KEY QUEUES_LISTBOX_KEY JOBS_LISTBOX_KEY \ hostsSelMode queuesSelMode jobsSelMode \ hostsSelected queuesSelected jobsSelected tk_version mode$listbox switch -exact -- $mode { concur { global concurJob set mode$listbox concur } after { global afterJob set mode$listbox after } before { global beforeJob set mode$listbox before } } if { $tk_version >= 4.0 } { bindtags $listbox [list all Listbox $listbox] } bind $listbox <1> { if { $tk_version < 4.0 } { %W select from [%W nearest %y] } set ${mode%W}Job [get_keyvals %W {0} "" ":" "select"] } bind $listbox { win_cmdExec "" "$PBS_JOBS_DETAIL_CMD [set ${mode%W}Job]" } bind $listbox { if { $tk_version < 4.0 } { %W select to [%W nearest %y] } set ${mode%W}Job [get_keyvals %W {0} "" ":" "select"] } bind $listbox { if {$tk_version < 4.0} { %W select adjust [%W nearest %y] } set ${mode%W}Job [get_keyvals %W {0} "" ":" "select"] } bind $listbox { if { $tk_version < 4.0 } { %W select to [%W nearest %y] } set ${mode%W}Job [get_keyvals %W {0} "" ":" "select"] } bind $listbox { if {$tk_version < 4.0} { set cur_selection [%W curselection] set new_selection [%W nearest %y] listbox_non_contiguous_selection %W $cur_selection $new_selection %W yview [lindex [%W curselection] 0] } set ${mode%W}Job [get_keyvals %W {0} "" ":" "select"] } } # t - toplevel # e - name entry # lb - listbox proc fileselectBindings { e lb } { global fileselect tk_version if { $tk_version >= 4.0 } { bindtags $lb [list all Listbox $lb] bindtags $e [list all Entry $e] } # Entry bindings bind $e { fileselectList $fileselect(dir) } # A single click puts the name in the entry # A double click or select the name bind $lb { if { $tk_version < 4.0 } { %W select from [%W nearest %y] } fileselectClick %W %y if { [string compare $fileselect(dir) "/"] != 0 && \ [file isfile $fileselect(dir)/$fileselect(path)] } { set fileselect(filepath) $fileselect(dir)/$fileselect(path) } elseif { [string compare $fileselect(dir) "/"] == 0 && \ [file isfile /$fileselect(path)] } { set fileselect(filepath) /$fileselect(path) } else { set fileselect(filepath) {} } } bind $lb { busy_cursor fileselectClick %W %y fileselectOK if [file isfile $fileselect(path)] { set fileselect(filepath) $fileselect(path) } else { set fileselect(filepath) {} } remove_busy_cursor } } proc bind_button1 win { global coordX coordY bind $win <1> { set coordX %X set coordY %Y } } proc bind_listbox_select {listbox boxframe} { global tk_version box$listbox set box$listbox $boxframe if { $tk_version >= 4.0 } { bindtags $listbox [list all Listbox $listbox] } bind $listbox <1> { if { $tk_version < 4.0 } { %W select from [%W nearest %y] boxSelect ${box%W} [%W index @%x,%y] } boxSelect ${box%W} [%W index @%x,%y] } }