home *** CD-ROM | disk | FTP | other *** search
/ Chip: Linux Special / CorelLinux_CHIP.iso / live / usr / X11R6 / lib / X11 / cbb / filebox.tcl < prev    next >
Encoding:
Tcl/Tk script  |  1998-10-07  |  10.8 KB  |  371 lines
  1. #!/usr/bin/wish -f
  2. #  'CBB' -- Check Book Balancer
  3. #
  4. # filebox.tcl -- file selection box (yanked out of tkispell) with
  5. #                minute modifications.  
  6. #
  7. # $Id: filebox.tcl,v 2.4 1996/12/17 14:53:57 curt Exp $
  8. # (Log is kept at end of this file)
  9.  
  10.  
  11. #-----------------------------------------------------------------------
  12. # File Selection Box
  13. #-----------------------------------------------------------------------
  14.  
  15. global ut_glob
  16.  
  17. # whether default is to show hidden files in fsbox
  18. if {![info exists ut_glob(hidden)]} {set ut_glob(hidden) 0}
  19. global ut_hidden; set ut_hidden $ut_glob(hidden)
  20.  
  21. # whether to make dialogs transient
  22. if {![info exists ut_glob(transient)]} {set ut_glob(transient) 1}
  23.  
  24. # possible prefix to Escape for cancels (needed by emacs users)
  25. if {![info exists ut_glob(cancel)]} {set ut_glob(cancel) ""}
  26.  
  27. # procedure to call to get key seq for special bindings
  28. if {![info exists ut_glob(key-hook)]} {set ut_glob(key-hook) ut:key-hook}
  29. proc ut:key-hook {k} {return <Meta-[string tolower $k]>}
  30.  
  31. ###############################################
  32. # BEGINNING OF FILESELECTOR PACKAGES
  33. #   hacked from code by Mario J. Silva
  34.  
  35. # Arguments:
  36. #   -prompt     a text string to prompt with
  37. #   -cancelvalue value to return if Cancel pressed
  38. #   -default     value to set as default
  39. #   -grab     whether to grab focus or not
  40. #   -callback    possible command to eval before event loop
  41. #         which will be given the fileselector toplevel
  42. #         as a first argument
  43. #   -cbargs     arguments to callback in addition to toplevel
  44. #   -master     name of toplevel to be transient to
  45. #   -title     title for fileselector toplevel
  46. #   -dir     startup directory
  47. #   -hidden     whether to show hidden directories
  48. #   -quick       pair list of label and directory for quick change
  49. #
  50. proc ut:fsbox { args } {
  51.   global env ut_fs ut_hidden ut_glob
  52.   
  53.  j:parse_args { \
  54.    {prompt "File: "} \
  55.    {default ""} \
  56.    {cancelvalue ""} \
  57.    {grab 0} \
  58.    {callback ""} \
  59.    {cbargs ""} \
  60.    {master ""} \
  61.    {title "Select File"} \
  62.    {dir ""} \
  63.    {hidden -1} \
  64.    {quick {}} }
  65.   
  66.   set w .utfsbox
  67.   if {[winfo exists $w]} {return $cancelvalue }
  68.   set ut_fs(result) $cancelvalue
  69.   if {$hidden < 0} { 
  70.     set hidden $ut_hidden 
  71.   } else { set ut_hidden $hidden }
  72.  
  73.   toplevel $w -class UTFSBox
  74.   wm protocol $w WM_DELETE_WINDOW "ut:fscancelcmd $w {$cancelvalue} $grab"
  75.   if {[string length $master]} { 
  76.     if $ut_glob(transient) {wm transient $w $master}
  77.     set xpos [expr [winfo rootx $master]+[winfo width $master]/3]
  78.     set ypos [expr [winfo rooty $master]+[winfo height $master]/3]
  79.     wm geometry $w +${xpos}+${ypos}
  80.   }
  81.   wm title $w $title
  82.   if {$grab != 0} {after 20 grab $w}
  83.  
  84.   # widgets
  85.   frame $w.file -bd 10 
  86.   frame $w.bframe -bd 10
  87.  
  88.   pack $w.bframe -side bottom
  89.   pack $w.file -side top -expand 1 -fill both
  90.  
  91.   frame $w.file.eframe
  92.   frame $w.file.sframe
  93.   frame $w.file.bframe
  94.  
  95.   if {[string length $dir] && [file isdirectory $dir]} {cd $dir}
  96.   set dir [pwd]
  97.   if {[string length $dir] > 32} {
  98.     set dir [join "... $dir" ""]
  99.     while {[string length $dir] > 32} {
  100.       set dir [string range $dir 4 end]
  101.       set dir [string range $dir [string first "/" $dir] end]
  102.       set dir [join "... $dir" ""]
  103.     }
  104.   }
  105.   label $w.file.dirlabel -width 32 -anchor w -text "Dir: $dir"
  106.  
  107.   pack $w.file.dirlabel -side top -fill x
  108.   pack $w.file.eframe -side top -fill x
  109.   pack $w.file.bframe -side bottom -fill x
  110.   pack $w.file.sframe -side top -expand 1 -fill both
  111.  
  112.   label $w.file.eframe.label -text "$prompt"
  113.   entry $w.file.eframe.entry -relief sunken \
  114.       -exportselection 0 
  115.   $w.file.eframe.entry insert 0 $default
  116.  
  117.   pack $w.file.eframe.label -side left
  118.   pack $w.file.eframe.entry -side left -pady 10 -expand true \
  119.       -fill x -ipady 3
  120.  
  121.  
  122.   scrollbar $w.file.sframe.yscroll -relief flat \
  123.       -command "$w.file.sframe.list yview"
  124.  
  125.   listbox $w.file.sframe.list -relief sunken \
  126.       -width 25 -height 10 \
  127.       -yscroll "$w.file.sframe.yscroll set" \
  128.       -exportselection 0
  129.  
  130.   pack $w.file.sframe.yscroll -side left -fill y
  131.   pack $w.file.sframe.list -expand 1 -fill both
  132.  
  133.   # buttons
  134.  
  135.   checkbutton $w.file.bframe.hide -text "hidden" -variable ut_hidden \
  136.       -relief raised -command "ut:fsfill $w.file.sframe.list \[pwd\]"
  137.  
  138.   button $w.file.bframe.home -text Home -relief raised \
  139.       -command "global env; ut:fsgo \$env(HOME) $w $grab"
  140.  
  141.   pack $w.file.bframe.hide -side left -expand 1 -fill x
  142.   pack $w.file.bframe.home -side left -expand 1 -fill x
  143.  
  144.   set cnt 0
  145.   foreach quickref $quick {
  146.     button $w.file.bframe.quick$cnt -text [lindex $quickref 0] \
  147.     -command "ut:fsgo [lindex $quickref 1] $w $grab" \
  148.     -relief raised
  149.     if {[regexp {[A-Z]} [lindex $quickref 0] char]} {
  150.       bind $w.file.eframe.entry [$ut_glob(key-hook) [string tolower $char]] \
  151.       "$w.file.bframe.quick$cnt invoke"
  152.     }
  153.     pack $w.file.bframe.quick$cnt -side left -expand 1 -fill x
  154.     incr cnt
  155.   }
  156.  
  157.   button $w.bframe.ok -text OK -relief raised  -width 10 \
  158.       -command "ut:fsokcmd $w $grab"
  159.  
  160.   button $w.bframe.cancel -text Cancel -relief raised -width 10 \
  161.       -command "ut:fscancelcmd $w {$cancelvalue} $grab"
  162.  
  163.   pack $w.bframe.ok -side left -padx 15
  164.   pack $w.bframe.cancel -side left -padx 15
  165.  
  166.   # Set up bindings for the browser.
  167.   bind $w.file.eframe.entry <Return> "$w.bframe.ok invoke"
  168.   bind $w.file.eframe.entry [$ut_glob(key-hook) o] "$w.bframe.ok invoke"
  169.   bind $w.file.eframe.entry <$ut_glob(cancel)Escape> "$w.bframe.cancel invoke"
  170.   bind $w.file.eframe.entry [$ut_glob(key-hook) c] "$w.bframe.cancel invoke"
  171.   bind $w.file.eframe.entry [$ut_glob(key-hook) h] "$w.file.bframe.home invoke"
  172.   bind $w.file.eframe.entry [$ut_glob(key-hook) period] "$w.file.bframe.hide invoke"
  173.  
  174.   bind $w.file.eframe.entry <Tab> {
  175.     set f [%W get]
  176.     %W delete 0 end
  177.     %W insert end [j:expand_filename $f]
  178.   }    
  179.   bind $w.file.eframe.entry <Up> {
  180.     set lw [winfo toplevel %W].file.sframe.list
  181.     if {![string length [set ndx [$lw curselection]]]} {set ndx 0}
  182.     incr ndx -1
  183.     ut:fsselect $lw $ndx
  184.     set ymax [$lw nearest [winfo height $lw]]
  185.     set ymin [$lw nearest 0]
  186.     if {$ndx > $ymax} {
  187.       $lw yview [expr $ndx-$ymax+$ymin]
  188.     } elseif {$ndx < $ymin}  {
  189.       $lw yview $ndx
  190.     }
  191.   }
  192.   bind $w.file.eframe.entry <Down> {
  193.     set lw [winfo toplevel %W].file.sframe.list
  194.     if {![string length [set ndx [$lw curselection]]]} {set ndx 0}
  195.     incr ndx 1
  196.     ut:fsselect $lw $ndx
  197.     set ymax [$lw nearest [winfo height $lw]]
  198.     set ymin [$lw nearest 0]
  199.     if {$ndx > $ymax} {
  200.       $lw yview [expr $ndx-$ymax+$ymin]
  201.     } elseif {$ndx < $ymin}  {
  202.       $lw yview $ndx
  203.     }
  204.   }
  205.  
  206.   bind $w.file.sframe.list <Button-1> "ut:fsselect %W \[%W nearest %y\]"
  207.  
  208.   bind $w.file.sframe.list <Key> "ut:fsselect %W \[%W nearest %y\]"
  209.  
  210.   bind $w.file.sframe.list <B1-Motion> " "
  211.  
  212.   bind $w.file.sframe.list <Double-Button-1> "eval $w.bframe.ok invoke"
  213.  
  214.   bind $w.file.sframe.list <Return> \
  215.       "ut:fsselect %W \[%W nearest %y\]; eval $w.bframe.ok invoke"
  216.  
  217.   ut:fsfill $w.file.sframe.list [pwd]
  218.   if {[string length $callback]} {eval "$callback $w $cbargs"}
  219.  
  220.   set savefocus [focus]
  221.   focus $w.file.eframe.entry
  222.   tkwait window $w
  223.   focus $savefocus
  224.   if {$ut_fs(result) == $cancelvalue} {return $cancelvalue}
  225.   if {[file isdirectory [set dir [file dirname $ut_fs(result)]]]} {
  226.     cd $dir
  227.     return [pwd]/[file tail $ut_fs(result)]
  228.   } else {
  229.     return [pwd]/$ut_fs(result)
  230.   }
  231. }
  232.  
  233. proc ut:fsgo {dir w grab} {
  234.   $w.file.eframe.entry delete 0 end
  235.   $w.file.eframe.entry insert 0 "$dir/"
  236.   eval "ut:fsokcmd $w $grab"
  237. }
  238.  
  239. proc ut:fsselect {W ndx} {
  240.   set B_entry [winfo toplevel $W].file.eframe.entry
  241.   $W select anchor $ndx
  242.   $B_entry delete 0 end
  243.   $B_entry insert 0 [$W get $ndx]
  244. }
  245.  
  246. proc ut:fsokcmd {w grab} {
  247.   global ut_fs env
  248.  
  249.   set selected [$w.file.eframe.entry get]
  250.   set ndx [expr [string length $selected]-1]
  251.   if {[string index $selected $ndx] == "/"} {
  252.     set selected [string range $selected 0 [expr $ndx-1]]
  253.   }
  254.   $w.file.eframe.entry delete 0 end
  255.   if {![string length $selected]} {return}
  256.   
  257.   if {![catch {set res [glob $selected]}]} {
  258.     set selected $res
  259.   }
  260.  
  261.   if {[file isdirectory $selected] != 0} {
  262.     cd $selected
  263.     set dir [pwd]
  264.     if {[string length $dir] > 32} {
  265.       set dir [join "... $dir" ""]
  266.       while {[string length $dir] > 32} {
  267.     set dir [string range $dir 4 end]
  268.     set dir [string range $dir [string first "/" $dir] end]
  269.     set dir [join "... $dir" ""]
  270.       }
  271.     }
  272.     $w.file.dirlabel configure -text "Dir: $dir"
  273.     ut:fsfill $w.file.sframe.list [pwd]
  274.     return
  275.   }
  276.   if {$grab != 0} {grab release $w}
  277.   set ut_fs(result) $selected
  278.   after idle destroy $w
  279. }
  280.  
  281. proc ut:fscancelcmd {w cancelvalue grab} {
  282.   global ut_fs
  283.  
  284.   if {$grab != 0} {grab release $w}
  285.   set ut_fs(result) $cancelvalue
  286.   destroy $w
  287. }
  288.  
  289. proc ut:fsfill {fslist dir} {
  290.   global ut_hidden
  291.  
  292.   if {$ut_hidden} { 
  293.     set opt "-a"
  294.     set dirlist ""
  295.   } else { 
  296.     set opt "" 
  297.     set dirlist ".."
  298.   }
  299.   $fslist delete 0 end
  300.   foreach i [split [eval "exec ls $opt $dir"] \n] {
  301.     if {[string compare $i "."] != 0} {
  302.       if {[file isdirectory $i]} {
  303.     set dirlist [linsert $dirlist 0 $i]
  304.       } else {
  305.     $fslist insert end $i
  306.       }
  307.     }
  308.   }
  309.   foreach i $dirlist {
  310.     $fslist insert 0 "$i/"
  311.   }
  312. }
  313.  
  314.  
  315. ######################################################################
  316. # j:parse_args arglist - parse arglist in parent procedure
  317. #   arglist is a list of option names (without leading "-");
  318. # this proc puts their values (if any) into variables (named after
  319. #   the option name) in d parent procedure
  320. # any element of arglist can also be a list consisting of an option
  321. #   name and a default value.
  322. ######################################################################
  323. proc j:parse_args {arglist} {
  324.   upvar args args
  325.  
  326.   foreach pair $arglist {
  327.     set option [lindex $pair 0]
  328.     set default [lindex $pair 1]        ;# will be null if not supplied
  329.     set index [lsearch -exact $args "-$option"]
  330.     if {$index != -1} {
  331.       set index1 [expr {$index + 1}]
  332.       set value [lindex $args $index1]
  333.       uplevel 1 [list set $option $value]    ;# caller's variable "$option"
  334.       set args [lreplace $args $index $index1]
  335.     } else {
  336.       uplevel 1 [list set $option $default]    ;# caller's variable "$option"
  337.     }
  338.   }
  339. }
  340.  
  341.  
  342. # ----------------------------------------------------------------------------
  343. # $Log: filebox.tcl,v $
  344. # Revision 2.4  1996/12/17 14:53:57  curt
  345. # Updated copyright date.
  346. #
  347. # Revision 2.3  1996/12/11 18:33:37  curt
  348. # Ran a spell checker.
  349. #
  350. # Revision 2.2  1996/12/08 07:39:59  curt
  351. # Rearranged quite a bit of code.
  352. # Put most global variables in cbb() structure.
  353. #
  354. # Revision 2.1  1996/12/07 20:38:15  curt
  355. # Renamed *.tk -> *.tcl
  356. #
  357. # Revision 2.3  1996/09/30 15:14:37  curt
  358. # Updated CBB URL, and hardwired wish path.
  359. #
  360. # Revision 2.2  1996/07/13 02:57:46  curt
  361. # Version 0.65
  362. # Packing Changes
  363. # Documentation changes
  364. # Changes to handle a value in both debit and credit fields.
  365. #
  366. # Revision 2.1  1996/02/27  05:35:44  curt
  367. # Just stumbling around a bit with cvs ... :-(
  368. #
  369. # Revision 2.0  1996/02/27  04:42:58  curt
  370. # Initial 2.0 revision.  (See "Log" files for old history.)
  371.