Initial revision

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)}
+}
+