home *** CD-ROM | disk | FTP | other *** search
/ Chip: Linux Special / CorelLinux_CHIP.iso / live / usr / X11R6 / lib / X11 / cbb / common.tcl < prev    next >
Encoding:
Tcl/Tk script  |  1998-10-07  |  4.5 KB  |  160 lines
  1. #!/usr/bin/wish -f
  2. #  'CBB' -- Check Book Balancer
  3. #
  4. #   common.tcl -- commonly used tcl routines.
  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: common.tcl,v 2.5 1996/12/17 14:53:54 curt Exp $
  25. # (Log is kept at end of this file)
  26.  
  27.  
  28. #------------------------------------------------------------------------------
  29. # Ok message for general use
  30. #------------------------------------------------------------------------------
  31.  
  32. proc cbbWindow.ok mesg {
  33.     global cbb
  34.  
  35.     set w ".ok"
  36.  
  37.     if {[winfo exists $w] == 1} {
  38.         destroy $w
  39.     }
  40.  
  41.     option add *font $cbb(msg_text_font)
  42.     
  43.     toplevel $w
  44.  
  45.     wm title $w "Info / Warning"
  46.     wm iconname $w "Info / Warning"
  47.     frame $w.frame -borderwidth 2 -relief groove
  48.  
  49.     message $w.frame.m -width 300 -text $mesg
  50.     button $w.frame.dismiss -text " Dismiss " -command "destroy $w" \
  51.         -font $cbb(button_font)
  52.  
  53.     pack $w.frame -side top -fill both -expand 1 -padx 4 -pady 4
  54.     pack $w.frame.dismiss -side bottom -fill x -padx 6 -pady 6
  55.     pack $w.frame.m -side top -fill both -expand 1
  56. }
  57.  
  58.  
  59. #------------------------------------------------------------------------------
  60. # Yes/No message for general use
  61. #------------------------------------------------------------------------------
  62.  
  63. proc cbbWindow.yesno { mesg } {
  64.     global cbb yesno
  65.  
  66.     set w ".yesno"
  67.  
  68.     if "[winfo exists $w] == 1" {
  69.         destroy $w
  70.     }
  71.  
  72.     option add *font $cbb(msg_text_font)
  73.     
  74.     toplevel $w
  75.  
  76.     wm title $w "Yes / No"
  77.     wm iconname $w "Yes / No"
  78.     frame $w.frame -borderwidth 2 -relief groove
  79.  
  80.     message $w.frame.m -width 300 -text $mesg
  81.     frame $w.frame.btn -borderwidth 0
  82.     button $w.frame.btn.yes -text " Yes " -font $cbb(button_font) \
  83.         -command "set yesno(result) yes; destroy $w"
  84.     button $w.frame.btn.no -text " No " -font $cbb(button_font) \
  85.         -command "set yesno(result) no; destroy $w"
  86.     button $w.frame.btn.maybe -text " Cancel " -font $cbb(button_font) \
  87.         -command "set yesno(result) cancel; destroy $w"
  88.  
  89.     pack $w.frame -side top -fill both -expand 1 -padx 4 -pady 4
  90.     pack $w.frame.btn -side bottom -fill x
  91.     pack $w.frame.btn.yes $w.frame.btn.no $w.frame.btn.maybe \
  92.     -side left -fill x -expand 1 -padx 8 -pady 8
  93.     pack $w.frame.m -side top -fill both -expand 1
  94. }
  95.  
  96.  
  97. # use the system's pwd instead of builtin tcl-pwd, since the system's version
  98. # seems to handle soft links better.
  99. proc mypwd {} {
  100.     global env
  101.  
  102.     # set pwdhandle [open |pwd r+]
  103.     # gets $pwdhandle pwd
  104.     # close $pwdhandle
  105.  
  106.     #puts "[array names env PWD]"
  107.  
  108.     if { "[array names env PWD]" == "" } {
  109.     #puts "Using pwd()"
  110.     return "[pwd]"
  111.     } else {
  112.     #puts "Using mypwd()"
  113.     return "$env(PWD)"
  114.     }
  115. }
  116.  
  117.  
  118. # get the current system date
  119. proc get_sys_date {} {
  120.     set datehandle [open |date r+]
  121.     gets $datehandle now_today
  122.     close $datehandle
  123.  
  124.     return $now_today
  125. }
  126.  
  127.  
  128. # ----------------------------------------------------------------------------
  129. # $Log: common.tcl,v $
  130. # Revision 2.5  1996/12/17 14:53:54  curt
  131. # Updated copyright date.
  132. #
  133. # Revision 2.4  1996/12/14 17:15:21  curt
  134. # The great overhaul of December '96.
  135. #
  136. # Revision 2.3  1996/12/11 18:33:31  curt
  137. # Ran a spell checker.
  138. #
  139. # Revision 2.2  1996/12/08 07:39:58  curt
  140. # Rearranged quite a bit of code.
  141. # Put most global variables in cbb() structure.
  142. #
  143. # Revision 2.1  1996/12/07 20:38:14  curt
  144. # Renamed *.tk -> *.tcl
  145. #
  146. # Revision 2.3  1996/09/30 15:14:36  curt
  147. # Updated CBB URL, and hardwired wish path.
  148. #
  149. # Revision 2.2  1996/07/13 02:57:39  curt
  150. # Version 0.65
  151. # Packing Changes
  152. # Documentation changes
  153. # Changes to handle a value in both debit and credit fields.
  154. #
  155. # Revision 2.1  1996/02/27  05:35:38  curt
  156. # Just stumbling around a bit with cvs ... :-(
  157. #
  158. # Revision 2.0  1996/02/27  04:41:50  curt
  159. # Initial 2.0 revision.  (See "Log" files for old history.)
  160.