File: common.tcl

package info (click to toggle)
cbb 1%3A0.8.1-1
  • links: PTS
  • area: main
  • in suites: slink
  • size: 1,864 kB
  • ctags: 551
  • sloc: tcl: 5,221; perl: 4,512; sh: 376; makefile: 152
file content (161 lines) | stat: -rw-r--r-- 4,552 bytes parent folder | download | duplicates (3)
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"
    }
}