home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tk42r2x.zip / TclTk / lib / tk4.2 / xmfbox.tcl < prev   
Text File  |  1999-07-27  |  16KB  |  629 lines
  1. # xmfbox.tcl --
  2. #
  3. #    Implements the "Motif" style file selection dialog for the
  4. #    Unix platform. This implementation is used only if the
  5. #    "tk_strictMotif" flag is set.
  6. #
  7. # SCCS: @(#) xmfbox.tcl 1.5 96/10/04 17:09:24
  8. #
  9. # Copyright (c) 1996 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14.  
  15.  
  16. # tkMotifFDialog --
  17. #
  18. #    Implements a file dialog similar to the standard Motif file
  19. #    selection box.
  20. #
  21. # Return value:
  22. #
  23. #    A list of two members. The first member is the absolute
  24. #    pathname of the selected file or "" if user hits cancel. The
  25. #    second member is the name of the selected file type, or ""
  26. #    which stands for "default file type"
  27. #
  28. proc tkMotifFDialog {args} {
  29.     global tkPriv
  30.     set w .__tk_filedialog
  31.     upvar #0 $w data
  32.  
  33.     if ![string compare [lindex [info level 0] 0] tk_getOpenFile] {
  34.     set type open
  35.     } else {
  36.     set type save
  37.     }
  38.  
  39.     tkMotifFDialog_Config $w $type $args
  40.  
  41.     # (re)create the dialog box if necessary
  42.     #
  43.     if {![winfo exists $w]} {
  44.     tkMotifFDialog_Create $w
  45.     } elseif {[string compare [winfo class $w] TkMotifFDialog]} {
  46.     destroy $w
  47.     tkMotifFDialog_Create $w
  48.     }
  49.     wm transient $w $data(-parent)
  50.  
  51.     tkMotifFDialog_Update $w
  52.  
  53.     # 5. Withdraw the window, then update all the geometry information
  54.     # so we know how big it wants to be, then center the window in the
  55.     # display and de-iconify it.
  56.  
  57.     wm withdraw $w
  58.     update idletasks
  59.     set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
  60.         - [winfo vrootx [winfo parent $w]]]
  61.     set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
  62.         - [winfo vrooty [winfo parent $w]]]
  63.     wm geom $w +$x+$y
  64.     wm deiconify $w
  65.     wm title $w $data(-title)
  66.  
  67.     # 6. Set a grab and claim the focus too.
  68.  
  69.     set oldFocus [focus]
  70.     set oldGrab [grab current $w]
  71.     if {$oldGrab != ""} {
  72.     set grabStatus [grab status $oldGrab]
  73.     }
  74.     grab $w
  75.     focus $data(sEnt)
  76.     $data(sEnt) select from 0
  77.     $data(sEnt) select to   end
  78.  
  79.     # 7. Wait for the user to respond, then restore the focus and
  80.     # return the index of the selected button.  Restore the focus
  81.     # before deleting the window, since otherwise the window manager
  82.     # may take the focus away so we can't redirect it.  Finally,
  83.     # restore any grab that was in effect.
  84.  
  85.     tkwait variable tkPriv(selectFilePath)
  86.     catch {focus $oldFocus}
  87.     grab release $w
  88.     wm withdraw $w
  89.     if {$oldGrab != ""} {
  90.     if {$grabStatus == "global"} {
  91.         grab -global $oldGrab
  92.     } else {
  93.         grab $oldGrab
  94.     }
  95.     }
  96.     return $tkPriv(selectFilePath)
  97. }
  98.  
  99. proc tkMotifFDialog_Config {w type argList} {
  100.     upvar #0 $w data
  101.  
  102.     set data(type) $type
  103.  
  104.     # 1: the configuration specs
  105.     #
  106.     set specs {
  107.     {-defaultextension "" "" ""}
  108.     {-filetypes "" "" ""}
  109.     {-initialdir "" "" ""}
  110.     {-initialfile "" "" ""}
  111.     {-parent "" "" "."}
  112.     {-title "" "" ""}
  113.     }
  114.  
  115.     # 2: default values depending on the type of the dialog
  116.     #
  117.     if ![info exists data(selectPath)] {
  118.     # first time the dialog has been popped up
  119.     set data(selectPath) [pwd]
  120.     set data(selectFile) ""
  121.     }
  122.  
  123.     # 3: parse the arguments
  124.     #
  125.     tclParseConfigSpec $w $specs "" $argList
  126.  
  127.     if ![string compare $data(-title) ""] {
  128.     if ![string compare $type "open"] {
  129.         set data(-title) "Open"
  130.     } else {
  131.         set data(-title) "Save As"
  132.     }
  133.     }
  134.  
  135.     # 4: set the default directory and selection according to the -initial
  136.     #    settings
  137.     #
  138.     if [string compare $data(-initialdir) ""] {
  139.     if [file isdirectory $data(-initialdir)] {
  140.         set data(selectPath) [glob $data(-initialdir)]
  141.     } else {
  142.         error "\"$data(-initialdir)\" is not a valid directory"
  143.     }
  144.     }
  145.     set data(selectFile) $data(-initialfile)
  146.  
  147.     # 5. Parse the -filetypes option. It is not used by the motif
  148.     #    file dialog, but we check for validity of the value to make sure
  149.     #    the application code also runs fine with the TK file dialog.
  150.     #
  151.     set data(-filetypes) [tkFDGetFileTypes $data(-filetypes)]
  152.  
  153.     if ![info exists data(filter)] {
  154.     set data(filter) *
  155.     }
  156.     if ![winfo exists $data(-parent)] {
  157.     error "bad window path name \"$data(-parent)\""
  158.     }
  159. }
  160.  
  161. proc tkMotifFDialog_Create {w} {
  162.     upvar #0 $w data
  163.  
  164.     # 1: Create the dialog ...
  165.     #
  166.     toplevel $w -class TkMotifFDialog
  167.     set top [frame $w.top -relief raised -bd 1]
  168.     set bot [frame $w.bot -relief raised -bd 1]
  169.  
  170.     pack $w.bot -side bottom -fill x
  171.     pack $w.top -side top -expand yes -fill both
  172.  
  173.     set f1 [frame $top.f1]
  174.     set f2 [frame $top.f2]
  175.     set f3 [frame $top.f3]
  176.  
  177.     pack $f1 -side top    -fill x
  178.     pack $f3 -side bottom -fill x
  179.     pack $f2 -expand yes -fill both
  180.  
  181.     set f2a [frame $f2.a]
  182.     set f2b [frame $f2.b]
  183.  
  184.     grid $f2a -row 0 -column 0 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \
  185.     -sticky news
  186.     grid $f2b -row 0 -column 1 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \
  187.     -sticky news
  188.     grid rowconfig $f2 0    -minsize 0   -weight 1
  189.     grid columnconfig $f2 0 -minsize 0   -weight 1
  190.     grid columnconfig $f2 1 -minsize 150 -weight 2
  191.  
  192.     # The Filter box
  193.     #
  194.     label $f1.lab -text "Filter:" -under 3 -anchor w
  195.     entry $f1.ent
  196.     pack $f1.lab -side top -fill x -padx 6 -pady 4
  197.     pack $f1.ent -side top -fill x -padx 4 -pady 0
  198.     set data(fEnt) $f1.ent
  199.  
  200.     # The file and directory lists
  201.     #
  202.     set data(dList) [tkMotifFDialog_MakeSList $w $f2a Directory: 0 DList]
  203.     set data(fList) [tkMotifFDialog_MakeSList $w $f2b Files:     2 FList]
  204.  
  205.     # The Selection box
  206.     #
  207.     label $f3.lab -text "Selection:" -under 0 -anchor w
  208.     entry $f3.ent
  209.     pack $f3.lab -side top -fill x -padx 6 -pady 0
  210.     pack $f3.ent -side top -fill x -padx 4 -pady 4
  211.     set data(sEnt) $f3.ent
  212.  
  213.     # The buttons
  214.     #
  215.     set data(okBtn) [button $bot.ok     -text OK     -width 6 -under 0 \
  216.     -command "tkMotifFDialog_OkCmd $w"]
  217.     set data(filterBtn) [button $bot.filter -text Filter -width 6 -under 0 \
  218.     -command "tkMotifFDialog_FilterCmd $w"]
  219.     set data(cancelBtn) [button $bot.cancel -text Cancel -width 6 -under 0 \
  220.     -command "tkMotifFDialog_CancelCmd $w"]
  221.  
  222.     pack $bot.ok $bot.filter $bot.cancel -padx 10 -pady 10 -expand yes \
  223.     -side left
  224.  
  225.     # Create the bindings:
  226.     #
  227.     bind $w <Alt-t> "focus $data(fEnt)"
  228.     bind $w <Alt-d> "focus $data(dList)"
  229.     bind $w <Alt-l> "focus $data(fList)"
  230.     bind $w <Alt-s> "focus $data(sEnt)"
  231.  
  232.     bind $w <Alt-o> "tkButtonInvoke $bot.ok    "
  233.     bind $w <Alt-f> "tkButtonInvoke $bot.filter"
  234.     bind $w <Alt-c> "tkButtonInvoke $bot.cancel"
  235.  
  236.     bind $data(fEnt) <Return> "tkMotifFDialog_ActivateFEnt $w"
  237.     bind $data(sEnt) <Return> "tkMotifFDialog_ActivateSEnt $w"
  238.  
  239.     wm protocol $w WM_DELETE_WINDOW "tkMotifFDialog_CancelCmd $w"
  240. }
  241.  
  242. proc tkMotifFDialog_MakeSList {w f label under cmd} {
  243.     label $f.lab -text $label -under $under -anchor w
  244.     listbox $f.l -width 12 -height 5 -selectmode browse -exportselection 0\
  245.     -xscrollcommand "$f.h set" \
  246.     -yscrollcommand "$f.v set" 
  247.     scrollbar $f.v -orient vertical   -takefocus 0 \
  248.     -command "$f.l yview"
  249.     scrollbar $f.h -orient horizontal -takefocus 0 \
  250.     -command "$f.l xview"
  251.     grid $f.lab -row 0 -column 0 -sticky news -rowspan 1 -columnspan 2 \
  252.     -padx 2 -pady 2
  253.     grid $f.l -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
  254.     grid $f.v -row 1 -column 1 -rowspan 1 -columnspan 1 -sticky news
  255.     grid $f.h -row 2 -column 0 -rowspan 1 -columnspan 1 -sticky news
  256.  
  257.     grid rowconfig    $f 0 -weight 0 -minsize 0
  258.     grid rowconfig    $f 1 -weight 1 -minsize 0
  259.     grid columnconfig $f 0 -weight 1 -minsize 0
  260.  
  261.     # bindings for the listboxes
  262.     #
  263.     set list $f.l
  264.     bind $list <Up>        "tkMotifFDialog_Browse$cmd $w"
  265.     bind $list <Down>      "tkMotifFDialog_Browse$cmd $w"
  266.     bind $list <space>     "tkMotifFDialog_Browse$cmd $w"
  267.     bind $list <1>         "tkMotifFDialog_Browse$cmd $w"
  268.     bind $list <B1-Motion> "tkMotifFDialog_Browse$cmd $w"
  269.     bind $list <Double-1>  "tkMotifFDialog_Activate$cmd $w"
  270.     bind $list <Return>    "tkMotifFDialog_Browse$cmd $w; tkMotifFDialog_Activate$cmd $w"
  271.  
  272.     bindtags $list "Listbox $list [winfo toplevel $list] all"
  273.     tkListBoxKeyAccel_Set $list
  274.  
  275.     return $f.l
  276. }
  277.  
  278. proc tkMotifFDialog_BrowseDList {w} {
  279.     upvar #0 $w data
  280.  
  281.     focus $data(dList)
  282.     if ![string compare [$data(dList) curselection] ""] {
  283.     return
  284.     }
  285.     set subdir [$data(dList) get [$data(dList) curselection]]
  286.     if ![string compare $subdir ""] {
  287.     return
  288.     }
  289.  
  290.     $data(fList) selection clear 0 end
  291.  
  292.     set list [tkMotifFDialog_InterpFilter $w]
  293.     set data(filter) [lindex $list 1]
  294.  
  295.     case $subdir {
  296.     . {
  297.         set newSpec [file join $data(selectPath) $data(filter)]
  298.     }
  299.     .. {
  300.         set newSpec [file join [file dirname $data(selectPath)] \
  301.         $data(filter)]
  302.     }
  303.     default {
  304.         set newSpec [file join $data(selectPath) $subdir $data(filter)]
  305.     }
  306.     }
  307.  
  308.     $data(fEnt) delete 0 end
  309.     $data(fEnt) insert 0 $newSpec
  310. }
  311.  
  312. proc tkMotifFDialog_ActivateDList {w} {
  313.     upvar #0 $w data
  314.  
  315.     if ![string compare [$data(dList) curselection] ""] {
  316.     return
  317.     }
  318.     set subdir [$data(dList) get [$data(dList) curselection]]
  319.     if ![string compare $subdir ""] {
  320.     return
  321.     }
  322.  
  323.     $data(fList) selection clear 0 end
  324.  
  325.     case $subdir {
  326.     . {
  327.         set newDir $data(selectPath)
  328.     }
  329.     .. {
  330.         set newDir [file dirname $data(selectPath)]
  331.     }
  332.     default {
  333.         set newDir [file join $data(selectPath) $subdir]
  334.     }
  335.     }
  336.  
  337.     set data(selectPath) $newDir
  338.     tkMotifFDialog_Update $w
  339.  
  340.     if [string compare $subdir ..] {
  341.     $data(dList) selection set 0
  342.     $data(dList) activate 0
  343.     } else {
  344.     $data(dList) selection set 1
  345.     $data(dList) activate 1
  346.     }
  347. }
  348.  
  349. proc tkMotifFDialog_BrowseFList {w} {
  350.     upvar #0 $w data
  351.  
  352.     focus $data(fList)
  353.     if ![string compare [$data(fList) curselection] ""] {
  354.     return
  355.     }
  356.     set data(selectFile) [$data(fList) get [$data(fList) curselection]]
  357.     if ![string compare $data(selectFile) ""] {
  358.     return
  359.     }
  360.  
  361.     $data(dList) selection clear 0 end
  362.  
  363.     $data(fEnt) delete 0 end
  364.     $data(fEnt) insert 0 [file join $data(selectPath) $data(filter)]
  365.     $data(fEnt) xview end
  366.  
  367.     $data(sEnt) delete 0 end
  368.     $data(sEnt) insert 0 [file join $data(selectPath) $data(selectFile)]
  369.     $data(sEnt) xview end
  370. }
  371.  
  372. proc tkMotifFDialog_ActivateFList {w} {
  373.     upvar #0 $w data
  374.  
  375.     if ![string compare [$data(fList) curselection] ""] {
  376.     return
  377.     }
  378.     set data(selectFile) [$data(fList) get [$data(fList) curselection]]
  379.     if ![string compare $data(selectFile) ""] {
  380.     return
  381.     } else {
  382.     tkMotifFDialog_ActivateSEnt $w
  383.     }
  384. }
  385.  
  386. proc tkMotifFDialog_ActivateFEnt {w} {
  387.     upvar #0 $w data
  388.  
  389.     set list [tkMotifFDialog_InterpFilter $w]
  390.     set data(selectPath) [lindex $list 0]
  391.     set data(filter)    [lindex $list 1]
  392.  
  393.     tkMotifFDialog_Update $w
  394. }
  395.  
  396. proc tkMotifFDialog_InterpFilter {w} {
  397.     upvar #0 $w data
  398.  
  399.     set text [string trim [$data(fEnt) get]]
  400.     # Perform tilde substitution
  401.     #
  402.     if ![string compare [string index $text 0] ~] {
  403.     set list [file split $text]
  404.     set tilde [lindex $list 0]
  405.     catch {
  406.         set tilde [glob $tilde]
  407.     }
  408.     set text [eval file join [concat $tilde [lrange $list 1 end]]]
  409.     }
  410.  
  411.     set resolved [file join [file dirname $text] [file tail $text]]
  412.  
  413.     if [file isdirectory $resolved] {
  414.     set dir $resolved
  415.     set fil $data(filter)
  416.     } else {
  417.     set dir [file dirname $resolved]
  418.     set fil [file tail    $resolved]
  419.     }
  420.  
  421.     return [list $dir $fil]
  422. }
  423.  
  424.  
  425. proc tkMotifFDialog_ActivateSEnt {w} {
  426.     global tkPriv
  427.     upvar #0 $w data
  428.  
  429.     set selectFilePath [string trim [$data(sEnt) get]]
  430.     set selectFile     [file tail    $selectFilePath]
  431.     set selectPath     [file dirname $selectFilePath]
  432.  
  433.  
  434.     if {![string compare $selectFilePath ""]} {
  435.     tkMotifFDialog_FilterCmd $w
  436.     return
  437.     }
  438.  
  439.     if {[file isdirectory $selectFilePath]} {
  440.     set data(selectPath) [glob $selectFilePath]
  441.     set data(selectFile) ""
  442.     tkMotifFDialog_Update $w
  443.     return
  444.     }
  445.  
  446.     if [string compare [file pathtype $selectFilePath] "absolute"] {
  447.     tk_messageBox -icon warning -type ok \
  448.         -message "\"$selectFilePath\" must be an absolute pathname"
  449.     return
  450.     }
  451.  
  452.     if ![file exists $selectPath] {
  453.     tk_messageBox -icon warning -type ok \
  454.         -message "Directory \"$selectPath\" does not exist."
  455.     return
  456.     }
  457.  
  458.     if ![file exists $selectFilePath] {
  459.     if ![string compare $data(type) open] {
  460.         tk_messageBox -icon warning -type ok \
  461.         -message "File \"$selectFilePath\" does not exist."
  462.         return
  463.     }
  464.     } else {
  465.     if ![string compare $data(type) save] {
  466.         set message [format %s%s \
  467.         "File \"$selectFilePath\" already exists.\n\n" \
  468.         "Replace existing file?"]
  469.         set answer [tk_messageBox -icon warning -type yesno \
  470.         -message $message]
  471.         if ![string compare $answer "no"] {
  472.         return
  473.         }
  474.     }
  475.     }
  476.  
  477.     set tkPriv(selectFilePath) $selectFilePath
  478.     set tkPriv(selectFile)     $selectFile
  479.     set tkPriv(selectPath)     $selectPath
  480. }
  481.  
  482.  
  483. proc tkMotifFDialog_OkCmd {w} {
  484.     upvar #0 $w data
  485.  
  486.     tkMotifFDialog_ActivateSEnt $w
  487. }
  488.  
  489. proc tkMotifFDialog_FilterCmd {w} {
  490.     upvar #0 $w data
  491.  
  492.     tkMotifFDialog_ActivateFEnt $w
  493. }
  494.  
  495. proc tkMotifFDialog_CancelCmd {w} {
  496.     global tkPriv
  497.  
  498.     set tkPriv(selectFilePath) ""
  499.     set tkPriv(selectFile)     ""
  500.     set tkPriv(selectPath)     ""
  501. }
  502.  
  503. # tkMotifFDialog_Update
  504. #
  505. #    Load the files and synchronize the "filter" and "selection" fields
  506. #    boxes.
  507. #
  508. # popup:
  509. #    If this is true, then update the selection field according to the
  510. #    "-selection" flag
  511. #
  512. proc tkMotifFDialog_Update {w} {
  513.     upvar #0 $w data
  514.  
  515.     $data(fEnt) delete 0 end
  516.     $data(fEnt) insert 0 [file join $data(selectPath) $data(filter)]
  517.     $data(sEnt) delete 0 end
  518.     $data(sEnt) insert 0 [file join $data(selectPath) $data(selectFile)]
  519.  
  520.     tkMotifFDialog_LoadFiles $w
  521. }
  522.  
  523. proc tkMotifFDialog_LoadFiles {w} {
  524.     upvar #0 $w data
  525.  
  526.     $data(dList) delete 0 end
  527.     $data(fList) delete 0 end
  528.  
  529.     set appPWD [pwd]
  530.     if [catch {
  531.     cd $data(selectPath)
  532.     }] {
  533.     cd $appPWD
  534.  
  535.     $data(dList) insert end ".."
  536.     return
  537.     }
  538.  
  539.     # Make the dir list
  540.     #
  541.     foreach f [lsort -command tclSortNoCase [glob -nocomplain .* *]] {
  542.     if [file isdir $f] {
  543.         $data(dList) insert end $f
  544.     }
  545.     }
  546.     # Make the file list
  547.     #
  548.     if ![string compare $data(filter) *] {
  549.     set files [lsort -command tclSortNoCase [glob -nocomplain .* *]]
  550.     } else {
  551.     set files [lsort -command tclSortNoCase \
  552.         [glob -nocomplain $data(filter)]]
  553.     }
  554.  
  555.     set top 0
  556.     foreach f $files {
  557.     if ![file isdir $f] {
  558.         $data(fList) insert end $f
  559.         if [string match .* $f] {
  560.         incr top
  561.         }
  562.     }
  563.     }
  564.  
  565.     # The user probably doesn't want to see the . files. We adjust the view
  566.     # so that the listbox displays all the non-dot files
  567.     $data(fList) yview $top
  568.  
  569.     cd $appPWD
  570. }
  571.  
  572. proc tkListBoxKeyAccel_Set {w} {
  573.     bind Listbox <Any-KeyPress> ""
  574.     bind $w <Destroy> "tkListBoxKeyAccel_Unset $w"
  575.     bind $w <Any-KeyPress> "tkListBoxKeyAccel_Key $w %A"
  576. }
  577.  
  578. proc tkListBoxKeyAccel_Unset {w} {
  579.     global tkPriv
  580.  
  581.     catch {after cancel $tkPriv(lbAccel,$w,afterId)}
  582.     catch {unset tkPriv(lbAccel,$w)}
  583.     catch {unset tkPriv(lbAccel,$w,afterId)}
  584. }
  585.  
  586. proc tkListBoxKeyAccel_Key {w key} {
  587.     global tkPriv
  588.  
  589.     append tkPriv(lbAccel,$w) $key
  590.     tkListBoxKeyAccel_Goto $w $tkPriv(lbAccel,$w)
  591.     catch {
  592.     after cancel $tkPriv(lbAccel,$w,afterId)
  593.     }
  594.     set tkPriv(lbAccel,$w,afterId) [after 500 tkListBoxKeyAccel_Reset $w]
  595. }
  596.  
  597. proc tkListBoxKeyAccel_Goto {w string} {
  598.     global tkPriv
  599.  
  600.     set string [string tolower $string]
  601.     set end [$w index end]
  602.     set theIndex -1
  603.  
  604.     for {set i 0} {$i < $end} {incr i} {
  605.     set item [string tolower [$w get $i]]
  606.     if {[string compare $string $item] >= 0} {
  607.         set theIndex $i
  608.     }
  609.     if {[string compare $string $item] <= 0} {
  610.         set theIndex $i
  611.         break
  612.     }
  613.     }
  614.  
  615.     if {$theIndex >= 0} {
  616.     $w selection clear 0 end
  617.     $w selection set $theIndex $theIndex
  618.     $w activate $theIndex
  619.     $w see $theIndex
  620.     }
  621. }
  622.  
  623. proc tkListBoxKeyAccel_Reset {w} {
  624.     global tkPriv
  625.  
  626.     catch {unset tkPriv(lbAccel,$w)}
  627. }
  628.  
  629.