diff options
Diffstat (limited to 'library/xmfbox.tcl')
| -rw-r--r-- | library/xmfbox.tcl | 635 |
1 files changed, 635 insertions, 0 deletions
diff --git a/library/xmfbox.tcl b/library/xmfbox.tcl new file mode 100644 index 0000000..52f8b33 --- /dev/null +++ b/library/xmfbox.tcl @@ -0,0 +1,635 @@ +# xmfbox.tcl -- +# +# Implements the "Motif" style file selection dialog for the +# Unix platform. This implementation is used only if the +# "tk_strictMotif" flag is set. +# +# SCCS: @(#) xmfbox.tcl 1.6 97/10/01 15:06:07 +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + + +# tkMotifFDialog -- +# +# Implements a file dialog similar to the standard Motif file +# selection box. +# +# Return value: +# +# A list of two members. The first member is the absolute +# pathname of the selected file or "" if user hits cancel. The +# second member is the name of the selected file type, or "" +# which stands for "default file type" +# +proc tkMotifFDialog {args} { + global tkPriv + set w __tk_filedialog + upvar #0 $w data + + if ![string compare [lindex [info level 0] 0] tk_getOpenFile] { + set type open + } else { + set type save + } + + tkMotifFDialog_Config $w $type $args + + if {![string compare $data(-parent) .]} { + set w .$w + } else { + set w $data(-parent).$w + } + + # (re)create the dialog box if necessary + # + if {![winfo exists $w]} { + tkMotifFDialog_Create $w + } elseif {[string compare [winfo class $w] TkMotifFDialog]} { + destroy $w + tkMotifFDialog_Create $w + } + wm transient $w $data(-parent) + + tkMotifFDialog_Update $w + + # 5. Withdraw the window, then update all the geometry information + # so we know how big it wants to be, then center the window in the + # display and de-iconify it. + + wm withdraw $w + update idletasks + set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ + - [winfo vrootx [winfo parent $w]]] + set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ + - [winfo vrooty [winfo parent $w]]] + wm geom $w +$x+$y + wm deiconify $w + wm title $w $data(-title) + + # 6. Set a grab and claim the focus too. + + set oldFocus [focus] + set oldGrab [grab current $w] + if {$oldGrab != ""} { + set grabStatus [grab status $oldGrab] + } + grab $w + focus $data(sEnt) + $data(sEnt) select from 0 + $data(sEnt) select to end + + # 7. Wait for the user to respond, then restore the focus and + # return the index of the selected button. Restore the focus + # before deleting the window, since otherwise the window manager + # may take the focus away so we can't redirect it. Finally, + # restore any grab that was in effect. + + tkwait variable tkPriv(selectFilePath) + catch {focus $oldFocus} + grab release $w + wm withdraw $w + if {$oldGrab != ""} { + if {$grabStatus == "global"} { + grab -global $oldGrab + } else { + grab $oldGrab + } + } + return $tkPriv(selectFilePath) +} + +proc tkMotifFDialog_Config {w type argList} { + upvar #0 $w data + + set data(type) $type + + # 1: the configuration specs + # + set specs { + {-defaultextension "" "" ""} + {-filetypes "" "" ""} + {-initialdir "" "" ""} + {-initialfile "" "" ""} + {-parent "" "" "."} + {-title "" "" ""} + } + + # 2: default values depending on the type of the dialog + # + if ![info exists data(selectPath)] { + # first time the dialog has been popped up + set data(selectPath) [pwd] + set data(selectFile) "" + } + + # 3: parse the arguments + # + tclParseConfigSpec $w $specs "" $argList + + if ![string compare $data(-title) ""] { + if ![string compare $type "open"] { + set data(-title) "Open" + } else { + set data(-title) "Save As" + } + } + + # 4: set the default directory and selection according to the -initial + # settings + # + if [string compare $data(-initialdir) ""] { + if [file isdirectory $data(-initialdir)] { + set data(selectPath) [glob $data(-initialdir)] + } else { + error "\"$data(-initialdir)\" is not a valid directory" + } + } + set data(selectFile) $data(-initialfile) + + # 5. Parse the -filetypes option. It is not used by the motif + # file dialog, but we check for validity of the value to make sure + # the application code also runs fine with the TK file dialog. + # + set data(-filetypes) [tkFDGetFileTypes $data(-filetypes)] + + if ![info exists data(filter)] { + set data(filter) * + } + if ![winfo exists $data(-parent)] { + error "bad window path name \"$data(-parent)\"" + } +} + +proc tkMotifFDialog_Create {w} { + set dataName [lindex [split $w .] end] + upvar #0 $dataName data + + # 1: Create the dialog ... + # + toplevel $w -class TkMotifFDialog + set top [frame $w.top -relief raised -bd 1] + set bot [frame $w.bot -relief raised -bd 1] + + pack $w.bot -side bottom -fill x + pack $w.top -side top -expand yes -fill both + + set f1 [frame $top.f1] + set f2 [frame $top.f2] + set f3 [frame $top.f3] + + pack $f1 -side top -fill x + pack $f3 -side bottom -fill x + pack $f2 -expand yes -fill both + + set f2a [frame $f2.a] + set f2b [frame $f2.b] + + grid $f2a -row 0 -column 0 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \ + -sticky news + grid $f2b -row 0 -column 1 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \ + -sticky news + grid rowconfig $f2 0 -minsize 0 -weight 1 + grid columnconfig $f2 0 -minsize 0 -weight 1 + grid columnconfig $f2 1 -minsize 150 -weight 2 + + # The Filter box + # + label $f1.lab -text "Filter:" -under 3 -anchor w + entry $f1.ent + pack $f1.lab -side top -fill x -padx 6 -pady 4 + pack $f1.ent -side top -fill x -padx 4 -pady 0 + set data(fEnt) $f1.ent + + # The file and directory lists + # + set data(dList) [tkMotifFDialog_MakeSList $w $f2a Directory: 0 DList] + set data(fList) [tkMotifFDialog_MakeSList $w $f2b Files: 2 FList] + + # The Selection box + # + label $f3.lab -text "Selection:" -under 0 -anchor w + entry $f3.ent + pack $f3.lab -side top -fill x -padx 6 -pady 0 + pack $f3.ent -side top -fill x -padx 4 -pady 4 + set data(sEnt) $f3.ent + + # The buttons + # + set data(okBtn) [button $bot.ok -text OK -width 6 -under 0 \ + -command "tkMotifFDialog_OkCmd $w"] + set data(filterBtn) [button $bot.filter -text Filter -width 6 -under 0 \ + -command "tkMotifFDialog_FilterCmd $w"] + set data(cancelBtn) [button $bot.cancel -text Cancel -width 6 -under 0 \ + -command "tkMotifFDialog_CancelCmd $w"] + + pack $bot.ok $bot.filter $bot.cancel -padx 10 -pady 10 -expand yes \ + -side left + + # Create the bindings: + # + bind $w <Alt-t> "focus $data(fEnt)" + bind $w <Alt-d> "focus $data(dList)" + bind $w <Alt-l> "focus $data(fList)" + bind $w <Alt-s> "focus $data(sEnt)" + + bind $w <Alt-o> "tkButtonInvoke $bot.ok " + bind $w <Alt-f> "tkButtonInvoke $bot.filter" + bind $w <Alt-c> "tkButtonInvoke $bot.cancel" + + bind $data(fEnt) <Return> "tkMotifFDialog_ActivateFEnt $w" + bind $data(sEnt) <Return> "tkMotifFDialog_ActivateSEnt $w" + + wm protocol $w WM_DELETE_WINDOW "tkMotifFDialog_CancelCmd $w" +} + +proc tkMotifFDialog_MakeSList {w f label under cmd} { + label $f.lab -text $label -under $under -anchor w + listbox $f.l -width 12 -height 5 -selectmode browse -exportselection 0\ + -xscrollcommand "$f.h set" \ + -yscrollcommand "$f.v set" + scrollbar $f.v -orient vertical -takefocus 0 \ + -command "$f.l yview" + scrollbar $f.h -orient horizontal -takefocus 0 \ + -command "$f.l xview" + grid $f.lab -row 0 -column 0 -sticky news -rowspan 1 -columnspan 2 \ + -padx 2 -pady 2 + grid $f.l -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news + grid $f.v -row 1 -column 1 -rowspan 1 -columnspan 1 -sticky news + grid $f.h -row 2 -column 0 -rowspan 1 -columnspan 1 -sticky news + + grid rowconfig $f 0 -weight 0 -minsize 0 + grid rowconfig $f 1 -weight 1 -minsize 0 + grid columnconfig $f 0 -weight 1 -minsize 0 + + # bindings for the listboxes + # + set list $f.l + bind $list <Up> "tkMotifFDialog_Browse$cmd $w" + bind $list <Down> "tkMotifFDialog_Browse$cmd $w" + bind $list <space> "tkMotifFDialog_Browse$cmd $w" + bind $list <1> "tkMotifFDialog_Browse$cmd $w" + bind $list <B1-Motion> "tkMotifFDialog_Browse$cmd $w" + bind $list <Double-1> "tkMotifFDialog_Activate$cmd $w" + bind $list <Return> "tkMotifFDialog_Browse$cmd $w; tkMotifFDialog_Activate$cmd $w" + + bindtags $list "Listbox $list [winfo toplevel $list] all" + tkListBoxKeyAccel_Set $list + + return $f.l +} + +proc tkMotifFDialog_BrowseDList {w} { + upvar #0 [winfo name $w] data + + focus $data(dList) + if ![string compare [$data(dList) curselection] ""] { + return + } + set subdir [$data(dList) get [$data(dList) curselection]] + if ![string compare $subdir ""] { + return + } + + $data(fList) selection clear 0 end + + set list [tkMotifFDialog_InterpFilter $w] + set data(filter) [lindex $list 1] + + case $subdir { + . { + set newSpec [file join $data(selectPath) $data(filter)] + } + .. { + set newSpec [file join [file dirname $data(selectPath)] \ + $data(filter)] + } + default { + set newSpec [file join $data(selectPath) $subdir $data(filter)] + } + } + + $data(fEnt) delete 0 end + $data(fEnt) insert 0 $newSpec +} + +proc tkMotifFDialog_ActivateDList {w} { + upvar #0 [winfo name $w] data + + if ![string compare [$data(dList) curselection] ""] { + return + } + set subdir [$data(dList) get [$data(dList) curselection]] + if ![string compare $subdir ""] { + return + } + + $data(fList) selection clear 0 end + + case $subdir { + . { + set newDir $data(selectPath) + } + .. { + set newDir [file dirname $data(selectPath)] + } + default { + set newDir [file join $data(selectPath) $subdir] + } + } + + set data(selectPath) $newDir + tkMotifFDialog_Update $w + + if [string compare $subdir ..] { + $data(dList) selection set 0 + $data(dList) activate 0 + } else { + $data(dList) selection set 1 + $data(dList) activate 1 + } +} + +proc tkMotifFDialog_BrowseFList {w} { + upvar #0 [winfo name $w] data + + focus $data(fList) + if ![string compare [$data(fList) curselection] ""] { + return + } + set data(selectFile) [$data(fList) get [$data(fList) curselection]] + if ![string compare $data(selectFile) ""] { + return + } + + $data(dList) selection clear 0 end + + $data(fEnt) delete 0 end + $data(fEnt) insert 0 [file join $data(selectPath) $data(filter)] + $data(fEnt) xview end + + $data(sEnt) delete 0 end + $data(sEnt) insert 0 [file join $data(selectPath) $data(selectFile)] + $data(sEnt) xview end +} + +proc tkMotifFDialog_ActivateFList {w} { + upvar #0 [winfo name $w] data + + if ![string compare [$data(fList) curselection] ""] { + return + } + set data(selectFile) [$data(fList) get [$data(fList) curselection]] + if ![string compare $data(selectFile) ""] { + return + } else { + tkMotifFDialog_ActivateSEnt $w + } +} + +proc tkMotifFDialog_ActivateFEnt {w} { + upvar #0 [winfo name $w] data + + set list [tkMotifFDialog_InterpFilter $w] + set data(selectPath) [lindex $list 0] + set data(filter) [lindex $list 1] + + tkMotifFDialog_Update $w +} + +proc tkMotifFDialog_InterpFilter {w} { + upvar #0 [winfo name $w] data + + set text [string trim [$data(fEnt) get]] + # Perform tilde substitution + # + if ![string compare [string index $text 0] ~] { + set list [file split $text] + set tilde [lindex $list 0] + catch { + set tilde [glob $tilde] + } + set text [eval file join [concat $tilde [lrange $list 1 end]]] + } + + set resolved [file join [file dirname $text] [file tail $text]] + + if [file isdirectory $resolved] { + set dir $resolved + set fil $data(filter) + } else { + set dir [file dirname $resolved] + set fil [file tail $resolved] + } + + return [list $dir $fil] +} + + +proc tkMotifFDialog_ActivateSEnt {w} { + global tkPriv + upvar #0 [winfo name $w] data + + set selectFilePath [string trim [$data(sEnt) get]] + set selectFile [file tail $selectFilePath] + set selectPath [file dirname $selectFilePath] + + + if {![string compare $selectFilePath ""]} { + tkMotifFDialog_FilterCmd $w + return + } + + if {[file isdirectory $selectFilePath]} { + set data(selectPath) [glob $selectFilePath] + set data(selectFile) "" + tkMotifFDialog_Update $w + return + } + + if [string compare [file pathtype $selectFilePath] "absolute"] { + tk_messageBox -icon warning -type ok \ + -message "\"$selectFilePath\" must be an absolute pathname" + return + } + + if ![file exists $selectPath] { + tk_messageBox -icon warning -type ok \ + -message "Directory \"$selectPath\" does not exist." + return + } + + if ![file exists $selectFilePath] { + if ![string compare $data(type) open] { + tk_messageBox -icon warning -type ok \ + -message "File \"$selectFilePath\" does not exist." + return + } + } else { + if ![string compare $data(type) save] { + set message [format %s%s \ + "File \"$selectFilePath\" already exists.\n\n" \ + "Replace existing file?"] + set answer [tk_messageBox -icon warning -type yesno \ + -message $message] + if ![string compare $answer "no"] { + return + } + } + } + + set tkPriv(selectFilePath) $selectFilePath + set tkPriv(selectFile) $selectFile + set tkPriv(selectPath) $selectPath +} + + +proc tkMotifFDialog_OkCmd {w} { + upvar #0 [winfo name $w] data + + tkMotifFDialog_ActivateSEnt $w +} + +proc tkMotifFDialog_FilterCmd {w} { + upvar #0 [winfo name $w] data + + tkMotifFDialog_ActivateFEnt $w +} + +proc tkMotifFDialog_CancelCmd {w} { + global tkPriv + + set tkPriv(selectFilePath) "" + set tkPriv(selectFile) "" + set tkPriv(selectPath) "" +} + +# tkMotifFDialog_Update +# +# Load the files and synchronize the "filter" and "selection" fields +# boxes. +# +# popup: +# If this is true, then update the selection field according to the +# "-selection" flag +# +proc tkMotifFDialog_Update {w} { + upvar #0 [winfo name $w] data + + $data(fEnt) delete 0 end + $data(fEnt) insert 0 [file join $data(selectPath) $data(filter)] + $data(sEnt) delete 0 end + $data(sEnt) insert 0 [file join $data(selectPath) $data(selectFile)] + + tkMotifFDialog_LoadFiles $w +} + +proc tkMotifFDialog_LoadFiles {w} { + upvar #0 [winfo name $w] data + + $data(dList) delete 0 end + $data(fList) delete 0 end + + set appPWD [pwd] + if [catch { + cd $data(selectPath) + }] { + cd $appPWD + + $data(dList) insert end ".." + return + } + + # Make the dir list + # + foreach f [lsort -command tclSortNoCase [glob -nocomplain .* *]] { + if [file isdir $f] { + $data(dList) insert end $f + } + } + # Make the file list + # + if ![string compare $data(filter) *] { + set files [lsort -command tclSortNoCase [glob -nocomplain .* *]] + } else { + set files [lsort -command tclSortNoCase \ + [glob -nocomplain $data(filter)]] + } + + set top 0 + foreach f $files { + if ![file isdir $f] { + $data(fList) insert end $f + if [string match .* $f] { + incr top + } + } + } + + # The user probably doesn't want to see the . files. We adjust the view + # so that the listbox displays all the non-dot files + $data(fList) yview $top + + cd $appPWD +} + +proc tkListBoxKeyAccel_Set {w} { + bind Listbox <Any-KeyPress> "" + bind $w <Destroy> "tkListBoxKeyAccel_Unset $w" + bind $w <Any-KeyPress> "tkListBoxKeyAccel_Key $w %A" +} + +proc tkListBoxKeyAccel_Unset {w} { + global tkPriv + + catch {after cancel $tkPriv(lbAccel,$w,afterId)} + catch {unset tkPriv(lbAccel,$w)} + catch {unset tkPriv(lbAccel,$w,afterId)} +} + +proc tkListBoxKeyAccel_Key {w key} { + global tkPriv + + append tkPriv(lbAccel,$w) $key + tkListBoxKeyAccel_Goto $w $tkPriv(lbAccel,$w) + catch { + after cancel $tkPriv(lbAccel,$w,afterId) + } + set tkPriv(lbAccel,$w,afterId) [after 500 tkListBoxKeyAccel_Reset $w] +} + +proc tkListBoxKeyAccel_Goto {w string} { + global tkPriv + + set string [string tolower $string] + set end [$w index end] + set theIndex -1 + + for {set i 0} {$i < $end} {incr i} { + set item [string tolower [$w get $i]] + if {[string compare $string $item] >= 0} { + set theIndex $i + } + if {[string compare $string $item] <= 0} { + set theIndex $i + break + } + } + + if {$theIndex >= 0} { + $w selection clear 0 end + $w selection set $theIndex $theIndex + $w activate $theIndex + $w see $theIndex + } +} + +proc tkListBoxKeyAccel_Reset {w} { + global tkPriv + + catch {unset tkPriv(lbAccel,$w)} +} + |