home *** CD-ROM | disk | FTP | other *** search
/ Chip: Linux Special / CorelLinux_CHIP.iso / live / usr / X11R6 / lib / X11 / cbb / bindings.tcl < prev    next >
Encoding:
Tcl/Tk script  |  1998-10-07  |  12.9 KB  |  463 lines
  1. #!/usr/bin/wish -f
  2. #  'CBB' -- Check Book Balancer
  3. #
  4. #   bindings.tcl -- common bindings
  5. #
  6. #  Written by Curtis Olson.  Started August 25, 1994.
  7. #
  8. #  Copyright (C) 1994 - 1997  Curtis L. Olson  - curt@sledge.mn.org
  9. #
  10. #  This program is free software; you can redistribute it and/or modify
  11. #  it under the terms of the GNU General Public License as published by
  12. #  the Free Software Foundation; either version 2 of the License, or
  13. #  (at your option) any later version.
  14. #
  15. #  This program is distributed in the hope that it will be useful,
  16. #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. #  GNU General Public License for more details.
  19. #
  20. #  You should have received a copy of the GNU General Public License
  21. #  along with this program; if not, write to the Free Software
  22. #  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  23. #
  24. # $Id: bindings.tcl,v 2.8 1997/01/02 04:38:30 curt Exp $
  25. # (Log is kept at end of this file)
  26.  
  27.  
  28. #------------------------------------------------------------------------------
  29. # Setup auto highlighting of entry fields
  30. #------------------------------------------------------------------------------
  31. proc setup_auto_hilite {} {
  32.     global cbb
  33.  
  34.     bind Entry <FocusIn> { 
  35.     set textvar [lindex [%W configure -textvariable] 4]
  36.         set value [subst $[subst $textvar]]
  37.     if { $cbb(debug) } { puts "$textvar = '$value'" }
  38.  
  39.     if { "$value" == "" } {
  40.         # do nothing, blank value
  41.     } else {
  42.         %W selection from 0
  43.         %W selection to end
  44.     }
  45.     }
  46.  
  47.     bind Entry <FocusOut> { 
  48.     %W selection clear
  49.     }
  50. }
  51.  
  52.  
  53. #------------------------------------------------------------------------------
  54. # Setup default field binding
  55. #------------------------------------------------------------------------------
  56.  
  57. proc setup_default_binding {} {
  58.     global cbb desc addcat
  59.  
  60.     set tabList { .entry.line1.check .entry.line1.date .entry.line1.desc \
  61.         .entry.line1.debit .entry.line1.credit .entry.line2.com \
  62.         .entry.line2.cat .entry.line1.clear }
  63.  
  64.     foreach field $tabList {
  65.         bind $field <Return> { done_entering }
  66.     }
  67.  
  68.  
  69.     # The following are duplicates from menu.tk where these things
  70.     # are bound to "all".  I am duplicating them here for the widgets
  71.     # that ignore "all" bindings.
  72.  
  73.     foreach field { .entry.line1.desc .entry.line2.cat } {
  74.     # <Tab> is handled individual to make tab completion possible
  75.     bind $field <Shift-Tab> {focus [tk_focusPrev %W]}
  76.  
  77.         bind $field <Meta-q> { cbbQuit }
  78.     bind $field <Alt-q> { cbbQuit }
  79.     bind $field <Meta-u> { undoAction }
  80.     bind $field <Alt-u> { undoAction }
  81.     bind $field <Meta-n> { clear_entry_area }
  82.     bind $field <Alt-n> { clear_entry_area }
  83.     bind $field <Meta-e> { 
  84.         if { [listGetCurTrans] >= 1 } {
  85.         update_entry_area [listGetCurTrans].0
  86.         }
  87.     }                                                  
  88.     bind $field <Alt-e> { 
  89.         if { [listGetCurTrans] >= 1 } {
  90.         update_entry_area [listGetCurTrans].0
  91.         }
  92.     }
  93.     bind $field <Meta-s> { 
  94.         cbbWindow.splits
  95.         tkwait window .splits
  96.     }
  97.     bind $field <Alt-s> { 
  98.         cbbWindow.splits
  99.         tkwait window .splits
  100.     }
  101.     bind $field <Meta-c> { cbbWindow.catwin }
  102.     bind $field <Alt-c> { cbbWindow.catwin }
  103.     }
  104.  
  105.     bind .entry.line1.desc <Control-Tab> {
  106.     set cbb(no_more_mem) 1
  107.     focus [tk_focusNext %W];
  108.     }
  109.  
  110.     bind .entry.line1.desc <Tab> {
  111.     if { [expr ($cbb(no_more_mem) == 0) && ($cbb(use_mems) == 1)] } { 
  112.         puts $eng "find_mem $desc"; flush $eng
  113.         gets $eng result
  114.         if { $cbb(debug) } { puts $result }
  115.         if { "$result" != "none" } {
  116.         if { [string range $result 0 13] == "partial_match:" } {
  117.             set desc [string range $result 14 end]
  118.                     .status.line configure -text "Partial completion:  '$desc'"
  119.         } else {
  120.             update_from_mem $result
  121.             set cbb(no_more_mem) 1
  122.                     .status.line configure -text "Unique description found."
  123.             focus [tk_focusNext %W];
  124.         }
  125.         tkEntrySetCursor %W end
  126.         } else {
  127.         focus [tk_focusNext %W];
  128.         }
  129.     } else {
  130.         focus [tk_focusNext %W];
  131.     }
  132.     }
  133.  
  134.     bind .entry.line2.cat <Tab> {
  135.     if { "[string range $cat 0 0]" != "|" } {
  136.         puts $eng "find_cat $cat"; flush $eng
  137.         gets $eng result
  138.         if { "$result" != "none" } {
  139.         if { $cbb(debug) } { puts $result }
  140.                 if { [string range $result 0 13] == "partial_match:" } {
  141.                     set cat [string range $result 14 end]             
  142.                     .status.line configure -text "Partial completion:  '$cat'"
  143.                 } else {              
  144.             set cat $result
  145.                     .status.line configure -text "Unique category found."
  146.             focus [tk_focusNext %W];
  147.                 }                                                
  148.         tkEntrySetCursor %W end
  149.         } elseif { "$cat" != "" } {
  150.         set addcat(cat) $cat
  151.         set addcat(mode) "missing"
  152.         cbbWindow.newcat
  153.         tkwait window .newcat
  154.         focus [tk_focusNext %W];
  155.         } else {
  156.         focus [tk_focusNext %W];
  157.         }
  158.     } else {
  159.         focus [tk_focusNext %W];
  160.     }
  161.     }
  162.  
  163.     bind . <Alt-Home> { goto 1 }
  164.     bind . <Meta-Home> { goto 1 }
  165.     bind . <Alt-End> { goto [expr [listGetSize] - 1] }
  166.     bind . <Meta-End> { goto [expr [listGetSize] - 1] }
  167.     bind . <Up> { goto [expr [listGetCurTrans] - 2] }
  168.     bind . <Down> { goto [expr [listGetCurTrans] + 2] }
  169.     bind . <Prior> { 
  170.     goto [expr [listGetCurTrans] - ($cbb(list_height) - 4)]
  171.     }
  172.     bind . <Next> { 
  173.     goto [expr [listGetCurTrans] + ($cbb(list_height) - 4)]
  174.     }
  175. }
  176.  
  177.  
  178. proc inc_check check {
  179.     global cbb
  180.  
  181.     if { "$check" == "" } {
  182.     set check $cbb(next_chk)
  183.     }
  184.  
  185.     .entry.line1.check icursor end
  186.  
  187.     return [expr int($check.) + 1]
  188. }
  189.  
  190.  
  191. proc dec_check check {
  192.     global cbb
  193.  
  194.     if { "$check" == "" } {
  195.     set check $cbb(next_chk)
  196.     }
  197.  
  198.     .entry.line1.check icursor end
  199.  
  200.     if { [expr $check > 1] } {
  201.         return [expr int($check.) - 1]
  202.     } else {
  203.         return 1
  204.     }
  205. }
  206.  
  207.  
  208. proc pad num {
  209.     if { "$num" == "" } {
  210.     set num 0
  211.     }
  212.     set num [expr int($num.)]
  213.     if { [expr $num >= 0 && $num <= 9] } {
  214.     return "0$num"
  215.     } else {
  216.     return $num
  217.     }
  218. }
  219.  
  220.  
  221. proc inc_date nicedate {
  222.     global cbb
  223.  
  224.     if { $cbb(date_fmt) == 1 } {
  225.     if { "$nicedate" == "" } {
  226.         set nicedate "01/01/01"
  227.     }
  228.  
  229.     set pieces [split $nicedate /]
  230.         set month [expr int([lindex $pieces 0].)]
  231.         set day [expr int([lindex $pieces 1].)]
  232.     } else {
  233.     if { "$nicedate" == "" } {
  234.         set nicedate "01.01.01"
  235.     }
  236.  
  237.     set pieces [split $nicedate .]
  238.         set day [expr int([lindex $pieces 0].)]
  239.         set month [expr int([lindex $pieces 1].)]
  240.     }
  241.  
  242.     set year [expr int([lindex $pieces 2].)]
  243.  
  244.     if { [string length $year] == 2 } {
  245.     set year "$cbb(century)$year"
  246.     }
  247.  
  248.     set day [incr day]
  249.  
  250.     # for the calculations of leap years, I have ignored the fact
  251.     # that 2000 is a leap year, but 2100, 2200 and 2300 are not.
  252.     # This holds true for any time that the century is/is not 
  253.     # divisible by four.  If you _have_ to have this coded in here, 
  254.     # please write Curtis, he will know how to get ahold of me.
  255.     # I will do it, if your need seems legit or funny enough.  -- Rob
  256.  
  257.     if {$day > 28} {                               
  258.     # only check for Feb.  ~ 4 times a month.
  259.         if {$month == 2} {
  260.         # it is Feb.
  261.             # if { { {expr $year fmod 4} == 0} || 
  262.         #      { {expr $year fmod 4} == 4} } {
  263.         # is leap year, or ends in 00
  264.         # if {$day == 29} {
  265.             #first time through
  266.                     # nop
  267.         # } else {
  268.             # Feb over 29 days?
  269.                     set day 1
  270.                     set month 3
  271.         # }
  272.         # }
  273.         } elseif {$day > 30} {
  274.             if {$month == 4 || $month == 6 || $month == 9 || $month == 11} {
  275.                 set day 1
  276.                 set month [incr month]
  277.             } elseif {$day > 31} {
  278.                 set day 1
  279.                 set month [incr month]
  280.             }
  281.         }
  282.     }
  283.                 
  284.     if {$month > 12} {
  285.     set month 1
  286.     set year [incr year]
  287.     }
  288.  
  289.     if {$year > 9999} {
  290.     set year 0
  291.     }
  292.  
  293.     if { $cbb(date_fmt) == 1 } {
  294.     if { [string length $year] == 4 } {
  295.         return "[pad $month]/[pad $day]/[string range [pad $year] 2 3]"
  296.     } else {
  297.         return "[pad $month]/[pad $day]/[pad $year]"
  298.     }
  299.     } else {
  300.     if { [string length $year] == 4 } {
  301.         return "[pad $day].[pad $month].[string range [pad $year] 2 3]"
  302.     } else {
  303.         return "[pad $day].[pad $month].[pad $year]"
  304.      }
  305.     }
  306. }
  307.  
  308.  
  309. proc dec_date nicedate {
  310.     global cbb
  311.  
  312.     if { $cbb(date_fmt) == 1 } {
  313.     if { "$nicedate" == "" } {
  314.         set nicedate "01/01/01"
  315.     }
  316.  
  317.     set pieces [split $nicedate /]
  318.         set month [expr int([lindex $pieces 0].)]
  319.         set day [expr int([lindex $pieces 1].)]
  320.     } else {
  321.     if { "$nicedate" == "" } {
  322.         set nicedate "01.01.01"
  323.     }
  324.  
  325.     set pieces [split $nicedate .]
  326.         set day [expr int([lindex $pieces 0].)]
  327.         set month [expr int([lindex $pieces 1].)]
  328.     }
  329.  
  330.     set year [expr int([lindex $pieces 2].)]
  331.  
  332.     if { [string length $year] == 2 } {
  333.     set year "$cbb(century)$year"
  334.     }
  335.  
  336.     set day [expr $day - 1]
  337.  
  338.     if {$day < 1} {
  339.         if {$month == 3} {
  340.             set day 28
  341.             # get the leap year stuff to 
  342.             # go in here.
  343.         } elseif {$month == 5 || $month == 7 || $month == 10 || $month == 12} {
  344.             set day 30
  345.         } elseif { $month == 1 || $month == 2 || $month == 4 || $month == 6 \
  346.                 || $month == 8 || $month == 9 || $month == 11} {
  347.             set day 31
  348.         }
  349.         set month [expr int($month - 1)]
  350.     }
  351.  
  352.     if {$month < 1} {
  353.         set month 12
  354.         set year [expr $year - 1]
  355.     }
  356.  
  357.     if {$year < 0} {
  358.     set year 9999
  359.     }
  360.  
  361.     if { $cbb(date_fmt) == 1 } {
  362.     if { [string length $year] == 4 } {
  363.         return "[pad $month]/[pad $day]/[string range [pad $year] 2 3]"
  364.     } else {
  365.         return "[pad $month]/[pad $day]/[pad $year]"
  366.     }
  367.     } else {
  368.     if { [string length $year] == 4 } {
  369.         return "[pad $day].[pad $month].[string range [pad $year] 2 3]"
  370.     } else {
  371.         return "[pad $day].[pad $month].[pad $year]"
  372.      }
  373.     }
  374. }
  375.  
  376.  
  377. # ----------------------------------------------------------------------------
  378. # $Log: bindings.tcl,v $
  379. # Revision 2.8  1997/01/02 04:38:30  curt
  380. # Changes over the 1996 holidays:
  381. #   - Converted listbox to text widget.  This allows us to do nice
  382. #     things with alternating background colors, highliting, red
  383. #     negative numbers, etc.
  384. #   - Negative transactions are now drawn in red.
  385. #   - Added a Goto <Today> option.
  386. #   - <Home> & <End> were double bound.  Now, listbox can be traversed with
  387. #     <Meta-Home> and <Meta-End>
  388. #
  389. # Revision 2.7  1996/12/17 14:53:51  curt
  390. # Updated copyright date.
  391. #
  392. # Revision 2.6  1996/12/16 04:18:11  curt
  393. # Continuing the great overhaul of December 1996.
  394. #
  395. # Revision 2.5  1996/12/14 17:15:19  curt
  396. # The great overhaul of December '96.
  397. #
  398. # Revision 2.4  1996/12/11 18:33:25  curt
  399. # Ran a spell checker.
  400. #
  401. # Revision 2.3  1996/12/09 14:36:56  curt
  402. # Fixed a couple of variables to be in the cbb() realm where they should be.
  403. #
  404. # Revision 2.2  1996/12/08 07:39:57  curt
  405. # Rearranged quite a bit of code.
  406. # Put most global variables in cbb() structure.
  407. #
  408. # Revision 2.1  1996/12/07 20:38:13  curt
  409. # Renamed *.tk -> *.tcl
  410. #
  411. # Revision 2.13  1996/11/07 20:30:25  curt
  412. # Fixed the <Control-Tab> binding for the description field (again ... oops :-)
  413. #
  414. # Revision 2.12  1996/10/22 19:43:15  curt
  415. # Rob and Heather got the inc_date and dec_date to work with months with
  416. # other than 31 days.  They will do the leap year stuff later.
  417. #
  418. # Revision 2.10  1996/10/02 19:37:16  curt
  419. # Replaced instances of hardcoded century (19) with a variable.  We need to
  420. # know the current century in cases where it is not provided and it is
  421. # assumed to be the current century.  Someday I need to figure out how
  422. # to determine the current century, but I have a couple of years to do it. :-)
  423. #
  424. # I still need to fix conf-reports and reports.pl
  425. #
  426. # Revision 2.9  1996/09/30 15:14:35  curt
  427. # Updated CBB URL, and hardwired wish path.
  428. #
  429. # Revision 2.8  1996/09/28 21:18:10  curt
  430. # Fixed a problem in the autohilite code that caused delete/backspace not
  431. # to work if you just tabbed to and started typing in a previously blank
  432. # field.  Also, previous selection is cleared when tabbing to a blank field.
  433. #
  434. # Revision 2.7  1996/09/26 19:53:35  curt
  435. # Worked on splits totals to automatically keep track of the difference.
  436. # Touch up tab completion.
  437. #
  438. # Revision 2.6  1996/09/25 17:45:42  curt
  439. # Revamped tab completions in description and category fields.
  440. # Fixed a problem with autohiliting.  When tabbing to a blank field, we used
  441. # to leave the previous hilited field hilited.
  442. #
  443. # Revision 2.5  1996/09/25 17:11:09  curt
  444. # Added some initial code to better handle tab completion.
  445. #
  446. # Revision 2.4  1996/08/29 14:31:50  curt
  447. # Removed unused bindings.  (tk3.6 support)
  448. #
  449. # Revision 2.3  1996/08/29 14:22:33  curt
  450. # <Meta-Tab> changed to <Control-Tab> in desc field.
  451. #
  452. # Revision 2.2  1996/07/13 02:57:33  curt
  453. # Version 0.65
  454. # Packing Changes
  455. # Documentation changes
  456. # Changes to handle a value in both debit and credit fields.
  457. #
  458. # Revision 2.1  1996/02/27  05:35:30  curt
  459. # Just stumbling around a bit with cvs ... :-(
  460. #
  461. # Revision 2.0  1996/02/27  04:41:45  curt
  462. # Initial 2.0 revision.  (See "Log" files for old history.)
  463.