1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161
|
#
# 'CBB' -- Check Book Balancer
#
# common.tcl -- commonly used tcl routines.
#
# Written by Curtis Olson. Started August 25, 1994.
#
# Copyright (C) 1994 - 1999 Curtis L. Olson - curt@me.umn.edu
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
# $Id: common.tcl,v 1.2 2000/01/02 19:08:02 curt Exp $
#------------------------------------------------------------------------------
# Ok message for general use
#------------------------------------------------------------------------------
proc cbbWindow.ok mesg {
global cbb
set w ".ok"
if {[winfo exists $w] == 1} {
destroy $w
}
option add *font $cbb(msg_text_font)
toplevel $w
wm title $w "Info / Warning"
wm iconname $w "Info / Warning"
frame $w.frame -borderwidth 2 -relief groove
message $w.frame.m -width 300 -text $mesg
button $w.frame.dismiss -text " Dismiss " -command "destroy $w" \
-font $cbb(button_font)
pack $w.frame -side top -fill both -expand 1 -padx 4 -pady 4
pack $w.frame.dismiss -side bottom -fill x -padx 6 -pady 6
pack $w.frame.m -side top -fill both -expand 1
}
#------------------------------------------------------------------------------
# Yes/No message for general use
# Second optional argument indicates the button which will get default
# focus (note you need to hit the space bar, not the enter key, to
# activate the button).
#------------------------------------------------------------------------------
proc cbbWindow.yesno { mesg {focus none} } {
global cbb yesno
set w ".yesno"
if "[winfo exists $w] == 1" {
destroy $w
}
option add *font $cbb(msg_text_font)
toplevel $w
wm title $w "Yes / No"
wm iconname $w "Yes / No"
frame $w.frame -borderwidth 2 -relief groove
message $w.frame.m -width 300 -text $mesg
frame $w.frame.btn -borderwidth 0
set old [focus]
button $w.frame.btn.yes -text " Yes " -font $cbb(button_font) \
-command "set yesno(result) yes; focus $old; destroy $w"
button $w.frame.btn.no -text " No " -font $cbb(button_font) \
-command "set yesno(result) no; focus $old; destroy $w"
button $w.frame.btn.maybe -text " Cancel " -font $cbb(button_font) \
-command "set yesno(result) cancel; focus $old; destroy $w"
pack $w.frame -side top -fill both -expand 1 -padx 4 -pady 4
pack $w.frame.btn -side bottom -fill x
pack $w.frame.btn.yes $w.frame.btn.no $w.frame.btn.maybe \
-side left -fill x -expand 1 -padx 8 -pady 8
pack $w.frame.m -side top -fill both -expand 1
if {$focus == "yes"} {
focus $w.frame.btn.yes
} elseif {$focus == "no"} {
focus $w.frame.btn.no
} elseif {$focus == "maybe"} {
focus $w.frame.btn.maybe
}
}
# use the system's pwd instead of builtin tcl-pwd, since the system's version
# seems to handle soft links better.
proc mypwd {} {
global env
# set pwdhandle [open |pwd r+]
# gets $pwdhandle pwd
# close $pwdhandle
#puts "[array names env PWD]"
if { "[array names env PWD]" == "" } {
#puts "Using pwd()"
return "[pwd]"
} else {
#puts "Using mypwd()"
return "$env(PWD)"
}
}
# get the current system date
proc get_sys_date {} {
set datehandle [open |date r+]
gets $datehandle now_today
close $datehandle
return $now_today
}
# convert date YYYYMMDD to nicedate format
proc date_to_nicedate date {
global cbb
if { [string length $date] == 6 } {
puts "invalid date in date_to_nicedate $date"
exit
set year "[string range $date 0 1]"
set month [string range $date 2 3]
set day [string range $date 4 5]
} else {
set year [string range $date 0 3]
set month [string range $date 4 5]
set day [string range $date 6 7]
}
if { $cbb(date_fmt) == 1 } {
set nicedate "$month/$day/$year"
} else {
set nicedate "$day.$month.$year"
}
}
|