archie/tk4.2/library/xmfbox.tcl
2024-05-27 16:40:40 +02:00

629 lines
16 KiB
Tcl

# 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.5 96/10/04 17:09:24
#
# 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
# (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} {
upvar #0 $w 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 $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 $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 $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 $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 $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 $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 $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 $w data
tkMotifFDialog_ActivateSEnt $w
}
proc tkMotifFDialog_FilterCmd {w} {
upvar #0 $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 $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 $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)}
}