|
a/sqlscreens.tcl |
|
b/sqlscreens.tcl |
|
... |
|
... |
64 |
#### Printing statements that are executed
|
64 |
#### Printing statements that are executed
|
65 |
|
65 |
|
66 |
proc _sqlsclogstmt {txt} {
|
66 |
proc _sqlsclogstmt {txt} {
|
67 |
global sqlscshowstmts sqlsccurstmt
|
67 |
global sqlscshowstmts sqlsccurstmt
|
68 |
if {$sqlscshowstmts != 0} {
|
68 |
if {$sqlscshowstmts != 0} {
|
69 |
set sqlsccurstmt $txt
|
69 |
set sqlsccurstmt $txt
|
70 |
}
|
70 |
}
|
71 |
}
|
71 |
}
|
72 |
proc _sqlsclogcommit {} {
|
72 |
proc _sqlsclogcommit {} {
|
73 |
global sqlscshowstmts sqlsccurstmt sqlsclog
|
73 |
global sqlscshowstmts sqlsccurstmt sqlsclog
|
74 |
if {$sqlscshowstmts != 0} {
|
74 |
if {$sqlscshowstmts != 0} {
|
75 |
puts $sqlsclog "-- [clock format [clock seconds]]\n$sqlsccurstmt"
|
75 |
puts $sqlsclog "-- [clock format [clock seconds]]\n$sqlsccurstmt"
|
76 |
flush $sqlsclog
|
76 |
flush $sqlsclog
|
77 |
}
|
77 |
}
|
78 |
}
|
78 |
}
|
79 |
##################################################
|
79 |
##################################################
|
80 |
# Small window utilities
|
80 |
# Small window utilities
|
81 |
#####################
|
81 |
#####################
|
|
|
82 |
## Check that entry doesn't become longer than allowed width
|
|
|
83 |
# This is a standard tcl entry validation proc. See the entry widget man page
|
|
|
84 |
# txt is the value after entry and w the max length
|
|
|
85 |
proc _sqlscentryvalidate {txt w} {
|
|
|
86 |
#puts stderr "_sqlscentryvalidate: $txt. maxlen $w"
|
|
|
87 |
if {[string length $txt] > $w} {
|
|
|
88 |
return 0
|
|
|
89 |
}
|
|
|
90 |
return 1
|
|
|
91 |
}
|
|
|
92 |
|
82 |
# Create a labeled entry widget with emacs-like bindings
|
93 |
# Create a labeled entry widget with emacs-like bindings
|
83 |
proc _sqlsclabentry {name labtext labwidth entryvar \
|
94 |
proc _sqlsclabentry {name labtext labwidth entryvar entrywidth \
|
84 |
entrywidth {entryfillx 0}} {
|
95 |
{entryfillx 0} {maxlen 0}} {
|
85 |
global tk_version
|
96 |
global tk_version
|
86 |
set f [frame ${name} -relief groove -borderwidth 0]
|
97 |
set f [frame ${name} -relief groove -borderwidth 0]
|
87 |
label $f.lab -text "$labtext" -width $labwidth -anchor e
|
98 |
label $f.lab -text "$labtext" -width $labwidth -anchor e
|
88 |
entry $f.ent -width $entrywidth -textvariable $entryvar \
|
99 |
set ecmd [list entry $f.ent -width $entrywidth -textvariable $entryvar \
|
89 |
-relief sunken -borderwidth 1
|
100 |
-relief sunken -borderwidth 1 ]
|
|
|
101 |
if {$maxlen > 0 && $tk_version >= 8.3} {
|
|
|
102 |
lappend ecmd -invcmd bell -validate key \
|
|
|
103 |
-vcmd "_sqlscentryvalidate %P $maxlen"
|
|
|
104 |
}
|
|
|
105 |
|
|
|
106 |
eval $ecmd
|
|
|
107 |
|
90 |
if {$tk_version < 4.0} {
|
108 |
if {$tk_version < 4.0} {
|
91 |
entryemacsbind $f.ent
|
109 |
entryemacsbind $f.ent
|
92 |
}
|
110 |
}
|
93 |
pack $f.lab -side left -ipadx 1 -ipady 1
|
111 |
pack $f.lab -side left -ipadx 1 -ipady 1
|
94 |
if {$entryfillx} {
|
112 |
if {$entryfillx} {
|
95 |
pack $f.ent -side left -ipadx 1 -ipady 1 -expand 1 -fill x
|
113 |
pack $f.ent -side left -ipadx 1 -ipady 1 -expand 1 -fill x
|
96 |
} else {
|
114 |
} else {
|
97 |
pack $f.ent -side left -ipadx 1 -ipady 1
|
115 |
pack $f.ent -side left -ipadx 1 -ipady 1
|
98 |
}
|
116 |
}
|
99 |
return $f
|
117 |
return $f
|
100 |
}
|
118 |
}
|
101 |
|
119 |
|
102 |
#####################
|
120 |
#####################
|
|
... |
|
... |
110 |
-relief groove -borderwidth 2 -padx 4
|
128 |
-relief groove -borderwidth 2 -padx 4
|
111 |
pack $f.lab $f.ent -side left -ipadx 1 -ipady 1
|
129 |
pack $f.lab $f.ent -side left -ipadx 1 -ipady 1
|
112 |
return $f
|
130 |
return $f
|
113 |
}
|
131 |
}
|
114 |
|
132 |
|
|
|
133 |
#####################
|
|
|
134 |
# Labelled text window
|
|
|
135 |
proc _sqlsclabtext { name labtext labwidth ew eh opt } {
|
|
|
136 |
set f [frame ${name}]
|
|
|
137 |
label $f.lab -text "$labtext" -width $labwidth -anchor e
|
|
|
138 |
text $f.ent -width $ew -height $eh
|
|
|
139 |
if {[string first $opt t] != -1 } {
|
|
|
140 |
pack $f.lab $f.ent -side top -ipadx 1 -ipady 1
|
|
|
141 |
} elseif {[string first $opt l] != -1 } {
|
|
|
142 |
pack $f.lab $f.ent -side left -ipadx 1 -ipady 1
|
|
|
143 |
} else {
|
|
|
144 |
pack $f.ent -side left -ipadx 1 -ipady 1
|
|
|
145 |
}
|
|
|
146 |
return $f
|
|
|
147 |
}
|
|
|
148 |
|
115 |
###################################################################
|
149 |
###################################################################
|
116 |
# Same idea as _sqlsclabentry and _sqlsclablabel, except that the value
|
150 |
# Same idea as _sqlsclabentry and _sqlsclablabel, except that the value
|
117 |
# comes from a list. The choice list can be made of single element (value
|
151 |
# comes from a list. The choice list can be made of single element (value
|
118 |
# same as labels), or made of {text, value} pairs There is some complicated
|
152 |
# same as labels), or made of {text, value} pairs There is some complicated
|
119 |
# stuff done to update the visible label when the variable's value changes
|
153 |
# stuff done to update the visible label when the variable's value changes
|
120 |
# other than through a menu choice
|
154 |
# other than through a menu choice
|
121 |
# Note: this is much like a tk_optMenu, with the provision to separate the
|
155 |
# Note: this is much like a tk_optMenu, with the provision to separate the
|
122 |
# actual values and the displayed strings.
|
156 |
# actual values and the displayed strings.
|
123 |
proc _sqlsclabmenu {name labtext labwidth varname butwidth choicelist} {
|
157 |
proc _sqlsclabmenu {name labtext labwidth varname butwidth choicelist} {
|
124 |
# puts "_sqlsclabmenu: name $name, labtext $labtext, labwidth $labwidth,\
|
158 |
# puts "_sqlsclabmenu: name $name, labtext $labtext, labwidth $labwidth,\
|
125 |
#varname $varname, butwidth $butwidth, choicelist $choicelist"
|
159 |
#varname $varname, butwidth $butwidth, choicelist $choicelist"
|
126 |
set f [frame $name]
|
160 |
set f [frame $name]
|
127 |
label $f.lab -text $labtext -width $labwidth -anchor e
|
161 |
label $f.lab -text $labtext -width $labwidth -anchor e
|
128 |
menubutton $f.b -menu $f.b.m -width $butwidth -relief raised
|
162 |
menubutton $f.b -menu $f.b.m -width $butwidth -relief raised
|
129 |
menu $f.b.m
|
163 |
menu $f.b.m
|
130 |
foreach choice $choicelist {
|
164 |
foreach choice $choicelist {
|
131 |
set label [lindex $choice 0]
|
165 |
set label [lindex $choice 0]
|
132 |
set value $label
|
166 |
set value $label
|
133 |
if {[llength $choice] == 2} {
|
167 |
if {[llength $choice] == 2} {
|
134 |
set value [lindex $choice 1]
|
168 |
set value [lindex $choice 1]
|
135 |
}
|
169 |
}
|
136 |
# No need to use a command to set the menubutton's label
|
170 |
# No need to use a command to set the menubutton's label
|
137 |
# because this is done through tracing the variable (see after)
|
171 |
# because this is done through tracing the variable (see after)
|
138 |
$f.b.m add radiobutton -variable $varname -label $label \
|
172 |
$f.b.m add radiobutton -variable $varname -label $label \
|
139 |
-value $value
|
173 |
-value $value
|
140 |
}
|
174 |
}
|
141 |
|
175 |
|
142 |
# Create a proc to update the label when the variable's value changes
|
176 |
# Create a proc to update the label when the variable's value changes
|
143 |
set s {proc _sqlsclabmenutrace%s {name element op} {
|
177 |
set s {proc _sqlsclabmenutrace%s {name element op} {
|
144 |
set currentvalue [string trim [uplevel #0 set %s]]
|
178 |
set currentvalue [string trim [uplevel #0 set %s]]
|
145 |
foreach elt {%s} {
|
179 |
foreach elt {%s} {
|
146 |
if {$currentvalue == [lindex $elt end]} {
|
180 |
if {$currentvalue == [lindex $elt end]} {
|
147 |
%s.b configure -text [lindex $elt 0]
|
181 |
%s.b configure -text [lindex $elt 0]
|
148 |
return
|
182 |
return
|
149 |
}
|
183 |
}
|
150 |
}
|
184 |
}
|
151 |
%s.b configure -text {}
|
185 |
%s.b configure -text {}
|
152 |
}
|
186 |
}
|
153 |
}
|
187 |
}
|
154 |
set ps [format $s $f $varname $choicelist $f $f]
|
188 |
set ps [format $s $f $varname $choicelist $f $f]
|
155 |
#puts $ps
|
189 |
#puts $ps
|
156 |
eval $ps
|
190 |
eval $ps
|
157 |
uplevel #0 trace variable $varname w _sqlsclabmenutrace$f
|
191 |
uplevel #0 trace variable $varname w _sqlsclabmenutrace$f
|
|
... |
|
... |
164 |
# Change value to uppercase if column is in the upshift list
|
198 |
# Change value to uppercase if column is in the upshift list
|
165 |
proc _sqlscmaybetoupper {arnm col value} {
|
199 |
proc _sqlscmaybetoupper {arnm col value} {
|
166 |
upvar $arnm ar
|
200 |
upvar $arnm ar
|
167 |
# puts "_sqlscmaybetoupper: arnm: $arnm, col: $col, value: $value"
|
201 |
# puts "_sqlscmaybetoupper: arnm: $arnm, col: $col, value: $value"
|
168 |
if {[info exists ar(upshiftcols)] && \
|
202 |
if {[info exists ar(upshiftcols)] && \
|
169 |
[lsearch $ar(upshiftcols) $col ] != -1} {
|
203 |
[lsearch $ar(upshiftcols) $col ] != -1} {
|
170 |
return [string toupper $value]
|
204 |
return [string toupper $value]
|
171 |
}
|
205 |
}
|
172 |
return $value
|
206 |
return $value
|
173 |
}
|
207 |
}
|
174 |
|
208 |
|
175 |
#######################################################
|
209 |
#######################################################
|
|
... |
|
... |
191 |
upvar $arnm ar
|
225 |
upvar $arnm ar
|
192 |
|
226 |
|
193 |
# Special case for designated texts which have already been quoted
|
227 |
# Special case for designated texts which have already been quoted
|
194 |
# by sqlsctextstocols, we just add the external ''
|
228 |
# by sqlsctextstocols, we just add the external ''
|
195 |
if {[_sqlsccolattr ar $col textcols]} {
|
229 |
if {[_sqlsccolattr ar $col textcols]} {
|
196 |
return '$value'
|
230 |
return '$value'
|
197 |
}
|
231 |
}
|
198 |
|
232 |
|
199 |
# 'a' stuff to avoid 'integer too big' errors
|
233 |
# 'a' stuff to avoid 'integer too big' errors
|
200 |
if {"a$value" == "a" } {
|
234 |
if {"a$value" == "a" } {
|
201 |
if {$coltype == "char"} {
|
235 |
if {$coltype == "char"} {
|
202 |
if {$setarvalue == 1} {
|
236 |
if {$setarvalue == 1} {
|
203 |
set ar(sqlsc_${col}_value) $value
|
237 |
set ar(sqlsc_${col}_value) $value
|
|
|
238 |
}
|
|
|
239 |
set txt ''
|
|
|
240 |
} else {
|
|
|
241 |
set txt "null"
|
204 |
}
|
242 |
}
|
205 |
set txt ''
|
|
|
206 |
} else {
|
|
|
207 |
set txt "null"
|
|
|
208 |
}
|
|
|
209 |
return $txt
|
243 |
return $txt
|
210 |
}
|
244 |
}
|
211 |
|
245 |
|
212 |
switch $coltype {
|
246 |
switch $coltype {
|
213 |
char {
|
247 |
char {
|
214 |
set value [_sqlscmaybetoupper $arnm $col $value]
|
248 |
set value [_sqlscmaybetoupper $arnm $col $value]
|
215 |
if {$setarvalue == 1} {
|
249 |
if {$setarvalue == 1} {
|
216 |
set ar(sqlsc_${col}_value) $value
|
250 |
set ar(sqlsc_${col}_value) $value
|
217 |
}
|
251 |
}
|
218 |
|
252 |
|
219 |
set txt '[tcsqquotequote $value]'
|
253 |
set txt '[tcsqquotequote $value]'
|
220 |
}
|
254 |
}
|
221 |
date -
|
255 |
date -
|
222 |
timestamp -
|
256 |
timestamp -
|
223 |
datetime {
|
257 |
datetime {
|
224 |
set txt '[tcsqquotequote $value]'
|
258 |
set txt '[tcsqquotequote $value]'
|
225 |
}
|
259 |
}
|
226 |
money {
|
260 |
money {
|
227 |
set txt [_sqlscstripmoney $value]
|
261 |
set txt [_sqlscstripmoney $value]
|
228 |
}
|
262 |
}
|
229 |
default {
|
263 |
default {
|
230 |
set txt $value
|
264 |
set txt $value
|
231 |
}
|
265 |
}
|
232 |
}
|
266 |
}
|
233 |
return $txt
|
267 |
return $txt
|
234 |
}
|
268 |
}
|
235 |
|
269 |
|
|
... |
|
... |
241 |
upvar $arnm ar
|
275 |
upvar $arnm ar
|
242 |
|
276 |
|
243 |
set txt "select"
|
277 |
set txt "select"
|
244 |
# column list
|
278 |
# column list
|
245 |
foreach arg $ar(columns) {
|
279 |
foreach arg $ar(columns) {
|
246 |
append txt " $arg,"
|
280 |
append txt " $arg,"
|
247 |
}
|
281 |
}
|
248 |
set txt [string trimright $txt ", "]
|
282 |
set txt [string trimright $txt ", "]
|
249 |
|
283 |
|
250 |
# Tables
|
284 |
# Tables
|
251 |
append txt " from "
|
285 |
append txt " from "
|
252 |
foreach table $ar(table) {
|
286 |
foreach table $ar(table) {
|
253 |
append txt " $table,"
|
287 |
append txt " $table,"
|
254 |
}
|
288 |
}
|
255 |
set txt [string trimright $txt ", "]
|
289 |
set txt [string trimright $txt ", "]
|
256 |
|
290 |
|
257 |
# Import the text fields into the column variables
|
291 |
# Import the text fields into the column variables
|
258 |
_sqlsctextstocols ar
|
292 |
_sqlsctextstocols ar
|
259 |
|
293 |
|
260 |
# Where clause: use all fields that are set.
|
294 |
# Where clause: use all fields that are set.
|
261 |
set wheredone 0
|
295 |
set wheredone 0
|
262 |
foreach col $ar(columns) {
|
296 |
foreach col $ar(columns) {
|
263 |
set value [string trim $ar(sqlsc_${col}_value)]
|
297 |
set value [string trim $ar(sqlsc_${col}_value)]
|
264 |
if {"a$value" == "a"} continue
|
298 |
if {"a$value" == "a"} continue
|
265 |
|
299 |
|
266 |
if {$wheredone == 0} {
|
300 |
if {$wheredone == 0} {
|
267 |
append txt " where "
|
301 |
append txt " where "
|
268 |
set wheredone 1
|
302 |
set wheredone 1
|
269 |
} else {
|
303 |
} else {
|
270 |
append txt " and "
|
304 |
append txt " and "
|
271 |
}
|
305 |
}
|
272 |
set ntxt [_sqlscprepvalue $arnm $col $ar(sqlsc_${col}_type) $value]
|
306 |
set ntxt [_sqlscprepvalue $arnm $col $ar(sqlsc_${col}_type) $value]
|
273 |
if {[_sqlsccolattr ar $col textcols]} {
|
307 |
if {[_sqlsccolattr ar $col textcols]} {
|
274 |
append txt " $col like $ntxt"
|
308 |
append txt " $col like $ntxt"
|
275 |
continue
|
309 |
continue
|
276 |
}
|
310 |
}
|
277 |
switch $ar(sqlsc_${col}_type) {
|
311 |
switch $ar(sqlsc_${col}_type) {
|
278 |
char {append txt " $col like $ntxt"}
|
312 |
char {append txt " $col like $ntxt"}
|
279 |
default {
|
313 |
default {
|
280 |
if {[regexp {[<>=].*} $ntxt] == 1} {
|
314 |
if {[regexp {[<>=].*} $ntxt] == 1} {
|
281 |
append txt " $col $ntxt"
|
315 |
append txt " $col $ntxt"
|
282 |
} else {
|
316 |
} else {
|
283 |
append txt " $col = $ntxt"
|
317 |
append txt " $col = $ntxt"
|
284 |
}
|
318 |
}
|
|
|
319 |
}
|
285 |
}
|
320 |
}
|
286 |
}
|
|
|
287 |
}
|
321 |
}
|
288 |
if {[info exists ar(joinclause)]} {
|
322 |
if {[info exists ar(joinclause)]} {
|
289 |
if {$wheredone == 1} {
|
323 |
if {$wheredone == 1} {
|
290 |
append txt " and $ar(joinclause) "
|
324 |
append txt " and $ar(joinclause) "
|
291 |
} else {
|
325 |
} else {
|
292 |
append txt " where $ar(joinclause) "
|
326 |
append txt " where $ar(joinclause) "
|
293 |
}
|
327 |
}
|
294 |
}
|
328 |
}
|
295 |
if {[info exists ar(ordercols)] && [string trim $ar(ordercols)] != ""} {
|
329 |
if {[info exists ar(ordercols)] && [string trim $ar(ordercols)] != ""} {
|
296 |
append txt " order by $ar(ordercols)"
|
330 |
append txt " order by $ar(ordercols)"
|
297 |
}
|
331 |
}
|
298 |
return $txt
|
332 |
return $txt
|
299 |
}
|
333 |
}
|
300 |
|
334 |
|
301 |
###################################################################
|
335 |
###################################################################
|
|
... |
|
... |
309 |
# insist on having a where clause !. Will cause a syntax error if
|
343 |
# insist on having a where clause !. Will cause a syntax error if
|
310 |
# no value is set, which is better than emptying the table
|
344 |
# no value is set, which is better than emptying the table
|
311 |
set txt "from $ar(table) where "
|
345 |
set txt "from $ar(table) where "
|
312 |
set first 1
|
346 |
set first 1
|
313 |
foreach col $ar(columns) {
|
347 |
foreach col $ar(columns) {
|
314 |
set value [string trim $ar(sqlsc_${col}_value)]
|
348 |
set value [string trim $ar(sqlsc_${col}_value)]
|
315 |
if {"a$value" == "a"} {
|
349 |
if {"a$value" == "a"} {
|
316 |
continue
|
350 |
continue
|
317 |
}
|
351 |
}
|
318 |
if {$first == 1} {
|
352 |
if {$first == 1} {
|
319 |
set first 0
|
353 |
set first 0
|
320 |
} else {
|
354 |
} else {
|
321 |
append txt " and "
|
355 |
append txt " and "
|
322 |
}
|
356 |
}
|
323 |
append txt \
|
357 |
append txt \
|
324 |
" $col = [_sqlscprepvalue $arnm $col $ar(sqlsc_${col}_type) $value]"
|
358 |
" $col = [_sqlscprepvalue $arnm $col $ar(sqlsc_${col}_type) $value]"
|
325 |
}
|
359 |
}
|
326 |
return $txt
|
360 |
return $txt
|
327 |
}
|
361 |
}
|
328 |
|
362 |
|
329 |
###################################################################
|
363 |
###################################################################
|
|
... |
|
... |
336 |
|
370 |
|
337 |
# Use all fields that are set
|
371 |
# Use all fields that are set
|
338 |
set coltxt "("
|
372 |
set coltxt "("
|
339 |
set valtxt "("
|
373 |
set valtxt "("
|
340 |
foreach col $ar(columns) {
|
374 |
foreach col $ar(columns) {
|
341 |
set value [string trim $ar(sqlsc_${col}_value)]
|
375 |
set value [string trim $ar(sqlsc_${col}_value)]
|
342 |
# 'a' stuff to avoid integer too big errors
|
376 |
# 'a' stuff to avoid integer too big errors
|
343 |
if {"a$value" == "a"} {
|
377 |
if {"a$value" == "a"} {
|
344 |
continue
|
378 |
continue
|
345 |
}
|
379 |
}
|
346 |
append coltxt " $col,"
|
380 |
append coltxt " $col,"
|
347 |
append valtxt \
|
381 |
append valtxt \
|
348 |
" [_sqlscprepvalue $arnm $col $ar(sqlsc_${col}_type) $value],"
|
382 |
" [_sqlscprepvalue $arnm $col $ar(sqlsc_${col}_type) $value],"
|
349 |
}
|
383 |
}
|
350 |
# trim last ','
|
384 |
# trim last ','
|
351 |
set valtxt [string trimright $valtxt ", "]
|
385 |
set valtxt [string trimright $valtxt ", "]
|
352 |
set coltxt [string trimright $coltxt ", "]
|
386 |
set coltxt [string trimright $coltxt ", "]
|
353 |
# Check that at least a value is set
|
387 |
# Check that at least a value is set
|
354 |
if {[string length $valtxt] == 1} {
|
388 |
if {[string length $valtxt] == 1} {
|
355 |
return -code error "NO value set for insert statement"
|
389 |
return -code error "NO value set for insert statement"
|
356 |
}
|
390 |
}
|
357 |
append txt " $coltxt) values $valtxt)"
|
391 |
append txt " $coltxt) values $valtxt)"
|
358 |
return $txt
|
392 |
return $txt
|
359 |
}
|
393 |
}
|
360 |
|
394 |
|
|
... |
|
... |
370 |
set itxt $txt
|
404 |
set itxt $txt
|
371 |
# Update database values to current ones
|
405 |
# Update database values to current ones
|
372 |
foreach col $ar(columns) {
|
406 |
foreach col $ar(columns) {
|
373 |
# If the column value did not change don't set it.
|
407 |
# If the column value did not change don't set it.
|
374 |
# This avoids errors about updating a unique index
|
408 |
# This avoids errors about updating a unique index
|
375 |
if {"a$ar(sqlsc_${col}_value)" == "a$ar(sqlsc_${col}_valsaved)"} {
|
409 |
if {"a$ar(sqlsc_${col}_value)" == "a$ar(sqlsc_${col}_valsaved)"} {
|
376 |
continue
|
410 |
continue
|
377 |
}
|
411 |
}
|
378 |
set value [string trim $ar(sqlsc_${col}_value)]
|
412 |
set value [string trim $ar(sqlsc_${col}_value)]
|
379 |
append txt " $col = \
|
413 |
append txt " $col = \
|
380 |
[_sqlscprepvalue $arnm $col $ar(sqlsc_${col}_type) $value],"
|
414 |
[_sqlscprepvalue $arnm $col $ar(sqlsc_${col}_type) $value],"
|
381 |
}
|
415 |
}
|
382 |
if {$txt == $itxt} {
|
416 |
if {$txt == $itxt} {
|
383 |
return -code error "No fields changed (nothing to update)"
|
417 |
return -code error "No fields changed (nothing to update)"
|
384 |
}
|
418 |
}
|
385 |
# trim last ',', add 'where'
|
419 |
# trim last ',', add 'where'
|
386 |
set txt "[string trimright $txt ","] where"
|
420 |
set txt "[string trimright $txt ","] where"
|
387 |
# where clause
|
421 |
# where clause
|
388 |
set first 1
|
422 |
set first 1
|
389 |
foreach col $ar(updateindex) {
|
423 |
foreach col $ar(updateindex) {
|
390 |
if {$first == 0} {
|
424 |
if {$first == 0} {
|
391 |
append txt " and"
|
425 |
append txt " and"
|
392 |
} else {
|
426 |
} else {
|
393 |
set first 0
|
427 |
set first 0
|
394 |
}
|
428 |
}
|
395 |
append txt " $col = \
|
429 |
append txt " $col = \
|
396 |
[_sqlscprepvalue $arnm $col $ar(sqlsc_${col}_type) \
|
430 |
[_sqlscprepvalue $arnm $col $ar(sqlsc_${col}_type) \
|
397 |
$ar(sqlsc_${col}_valsaved) 0]"
|
431 |
$ar(sqlsc_${col}_valsaved) 0]"
|
398 |
}
|
432 |
}
|
399 |
return $txt
|
433 |
return $txt
|
400 |
}
|
434 |
}
|
401 |
|
435 |
|
402 |
#
|
436 |
#
|
|
... |
|
... |
405 |
# updateindex
|
439 |
# updateindex
|
406 |
proc _sqlsccheckserial {arnm} {
|
440 |
proc _sqlsccheckserial {arnm} {
|
407 |
upvar #0 $arnm ar
|
441 |
upvar #0 $arnm ar
|
408 |
# Does table have a serial ?
|
442 |
# Does table have a serial ?
|
409 |
if {[info exists ar(tabcolserial)]} {
|
443 |
if {[info exists ar(tabcolserial)]} {
|
410 |
# Then it must be in the columns list, and listed
|
444 |
# Then it must be in the columns list, and listed
|
411 |
# as updateindex
|
445 |
# as updateindex
|
412 |
if {![info exists ar(updateindex)]} {
|
446 |
if {![info exists ar(updateindex)]} {
|
413 |
return -code error \
|
447 |
return -code error \
|
414 |
"$ar(table): has serial col $ar(tabcolserial), \
|
448 |
"$ar(table): has serial col $ar(tabcolserial), \
|
415 |
must be listed as updateindex"
|
449 |
must be listed as updateindex"
|
416 |
}
|
450 |
}
|
417 |
set idxcol [lindex $ar(updateindex) 0]
|
451 |
set idxcol [lindex $ar(updateindex) 0]
|
418 |
if {[lsearch $ar(columns) $idxcol] == -1} {
|
452 |
if {[lsearch $ar(columns) $idxcol] == -1} {
|
419 |
return -code error \
|
453 |
return -code error \
|
420 |
"$ar(table): Updateindex $idxcol not in column list ?"
|
454 |
"$ar(table): Updateindex $idxcol not in column list ?"
|
421 |
}
|
455 |
}
|
422 |
if {$idxcol != $ar(tabcolserial)} {
|
456 |
if {$idxcol != $ar(tabcolserial)} {
|
423 |
return -code error \
|
457 |
return -code error \
|
424 |
"$ar(table): updateindex $idxcol should be serial \
|
458 |
"$ar(table): updateindex $idxcol should be serial \
|
425 |
column $ar(tabcolserial)"
|
459 |
column $ar(tabcolserial)"
|
426 |
}
|
460 |
}
|
427 |
}
|
461 |
}
|
428 |
}
|
462 |
}
|
429 |
|
463 |
|
430 |
# Check if column has an attribute
|
464 |
# Check if column has an attribute
|
431 |
proc _sqlsccolattr {arnm col attr} {
|
465 |
proc _sqlsccolattr {arnm col attr} {
|
432 |
upvar $arnm ar
|
466 |
upvar $arnm ar
|
433 |
if {[info exists ar($attr)] && [lsearch $ar($attr) $col] != -1} {
|
467 |
if {[info exists ar($attr)] && [lsearch $ar($attr) $col] != -1} {
|
434 |
return 1
|
468 |
return 1
|
435 |
}
|
469 |
}
|
436 |
return 0
|
470 |
return 0
|
437 |
}
|
471 |
}
|
438 |
|
472 |
|
439 |
##########################################################
|
473 |
##########################################################
|
440 |
###### Procedures for the QBE screen
|
474 |
###### Procedures for the QBE screen
|
441 |
|
475 |
|
442 |
############
|
476 |
############
|
443 |
# Insert callback
|
477 |
# Insert callback
|
444 |
proc sqlscinsert {arnm} {
|
478 |
proc sqlscinsert {arnm} {
|
445 |
upvar #0 $arnm ar
|
479 |
upvar #0 $arnm ar
|
446 |
global env
|
480 |
global env
|
447 |
# puts "sqlscinsert: array: $arnm"; flush stdout
|
481 |
# puts "sqlscinsert: array: $arnm"; flush stdout
|
448 |
|
482 |
|
449 |
if {[info exists ar(queryonly)]} {
|
483 |
if {[info exists ar(queryonly)]} {
|
450 |
return -code error "queryonly table"
|
484 |
return -code error "queryonly table"
|
451 |
}
|
485 |
}
|
452 |
|
486 |
|
453 |
# In case there is a serial field, and the user did not or
|
487 |
# In case there is a serial field, and the user did not or
|
454 |
# could not (noentry) set its value explicitely:
|
488 |
# could not (noentry) set its value explicitely:
|
455 |
# In Cdkit: set its value with "uniqueid" (see bdsync.d)
|
489 |
# In Cdkit: set its value with "uniqueid" (see bdsync.d)
|
456 |
# Else set it to "" and let auto_increment do its job
|
490 |
# Else set it to "" and let auto_increment do its job
|
457 |
# Note that we do this before calling the beforeinsert proc, so
|
491 |
# Note that we do this before calling the beforeinsert proc, so
|
458 |
# that an application would still have a chance to apply its own
|
492 |
# that an application would still have a chance to apply its own
|
459 |
# value allocation scheme.
|
493 |
# value allocation scheme.
|
460 |
if {[info exists ar(tabcolserial)]} {
|
494 |
if {[info exists ar(tabcolserial)]} {
|
461 |
set serial $ar(tabcolserial)
|
495 |
set serial $ar(tabcolserial)
|
462 |
if {$ar(sqlsc_${serial}_value) == "" || \
|
496 |
if {$ar(sqlsc_${serial}_value) == "" || \
|
463 |
[_sqlsccolattr ar $serial noentry] || \
|
497 |
[_sqlsccolattr ar $serial noentry] || \
|
464 |
[_sqlsccolattr ar $serial nodisplay] } {
|
498 |
[_sqlsccolattr ar $serial nodisplay] } {
|
465 |
if {[info exists env(CDKITDB)]} {
|
499 |
if {[info exists env(CDKITDB)]} {
|
466 |
# puts "Calling tcsquniqueid";flush stdout
|
500 |
# puts "Calling tcsquniqueid";flush stdout
|
467 |
set ar(sqlsc_${serial}_value) \
|
501 |
set ar(sqlsc_${serial}_value) \
|
468 |
[tcsquniqueid $ar(hdl) $ar(table)]
|
502 |
[tcsquniqueid $ar(hdl) $ar(table)]
|
469 |
# puts "uniqueid returned: ar(sqlsc_${serial}_value)"
|
503 |
# puts "uniqueid returned: ar(sqlsc_${serial}_value)"
|
470 |
} else {
|
504 |
} else {
|
471 |
set ar(sqlsc_${serial}_value) ""
|
505 |
set ar(sqlsc_${serial}_value) ""
|
|
|
506 |
}
|
472 |
}
|
507 |
}
|
473 |
}
|
|
|
474 |
}
|
508 |
}
|
475 |
|
509 |
|
476 |
# Prepare text values
|
510 |
# Prepare text values
|
477 |
_sqlsctextstocols ar
|
511 |
_sqlsctextstocols ar
|
478 |
if {[info exists ar(beforeinsert)]} {
|
512 |
if {[info exists ar(beforeinsert)]} {
|
479 |
set res [$ar(beforeinsert) "beforeinsert" $arnm]
|
513 |
set res [$ar(beforeinsert) "beforeinsert" $arnm]
|
480 |
if {$res != 0} {
|
514 |
if {$res != 0} {
|
481 |
return;
|
515 |
return;
|
482 |
}
|
516 |
}
|
483 |
}
|
517 |
}
|
484 |
set txt [_sqlscbuildinsert ar]
|
518 |
set txt [_sqlscbuildinsert ar]
|
485 |
_sqlsclogstmt $txt
|
519 |
_sqlsclogstmt $txt
|
486 |
tcsqexec $ar(hdl) $txt
|
520 |
tcsqexec $ar(hdl) $txt
|
487 |
_sqlsclogcommit
|
521 |
_sqlsclogcommit
|
488 |
# If there is a serial and we're not in cdkit, update serial
|
522 |
# If there is a serial and we're not in cdkit, update serial
|
489 |
# fields with autogenerated value,
|
523 |
# fields with autogenerated value,
|
490 |
if {![info exists env(CDKITDB)] && [info exists serial]} {
|
524 |
if {![info exists env(CDKITDB)] && [info exists serial]} {
|
491 |
set ar(sqlsc_${serial}_value) [tcsqinsertid $ar(hdl)]
|
525 |
set ar(sqlsc_${serial}_value) [tcsqinsertid $ar(hdl)]
|
492 |
}
|
526 |
}
|
493 |
# Run a query to update other fields with automatically generated
|
527 |
# Run a query to update other fields with automatically generated
|
494 |
# values (defaults)
|
528 |
# values (defaults)
|
495 |
sqlscquery $arnm
|
529 |
sqlscquery $arnm
|
496 |
|
530 |
|
497 |
# Possibly run postadd routine
|
531 |
# Possibly run postadd routine
|
498 |
if {[info exists ar(afterinsert)]} {
|
532 |
if {[info exists ar(afterinsert)]} {
|
499 |
$ar(afterinsert) afterinsert $txt $arnm
|
533 |
$ar(afterinsert) afterinsert $txt $arnm
|
500 |
}
|
534 |
}
|
501 |
}
|
535 |
}
|
502 |
|
536 |
|
503 |
proc _sqlscisupdidx {arnm} {
|
537 |
proc _sqlscisupdidx {arnm} {
|
504 |
upvar #0 $arnm ar
|
538 |
upvar #0 $arnm ar
|
505 |
if {![info exists ar(updateindex)] || \
|
539 |
if {![info exists ar(updateindex)] || \
|
506 |
[llength $ar(updateindex)] == 0 || \
|
540 |
[llength $ar(updateindex)] == 0 || \
|
507 |
[lindex $ar(updateindex) 0] == ""} {
|
541 |
[lindex $ar(updateindex) 0] == ""} {
|
508 |
return 0
|
542 |
return 0
|
509 |
} else {
|
543 |
} else {
|
510 |
return 1
|
544 |
return 1
|
511 |
}
|
545 |
}
|
512 |
}
|
546 |
}
|
513 |
|
547 |
|
514 |
|
548 |
|
515 |
############
|
549 |
############
|
516 |
# Update callback
|
550 |
# Update callback
|
517 |
proc sqlscupd {arnm} {
|
551 |
proc sqlscupd {arnm} {
|
518 |
upvar #0 $arnm ar
|
552 |
upvar #0 $arnm ar
|
519 |
# puts "sqlscupd: array: $arnm"; flush stdout
|
553 |
# puts "sqlscupd: array: $arnm"; flush stdout
|
520 |
if {[info exists ar(queryonly)]} {
|
554 |
if {[info exists ar(queryonly)]} {
|
521 |
return -code error "Table is queryonly: no updates allowed"
|
555 |
return -code error "Table is queryonly: no updates allowed"
|
522 |
}
|
556 |
}
|
523 |
if {![_sqlscisupdidx $arnm]} {
|
557 |
if {![_sqlscisupdidx $arnm]} {
|
524 |
return -code error "Can't update: no 'updateindex' fields"
|
558 |
return -code error "Can't update: no 'updateindex' fields"
|
525 |
}
|
559 |
}
|
526 |
# Prepare text values
|
560 |
# Prepare text values
|
527 |
_sqlsctextstocols ar
|
561 |
_sqlsctextstocols ar
|
528 |
if {[info exists ar(beforeupdate)]} {
|
562 |
if {[info exists ar(beforeupdate)]} {
|
529 |
set res [$ar(beforeupdate) beforeupdate $arnm]
|
563 |
set res [$ar(beforeupdate) beforeupdate $arnm]
|
530 |
if {$res != 0} {
|
564 |
if {$res != 0} {
|
531 |
return;
|
565 |
return;
|
532 |
}
|
566 |
}
|
533 |
}
|
567 |
}
|
534 |
|
568 |
|
535 |
set txt [_sqlscbuildupdate ar]
|
569 |
set txt [_sqlscbuildupdate ar]
|
536 |
_sqlsclogstmt $txt
|
570 |
_sqlsclogstmt $txt
|
537 |
tcsqexec $ar(hdl) $txt
|
571 |
tcsqexec $ar(hdl) $txt
|
538 |
_sqlsclogcommit
|
572 |
_sqlsclogcommit
|
539 |
_sqlscsavevalues ar
|
573 |
_sqlscsavevalues ar
|
540 |
|
574 |
|
541 |
if {[info exists ar(afterupdate)]} {
|
575 |
if {[info exists ar(afterupdate)]} {
|
542 |
$ar(afterupdate) afterupdate $txt $arnm
|
576 |
$ar(afterupdate) afterupdate $txt $arnm
|
543 |
}
|
577 |
}
|
544 |
}
|
578 |
}
|
545 |
|
579 |
|
546 |
# Add '%' where needed for fields listed as "autopercent"
|
580 |
# Add '%' where needed for fields listed as "autopercent"
|
547 |
proc _sqlscsetautopercent {arnm} {
|
581 |
proc _sqlscsetautopercent {arnm} {
|
548 |
upvar #0 $arnm ar
|
582 |
upvar #0 $arnm ar
|
549 |
if {[info exists ar(autopercentboth)]} {
|
583 |
if {[info exists ar(autopercentboth)]} {
|
550 |
foreach col $ar(autopercentboth) {
|
584 |
foreach col $ar(autopercentboth) {
|
551 |
if {$ar(sqlsc_${col}_value) != "" && \
|
585 |
if {$ar(sqlsc_${col}_value) != "" && \
|
552 |
[string first "%" $ar(sqlsc_${col}_value)] == -1} {
|
586 |
[string first "%" $ar(sqlsc_${col}_value)] == -1} {
|
553 |
set ar(sqlsc_${col}_value) "%$ar(sqlsc_${col}_value)%"
|
587 |
set ar(sqlsc_${col}_value) "%$ar(sqlsc_${col}_value)%"
|
|
|
588 |
}
|
554 |
}
|
589 |
}
|
555 |
}
|
|
|
556 |
}
|
590 |
}
|
557 |
if {[info exists ar(autopercentleft)]} {
|
591 |
if {[info exists ar(autopercentleft)]} {
|
558 |
foreach col $ar(autopercentleft) {
|
592 |
foreach col $ar(autopercentleft) {
|
559 |
if {$ar(sqlsc_${col}_value) != "" && \
|
593 |
if {$ar(sqlsc_${col}_value) != "" && \
|
560 |
[string first "%" $ar(sqlsc_${col}_value)] == -1} {
|
594 |
[string first "%" $ar(sqlsc_${col}_value)] == -1} {
|
561 |
set ar(sqlsc_${col}_value) "%$ar(sqlsc_${col}_value)"
|
595 |
set ar(sqlsc_${col}_value) "%$ar(sqlsc_${col}_value)"
|
|
|
596 |
}
|
562 |
}
|
597 |
}
|
563 |
}
|
|
|
564 |
}
|
598 |
}
|
565 |
if {[info exists ar(autopercentright)]} {
|
599 |
if {[info exists ar(autopercentright)]} {
|
566 |
foreach col $ar(autopercentright) {
|
600 |
foreach col $ar(autopercentright) {
|
567 |
if {$ar(sqlsc_${col}_value) != "" && \
|
601 |
if {$ar(sqlsc_${col}_value) != "" && \
|
568 |
[string first "%" $ar(sqlsc_${col}_value)] == -1} {
|
602 |
[string first "%" $ar(sqlsc_${col}_value)] == -1} {
|
569 |
set ar(sqlsc_${col}_value) "$ar(sqlsc_${col}_value)%"
|
603 |
set ar(sqlsc_${col}_value) "$ar(sqlsc_${col}_value)%"
|
|
|
604 |
}
|
570 |
}
|
605 |
}
|
571 |
}
|
|
|
572 |
}
|
606 |
}
|
573 |
}
|
607 |
}
|
574 |
|
608 |
|
575 |
# Save a copy of the column values. This is used in updates, to avoid
|
609 |
# Save a copy of the column values. This is used in updates, to avoid
|
576 |
# updating columns that haven't changed, and to enable updating the
|
610 |
# updating columns that haven't changed, and to enable updating the
|
577 |
# updateindex columns (the where clause uses the saved values).
|
611 |
# updateindex columns (the where clause uses the saved values).
|
578 |
proc _sqlscsavevalues {arnm} {
|
612 |
proc _sqlscsavevalues {arnm} {
|
579 |
upvar $arnm ar
|
613 |
upvar $arnm ar
|
580 |
# puts "_sqlscsavevalues"
|
614 |
# puts "_sqlscsavevalues"
|
581 |
foreach col $ar(columns) {
|
615 |
foreach col $ar(columns) {
|
582 |
set ar(sqlsc_${col}_valsaved) $ar(sqlsc_${col}_value)
|
616 |
set ar(sqlsc_${col}_valsaved) $ar(sqlsc_${col}_value)
|
583 |
}
|
617 |
}
|
584 |
}
|
618 |
}
|
585 |
|
619 |
|
586 |
#############
|
620 |
#############
|
587 |
# Select callback
|
621 |
# Select callback
|
588 |
proc sqlscquery {arnm} {
|
622 |
proc sqlscquery {arnm} {
|
589 |
upvar #0 $arnm ar
|
623 |
upvar #0 $arnm ar
|
590 |
# puts "sqlscquery: array: $arnm"; flush stdout
|
624 |
# puts "sqlscquery: array: $arnm"; flush stdout
|
591 |
|
625 |
|
592 |
if {[info exists ar(querynum)] && $ar(querynum) != ""} {
|
626 |
if {[info exists ar(querynum)] && $ar(querynum) != ""} {
|
593 |
tcsqclosel $ar(querynum)
|
627 |
tcsqclosel $ar(querynum)
|
594 |
set ar(querynum) ""
|
628 |
set ar(querynum) ""
|
595 |
}
|
629 |
}
|
596 |
|
630 |
|
597 |
if {[info exists ar(beforequery)] && \
|
631 |
if {[info exists ar(beforequery)] && \
|
598 |
[$ar(beforequery) "beforequery" $arnm]} {
|
632 |
[$ar(beforequery) "beforequery" $arnm]} {
|
599 |
return;
|
633 |
return;
|
600 |
}
|
634 |
}
|
601 |
|
635 |
|
602 |
_sqlscsetautopercent $arnm
|
636 |
_sqlscsetautopercent $arnm
|
603 |
set txt [_sqlscbuildselect ar]
|
637 |
set txt [_sqlscbuildselect ar]
|
|
... |
|
... |
606 |
_sqlsclogcommit
|
640 |
_sqlsclogcommit
|
607 |
|
641 |
|
608 |
set result1 [tcsqnext $ar(querynum)]
|
642 |
set result1 [tcsqnext $ar(querynum)]
|
609 |
# puts "result1: $result1"
|
643 |
# puts "result1: $result1"
|
610 |
if {$result1 == ""} {
|
644 |
if {$result1 == ""} {
|
611 |
global sqlscnobell
|
645 |
global sqlscnobell
|
612 |
if {$sqlscnobell == 0} {
|
646 |
if {$sqlscnobell == 0} {
|
613 |
bell
|
647 |
bell
|
614 |
}
|
648 |
}
|
615 |
return 0
|
649 |
return 0
|
616 |
}
|
650 |
}
|
617 |
set ind 0
|
651 |
set ind 0
|
618 |
foreach col $ar(columns) {
|
652 |
foreach col $ar(columns) {
|
619 |
set ar(sqlsc_${col}_value) [string trim [lindex $result1 $ind]]
|
653 |
set ar(sqlsc_${col}_value) [string trim [lindex $result1 $ind]]
|
620 |
incr ind
|
654 |
incr ind
|
621 |
}
|
655 |
}
|
622 |
_sqlscsavevalues ar
|
656 |
_sqlscsavevalues ar
|
623 |
_sqlsccolstotexts ar
|
657 |
_sqlsccolstotexts ar
|
624 |
_sqlscdolinks $arnm
|
658 |
_sqlscdolinks $arnm
|
625 |
# If there is an associated list screen, unroll the query there
|
659 |
# If there is an associated list screen, unroll the query there
|
626 |
if {[info exists ar(list_columns)] && \
|
660 |
if {[info exists ar(list_columns)] && \
|
627 |
![info exists ar(inslavelistdetail)]} {
|
661 |
![info exists ar(inslavelistdetail)]} {
|
628 |
sqlistquery $arnm
|
662 |
sqlistquery $arnm
|
629 |
}
|
663 |
}
|
630 |
if {[info exists ar(afterquery)]} {
|
664 |
if {[info exists ar(afterquery)]} {
|
631 |
# puts "afterquery exists for $arnm"
|
665 |
# puts "afterquery exists for $arnm"
|
632 |
$ar(afterquery) "afterquery" "$txt" "$arnm"
|
666 |
$ar(afterquery) "afterquery" "$txt" "$arnm"
|
633 |
}
|
667 |
}
|
634 |
return 1
|
668 |
return 1
|
635 |
}
|
669 |
}
|
636 |
|
670 |
|
637 |
#############
|
671 |
#############
|
|
... |
|
... |
639 |
proc sqlscdelete {arnm} {
|
673 |
proc sqlscdelete {arnm} {
|
640 |
upvar #0 $arnm ar
|
674 |
upvar #0 $arnm ar
|
641 |
# puts "sqlscdelete: array: $arnm"; flush stdout
|
675 |
# puts "sqlscdelete: array: $arnm"; flush stdout
|
642 |
|
676 |
|
643 |
if {[info exists ar(queryonly)]} {
|
677 |
if {[info exists ar(queryonly)]} {
|
644 |
return -code error "queryonly table"
|
678 |
return -code error "queryonly table"
|
645 |
}
|
679 |
}
|
646 |
if {[info exists ar(beforedelete)] && \
|
680 |
if {[info exists ar(beforedelete)] && \
|
647 |
[$ar(beforedelete) "beforedelete" $arnm]} {
|
681 |
[$ar(beforedelete) "beforedelete" $arnm]} {
|
648 |
return;
|
682 |
return;
|
649 |
}
|
683 |
}
|
650 |
|
684 |
|
651 |
set fromwhere [_sqlscbuilddelwhere ar]
|
685 |
set fromwhere [_sqlscbuilddelwhere ar]
|
652 |
set txt "select count(*) $fromwhere"
|
686 |
set txt "select count(*) $fromwhere"
|
|
... |
|
... |
655 |
_sqlsclogcommit
|
689 |
_sqlsclogcommit
|
656 |
|
690 |
|
657 |
set res [lindex [tcsqnext $qry 1] 0]
|
691 |
set res [lindex [tcsqnext $qry 1] 0]
|
658 |
tcsqclosel $qry
|
692 |
tcsqclosel $qry
|
659 |
if {$res == "" || $res == 0} {
|
693 |
if {$res == "" || $res == 0} {
|
660 |
# mysql sometimes returns an empty set instead of 0
|
694 |
# mysql sometimes returns an empty set instead of 0
|
661 |
tk_dialog .norow "no rows" \
|
695 |
tk_dialog .norow "no rows" \
|
662 |
"No rows selected by current values" "" 0 "Ok"
|
696 |
"No rows selected by current values" "" 0 "Ok"
|
663 |
return
|
697 |
return
|
664 |
}
|
698 |
}
|
665 |
if {$res != 1} {
|
699 |
if {$res != 1} {
|
666 |
set ans [tk_dialog .manyrows "Multiple rows deleted" \
|
700 |
set ans [tk_dialog .manyrows "Multiple rows deleted" \
|
667 |
"$res rows would be deleted. Do it anyway ?" "" 0 \
|
701 |
"$res rows would be deleted. Do it anyway ?" "" 0 \
|
668 |
"Don't delete" "DO IT"]
|
702 |
"Don't delete" "DO IT"]
|
669 |
if {$ans != 1} {
|
703 |
if {$ans != 1} {
|
670 |
return
|
704 |
return
|
671 |
}
|
705 |
}
|
672 |
}
|
706 |
}
|
673 |
|
707 |
|
674 |
set txt "delete $fromwhere"
|
708 |
set txt "delete $fromwhere"
|
675 |
_sqlsclogstmt $txt
|
709 |
_sqlsclogstmt $txt
|
676 |
tcsqexec $ar(hdl) "$txt"
|
710 |
tcsqexec $ar(hdl) "$txt"
|
677 |
_sqlsclogcommit
|
711 |
_sqlsclogcommit
|
678 |
|
712 |
|
679 |
if {[info exists ar(afterdelete)]} {
|
713 |
if {[info exists ar(afterdelete)]} {
|
680 |
$ar(afterdelete) "afterdelete" "$txt" "$arnm"
|
714 |
$ar(afterdelete) "afterdelete" "$txt" "$arnm"
|
681 |
}
|
715 |
}
|
682 |
return 1
|
716 |
return 1
|
683 |
}
|
717 |
}
|
684 |
|
718 |
|
685 |
#############################
|
719 |
#############################
|
|
... |
|
... |
688 |
upvar #0 $arnm ar
|
722 |
upvar #0 $arnm ar
|
689 |
|
723 |
|
690 |
set result1 [tcsqnext $ar(querynum)]
|
724 |
set result1 [tcsqnext $ar(querynum)]
|
691 |
# puts "result1: $result1"
|
725 |
# puts "result1: $result1"
|
692 |
if {$result1 == ""} {
|
726 |
if {$result1 == ""} {
|
693 |
return 0
|
727 |
return 0
|
694 |
}
|
728 |
}
|
695 |
set ind 0
|
729 |
set ind 0
|
696 |
foreach col $ar(columns) {
|
730 |
foreach col $ar(columns) {
|
697 |
set ar(sqlsc_${col}_value) [string trim [lindex $result1 $ind]]
|
731 |
set ar(sqlsc_${col}_value) [string trim [lindex $result1 $ind]]
|
698 |
incr ind
|
732 |
incr ind
|
699 |
}
|
733 |
}
|
700 |
_sqlscsavevalues ar
|
734 |
_sqlscsavevalues ar
|
701 |
_sqlsccolstotexts ar
|
735 |
_sqlsccolstotexts ar
|
702 |
_sqlscdolinks $arnm
|
736 |
_sqlscdolinks $arnm
|
703 |
if {[info exists ar(afterquery)]} {
|
737 |
if {[info exists ar(afterquery)]} {
|
704 |
# puts "afterquery exists for $arnm"
|
738 |
# puts "afterquery exists for $arnm"
|
705 |
$ar(afterquery) "afternext" "" "$arnm"
|
739 |
$ar(afterquery) "afternext" "" "$arnm"
|
706 |
}
|
740 |
}
|
707 |
return 1
|
741 |
return 1
|
708 |
}
|
742 |
}
|
709 |
|
743 |
|
710 |
########
|
744 |
########
|
|
... |
|
... |
712 |
proc sqlscreopen {arnm} {
|
746 |
proc sqlscreopen {arnm} {
|
713 |
upvar #0 $arnm ar
|
747 |
upvar #0 $arnm ar
|
714 |
|
748 |
|
715 |
tcsqrew $ar(querynum)
|
749 |
tcsqrew $ar(querynum)
|
716 |
set result1 [tcsqnext $ar(querynum)]
|
750 |
set result1 [tcsqnext $ar(querynum)]
|
717 |
|
751 |
|
718 |
# puts "result1: $result1"
|
752 |
# puts "result1: $result1"
|
719 |
if {$result1 == ""} {
|
753 |
if {$result1 == ""} {
|
720 |
return 0
|
754 |
return 0
|
721 |
}
|
755 |
}
|
722 |
set ind 0
|
756 |
set ind 0
|
723 |
foreach col $ar(columns) {
|
757 |
foreach col $ar(columns) {
|
724 |
set ar(sqlsc_${col}_value) [string trim [lindex $result1 $ind]]
|
758 |
set ar(sqlsc_${col}_value) [string trim [lindex $result1 $ind]]
|
725 |
incr ind
|
759 |
incr ind
|
726 |
}
|
760 |
}
|
727 |
_sqlscsavevalues ar
|
761 |
_sqlscsavevalues ar
|
728 |
_sqlsccolstotexts ar
|
762 |
_sqlsccolstotexts ar
|
729 |
_sqlscdolinks $arnm
|
763 |
_sqlscdolinks $arnm
|
730 |
if {[info exists ar(afterquery)]} {
|
764 |
if {[info exists ar(afterquery)]} {
|
731 |
# puts "afterquery exists for $arnm"
|
765 |
# puts "afterquery exists for $arnm"
|
732 |
$ar(afterquery) "afterreop" "" "$arnm"
|
766 |
$ar(afterquery) "afterreop" "" "$arnm"
|
733 |
}
|
767 |
}
|
734 |
return 1
|
768 |
return 1
|
735 |
}
|
769 |
}
|
736 |
|
770 |
|
737 |
###############
|
771 |
###############
|
738 |
# Reset all fields to null values
|
772 |
# Reset all fields to null values
|
739 |
proc sqlscreset {arnm} {
|
773 |
proc sqlscreset {arnm} {
|
740 |
upvar #0 $arnm ar
|
774 |
upvar #0 $arnm ar
|
741 |
# puts "sqlscreset: $ar(columns)"
|
775 |
# puts "sqlscreset: $ar(columns)"
|
742 |
foreach col $ar(columns) {
|
776 |
foreach col $ar(columns) {
|
743 |
set ar(sqlsc_${col}_value) ""
|
777 |
set ar(sqlsc_${col}_value) ""
|
744 |
}
|
778 |
}
|
745 |
if {[info exists ar(querynum)]} {
|
779 |
if {[info exists ar(querynum)]} {
|
746 |
tcsqclosel $ar(querynum)
|
780 |
tcsqclosel $ar(querynum)
|
747 |
unset ar(querynum)
|
781 |
unset ar(querynum)
|
748 |
}
|
782 |
}
|
749 |
_sqlscsavevalues ar
|
783 |
_sqlscsavevalues ar
|
750 |
_sqlsccolstotexts ar
|
784 |
_sqlsccolstotexts ar
|
751 |
_sqlscdolinks $arnm
|
785 |
_sqlscdolinks $arnm
|
752 |
# If there is an associated list screen, reset it
|
786 |
# If there is an associated list screen, reset it
|
753 |
if {[info exists ar(list_columns)] && \
|
787 |
if {[info exists ar(list_columns)] && \
|
754 |
![info exists ar(inslavelistdetail)]} {
|
788 |
![info exists ar(inslavelistdetail)]} {
|
755 |
sqlistquery $arnm "reset"
|
789 |
sqlistquery $arnm "reset"
|
756 |
}
|
790 |
}
|
757 |
if {[info exists ar(afterquery)]} {
|
791 |
if {[info exists ar(afterquery)]} {
|
758 |
# puts "afterquery exists for $arnm"
|
792 |
# puts "afterquery exists for $arnm"
|
759 |
$ar(afterquery) "afterreset" "" "$arnm"
|
793 |
$ar(afterquery) "afterreset" "" "$arnm"
|
760 |
}
|
794 |
}
|
761 |
if {[info exists ar(sqlsc_initfocus_win)]} {
|
795 |
if {[info exists ar(sqlsc_initfocus_win)]} {
|
762 |
focus $ar(sqlsc_initfocus_win)
|
796 |
focus $ar(sqlsc_initfocus_win)
|
763 |
}
|
797 |
}
|
764 |
return 1
|
798 |
return 1
|
765 |
}
|
799 |
}
|
766 |
|
800 |
|
767 |
# Cleanup when the array is unset. This is a trace which gets called
|
801 |
# Cleanup when the array is unset. This is a trace which gets called
|
|
... |
|
... |
770 |
proc sqlscreendelete {arnm} {
|
804 |
proc sqlscreendelete {arnm} {
|
771 |
upvar $arnm ar
|
805 |
upvar $arnm ar
|
772 |
# puts "sqlscreendelete: proceeding with unsets. Table $ar(table)"
|
806 |
# puts "sqlscreendelete: proceeding with unsets. Table $ar(table)"
|
773 |
# parray ar
|
807 |
# parray ar
|
774 |
if {[info exists ar(querynum)]} {
|
808 |
if {[info exists ar(querynum)]} {
|
775 |
# puts "sqlscreendelete: closel"
|
809 |
# puts "sqlscreendelete: closel"
|
776 |
tcsqclosel $ar(querynum)
|
810 |
tcsqclosel $ar(querynum)
|
777 |
}
|
811 |
}
|
778 |
if {[info exists ar(hdl)]} {
|
812 |
if {[info exists ar(hdl)]} {
|
779 |
# puts "sqlscreendelete: tcsqdiscon"
|
813 |
# puts "sqlscreendelete: tcsqdiscon"
|
780 |
tcsqdiscon $ar(hdl)
|
814 |
tcsqdiscon $ar(hdl)
|
781 |
}
|
815 |
}
|
782 |
if {[info exists ar(window)]} {
|
816 |
if {[info exists ar(window)]} {
|
783 |
# puts "sqlscreendelete: destroy $ar(window)"
|
817 |
# puts "sqlscreendelete: destroy $ar(window)"
|
784 |
destroy $ar(window)
|
818 |
destroy $ar(window)
|
785 |
}
|
819 |
}
|
786 |
if {[info exists ar(list_window)]} {
|
820 |
if {[info exists ar(list_window)]} {
|
787 |
# puts "sqlscreendelete: destroy $ar(list_window)"
|
821 |
# puts "sqlscreendelete: destroy $ar(list_window)"
|
788 |
destroy $ar(list_window)
|
822 |
destroy $ar(list_window)
|
789 |
}
|
823 |
}
|
790 |
unset ar
|
824 |
unset ar
|
791 |
}
|
825 |
}
|
792 |
|
826 |
|
793 |
# Bind <CR>, TAB, ^N for an entry field. Slightly different from what
|
827 |
# Bind <CR>, TAB, ^N for an entry field. Slightly different from what
|
|
... |
|
... |
806 |
# Compute button width for choice fields (max label length)
|
840 |
# Compute button width for choice fields (max label length)
|
807 |
proc _compchoicewidth {listname} {
|
841 |
proc _compchoicewidth {listname} {
|
808 |
upvar #0 $listname lst
|
842 |
upvar #0 $listname lst
|
809 |
set maxlab 0
|
843 |
set maxlab 0
|
810 |
foreach elt $lst {
|
844 |
foreach elt $lst {
|
811 |
set len [string length [string trim [lindex $elt 0]]]
|
845 |
set len [string length [string trim [lindex $elt 0]]]
|
812 |
if {$maxlab < $len} {
|
846 |
if {$maxlab < $len} {
|
813 |
set maxlab $len
|
847 |
set maxlab $len
|
814 |
}
|
848 |
}
|
815 |
}
|
849 |
}
|
816 |
return $maxlab
|
850 |
return $maxlab
|
817 |
}
|
851 |
}
|
818 |
|
852 |
|
819 |
set usecommonbuttons 0
|
853 |
set usecommonbuttons 0
|
|
... |
|
... |
841 |
button $w.rew -text "Rewind" -command "sqlscreopen \$focusarrayname"
|
875 |
button $w.rew -text "Rewind" -command "sqlscreopen \$focusarrayname"
|
842 |
pack $w.rew -side left -fill x -expand yes
|
876 |
pack $w.rew -side left -fill x -expand yes
|
843 |
button $w.reset -text "Reset" -command "sqlscreset \$focusarrayname"
|
877 |
button $w.reset -text "Reset" -command "sqlscreset \$focusarrayname"
|
844 |
pack $w.reset -side left -fill x -expand yes
|
878 |
pack $w.reset -side left -fill x -expand yes
|
845 |
if {[lsearch $butlist add] != -1} {
|
879 |
if {[lsearch $butlist add] != -1} {
|
846 |
button $w.add -text "Add" -command "sqlscinsert \$focusarrayname"
|
880 |
button $w.add -text "Add" -command "sqlscinsert \$focusarrayname"
|
847 |
pack $w.add -side left -fill x -expand yes
|
881 |
pack $w.add -side left -fill x -expand yes
|
848 |
}
|
882 |
}
|
849 |
if {[lsearch $butlist update] != -1} {
|
883 |
if {[lsearch $butlist update] != -1} {
|
850 |
button $w.upd -text "Update" -command "sqlscupd \$focusarrayname"
|
884 |
button $w.upd -text "Update" -command "sqlscupd \$focusarrayname"
|
851 |
pack $w.upd -side left -fill x -expand yes
|
885 |
pack $w.upd -side left -fill x -expand yes
|
852 |
}
|
886 |
}
|
853 |
pack $w -side top -fill both -expand yes
|
887 |
pack $w -side top -fill both -expand yes
|
854 |
}
|
888 |
}
|
855 |
|
889 |
|
|
... |
|
... |
861 |
upvar $passwdnm passwd
|
895 |
upvar $passwdnm passwd
|
862 |
set host ""
|
896 |
set host ""
|
863 |
set user ""
|
897 |
set user ""
|
864 |
set passwd ""
|
898 |
set passwd ""
|
865 |
if {[info exists ar(sqlschost)]} {
|
899 |
if {[info exists ar(sqlschost)]} {
|
866 |
set host $ar(sqlschost)
|
900 |
set host $ar(sqlschost)
|
867 |
}
|
901 |
}
|
868 |
if {[info exists ar(sqlscuser)]} {
|
902 |
if {[info exists ar(sqlscuser)]} {
|
869 |
set user $ar(sqlscuser)
|
903 |
set user $ar(sqlscuser)
|
870 |
}
|
904 |
}
|
871 |
if {[info exists ar(sqlscpasswd)]} {
|
905 |
if {[info exists ar(sqlscpasswd)]} {
|
872 |
set passwd $ar(sqlscpasswd)
|
906 |
set passwd $ar(sqlscpasswd)
|
873 |
}
|
907 |
}
|
874 |
}
|
908 |
}
|
875 |
|
909 |
|
876 |
# Procedure used to set old column value entries in the array. The
|
910 |
# Procedure used to set old column value entries in the array. The
|
877 |
# indexes for those were the column names (the new ones are like
|
911 |
# indexes for those were the column names (the new ones are like
|
|
... |
|
... |
899 |
proc _sqlscsetuptextlists {arnm} {
|
933 |
proc _sqlscsetuptextlists {arnm} {
|
900 |
upvar $arnm ar
|
934 |
upvar $arnm ar
|
901 |
# puts "_sqlscsetuptextlists: arnm: $arnm. Table: $ar(table)"
|
935 |
# puts "_sqlscsetuptextlists: arnm: $arnm. Table: $ar(table)"
|
902 |
|
936 |
|
903 |
if {![info exists ar(texts)]} {
|
937 |
if {![info exists ar(texts)]} {
|
904 |
# puts "_sqlscsetuptextlists: no texts"
|
938 |
# puts "_sqlscsetuptextlists: no texts"
|
905 |
return
|
939 |
return
|
906 |
}
|
940 |
}
|
907 |
foreach tlist $ar(texts) {
|
941 |
foreach tlist $ar(texts) {
|
908 |
if {[llength $tlist] != 3} {
|
942 |
set l [llength $tlist]
|
|
|
943 |
if {$l != 3 && $l != 4} {
|
909 |
return -code error "Bad text field definition: $tlist"
|
944 |
return -code error "Bad text field definition: $tlist"
|
910 |
}
|
945 |
}
|
911 |
lappend ar(textcols) [lindex $tlist 0]
|
946 |
lappend ar(textcols) [lindex $tlist 0]
|
912 |
lappend ar(textheights) [lindex $tlist 1]
|
947 |
lappend ar(textheights) [lindex $tlist 1]
|
913 |
lappend ar(textwidths) [lindex $tlist 2]
|
948 |
lappend ar(textwidths) [lindex $tlist 2]
|
|
|
949 |
if {$l == 4} {
|
|
|
950 |
lappend ar(textopts) [lindex $tlist 3]
|
|
|
951 |
} else {
|
|
|
952 |
lappend ar(textopts) ""
|
|
|
953 |
}
|
914 |
# puts "_sqlscsetuptextlists: found text: $ar(textcols)"
|
954 |
# puts "_sqlscsetuptextlists: found text: $ar(textcols)"
|
915 |
}
|
955 |
}
|
916 |
}
|
956 |
}
|
|
|
957 |
|
917 |
# Setup the column variables from the text in the text fields (if any)
|
958 |
# Setup the column variables from the text in the text fields (if any)
|
918 |
# Special chars are suitably quoted for insertion or update
|
959 |
# Special chars are suitably quoted for insertion or update
|
919 |
proc _sqlsctextstocols {arnm} {
|
960 |
proc _sqlsctextstocols {arnm} {
|
920 |
upvar $arnm ar
|
961 |
upvar $arnm ar
|
921 |
# puts "_sqlsctextstocols: arnm: $arnm. Table: $ar(table)"
|
962 |
# puts "_sqlsctextstocols: arnm: $arnm. Table: $ar(table)"
|
922 |
if {![info exists ar(textcols)]} {
|
963 |
if {![info exists ar(textcols)]} {
|
923 |
# puts "_sqlsctextstocols: no texts"
|
964 |
# puts "_sqlsctextstocols: no texts"
|
924 |
return
|
965 |
return
|
925 |
}
|
966 |
}
|
926 |
foreach col $ar(textcols) {
|
967 |
foreach col $ar(textcols) {
|
927 |
set ar(sqlsc_${col}_value) \
|
968 |
set ar(sqlsc_${col}_value) \
|
928 |
[tcsqquoteblob [$ar(window).ff.$col get 1.0 end]]
|
969 |
[tcsqquoteblob [$ar(window).ff.$col get 1.0 end]]
|
929 |
}
|
970 |
}
|
930 |
}
|
971 |
}
|
931 |
# Setup text in text fields from column values
|
972 |
# Setup text in text fields from column values
|
932 |
proc _sqlsccolstotexts {arnm} {
|
973 |
proc _sqlsccolstotexts {arnm} {
|
933 |
upvar $arnm ar
|
974 |
upvar $arnm ar
|
934 |
# puts "_sqlsccolstotexts: arnm: $arnm. Table: $ar(table)"
|
975 |
# puts "_sqlsccolstotexts: arnm: $arnm. Table: $ar(table)"
|
935 |
if {![info exists ar(textcols)]} {
|
976 |
if {![info exists ar(textcols)]} {
|
936 |
# puts "_sqlsccolstotexts: no texts"
|
977 |
# puts "_sqlsccolstotexts: no texts"
|
937 |
return
|
978 |
return
|
938 |
}
|
979 |
}
|
939 |
foreach col $ar(textcols) {
|
980 |
foreach col $ar(textcols) {
|
940 |
$ar(window).ff.$col delete 1.0 end
|
981 |
$ar(window).ff.$col delete 1.0 end
|
941 |
$ar(window).ff.$col insert 1.0 $ar(sqlsc_${col}_value)
|
982 |
$ar(window).ff.$col insert 1.0 $ar(sqlsc_${col}_value)
|
942 |
}
|
983 |
}
|
943 |
}
|
984 |
}
|
944 |
# Compute the maximal line. This
|
985 |
# Compute the maximal line. This
|
945 |
# is the max number of cols between "\n"'s. If no \n is found, then
|
986 |
# is the max number of cols between "\n"'s. If no \n is found, then
|
946 |
# there will be one single line or column depending on the "orient"
|
987 |
# there will be one single line or column depending on the "orient"
|
|
... |
|
... |
949 |
upvar #0 $arnm ar
|
990 |
upvar #0 $arnm ar
|
950 |
set len 0
|
991 |
set len 0
|
951 |
set maxlen 0
|
992 |
set maxlen 0
|
952 |
set isnewline 0
|
993 |
set isnewline 0
|
953 |
foreach col $collist {
|
994 |
foreach col $collist {
|
954 |
if {$col == "\n"} {
|
995 |
if {$col == "\n"} {
|
955 |
set isnewline 1
|
996 |
set isnewline 1
|
956 |
set len 0
|
997 |
set len 0
|
957 |
} else {
|
998 |
} else {
|
958 |
if {[_sqlsccolattr ar $col nodisplay]} {
|
999 |
if {[_sqlsccolattr ar $col nodisplay]} {
|
959 |
continue;
|
1000 |
continue;
|
960 |
}
|
1001 |
}
|
961 |
incr len
|
1002 |
incr len
|
962 |
if {$len > $maxlen} {
|
1003 |
if {$len > $maxlen} {
|
963 |
set maxlen $len
|
1004 |
set maxlen $len
|
964 |
}
|
1005 |
}
|
965 |
}
|
1006 |
}
|
966 |
}
|
1007 |
}
|
967 |
if {$isnewline == 0} {
|
1008 |
if {$isnewline == 0} {
|
968 |
set maxlen 0
|
1009 |
set maxlen 0
|
969 |
}
|
1010 |
}
|
970 |
# puts "maxlen: $maxlen"
|
1011 |
# puts "maxlen: $maxlen"
|
971 |
return $maxlen
|
1012 |
return $maxlen
|
972 |
}
|
1013 |
}
|
973 |
|
1014 |
|
|
... |
|
... |
985 |
_sqlscsetconparams ar host user passwd
|
1026 |
_sqlscsetconparams ar host user passwd
|
986 |
set ar(hdl) [tcsqconnect $host $user $passwd]
|
1027 |
set ar(hdl) [tcsqconnect $host $user $passwd]
|
987 |
tcsquse $ar(hdl) $ar(database)
|
1028 |
tcsquse $ar(hdl) $ar(database)
|
988 |
|
1029 |
|
989 |
# puts "--sqlscreen: w: $w, hdl: $ar(hdl) arnm: $arnm, tbl: $ar(table), \
|
1030 |
# puts "--sqlscreen: w: $w, hdl: $ar(hdl) arnm: $arnm, tbl: $ar(table), \
|
990 |
# cols: $ar(columns), orient: \"$orient\"";
|
1031 |
# cols: $ar(columns), orient: \"$orient\"";
|
991 |
set ntables [llength $ar(table)]
|
1032 |
set ntables [llength $ar(table)]
|
992 |
# Non-queryonly screens have more constraints
|
1033 |
# Non-queryonly screens have more constraints
|
993 |
if {[info exists ar(queryonly)] == 0} {
|
1034 |
if {[info exists ar(queryonly)] == 0} {
|
994 |
if {$ntables != 1} {
|
1035 |
if {$ntables != 1} {
|
995 |
return -code error "Multi-table screens must be queryonly"
|
1036 |
return -code error "Multi-table screens must be queryonly"
|
996 |
}
|
1037 |
}
|
997 |
_sqlsccheckserial $arnm
|
1038 |
_sqlsccheckserial $arnm
|
998 |
}
|
1039 |
}
|
999 |
if {$ntables > 1 && ![info exists ar(joinclause)]} {
|
1040 |
if {$ntables > 1 && ![info exists ar(joinclause)]} {
|
1000 |
return -code error \
|
1041 |
return -code error \
|
1001 |
"Multi-table screens must have a joinclause entry"
|
1042 |
"Multi-table screens must have a joinclause entry"
|
1002 |
}
|
1043 |
}
|
1003 |
# Get column type and size info.
|
1044 |
# Get column type and size info.
|
1004 |
foreach table $ar(table) {
|
1045 |
foreach table $ar(table) {
|
1005 |
tcsqcolinfo $ar(hdl) $table ar
|
1046 |
tcsqcolinfo $ar(hdl) $table ar
|
1006 |
}
|
1047 |
}
|
1007 |
# Check: better to have a nice errmes here than fail later
|
1048 |
# Check: better to have a nice errmes here than fail later
|
1008 |
foreach col $ar(columns) {
|
1049 |
foreach col $ar(columns) {
|
1009 |
if {$col == "\n"} {
|
1050 |
if {$col == "\n"} {
|
1010 |
continue
|
1051 |
continue
|
1011 |
}
|
1052 |
}
|
1012 |
if {![info exists ar(sqlsc_${col}_len)]} {
|
1053 |
if {![info exists ar(sqlsc_${col}_len)]} {
|
1013 |
return -code error \
|
1054 |
return -code error \
|
1014 |
"Column $col not found in table(s): $ar(table)"
|
1055 |
"Column $col not found in table(s): $ar(table)"
|
1015 |
}
|
1056 |
}
|
1016 |
}
|
1057 |
}
|
1017 |
frame $w -relief groove -borderwidth 3
|
1058 |
frame $w -relief groove -borderwidth 3
|
1018 |
if {![info exists ar(nobuttons)] && $usecommonbuttons == 0} {
|
1059 |
if {![info exists ar(nobuttons)] && $usecommonbuttons == 0} {
|
1019 |
frame $w.bf
|
1060 |
frame $w.bf
|
1020 |
button $w.bf.query -text "Query" -command "sqlscquery $arnm"
|
1061 |
button $w.bf.query -text "Query" -command "sqlscquery $arnm"
|
1021 |
pack $w.bf.query -side left -fill x -expand yes
|
1062 |
pack $w.bf.query -side left -fill x -expand yes
|
1022 |
button $w.bf.next -text "Next" -command "sqlscnext $arnm"
|
1063 |
button $w.bf.next -text "Next" -command "sqlscnext $arnm"
|
1023 |
pack $w.bf.next -side left -fill x -expand yes
|
1064 |
pack $w.bf.next -side left -fill x -expand yes
|
1024 |
button $w.bf.rew -text "Rewind" -command "sqlscreopen $arnm"
|
1065 |
button $w.bf.rew -text "Rewind" -command "sqlscreopen $arnm"
|
1025 |
pack $w.bf.rew -side left -fill x -expand yes
|
1066 |
pack $w.bf.rew -side left -fill x -expand yes
|
1026 |
button $w.bf.reset -text "Reset" -command "sqlscreset $arnm"
|
1067 |
button $w.bf.reset -text "Reset" -command "sqlscreset $arnm"
|
1027 |
pack $w.bf.reset -side left -fill x -expand yes
|
1068 |
pack $w.bf.reset -side left -fill x -expand yes
|
1028 |
if {[info exists ar(queryonly)] == 0} {
|
1069 |
if {[info exists ar(queryonly)] == 0} {
|
1029 |
if {![info exists ar(noaddbutton)]} {
|
1070 |
if {![info exists ar(noaddbutton)]} {
|
1030 |
button $w.bf.add -text "Add" -command "sqlscinsert $arnm"
|
1071 |
button $w.bf.add -text "Add" -command "sqlscinsert $arnm"
|
1031 |
pack $w.bf.add -side left -fill x -expand yes
|
1072 |
pack $w.bf.add -side left -fill x -expand yes
|
1032 |
}
|
1073 |
}
|
1033 |
if {![info exists ar(noupdbutton)] && [_sqlscisupdidx $arnm]} {
|
1074 |
if {![info exists ar(noupdbutton)] && [_sqlscisupdidx $arnm]} {
|
1034 |
button $w.bf.upd -text "Update" -command "sqlscupd $arnm"
|
1075 |
button $w.bf.upd -text "Update" -command "sqlscupd $arnm"
|
1035 |
pack $w.bf.upd -side left -fill x -expand yes
|
1076 |
pack $w.bf.upd -side left -fill x -expand yes
|
1036 |
}
|
1077 |
}
|
1037 |
if {[info exists ar(allowdelete)]} {
|
1078 |
if {[info exists ar(allowdelete)]} {
|
1038 |
button $w.bf.del -text "Delete" -command "sqlscdelete $arnm"
|
1079 |
button $w.bf.del -text "Delete" -command "sqlscdelete $arnm"
|
1039 |
pack $w.bf.del -side left -fill x -expand yes
|
1080 |
pack $w.bf.del -side left -fill x -expand yes
|
1040 |
}
|
1081 |
}
|
1041 |
}
|
1082 |
}
|
1042 |
pack $w.bf -side top -fill both -expand yes
|
1083 |
pack $w.bf -side top -fill both -expand yes
|
1043 |
}
|
1084 |
}
|
1044 |
|
1085 |
|
1045 |
if {[info exists ar(notitle)] == 0} {
|
1086 |
if {[info exists ar(notitle)] == 0} {
|
1046 |
set title "$arnm"
|
1087 |
set title "$arnm"
|
|
... |
|
... |
1049 |
}
|
1090 |
}
|
1050 |
|
1091 |
|
1051 |
# Compute label max width to align fields
|
1092 |
# Compute label max width to align fields
|
1052 |
set maxlab 0
|
1093 |
set maxlab 0
|
1053 |
foreach col $ar(columns) {
|
1094 |
foreach col $ar(columns) {
|
1054 |
set len [string length $col]
|
1095 |
set len [string length $col]
|
1055 |
if {$maxlab < $len} {
|
1096 |
if {$maxlab < $len} {
|
1056 |
set maxlab $len
|
1097 |
set maxlab $len
|
1057 |
}
|
1098 |
}
|
1058 |
}
|
1099 |
}
|
1059 |
|
1100 |
|
1060 |
# At least: The fields subscreen
|
1101 |
# At least: The fields subscreen
|
1061 |
frame $w.ff -relief groove -borderwidth 0
|
1102 |
frame $w.ff -relief groove -borderwidth 0
|
1062 |
pack $w.ff -side top -expand 1 -fill both
|
1103 |
pack $w.ff -side top -expand 1 -fill both
|
|
... |
|
... |
1065 |
set x 0
|
1106 |
set x 0
|
1066 |
set y 0
|
1107 |
set y 0
|
1067 |
set maxll [_sqlsccomputelinelen $arnm $ar(columns)]
|
1108 |
set maxll [_sqlsccomputelinelen $arnm $ar(columns)]
|
1068 |
# puts "maxll: $maxll"
|
1109 |
# puts "maxll: $maxll"
|
1069 |
if {$maxll != 0} {
|
1110 |
if {$maxll != 0} {
|
1070 |
set orient "explicit"
|
1111 |
set orient "explicit"
|
1071 |
}
|
1112 |
}
|
1072 |
foreach col $ar(columns) {
|
1113 |
foreach col $ar(columns) {
|
1073 |
# Handle "pseudo columns" things in the list that give placement
|
1114 |
# Handle "pseudo columns" things in the list that give placement
|
1074 |
# indications
|
1115 |
# indications
|
1075 |
if {$col == "\n"} {
|
1116 |
if {$col == "\n"} {
|
1076 |
# orient must be "explicit". If there are less columns
|
1117 |
# orient must be "explicit". If there are less columns
|
1077 |
# than in the longest line, make the last window span
|
1118 |
# than in the longest line, make the last window span
|
1078 |
# the remaining columns
|
1119 |
# the remaining columns
|
1079 |
if {$x < $maxll} {
|
1120 |
if {$x < $maxll} {
|
1080 |
for {} {$x < $maxll} {incr x} {
|
1121 |
for {} {$x < $maxll} {incr x} {
|
1081 |
# puts "$arnm: maxll $maxll, x $x, Spanning"
|
1122 |
# puts "$arnm: maxll $maxll, x $x, Spanning"
|
1082 |
grid configure $prev -
|
1123 |
grid configure $prev -
|
1083 |
}
|
1124 |
}
|
1084 |
}
|
1125 |
}
|
1085 |
incr y
|
1126 |
incr y
|
1086 |
set x 0
|
1127 |
set x 0
|
1087 |
continue
|
1128 |
continue
|
1088 |
}
|
1129 |
}
|
1089 |
# Make a list of "real" columns
|
1130 |
# Make a list of "real" columns
|
1090 |
lappend realcols $col
|
1131 |
lappend realcols $col
|
1091 |
|
1132 |
|
1092 |
# For some reason the variable needs to exist for _sqlsclablabel
|
1133 |
# For some reason the variable needs to exist for _sqlsclablabel
|
1093 |
if {![info exists ar(sqlsc_${col}_value)]} {
|
1134 |
if {![info exists ar(sqlsc_${col}_value)]} {
|
1094 |
set ar(sqlsc_${col}_value) ""
|
1135 |
set ar(sqlsc_${col}_value) ""
|
1095 |
}
|
1136 |
}
|
1096 |
if {$sqlsc_names_compat_old} {
|
1137 |
if {$sqlsc_names_compat_old} {
|
1097 |
# Note that TCL is smart enough to avoid trace loops
|
1138 |
# Note that TCL is smart enough to avoid trace loops
|
1098 |
trace variable ar(sqlsc_${col}_value) w _sqlscsetoldname
|
1139 |
trace variable ar(sqlsc_${col}_value) w _sqlscsetoldname
|
1099 |
trace variable ar(${col}) w _sqlscsetnewname
|
1140 |
trace variable ar(${col}) w _sqlscsetnewname
|
1100 |
}
|
1141 |
}
|
1101 |
if {[_sqlsccolattr ar $col nodisplay]} {
|
1142 |
if {[_sqlsccolattr ar $col nodisplay]} {
|
1102 |
continue;
|
1143 |
continue;
|
1103 |
}
|
1144 |
}
|
1104 |
# subwin name: there could be dots in the column name if it's
|
1145 |
# subwin name: there could be dots in the column name if it's
|
1105 |
# fully qualified. We replace them. This might create a collision
|
1146 |
# fully qualified. We replace them. This might create a collision
|
1106 |
# in names in very rare cases, (if there is a tabxx.colyy and
|
1147 |
# in names in very rare cases, (if there is a tabxx.colyy and
|
1107 |
# an unqualified column named tabxx_colyy), but this seems a remote
|
1148 |
# an unqualified column named tabxx_colyy), but this seems a remote
|
1108 |
# possibility
|
1149 |
# possibility
|
1109 |
regsub {\.} $col _ colw
|
1150 |
regsub {\.} $col _ colw
|
1110 |
set sw $w.ff.$colw
|
1151 |
set sw $w.ff.$colw
|
1111 |
|
1152 |
|
1112 |
if {[info exists ar(initfocus)] && $col == $ar(initfocus)} {
|
1153 |
if {[info exists ar(initfocus)] && $col == $ar(initfocus)} {
|
1113 |
set ar(sqlsc_initfocus_win) $sw.ent
|
1154 |
set ar(sqlsc_initfocus_win) $sw.ent
|
1114 |
}
|
1155 |
}
|
1115 |
|
1156 |
|
1116 |
# Label widths. Might be possible to gain some space by using
|
1157 |
# Label widths. Might be possible to gain some space by using
|
1117 |
# the actual lengths rather than the max in some cases, but this
|
1158 |
# the actual lengths rather than the max in some cases, but this
|
1118 |
# really does not look good
|
1159 |
# really does not look good
|
1119 |
# if {wantopack} {
|
1160 |
# if {wantopack} {
|
1120 |
# set labw [string length $col]
|
1161 |
# set labw [string length $col]
|
1121 |
# } else {
|
1162 |
# } else {
|
|
|
1163 |
# set labw $maxlab
|
|
|
1164 |
# }
|
1122 |
# set labw $maxlab
|
1165 |
set labw $maxlab
|
1123 |
# }
|
|
|
1124 |
set labw $maxlab
|
|
|
1125 |
set varnm ${arnm}(sqlsc_${col}_value)
|
1166 |
set varnm ${arnm}(sqlsc_${col}_value)
|
1126 |
set wwidth $ar(sqlsc_${col}_len)
|
1167 |
set wwidth $ar(sqlsc_${col}_len)
|
1127 |
if {[_sqlsccolattr ar $col noentry]} {
|
1168 |
if {[_sqlsccolattr ar $col noentry]} {
|
1128 |
_sqlsclablabel $sw $col $labw $varnm $wwidth
|
1169 |
_sqlsclablabel $sw $col $labw $varnm $wwidth
|
1129 |
} elseif {[_sqlsccolattr ar $col textcols]} {
|
1170 |
} elseif {[_sqlsccolattr ar $col textcols]} {
|
1130 |
set idx [lsearch $ar(textcols) $col]
|
1171 |
set idx [lsearch $ar(textcols) $col]
|
1131 |
text $sw -width [lindex $ar(textwidths) $idx] \
|
1172 |
_sqlsclabtext $sw $col $labw [lindex $ar(textwidths) $idx] \
|
1132 |
-height [lindex $ar(textheights) $idx]
|
1173 |
[lindex $ar(textheights) $idx] [lindex $ar(textopts) $idx]
|
1133 |
} elseif {[_sqlsccolattr ar $col choices] ||
|
1174 |
} elseif {[_sqlsccolattr ar $col choices] ||
|
1134 |
[info exists ar(sqlsc_${col}_dbchoices)]} {
|
1175 |
[info exists ar(sqlsc_${col}_dbchoices)]} {
|
1135 |
# Note that we give priority to the user's list over the
|
1176 |
# Note that we give priority to the user's list over the
|
1136 |
# database's. Especially this allows setting display
|
1177 |
# database's. Especially this allows setting display
|
1137 |
# values different from column values.
|
1178 |
# values different from column values.
|
1138 |
if {[_sqlsccolattr ar $col choices]} {
|
1179 |
if {[_sqlsccolattr ar $col choices]} {
|
1139 |
# List name comes right after column name
|
1180 |
# List name comes right after column name
|
1140 |
set ind [expr {[lsearch $ar(choices) $col] + 1}]
|
1181 |
set ind [expr {[lsearch $ar(choices) $col] + 1}]
|
1141 |
set choicelistname [lindex $ar(choices) $ind]
|
1182 |
set choicelistname [lindex $ar(choices) $ind]
|
1142 |
} else {
|
1183 |
} else {
|
1143 |
set choicelistname ${arnm}(sqlsc_${col}_dbchoices)
|
1184 |
set choicelistname ${arnm}(sqlsc_${col}_dbchoices)
|
1144 |
}
|
1185 |
}
|
1145 |
set width [_compchoicewidth $choicelistname]
|
1186 |
set width [_compchoicewidth $choicelistname]
|
1146 |
upvar #0 $choicelistname ch
|
1187 |
upvar #0 $choicelistname ch
|
1147 |
_sqlsclabmenu $sw $col $labw $varnm $width $ch
|
1188 |
_sqlsclabmenu $sw $col $labw $varnm $width $ch
|
1148 |
} else {
|
1189 |
} else {
|
|
|
1190 |
set maxlen $ar(sqlsc_${col}_dblen)
|
1149 |
_sqlsclabentry $sw $col $labw $varnm $wwidth
|
1191 |
_sqlsclabentry $sw $col $labw $varnm $wwidth 0 $maxlen
|
1150 |
if {![info exists firstent]} {
|
1192 |
if {![info exists firstent]} {
|
1151 |
set firstent $sw
|
1193 |
set firstent $sw
|
1152 |
}
|
1194 |
}
|
1153 |
if {$prev_ent != ""} {
|
1195 |
if {$prev_ent != ""} {
|
1154 |
_sqlcbindentrynext $prev_ent $sw $arnm
|
1196 |
_sqlcbindentrynext $prev_ent $sw $arnm
|
1155 |
}
|
1197 |
}
|
1156 |
bind $sw.ent <FocusIn> "set focusarrayname $arnm"
|
1198 |
bind $sw.ent <FocusIn> "set focusarrayname $arnm"
|
1157 |
bind $sw.ent <FocusOut> "set focusarrayname {}"
|
1199 |
bind $sw.ent <FocusOut> "set focusarrayname {}"
|
1158 |
if {[info exists ar(queryonly)] == 0} {
|
1200 |
if {[info exists ar(queryonly)] == 0} {
|
1159 |
bind $sw.ent <Escape>a "sqlscinsert $arnm;break"
|
1201 |
bind $sw.ent <Escape>a "sqlscinsert $arnm;break"
|
1160 |
bind $sw.ent <Escape>u "sqlscupd $arnm;break"
|
1202 |
bind $sw.ent <Escape>u "sqlscupd $arnm;break"
|
1161 |
}
|
1203 |
}
|
1162 |
bind $sw.ent <Escape>n "sqlscnext $arnm;break"
|
1204 |
bind $sw.ent <Escape>n "sqlscnext $arnm;break"
|
1163 |
bind $sw.ent <Escape>r "sqlscreopen $arnm;break"
|
1205 |
bind $sw.ent <Escape>r "sqlscreopen $arnm;break"
|
1164 |
bind $sw.ent <Escape>w "sqlscreset $arnm;break"
|
1206 |
bind $sw.ent <Escape>w "sqlscreset $arnm;break"
|
1165 |
set prev_ent $sw
|
1207 |
set prev_ent $sw
|
1166 |
}
|
1208 |
}
|
1167 |
set prev $sw
|
1209 |
set prev $sw
|
1168 |
grid $sw -sticky w -column $x -row $y
|
1210 |
grid $sw -sticky w -column $x -row $y
|
1169 |
if {$orient == "v"} {
|
1211 |
if {$orient == "v"} {
|
1170 |
incr y
|
1212 |
incr y
|
1171 |
} else {
|
1213 |
} else {
|
1172 |
incr x
|
1214 |
incr x
|
1173 |
}
|
1215 |
}
|
1174 |
# We sure could make less of these little effort
|
1216 |
# We sure could make less of these little effort
|
1175 |
grid rowconfigure $w.ff $y -weight 1
|
1217 |
grid rowconfigure $w.ff $y -weight 1
|
1176 |
grid columnconfigure $w.ff $x -weight 1
|
1218 |
grid columnconfigure $w.ff $x -weight 1
|
1177 |
}
|
1219 |
}
|
1178 |
# Replace column list with the one with the "\n" deleted
|
1220 |
# Replace column list with the one with the "\n" deleted
|
1179 |
set ar(columns) $realcols
|
1221 |
set ar(columns) $realcols
|
1180 |
# Bind next of last to first entry
|
1222 |
# Bind next of last to first entry
|
1181 |
if {$prev_ent != ""} {
|
1223 |
if {$prev_ent != ""} {
|
1182 |
_sqlcbindentrynext $prev_ent $firstent $arnm
|
1224 |
_sqlcbindentrynext $prev_ent $firstent $arnm
|
1183 |
}
|
1225 |
}
|
1184 |
pack $w -expand 1 -fill both
|
1226 |
pack $w -expand 1 -fill both
|
1185 |
|
1227 |
|
1186 |
# Do we have to create an associated list for query results ?
|
1228 |
# Do we have to create an associated list for query results ?
|
1187 |
if {[info exists ar(list_columns)]} {
|
1229 |
if {[info exists ar(list_columns)]} {
|
1188 |
sqlist $arnm
|
1230 |
sqlist $arnm
|
1189 |
}
|
1231 |
}
|
1190 |
}
|
1232 |
}
|
1191 |
|
1233 |
|
1192 |
#####################################################################
|
1234 |
#####################################################################
|
1193 |
# "List" screen:
|
1235 |
# "List" screen:
|
|
... |
|
... |
1205 |
proc sqlist {arnm} {
|
1247 |
proc sqlist {arnm} {
|
1206 |
upvar #0 $arnm ar
|
1248 |
upvar #0 $arnm ar
|
1207 |
global sqlsc_def_maxlen
|
1249 |
global sqlsc_def_maxlen
|
1208 |
|
1250 |
|
1209 |
if {[info exists ar(list_columns)]} {
|
1251 |
if {[info exists ar(list_columns)]} {
|
1210 |
# We're actually part of an sqlscreen
|
1252 |
# We're actually part of an sqlscreen
|
1211 |
set w $ar(list_window)
|
1253 |
set w $ar(list_window)
|
1212 |
if {![_sqlscisupdidx $arnm]} {
|
1254 |
if {![_sqlscisupdidx $arnm]} {
|
1213 |
return -code error "slave list: need an updateindex to \
|
1255 |
return -code error "slave list: need an updateindex to \
|
1214 |
link back to the main screen"
|
1256 |
link back to the main screen"
|
1215 |
}
|
1257 |
}
|
1216 |
foreach col $ar(updateindex) {
|
1258 |
foreach col $ar(updateindex) {
|
1217 |
if {[lsearch $ar(list_columns) $col] == -1} {
|
1259 |
if {[lsearch $ar(list_columns) $col] == -1} {
|
1218 |
return -code error "slave list: column $col is in
|
1260 |
return -code error "slave list: column $col is in
|
1219 |
updateindex, should be listed in list_columns"
|
1261 |
updateindex, should be listed in list_columns"
|
|
|
1262 |
}
|
1220 |
}
|
1263 |
}
|
1221 |
}
|
|
|
1222 |
set collist $ar(list_columns)
|
1264 |
set collist $ar(list_columns)
|
1223 |
} else {
|
1265 |
} else {
|
1224 |
# We're an independant screen
|
1266 |
# We're an independant screen
|
1225 |
# Indicate that this is a list (used at least by the screen
|
1267 |
# Indicate that this is a list (used at least by the screen
|
1226 |
# linking code)
|
1268 |
# linking code)
|
1227 |
set w $ar(window)
|
1269 |
set w $ar(window)
|
1228 |
set ar(isalist) ""
|
1270 |
set ar(isalist) ""
|
1229 |
_sqlscsetconparams ar host user passwd
|
1271 |
_sqlscsetconparams ar host user passwd
|
1230 |
set ar(hdl) [tcsqconnect $host $user $passwd]
|
1272 |
set ar(hdl) [tcsqconnect $host $user $passwd]
|
1231 |
tcsquse $ar(hdl) $ar(database)
|
1273 |
tcsquse $ar(hdl) $ar(database)
|
1232 |
foreach table $ar(table) {
|
1274 |
foreach table $ar(table) {
|
1233 |
tcsqcolinfo $ar(hdl) $table ar
|
1275 |
tcsqcolinfo $ar(hdl) $table ar
|
1234 |
}
|
1276 |
}
|
1235 |
set collist $ar(columns)
|
1277 |
set collist $ar(columns)
|
1236 |
# puts "Collist: $collist"
|
1278 |
# puts "Collist: $collist"
|
1237 |
}
|
1279 |
}
|
1238 |
|
1280 |
|
1239 |
# Compute columns and window widths in characters units
|
1281 |
# Compute columns and window widths in characters units
|
1240 |
# puts "sqlsc_def_maxlen: $sqlsc_def_maxlen"
|
1282 |
# puts "sqlsc_def_maxlen: $sqlsc_def_maxlen"
|
1241 |
set ww [expr {2 * $sqlsc_def_maxlen}]
|
1283 |
set ww [expr {2 * $sqlsc_def_maxlen}]
|
1242 |
set width 0
|
1284 |
set width 0
|
1243 |
if {[info exists ar(list_colwidths)]} {
|
1285 |
if {[info exists ar(list_colwidths)]} {
|
1244 |
set widthlist $ar(list_colwidths)
|
1286 |
set widthlist $ar(list_colwidths)
|
1245 |
} else {
|
1287 |
} else {
|
1246 |
set widthlist {}
|
1288 |
set widthlist {}
|
1247 |
}
|
1289 |
}
|
1248 |
foreach col $collist colwidth $widthlist {
|
1290 |
foreach col $collist colwidth $widthlist {
|
1249 |
# Create the value entry. This avoids using "info exists"
|
1291 |
# Create the value entry. This avoids using "info exists"
|
1250 |
# all over the place
|
1292 |
# all over the place
|
1251 |
if {![info exists ar(sqlsc_${col}_value)]} {
|
1293 |
if {![info exists ar(sqlsc_${col}_value)]} {
|
1252 |
set ar(sqlsc_${col}_value) ""
|
1294 |
set ar(sqlsc_${col}_value) ""
|
1253 |
}
|
1295 |
}
|
1254 |
if {$colwidth != ""} {
|
1296 |
if {$colwidth != ""} {
|
1255 |
set cw [expr {$colwidth + 3}]
|
1297 |
set cw [expr {$colwidth + 3}]
|
1256 |
} else {
|
1298 |
} else {
|
1257 |
set cw [expr {$ar(sqlsc_${col}_len) + 3}]
|
1299 |
set cw [expr {$ar(sqlsc_${col}_len) + 3}]
|
1258 |
}
|
1300 |
}
|
1259 |
lappend tabs $cw
|
1301 |
lappend tabs $cw
|
1260 |
incr width $cw
|
1302 |
incr width $cw
|
1261 |
if {$width > $ww} {
|
1303 |
if {$width > $ww} {
|
1262 |
set width $ww
|
1304 |
set width $ww
|
1263 |
# Don't stop the loop: need to set the values to ""
|
1305 |
# Don't stop the loop: need to set the values to ""
|
1264 |
}
|
1306 |
}
|
1265 |
}
|
1307 |
}
|
1266 |
# puts "text width $width"
|
1308 |
# puts "text width $width"
|
1267 |
frame $w -relief groove -borderwidth 3
|
1309 |
frame $w -relief groove -borderwidth 3
|
1268 |
set title "$ar(table)"
|
1310 |
set title "$ar(table)"
|
1269 |
if {[info exists ar(lines)]} {
|
1311 |
if {[info exists ar(lines)]} {
|
1270 |
set lines $ar(lines)
|
1312 |
set lines $ar(lines)
|
1271 |
} else {
|
1313 |
} else {
|
1272 |
set lines 15
|
1314 |
set lines 15
|
1273 |
}
|
1315 |
}
|
1274 |
# Create the list window elements:
|
1316 |
# Create the list window elements:
|
1275 |
# - a message at the top for the table list
|
1317 |
# - a message at the top for the table list
|
1276 |
# - a text for the column headings
|
1318 |
# - a text for the column headings
|
1277 |
# - a text and a scrollbar for displaying the actual rows
|
1319 |
# - a text and a scrollbar for displaying the actual rows
|
1278 |
message $w.tabnm -text $title -width 3i
|
1320 |
message $w.tabnm -text $title -width 3i
|
1279 |
text $w.collist -setgrid 1 -width $width -height 1 -wrap none \
|
1321 |
text $w.collist -setgrid 1 -width $width -height 1 -wrap none \
|
1280 |
-relief flat
|
1322 |
-relief flat
|
1281 |
$w.collist insert end [_sqlsclisttotabbedlist $collist]
|
1323 |
$w.collist insert end [_sqlsclisttotabbedlist $collist]
|
1282 |
|
1324 |
|
1283 |
# Create and set bold font from default font for this window.
|
1325 |
# Create and set bold font from default font for this window.
|
1284 |
# There doesn't appear to be any easy way to do this. Note
|
1326 |
# There doesn't appear to be any easy way to do this. Note
|
1285 |
# that if the current font is a named font or if tk returns an X11
|
1327 |
# that if the current font is a named font or if tk returns an X11
|
|
... |
|
... |
1287 |
# It seems that v8.0 sometimes returns an XLFD, but will accept a
|
1329 |
# It seems that v8.0 sometimes returns an XLFD, but will accept a
|
1288 |
# {family size {styles}}. v7.6 only returns and accepts XLFDs of
|
1330 |
# {family size {styles}}. v7.6 only returns and accepts XLFDs of
|
1289 |
# course.
|
1331 |
# course.
|
1290 |
set fna [$w.collist cget -font]
|
1332 |
set fna [$w.collist cget -font]
|
1291 |
if {[llength $fna] != 2} {
|
1333 |
if {[llength $fna] != 2} {
|
1292 |
set family Courier
|
1334 |
set family Courier
|
1293 |
set size 12
|
1335 |
set size 12
|
1294 |
} else {
|
1336 |
} else {
|
1295 |
set family [lindex $fna 0]
|
1337 |
set family [lindex $fna 0]
|
1296 |
set size [lindex $fna 1]
|
1338 |
set size [lindex $fna 1]
|
1297 |
}
|
1339 |
}
|
1298 |
# puts "Family: $family, size: $size"
|
1340 |
# puts "Family: $family, size: $size"
|
1299 |
if {[info commands font] != ""} {
|
1341 |
if {[info commands font] != ""} {
|
1300 |
set fn [font create -family $family -size $size]
|
1342 |
set fn [font create -family $family -size $size]
|
1301 |
font configure $fn -weight bold
|
1343 |
font configure $fn -weight bold
|
1302 |
$w.collist configure -font $fn -state disabled
|
1344 |
$w.collist configure -font $fn -state disabled
|
1303 |
} else {
|
1345 |
} else {
|
1304 |
# Have to choose a font
|
1346 |
# Have to choose a font
|
1305 |
# puts "Choosing font myself (courier-bold-r-normal-*-12-*)"
|
1347 |
# puts "Choosing font myself (courier-bold-r-normal-*-12-*)"
|
1306 |
$w.collist configure -font "-*-courier-bold-r-normal-*-12-*"
|
1348 |
$w.collist configure -font "-*-courier-bold-r-normal-*-12-*"
|
1307 |
}
|
1349 |
}
|
1308 |
|
1350 |
|
1309 |
scrollbar $w.scroll -relief sunken -command "$w.list yview"
|
1351 |
scrollbar $w.scroll -relief sunken -command "$w.list yview"
|
1310 |
# set textfont fixed -font $textfont
|
1352 |
# set textfont fixed -font $textfont
|
1311 |
text $w.list -setgrid 1 -yscroll "$w.scroll set" -relief sunken \
|
1353 |
text $w.list -setgrid 1 -yscroll "$w.scroll set" -relief sunken \
|
1312 |
-width $width -height $lines -wrap none
|
1354 |
-width $width -height $lines -wrap none
|
1313 |
|
1355 |
|
1314 |
# Compute and set the tab stops according to the font and columns widths
|
1356 |
# Compute and set the tab stops according to the font and columns widths
|
1315 |
for {set i 0} {$i < 100} {incr i} {append big0 "0000000000"}
|
1357 |
for {set i 0} {$i < 100} {incr i} {append big0 "0000000000"}
|
1316 |
set ll [llength $tabs]
|
1358 |
set ll [llength $tabs]
|
1317 |
set curpos 0
|
1359 |
set curpos 0
|
1318 |
set isfontcmd [expr {[info commands font] != ""}]
|
1360 |
set isfontcmd [expr {[info commands font] != ""}]
|
1319 |
for {set i 0} {$i < $ll} {incr i} {
|
1361 |
for {set i 0} {$i < $ll} {incr i} {
|
1320 |
if {$isfontcmd} {
|
1362 |
if {$isfontcmd} {
|
1321 |
# puts "--Using the font command"
|
1363 |
# puts "--Using the font command"
|
1322 |
set curpos [expr {$curpos + [font measure [$w.list cget -font] \
|
1364 |
set curpos [expr {$curpos + [font measure [$w.list cget -font] \
|
1323 |
[string range $big0 0 [lindex $tabs $i]]]}]
|
1365 |
[string range $big0 0 [lindex $tabs $i]]]}]
|
1324 |
} else {
|
1366 |
} else {
|
1325 |
# Assuming this is 12 points
|
1367 |
# Assuming this is 12 points
|
1326 |
# puts "--No font command, approximating tabs"
|
1368 |
# puts "--No font command, approximating tabs"
|
1327 |
set curpos [expr {$curpos + [expr {[lindex $tabs $i] * 7.2}]}]
|
1369 |
set curpos [expr {$curpos + [expr {[lindex $tabs $i] * 7.2}]}]
|
1328 |
}
|
1370 |
}
|
1329 |
lappend ntabs [expr {int($curpos)}]
|
1371 |
lappend ntabs [expr {int($curpos)}]
|
1330 |
}
|
1372 |
}
|
1331 |
# puts "char width lists: $tabs"; puts "Tabs list: $ntabs"
|
1373 |
# puts "char width lists: $tabs"; puts "Tabs list: $ntabs"
|
1332 |
$w.collist configure -tabs $ntabs
|
1374 |
$w.collist configure -tabs $ntabs
|
1333 |
$w.list configure -tabs $ntabs
|
1375 |
$w.list configure -tabs $ntabs
|
1334 |
|
1376 |
|
|
... |
|
... |
1355 |
# much nicer than the current solution...
|
1397 |
# much nicer than the current solution...
|
1356 |
proc _sqlsclisttotabbedlist {l} {
|
1398 |
proc _sqlsclisttotabbedlist {l} {
|
1357 |
# Note : NO blanks in our element!
|
1399 |
# Note : NO blanks in our element!
|
1358 |
set myboguslistelt "___sqlsc_bogus_sqlsc___"
|
1400 |
set myboguslistelt "___sqlsc_bogus_sqlsc___"
|
1359 |
foreach elt $l {
|
1401 |
foreach elt $l {
|
1360 |
lappend out [string trim $elt] $myboguslistelt
|
1402 |
lappend out [string trim $elt] $myboguslistelt
|
1361 |
}
|
1403 |
}
|
1362 |
regsub -all " *$myboguslistelt *" $out "\t" out
|
1404 |
regsub -all " *$myboguslistelt *" $out "\t" out
|
1363 |
# puts "listtotabbedlist: '$out'"
|
1405 |
# puts "listtotabbedlist: '$out'"
|
1364 |
return $out
|
1406 |
return $out
|
1365 |
}
|
1407 |
}
|
|
... |
|
... |
1368 |
# independant search screen or part of an sqlscreen
|
1410 |
# independant search screen or part of an sqlscreen
|
1369 |
proc sqlistquery {arnm {opt ""}} {
|
1411 |
proc sqlistquery {arnm {opt ""}} {
|
1370 |
upvar #0 $arnm ar
|
1412 |
upvar #0 $arnm ar
|
1371 |
# puts "sqlistquery $arnm";flush stdout
|
1413 |
# puts "sqlistquery $arnm";flush stdout
|
1372 |
if {[info exists ar(list_window)]} {
|
1414 |
if {[info exists ar(list_window)]} {
|
1373 |
set w $ar(list_window)
|
1415 |
set w $ar(list_window)
|
1374 |
} else {
|
1416 |
} else {
|
1375 |
set w $ar(window)
|
1417 |
set w $ar(window)
|
1376 |
}
|
1418 |
}
|
1377 |
|
1419 |
|
1378 |
$w.list configure -state normal
|
1420 |
$w.list configure -state normal
|
1379 |
$w.list delete 1.0 end
|
1421 |
$w.list delete 1.0 end
|
1380 |
if {$opt == "reset"} {
|
1422 |
if {$opt == "reset"} {
|
1381 |
return
|
1423 |
return
|
1382 |
}
|
1424 |
}
|
1383 |
if {![info exists ar(querynum)]} {
|
1425 |
if {![info exists ar(querynum)]} {
|
1384 |
# Independant screen
|
1426 |
# Independant screen
|
1385 |
set txt [_sqlscbuildselect ar]
|
1427 |
set txt [_sqlscbuildselect ar]
|
1386 |
# We don't run the select if there is no where clause (no valueset)
|
1428 |
# We don't run the select if there is no where clause (no valueset)
|
1387 |
if {[string match "* where *" $txt] == 0} {
|
1429 |
if {[string match "* where *" $txt] == 0} {
|
1388 |
return
|
1430 |
return
|
1389 |
}
|
1431 |
}
|
1390 |
_sqlsclogstmt $txt
|
1432 |
_sqlsclogstmt $txt
|
1391 |
set ar(querynum) [tcsqopensel $ar(hdl) $txt]
|
1433 |
set ar(querynum) [tcsqopensel $ar(hdl) $txt]
|
1392 |
_sqlsclogcommit
|
1434 |
_sqlsclogcommit
|
1393 |
set needunsetquery 1
|
1435 |
set needunsetquery 1
|
1394 |
} else {
|
1436 |
} else {
|
1395 |
# Part of an sqlscreen
|
1437 |
# Part of an sqlscreen
|
1396 |
tcsqrew $ar(querynum)
|
1438 |
tcsqrew $ar(querynum)
|
1397 |
set needunsetquery 0
|
1439 |
set needunsetquery 0
|
1398 |
# Indexes of list-columns in whole column list
|
1440 |
# Indexes of list-columns in whole column list
|
1399 |
foreach col $ar(list_columns) {
|
1441 |
foreach col $ar(list_columns) {
|
1400 |
lappend idxs [lsearch $ar(columns) $col]
|
1442 |
lappend idxs [lsearch $ar(columns) $col]
|
1401 |
}
|
1443 |
}
|
1402 |
}
|
1444 |
}
|
1403 |
set lnum 1
|
1445 |
set lnum 1
|
1404 |
while {[set rs [tcsqnext $ar(querynum)]] != ""} {
|
1446 |
while {[set rs [tcsqnext $ar(querynum)]] != ""} {
|
1405 |
if {[info exists idxs]} {
|
1447 |
if {[info exists idxs]} {
|
1406 |
set lst {}
|
1448 |
set lst {}
|
1407 |
foreach idx $idxs {
|
1449 |
foreach idx $idxs {
|
1408 |
lappend lst [lindex $rs $idx]
|
1450 |
lappend lst [lindex $rs $idx]
|
1409 |
}
|
1451 |
}
|
1410 |
set tag $w.list_sqlsctag$lnum
|
1452 |
set tag $w.list_sqlsctag$lnum
|
1411 |
$w.list insert end "[_sqlsclisttotabbedlist $lst]\n" $tag
|
1453 |
$w.list insert end "[_sqlsclisttotabbedlist $lst]\n" $tag
|
1412 |
$w.list tag bind $tag <1> \
|
1454 |
$w.list tag bind $tag <1> \
|
1413 |
"_sqslavelistdetailfromtag $w.list $arnm $tag"
|
1455 |
"_sqslavelistdetailfromtag $w.list $arnm $tag"
|
1414 |
# Give the application a chance to set the properties for
|
1456 |
# Give the application a chance to set the properties for
|
1415 |
# this line
|
1457 |
# this line
|
1416 |
if {[info exists ar(list_lineproc)]} {
|
1458 |
if {[info exists ar(list_lineproc)]} {
|
1417 |
uplevel #0 [list $ar(list_lineproc) $w.list $tag $lst]
|
1459 |
uplevel #0 [list $ar(list_lineproc) $w.list $tag $lst]
|
1418 |
} else {
|
1460 |
} else {
|
1419 |
# Alternate grey/white to help reading
|
1461 |
# Alternate grey/white to help reading
|
1420 |
set bgcolor [expr {($lnum & 1) ? "white" : "grey75"}]
|
1462 |
set bgcolor [expr {($lnum & 1) ? "white" : "grey75"}]
|
1421 |
$w.list tag configure $tag -background $bgcolor
|
1463 |
$w.list tag configure $tag -background $bgcolor
|
1422 |
}
|
1464 |
}
|
1423 |
} else {
|
1465 |
} else {
|
1424 |
$w.list insert end "[_sqlsclisttotabbedlist $rs]\n"
|
1466 |
$w.list insert end "[_sqlsclisttotabbedlist $rs]\n"
|
1425 |
}
|
1467 |
}
|
1426 |
incr lnum
|
1468 |
incr lnum
|
1427 |
}
|
1469 |
}
|
1428 |
# Reset current entry if it exists
|
1470 |
# Reset current entry if it exists
|
1429 |
if {[info exists ar(list_curtag)]} {
|
1471 |
if {[info exists ar(list_curtag)]} {
|
1430 |
$w.list tag configure $ar(list_curtag) -relief flat -borderwidth 3
|
1472 |
$w.list tag configure $ar(list_curtag) -relief flat -borderwidth 3
|
1431 |
}
|
1473 |
}
|
1432 |
$w.list configure -state disabled
|
1474 |
$w.list configure -state disabled
|
1433 |
if {$needunsetquery} {
|
1475 |
if {$needunsetquery} {
|
1434 |
tcsqclosel $ar(querynum)
|
1476 |
tcsqclosel $ar(querynum)
|
1435 |
unset ar(querynum)
|
1477 |
unset ar(querynum)
|
1436 |
} else {
|
1478 |
} else {
|
1437 |
tcsqrew $ar(querynum)
|
1479 |
tcsqrew $ar(querynum)
|
1438 |
set bid [tcsqnext $ar(querynum)]
|
1480 |
set bid [tcsqnext $ar(querynum)]
|
1439 |
}
|
1481 |
}
|
1440 |
}
|
1482 |
}
|
1441 |
|
1483 |
|
1442 |
# A small helper proc to avoid embedding detailed widget knowledge in
|
1484 |
# A small helper proc to avoid embedding detailed widget knowledge in
|
1443 |
# the main routine linking the list to the detail screen
|
1485 |
# the main routine linking the list to the detail screen
|
|
... |
|
... |
1445 |
upvar #0 $arnm ar
|
1487 |
upvar #0 $arnm ar
|
1446 |
# puts "_sqslavelisdetailfromtag: w $w, arnm $arnm, tag: $tag"
|
1488 |
# puts "_sqslavelisdetailfromtag: w $w, arnm $arnm, tag: $tag"
|
1447 |
set start [lindex [$w tag ranges $tag] 0]
|
1489 |
set start [lindex [$w tag ranges $tag] 0]
|
1448 |
set end [lindex [$w tag ranges $tag] 1]
|
1490 |
set end [lindex [$w tag ranges $tag] 1]
|
1449 |
if {[info exists ar(list_curtag)]} {
|
1491 |
if {[info exists ar(list_curtag)]} {
|
1450 |
#-fgstipple ""
|
1492 |
#-fgstipple ""
|
1451 |
$w tag configure $ar(list_curtag) -relief flat -borderwidth 3
|
1493 |
$w tag configure $ar(list_curtag) -relief flat -borderwidth 3
|
1452 |
}
|
1494 |
}
|
1453 |
set ar(list_curtag) $tag
|
1495 |
set ar(list_curtag) $tag
|
1454 |
# -fgstipple gray50
|
1496 |
# -fgstipple gray50
|
1455 |
$w tag configure $tag -relief sunken -borderwidth 3
|
1497 |
$w tag configure $tag -relief sunken -borderwidth 3
|
1456 |
_sqslavelistdetail $arnm [$w get $start $end]
|
1498 |
_sqslavelistdetail $arnm [$w get $start $end]
|
|
... |
|
... |
1465 |
set ar(inslavelistdetail) ""
|
1507 |
set ar(inslavelistdetail) ""
|
1466 |
# Reset the main screen
|
1508 |
# Reset the main screen
|
1467 |
sqlscreset $arnm
|
1509 |
sqlscreset $arnm
|
1468 |
# Set the updateindex colums
|
1510 |
# Set the updateindex colums
|
1469 |
foreach col $ar(updateindex) {
|
1511 |
foreach col $ar(updateindex) {
|
1470 |
set idx [lsearch $ar(list_columns) $col]
|
1512 |
set idx [lsearch $ar(list_columns) $col]
|
1471 |
set ar(sqlsc_${col}_value) [lindex $line $idx]
|
1513 |
set ar(sqlsc_${col}_value) [lindex $line $idx]
|
1472 |
}
|
1514 |
}
|
1473 |
sqlscquery $arnm
|
1515 |
sqlscquery $arnm
|
1474 |
unset ar(inslavelistdetail)
|
1516 |
unset ar(inslavelistdetail)
|
1475 |
}
|
1517 |
}
|
1476 |
|
1518 |
|
|
... |
|
... |
1497 |
proc _sqlscdolinks {arnm} {
|
1539 |
proc _sqlscdolinks {arnm} {
|
1498 |
upvar #0 $arnm ar
|
1540 |
upvar #0 $arnm ar
|
1499 |
# Avoid loops !
|
1541 |
# Avoid loops !
|
1500 |
set ar(beingmaster) ""
|
1542 |
set ar(beingmaster) ""
|
1501 |
if {[info exists ar(slaves)]} {
|
1543 |
if {[info exists ar(slaves)]} {
|
1502 |
_sqlscdoslaves $arnm
|
1544 |
_sqlscdoslaves $arnm
|
1503 |
}
|
1545 |
}
|
1504 |
if {[info exists ar(masters)]} {
|
1546 |
if {[info exists ar(masters)]} {
|
1505 |
_sqlscdomasters $arnm
|
1547 |
_sqlscdomasters $arnm
|
1506 |
}
|
1548 |
}
|
1507 |
unset ar(beingmaster)
|
1549 |
unset ar(beingmaster)
|
|
... |
|
... |
1512 |
proc _sqlscslavequery {arnm1 col1 arnm2 col2} {
|
1554 |
proc _sqlscslavequery {arnm1 col1 arnm2 col2} {
|
1513 |
upvar #0 $arnm1 ar1
|
1555 |
upvar #0 $arnm1 ar1
|
1514 |
upvar #0 $arnm2 ar2
|
1556 |
upvar #0 $arnm2 ar2
|
1515 |
# puts "sqlscslavequery: $arnm1 $col1 $arnm2 $col2"
|
1557 |
# puts "sqlscslavequery: $arnm1 $col1 $arnm2 $col2"
|
1516 |
if {[info exists ar2(isalist)] == 1} {
|
1558 |
if {[info exists ar2(isalist)] == 1} {
|
1517 |
sqlistquery $arnm2 reset
|
1559 |
sqlistquery $arnm2 reset
|
1518 |
# Note we're often called with a null value: during resets
|
1560 |
# Note we're often called with a null value: during resets
|
1519 |
if {[string trim $ar1(sqlsc_${col1}_value)] != ""} {
|
1561 |
if {[string trim $ar1(sqlsc_${col1}_value)] != ""} {
|
1520 |
set ar2(sqlsc_${col2}_value) $ar1(sqlsc_${col1}_value)
|
|
|
1521 |
sqlistquery $arnm2
|
|
|
1522 |
}
|
|
|
1523 |
} else {
|
|
|
1524 |
sqlscreset $arnm2
|
|
|
1525 |
# Run slave query only if master value not null
|
|
|
1526 |
# Note we're often called with a null value: during resets
|
|
|
1527 |
if {[string trim $ar1(sqlsc_${col1}_value)] != ""} {
|
|
|
1528 |
set ar2(sqlsc_${col2}_value) $ar1(sqlsc_${col1}_value)
|
1562 |
set ar2(sqlsc_${col2}_value) $ar1(sqlsc_${col1}_value)
|
|
|
1563 |
sqlistquery $arnm2
|
|
|
1564 |
}
|
|
|
1565 |
} else {
|
|
|
1566 |
sqlscreset $arnm2
|
|
|
1567 |
# Run slave query only if master value not null
|
|
|
1568 |
# Note we're often called with a null value: during resets
|
|
|
1569 |
if {[string trim $ar1(sqlsc_${col1}_value)] != ""} {
|
|
|
1570 |
set ar2(sqlsc_${col2}_value) $ar1(sqlsc_${col1}_value)
|
1529 |
sqlscquery $arnm2
|
1571 |
sqlscquery $arnm2
|
1530 |
}
|
1572 |
}
|
1531 |
}
|
1573 |
}
|
1532 |
}
|
1574 |
}
|
1533 |
|
1575 |
|
1534 |
# Process slave screens: call sqlscslavequery for each one which is not
|
1576 |
# Process slave screens: call sqlscslavequery for each one which is not
|
1535 |
# further up this link chain
|
1577 |
# further up this link chain
|
1536 |
proc _sqlscdoslaves {arnm1} {
|
1578 |
proc _sqlscdoslaves {arnm1} {
|
1537 |
upvar #0 $arnm1 ar1
|
1579 |
upvar #0 $arnm1 ar1
|
1538 |
# puts "Doing slaves for $arnm1"
|
1580 |
# puts "Doing slaves for $arnm1"
|
1539 |
foreach slist $ar1(slaves) {
|
1581 |
foreach slist $ar1(slaves) {
|
1540 |
set arnm2 [lindex $slist 1]
|
1582 |
set arnm2 [lindex $slist 1]
|
1541 |
upvar #0 $arnm2 ar2
|
1583 |
upvar #0 $arnm2 ar2
|
1542 |
if {[info exists ar2(beingmaster)]} {
|
1584 |
if {[info exists ar2(beingmaster)]} {
|
1543 |
# puts "$arnm2: being link origin"
|
1585 |
# puts "$arnm2: being link origin"
|
1544 |
continue
|
1586 |
continue
|
1545 |
}
|
1587 |
}
|
1546 |
set col1 [lindex $slist 0]
|
1588 |
set col1 [lindex $slist 0]
|
1547 |
set col2 [lindex $slist 2]
|
1589 |
set col2 [lindex $slist 2]
|
1548 |
# puts "arnm1 $arnm1 col1 $col1, arnm2 $arnm2, col2 $col2"
|
1590 |
# puts "arnm1 $arnm1 col1 $col1, arnm2 $arnm2, col2 $col2"
|
1549 |
_sqlscslavequery $arnm1 $col1 $arnm2 $col2
|
1591 |
_sqlscslavequery $arnm1 $col1 $arnm2 $col2
|
1550 |
}
|
1592 |
}
|
1551 |
}
|
1593 |
}
|
1552 |
|
1594 |
|
1553 |
# Process master screens: set up the link column value if the screen
|
1595 |
# Process master screens: set up the link column value if the screen
|
1554 |
# is not further up this link chain
|
1596 |
# is not further up this link chain
|
1555 |
proc _sqlscdomasters {arnm1} {
|
1597 |
proc _sqlscdomasters {arnm1} {
|
1556 |
upvar #0 $arnm1 ar1
|
1598 |
upvar #0 $arnm1 ar1
|
1557 |
# puts "Doing masters for $arnm1"
|
1599 |
# puts "Doing masters for $arnm1"
|
1558 |
foreach slist $ar1(masters) {
|
1600 |
foreach slist $ar1(masters) {
|
1559 |
set arnm2 [lindex $slist 1]
|
1601 |
set arnm2 [lindex $slist 1]
|
1560 |
upvar #0 $arnm2 ar2
|
1602 |
upvar #0 $arnm2 ar2
|
1561 |
if {[info exists ar2(beingmaster)]} {
|
1603 |
if {[info exists ar2(beingmaster)]} {
|
1562 |
# puts "$arnm2: being link origin"
|
1604 |
# puts "$arnm2: being link origin"
|
1563 |
continue
|
1605 |
continue
|
1564 |
}
|
1606 |
}
|
1565 |
set col1 [lindex $slist 0]
|
1607 |
set col1 [lindex $slist 0]
|
1566 |
set col2 [lindex $slist 2]
|
1608 |
set col2 [lindex $slist 2]
|
1567 |
# puts "arnm1 $arnm1 col1 $col1, arnm2 $arnm2, col2 $col2"
|
1609 |
# puts "arnm1 $arnm1 col1 $col1, arnm2 $arnm2, col2 $col2"
|
1568 |
set ar2(sqlsc_${col2}_value) $ar1(sqlsc_${col1}_value)
|
1610 |
set ar2(sqlsc_${col2}_value) $ar1(sqlsc_${col1}_value)
|
1569 |
}
|
1611 |
}
|
1570 |
}
|
1612 |
}
|
1571 |
|
1613 |
|
1572 |
# Return entry widget name
|
1614 |
# Return entry widget name
|
1573 |
proc sqlsc_entrywidget {arnm col} {
|
1615 |
proc sqlsc_entrywidget {arnm col} {
|
|
... |
|
... |
1579 |
proc sqlsc_labelwidget {arnm col} {
|
1621 |
proc sqlsc_labelwidget {arnm col} {
|
1580 |
upvar #0 $arnm ar
|
1622 |
upvar #0 $arnm ar
|
1581 |
regsub {\.} $col _ colw
|
1623 |
regsub {\.} $col _ colw
|
1582 |
return $ar(window).ff.$colw.lab
|
1624 |
return $ar(window).ff.$colw.lab
|
1583 |
}
|
1625 |
}
|
1584 |
|
|
|
1585 |
|
|
|