# @(#$Id$ (C) 1994 CDKIT
# Copyright (c) 1996, 1997 - CDKIT - SAINT CLOUD - FRANCE
#
# Permission to use, copy, modify, distribute, and sell this software
# and its documentation for any purpose is hereby granted without fee,
# provided that the above copyright notice and this permission notice
# appear in all copies of the software and related documentation.
#
# THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
# EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
# WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
#
# IN NO EVENT SHALL CDKIT BE LIABLE FOR ANY SPECIAL, INCIDENTAL,
# INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND, OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER OR NOT
# ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF LIABILITY,
# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
# SOFTWARE.
#
# sqlscreens: A database screen generator in tcl/tk
#
# Currently works with INFORMIX, MYSQL, MSQL and unix odbc by using
# the tcsq module
#
package provide sqlsc 0.3
# We catch the following, because we could also be using the autoload
# facility, not being installed as a package
catch {package require tcsq}
# If sqlsc_names_compat_old is not zero, we add compatibility entries
# in the array: in addition to the now standard
# entries (sqlsc_colname_value, sqlsc_colname_len, sqlsc_colname_typ),
# we add colname, colname_len, and colname_type for the value, length, and
# type.
# sqlsc_names_compat_old is set in tcsq.tcl. Can be set by our user before
# first calling sqlscreen
# Default max width for fields (used in tcsq.tcl). This is only used
# for fields whose length was not explicitely set by the application
# If tcsq is loaded first, it sets this to a very high value, hence
# the test > 10000
if {![info exists sqlsc_def_maxlen] || $sqlsc_def_maxlen > 10000} {
set sqlsc_def_maxlen 80
}
# Show all sql statements to, or not. Default is yes, to stdout
# if env(SQLSCLOG) is set we append the statements there
# The idea is that we would have a per-user log file (env variable)
# and a per-application decision to log or not (prog var).
# Something more sophisticated is probably needed, but enough for now
if {![info exists sqlscshowstmts]} {
set sqlscshowstmts 1
}
if {[info exists env(SQLSCLOG)]} {
set sqlsclog [open $env(SQLSCLOG) a]
} else {
set sqlsclog stdout
}
if {![info exists sqlscnobell]} {
set sqlscnobell 0
}
#### Printing statements that are executed
proc _sqlsclogstmt {txt} {
global sqlscshowstmts sqlsccurstmt
if {$sqlscshowstmts != 0} {
set sqlsccurstmt $txt
}
}
proc _sqlsclogcommit {} {
global sqlscshowstmts sqlsccurstmt sqlsclog
if {$sqlscshowstmts != 0} {
puts $sqlsclog "-- [clock format [clock seconds]]\n$sqlsccurstmt"
flush $sqlsclog
}
}
##################################################
# Small window utilities
#####################
## Check that entry doesn't become longer than allowed width
# This is a standard tcl entry validation proc. See the entry widget man page
# txt is the value after entry and w the max length
proc _sqlscentryvalidate {txt w} {
#puts stderr "_sqlscentryvalidate: $txt. maxlen $w"
if {[string length $txt] > $w} {
return 0
}
return 1
}
# Create a labeled entry widget with emacs-like bindings
proc _sqlsclabentry {name labtext labwidth entryvar entrywidth \
{entryfillx 0} {maxlen 0}} {
global tk_version
set f [frame ${name} -relief groove -borderwidth 0]
label $f.lab -text "$labtext" -width $labwidth -anchor e
set ecmd [list entry $f.ent -width $entrywidth -textvariable $entryvar \
-relief sunken -borderwidth 1 ]
if {$maxlen > 0 && $tk_version >= 8.3} {
lappend ecmd -invcmd bell -validate key \
-vcmd "_sqlscentryvalidate %P $maxlen"
}
eval $ecmd
if {$tk_version < 4.0} {
entryemacsbind $f.ent
}
pack $f.lab -side left -ipadx 1 -ipady 1
if {$entryfillx} {
pack $f.ent -side left -ipadx 1 -ipady 1 -expand 1 -fill x
} else {
pack $f.ent -side left -ipadx 1 -ipady 1
}
return $f
}
#####################
# Same as _sqlsclabentry, but with uneditable field. Not extremely useful
# except to make code more regular in dbase screens when choosing
# between editable or not
proc _sqlsclablabel { name labtext labwidth entryvar entrywidth } {
set f [frame ${name}]
label $f.lab -text "$labtext" -width $labwidth -anchor e
label $f.ent -width $entrywidth -textvariable $entryvar \
-relief groove -borderwidth 2 -padx 4
pack $f.lab $f.ent -side left -ipadx 1 -ipady 1
return $f
}
#####################
# Labelled text window
proc _sqlsclabtext { name labtext labwidth ew eh opt } {
set f [frame ${name}]
label $f.lab -text "$labtext" -width $labwidth -anchor e
text $f.ent -width $ew -height $eh
if {[string first $opt t] != -1 } {
pack $f.lab $f.ent -side top -ipadx 1 -ipady 1
} elseif {[string first $opt l] != -1 } {
pack $f.lab $f.ent -side left -ipadx 1 -ipady 1
} else {
pack $f.ent -side left -ipadx 1 -ipady 1
}
return $f
}
###################################################################
# Same idea as _sqlsclabentry and _sqlsclablabel, except that the value
# comes from a list. The choice list can be made of single element (value
# same as labels), or made of {text, value} pairs There is some complicated
# stuff done to update the visible label when the variable's value changes
# other than through a menu choice
# Note: this is much like a tk_optMenu, with the provision to separate the
# actual values and the displayed strings.
proc _sqlsclabmenu {name labtext labwidth varname butwidth choicelist} {
# puts "_sqlsclabmenu: name $name, labtext $labtext, labwidth $labwidth,\
#varname $varname, butwidth $butwidth, choicelist $choicelist"
set f [frame $name]
label $f.lab -text $labtext -width $labwidth -anchor e
menubutton $f.b -menu $f.b.m -width $butwidth -relief raised
menu $f.b.m
foreach choice $choicelist {
set label [lindex $choice 0]
set value $label
if {[llength $choice] == 2} {
set value [lindex $choice 1]
}
# No need to use a command to set the menubutton's label
# because this is done through tracing the variable (see after)
$f.b.m add radiobutton -variable $varname -label $label \
-value $value
}
# Create a proc to update the label when the variable's value changes
set s {proc _sqlsclabmenutrace%s {name element op} {
set currentvalue [string trim [uplevel #0 set %s]]
foreach elt {%s} {
if {$currentvalue == [lindex $elt end]} {
%s.b configure -text [lindex $elt 0]
return
}
}
%s.b configure -text {}
}
}
set ps [format $s $f $varname $choicelist $f $f]
#puts $ps
eval $ps
uplevel #0 trace variable $varname w _sqlsclabmenutrace$f
pack $f $f.lab $f.b -side left -ipadx 1 -ipady 1
return $f
}
######################
# Change value to uppercase if column is in the upshift list
proc _sqlscmaybetoupper {arnm col value} {
upvar $arnm ar
# puts "_sqlscmaybetoupper: arnm: $arnm, col: $col, value: $value"
if {[info exists ar(upshiftcols)] && \
[lsearch $ar(upshiftcols) $col ] != -1} {
return [string toupper $value]
}
return $value
}
#######################################################
# Translate money (like 1,10F) to standard floating point (1.10)
proc _sqlscstripmoney {in} {
regsub -all "," "$in" "." out
set out [string trim "$out" "\$F"]
return "$out"
}
# Prepare a value before executing an sql statement, depending on
# its type. Returns the string to be used in the statement.
# Note that we arbitrarily use 'null' values for non char columns
# and '' for char ones. This is the right thing to do in most but
# unfortunately not all cases.
# If this is a select this routine is not called for fields without
# values (consequence: can't search on null or '' fields)
proc _sqlscprepvalue {arnm col coltype value {setarvalue 1}} {
upvar $arnm ar
# Special case for designated texts which have already been quoted
# by sqlsctextstocols, we just add the external ''
if {[_sqlsccolattr ar $col textcols]} {
return '$value'
}
# 'a' stuff to avoid 'integer too big' errors
if {"a$value" == "a" } {
if {$coltype == "char"} {
if {$setarvalue == 1} {
set ar(sqlsc_${col}_value) $value
}
set txt ''
} else {
set txt "null"
}
return $txt
}
switch $coltype {
char {
set value [_sqlscmaybetoupper $arnm $col $value]
if {$setarvalue == 1} {
set ar(sqlsc_${col}_value) $value
}
set txt '[tcsqquotequote $value]'
}
date -
timestamp -
datetime {
set txt '[tcsqquotequote $value]'
}
money {
set txt [_sqlscstripmoney $value]
}
default {
set txt $value
}
}
return $txt
}
###################################################################
# Build a select statement from the columns whose values are set
# SELECT col1, col2, ... FROM tabname WHERE colx = valx, ...
# [ORDER BY ordercols]
proc _sqlscbuildselect {arnm} {
upvar $arnm ar
set txt "select"
# column list
foreach arg $ar(columns) {
append txt " $arg,"
}
set txt [string trimright $txt ", "]
# Tables
append txt " from "
foreach table $ar(table) {
append txt " $table,"
}
set txt [string trimright $txt ", "]
# Import the text fields into the column variables
_sqlsctextstocols ar
# Where clause: use all fields that are set.
set wheredone 0
foreach col $ar(columns) {
set value [string trim $ar(sqlsc_${col}_value)]
if {"a$value" == "a"} continue
if {$wheredone == 0} {
append txt " where "
set wheredone 1
} else {
append txt " and "
}
set ntxt [_sqlscprepvalue $arnm $col $ar(sqlsc_${col}_type) $value]
if {[_sqlsccolattr ar $col textcols]} {
append txt " $col like $ntxt"
continue
}
switch $ar(sqlsc_${col}_type) {
char {append txt " $col like $ntxt"}
default {
if {[regexp {[<>=].*} $ntxt] == 1} {
append txt " $col $ntxt"
} else {
append txt " $col = $ntxt"
}
}
}
}
if {[info exists ar(joinclause)]} {
if {$wheredone == 1} {
append txt " and $ar(joinclause) "
} else {
append txt " where $ar(joinclause) "
}
}
if {[info exists ar(ordercols)] && [string trim $ar(ordercols)] != ""} {
append txt " order by $ar(ordercols)"
}
return $txt
}
###################################################################
# Build a "FROM table WHERE..." clause suitable for a delete statement
# We have a problem with fields holding no value: can't know if we should
# use = '' or is null. We don't use them at all in the WHERE clause.
# There is a warning before the actual delete if several rows would be
# affected
proc _sqlscbuilddelwhere {arnm} {
upvar $arnm ar
# insist on having a where clause !. Will cause a syntax error if
# no value is set, which is better than emptying the table
set txt "from $ar(table) where "
set first 1
foreach col $ar(columns) {
set value [string trim $ar(sqlsc_${col}_value)]
if {"a$value" == "a"} {
continue
}
if {$first == 1} {
set first 0
} else {
append txt " and "
}
append txt \
" $col = [_sqlscprepvalue $arnm $col $ar(sqlsc_${col}_type) $value]"
}
return $txt
}
###################################################################
# Build an insert statement from the columns whose values are set
# INSERT INTO table-name [(col1, col2,...)] VALUES (val1, val2, ...)
proc _sqlscbuildinsert {arnm} {
upvar $arnm ar
set txt "insert into $ar(table)"
# Use all fields that are set
set coltxt "("
set valtxt "("
foreach col $ar(columns) {
set value [string trim $ar(sqlsc_${col}_value)]
# 'a' stuff to avoid integer too big errors
if {"a$value" == "a"} {
continue
}
append coltxt " $col,"
append valtxt \
" [_sqlscprepvalue $arnm $col $ar(sqlsc_${col}_type) $value],"
}
# trim last ','
set valtxt [string trimright $valtxt ", "]
set coltxt [string trimright $coltxt ", "]
# Check that at least a value is set
if {[string length $valtxt] == 1} {
return -code error "NO value set for insert statement"
}
append txt " $coltxt) values $valtxt)"
return $txt
}
###################################################################
# Build an update statement from the columns whose values are set
# UPDATE table-name SET col1 = val1, col2 = val2,... WHERE whereclause;
# This statement needs that columns be designated as a primary index
# to be used in the where clause (updateindex array element)
proc _sqlscbuildupdate {arnm} {
upvar $arnm ar
set txt "update $ar(table) set "
set itxt $txt
# Update database values to current ones
foreach col $ar(columns) {
# If the column value did not change don't set it.
# This avoids errors about updating a unique index
if {"a$ar(sqlsc_${col}_value)" == "a$ar(sqlsc_${col}_valsaved)"} {
continue
}
set value [string trim $ar(sqlsc_${col}_value)]
append txt " $col = \
[_sqlscprepvalue $arnm $col $ar(sqlsc_${col}_type) $value],"
}
if {$txt == $itxt} {
return -code error "No fields changed (nothing to update)"
}
# trim last ',', add 'where'
set txt "[string trimright $txt ","] where"
# where clause
set first 1
foreach col $ar(updateindex) {
if {$first == 0} {
append txt " and"
} else {
set first 0
}
append txt " $col = \
[_sqlscprepvalue $arnm $col $ar(sqlsc_${col}_type) \
$ar(sqlsc_${col}_valsaved) 0]"
}
return $txt
}
#
# This is called for arrays without a "noentry" or before an add
# to check that if the table has a serial field, it is listed as
# updateindex
proc _sqlsccheckserial {arnm} {
upvar #0 $arnm ar
# Does table have a serial ?
if {[info exists ar(tabcolserial)]} {
# Then it must be in the columns list, and listed
# as updateindex
if {![info exists ar(updateindex)]} {
return -code error \
"$ar(table): has serial col $ar(tabcolserial), \
must be listed as updateindex"
}
set idxcol [lindex $ar(updateindex) 0]
if {[lsearch $ar(columns) $idxcol] == -1} {
return -code error \
"$ar(table): Updateindex $idxcol not in column list ?"
}
if {$idxcol != $ar(tabcolserial)} {
return -code error \
"$ar(table): updateindex $idxcol should be serial \
column $ar(tabcolserial)"
}
}
}
# Check if column has an attribute
proc _sqlsccolattr {arnm col attr} {
upvar $arnm ar
if {[info exists ar($attr)] && [lsearch $ar($attr) $col] != -1} {
return 1
}
return 0
}
##########################################################
###### Procedures for the QBE screen
############
# Insert callback
proc sqlscinsert {arnm} {
upvar #0 $arnm ar
global env
# puts "sqlscinsert: array: $arnm"; flush stdout
if {[info exists ar(queryonly)]} {
return -code error "queryonly table"
}
# In case there is a serial field, and the user did not or
# could not (noentry) set its value explicitely:
# In Cdkit: set its value with "uniqueid" (see bdsync.d)
# Else set it to "" and let auto_increment do its job
# Note that we do this before calling the beforeinsert proc, so
# that an application would still have a chance to apply its own
# value allocation scheme.
if {[info exists ar(tabcolserial)]} {
set serial $ar(tabcolserial)
if {$ar(sqlsc_${serial}_value) == "" || \
[_sqlsccolattr ar $serial noentry] || \
[_sqlsccolattr ar $serial nodisplay] } {
if {[info exists env(CDKITDB)]} {
# puts "Calling tcsquniqueid";flush stdout
set ar(sqlsc_${serial}_value) \
[tcsquniqueid $ar(hdl) $ar(table)]
# puts "uniqueid returned: ar(sqlsc_${serial}_value)"
} else {
set ar(sqlsc_${serial}_value) ""
}
}
}
# Prepare text values
_sqlsctextstocols ar
if {[info exists ar(beforeinsert)]} {
set res [$ar(beforeinsert) "beforeinsert" $arnm]
if {$res != 0} {
return;
}
}
set txt [_sqlscbuildinsert ar]
_sqlsclogstmt $txt
tcsqexec $ar(hdl) $txt
_sqlsclogcommit
# If there is a serial and we're not in cdkit, update serial
# fields with autogenerated value,
if {![info exists env(CDKITDB)] && [info exists serial]} {
set ar(sqlsc_${serial}_value) [tcsqinsertid $ar(hdl)]
}
# Run a query to update other fields with automatically generated
# values (defaults)
sqlscquery $arnm
# Possibly run postadd routine
if {[info exists ar(afterinsert)]} {
$ar(afterinsert) afterinsert $txt $arnm
}
}
proc _sqlscisupdidx {arnm} {
upvar #0 $arnm ar
if {![info exists ar(updateindex)] || \
[llength $ar(updateindex)] == 0 || \
[lindex $ar(updateindex) 0] == ""} {
return 0
} else {
return 1
}
}
############
# Update callback
proc sqlscupd {arnm} {
upvar #0 $arnm ar
# puts "sqlscupd: array: $arnm"; flush stdout
if {[info exists ar(queryonly)]} {
return -code error "Table is queryonly: no updates allowed"
}
if {![_sqlscisupdidx $arnm]} {
return -code error "Can't update: no 'updateindex' fields"
}
# Prepare text values
_sqlsctextstocols ar
if {[info exists ar(beforeupdate)]} {
set res [$ar(beforeupdate) beforeupdate $arnm]
if {$res != 0} {
return;
}
}
set txt [_sqlscbuildupdate ar]
_sqlsclogstmt $txt
tcsqexec $ar(hdl) $txt
_sqlsclogcommit
_sqlscsavevalues ar
if {[info exists ar(afterupdate)]} {
$ar(afterupdate) afterupdate $txt $arnm
}
}
# Add '%' where needed for fields listed as "autopercent"
proc _sqlscsetautopercent {arnm} {
upvar #0 $arnm ar
if {[info exists ar(autopercentboth)]} {
foreach col $ar(autopercentboth) {
if {$ar(sqlsc_${col}_value) != "" && \
[string first "%" $ar(sqlsc_${col}_value)] == -1} {
set ar(sqlsc_${col}_value) "%$ar(sqlsc_${col}_value)%"
}
}
}
if {[info exists ar(autopercentleft)]} {
foreach col $ar(autopercentleft) {
if {$ar(sqlsc_${col}_value) != "" && \
[string first "%" $ar(sqlsc_${col}_value)] == -1} {
set ar(sqlsc_${col}_value) "%$ar(sqlsc_${col}_value)"
}
}
}
if {[info exists ar(autopercentright)]} {
foreach col $ar(autopercentright) {
if {$ar(sqlsc_${col}_value) != "" && \
[string first "%" $ar(sqlsc_${col}_value)] == -1} {
set ar(sqlsc_${col}_value) "$ar(sqlsc_${col}_value)%"
}
}
}
}
# Save a copy of the column values. This is used in updates, to avoid
# updating columns that haven't changed, and to enable updating the
# updateindex columns (the where clause uses the saved values).
proc _sqlscsavevalues {arnm} {
upvar $arnm ar
# puts "_sqlscsavevalues"
foreach col $ar(columns) {
set ar(sqlsc_${col}_valsaved) $ar(sqlsc_${col}_value)
}
}
#############
# Select callback
proc sqlscquery {arnm} {
upvar #0 $arnm ar
# puts "sqlscquery: array: $arnm"; flush stdout
if {[info exists ar(querynum)] && $ar(querynum) != ""} {
tcsqclosel $ar(querynum)
set ar(querynum) ""
}
if {[info exists ar(beforequery)] && \
[$ar(beforequery) "beforequery" $arnm]} {
return;
}
_sqlscsetautopercent $arnm
set txt [_sqlscbuildselect ar]
_sqlsclogstmt $txt
set ar(querynum) [tcsqopensel $ar(hdl) $txt]
_sqlsclogcommit
set result1 [tcsqnext $ar(querynum)]
# puts "result1: $result1"
if {$result1 == ""} {
global sqlscnobell
if {$sqlscnobell == 0} {
bell
}
return 0
}
set ind 0
foreach col $ar(columns) {
set ar(sqlsc_${col}_value) [string trim [lindex $result1 $ind]]
incr ind
}
_sqlscsavevalues ar
_sqlsccolstotexts ar
_sqlscdolinks $arnm
# If there is an associated list screen, unroll the query there
if {[info exists ar(list_columns)] && \
![info exists ar(inslavelistdetail)]} {
sqlistquery $arnm
}
if {[info exists ar(afterquery)]} {
# puts "afterquery exists for $arnm"
$ar(afterquery) "afterquery" "$txt" "$arnm"
}
return 1
}
#############
# Delete callback
proc sqlscdelete {arnm} {
upvar #0 $arnm ar
# puts "sqlscdelete: array: $arnm"; flush stdout
if {[info exists ar(queryonly)]} {
return -code error "queryonly table"
}
if {[info exists ar(beforedelete)] && \
[$ar(beforedelete) "beforedelete" $arnm]} {
return;
}
set fromwhere [_sqlscbuilddelwhere ar]
set txt "select count(*) $fromwhere"
_sqlsclogstmt $txt
set qry [tcsqopensel $ar(hdl) $txt]
_sqlsclogcommit
set res [lindex [tcsqnext $qry 1] 0]
tcsqclosel $qry
if {$res == "" || $res == 0} {
# mysql sometimes returns an empty set instead of 0
tk_dialog .norow "no rows" \
"No rows selected by current values" "" 0 "Ok"
return
}
if {$res != 1} {
set ans [tk_dialog .manyrows "Multiple rows deleted" \
"$res rows would be deleted. Do it anyway ?" "" 0 \
"Don't delete" "DO IT"]
if {$ans != 1} {
return
}
}
set txt "delete $fromwhere"
_sqlsclogstmt $txt
tcsqexec $ar(hdl) "$txt"
_sqlsclogcommit
if {[info exists ar(afterdelete)]} {
$ar(afterdelete) "afterdelete" "$txt" "$arnm"
}
return 1
}
#############################
## Advance to the next row returned by the select statement
proc sqlscnext {arnm} {
upvar #0 $arnm ar
set result1 [tcsqnext $ar(querynum)]
# puts "result1: $result1"
if {$result1 == ""} {
return 0
}
set ind 0
foreach col $ar(columns) {
set ar(sqlsc_${col}_value) [string trim [lindex $result1 $ind]]
incr ind
}
_sqlscsavevalues ar
_sqlsccolstotexts ar
_sqlscdolinks $arnm
if {[info exists ar(afterquery)]} {
# puts "afterquery exists for $arnm"
$ar(afterquery) "afternext" "" "$arnm"
}
return 1
}
########
# Rewind the query to the first row
proc sqlscreopen {arnm} {
upvar #0 $arnm ar
tcsqrew $ar(querynum)
set result1 [tcsqnext $ar(querynum)]
# puts "result1: $result1"
if {$result1 == ""} {
return 0
}
set ind 0
foreach col $ar(columns) {
set ar(sqlsc_${col}_value) [string trim [lindex $result1 $ind]]
incr ind
}
_sqlscsavevalues ar
_sqlsccolstotexts ar
_sqlscdolinks $arnm
if {[info exists ar(afterquery)]} {
# puts "afterquery exists for $arnm"
$ar(afterquery) "afterreop" "" "$arnm"
}
return 1
}
###############
# Reset all fields to null values
proc sqlscreset {arnm} {
upvar #0 $arnm ar
# puts "sqlscreset: $ar(columns)"
foreach col $ar(columns) {
set ar(sqlsc_${col}_value) ""
}
if {[info exists ar(querynum)]} {
tcsqclosel $ar(querynum)
unset ar(querynum)
}
_sqlscsavevalues ar
_sqlsccolstotexts ar
_sqlscdolinks $arnm
# If there is an associated list screen, reset it
if {[info exists ar(list_columns)] && \
![info exists ar(inslavelistdetail)]} {
sqlistquery $arnm "reset"
}
if {[info exists ar(afterquery)]} {
# puts "afterquery exists for $arnm"
$ar(afterquery) "afterreset" "" "$arnm"
}
if {[info exists ar(sqlsc_initfocus_win)]} {
focus $ar(sqlsc_initfocus_win)
}
return 1
}
# Cleanup when the array is unset. This is a trace which gets called
# whenever an array entry or the array itself is unset, but only takes
# action when the array is unset.
proc sqlscreendelete {arnm} {
upvar $arnm ar
# puts "sqlscreendelete: proceeding with unsets. Table $ar(table)"
# parray ar
if {[info exists ar(querynum)]} {
# puts "sqlscreendelete: closel"
tcsqclosel $ar(querynum)
}
if {[info exists ar(hdl)]} {
# puts "sqlscreendelete: tcsqdiscon"
tcsqdiscon $ar(hdl)
}
if {[info exists ar(window)]} {
# puts "sqlscreendelete: destroy $ar(window)"
destroy $ar(window)
}
if {[info exists ar(list_window)]} {
# puts "sqlscreendelete: destroy $ar(list_window)"
destroy $ar(list_window)
}
unset ar
}
# Bind <CR>, TAB, ^N for an entry field. Slightly different from what
# we do usually because <CR> is bound to "query"
# We don't actually do anything about TAB because we'd have to remove
# any existing bindings first and it already does almos what we want
# (except that it does not loop inside a screen but iterates in all
# windows instead)
proc _sqlcbindentrynext {w w1 arnm} {
bind $w.ent <KeyPress-Return> "sqlscquery $arnm"
bind $w.ent <Control-KeyPress-n> "focus $w1.ent"
# bind $w.ent <KeyPress-Tab> "focus $w1.ent"
}
#####################################################
# Compute button width for choice fields (max label length)
proc _compchoicewidth {listname} {
upvar #0 $listname lst
set maxlab 0
foreach elt $lst {
set len [string length [string trim [lindex $elt 0]]]
if {$maxlab < $len} {
set maxlab $len
}
}
return $maxlab
}
set usecommonbuttons 0
# Create a button set common to several screens
# This must be called before any call to sqlscreen. It creates a common
# button set, whose actions will apply to the screen with the current
# input focus.
# The screens will have no individual buttons, which saves screen space.
# The input list defines buttons to create in addition to query next
# rewind reset (may include: add and update)
# REMARK: You can create several common button sets, for example if
# you have several top level frames. Each will have the same function
# OTHER REMARK: can't create a delete button, this is really too
# dangerous
# LAST: we never use this, it confuses the operators a lot
proc sqcommonbuttons { name {butlist {}} } {
global usecommonbuttons
set usecommonbuttons 1
set w [frame $name -relief groove -borderwidth 3]
button $w.query -text "Query" -command "sqlscquery \$focusarrayname"
pack $w.query -side left -fill x -expand yes
button $w.next -text "Next" -command "sqlscnext \$focusarrayname"
pack $w.next -side left -fill x -expand yes
button $w.rew -text "Rewind" -command "sqlscreopen \$focusarrayname"
pack $w.rew -side left -fill x -expand yes
button $w.reset -text "Reset" -command "sqlscreset \$focusarrayname"
pack $w.reset -side left -fill x -expand yes
if {[lsearch $butlist add] != -1} {
button $w.add -text "Add" -command "sqlscinsert \$focusarrayname"
pack $w.add -side left -fill x -expand yes
}
if {[lsearch $butlist update] != -1} {
button $w.upd -text "Update" -command "sqlscupd \$focusarrayname"
pack $w.upd -side left -fill x -expand yes
}
pack $w -side top -fill both -expand yes
}
# Retrieve connection variables and set them in our caller
proc _sqlscsetconparams {arnm hostnm usernm passwdnm} {
upvar $arnm ar
upvar $hostnm host
upvar $usernm user
upvar $passwdnm passwd
set host ""
set user ""
set passwd ""
if {[info exists ar(sqlschost)]} {
set host $ar(sqlschost)
}
if {[info exists ar(sqlscuser)]} {
set user $ar(sqlscuser)
}
if {[info exists ar(sqlscpasswd)]} {
set passwd $ar(sqlscpasswd)
}
}
# Procedure used to set old column value entries in the array. The
# indexes for those were the column names (the new ones are like
# sqlsc_colname_value)
proc _sqlscsetoldname {arnm varnm op} {
upvar $arnm ar
# remove sqlsc_ and _value from name
set l [string length $varnm]
set oldname [string range $varnm 6 [expr {$l - 7}]]
# puts "Setting $oldname in $arnm to $ar($varnm)"
set ar($oldname) $ar($varnm)
}
# Proc used to set new column value entries in the array (when
# the application sets the old ones)
proc _sqlscsetnewname {arnm varnm op} {
upvar $arnm ar
# new name
set nn sqlsc_${varnm}_value
set ar($nn) $ar($varnm)
}
# Translate the list of "text" fields. It is input by the application as
# a list of {col lines columns}, we create three separate and parallel lists
proc _sqlscsetuptextlists {arnm} {
upvar $arnm ar
# puts "_sqlscsetuptextlists: arnm: $arnm. Table: $ar(table)"
if {![info exists ar(texts)]} {
# puts "_sqlscsetuptextlists: no texts"
return
}
foreach tlist $ar(texts) {
set l [llength $tlist]
if {$l != 3 && $l != 4} {
return -code error "Bad text field definition: $tlist"
}
lappend ar(textcols) [lindex $tlist 0]
lappend ar(textheights) [lindex $tlist 1]
lappend ar(textwidths) [lindex $tlist 2]
if {$l == 4} {
lappend ar(textopts) [lindex $tlist 3]
} else {
lappend ar(textopts) ""
}
# puts "_sqlscsetuptextlists: found text: $ar(textcols)"
}
}
# Setup the column variables from the text in the text fields (if any)
# Special chars are suitably quoted for insertion or update
proc _sqlsctextstocols {arnm} {
upvar $arnm ar
# puts "_sqlsctextstocols: arnm: $arnm. Table: $ar(table)"
if {![info exists ar(textcols)]} {
# puts "_sqlsctextstocols: no texts"
return
}
foreach col $ar(textcols) {
set ar(sqlsc_${col}_value) \
[tcsqquoteblob [$ar(window).ff.$col get 1.0 end]]
}
}
# Setup text in text fields from column values
proc _sqlsccolstotexts {arnm} {
upvar $arnm ar
# puts "_sqlsccolstotexts: arnm: $arnm. Table: $ar(table)"
if {![info exists ar(textcols)]} {
# puts "_sqlsccolstotexts: no texts"
return
}
foreach col $ar(textcols) {
$ar(window).ff.$col delete 1.0 end
$ar(window).ff.$col insert 1.0 $ar(sqlsc_${col}_value)
}
}
# Compute the maximal line. This
# is the max number of cols between "\n"'s. If no \n is found, then
# there will be one single line or column depending on the "orient"
# parameter
proc _sqlsccomputelinelen {arnm collist} {
upvar #0 $arnm ar
set len 0
set maxlen 0
set isnewline 0
foreach col $collist {
if {$col == "\n"} {
set isnewline 1
set len 0
} else {
if {[_sqlsccolattr ar $col nodisplay]} {
continue;
}
incr len
if {$len > $maxlen} {
set maxlen $len
}
}
}
if {$isnewline == 0} {
set maxlen 0
}
# puts "maxlen: $maxlen"
return $maxlen
}
# Create screen according to values in input array. The fields are
# set vertically except if orient is not "v"
proc sqlscreen {arnm {orient "v"}} {
global focusarrayname usecommonbuttons sqlsc_names_compat_old
upvar #0 $arnm ar
set w $ar(window)
# Blob/Text fields are special : we change the input format from list
# of triplets to 3 lists (cols widths heights)
_sqlscsetuptextlists ar
_sqlscsetconparams ar host user passwd
set ar(hdl) [tcsqconnect $host $user $passwd]
tcsquse $ar(hdl) $ar(database)
# puts "--sqlscreen: w: $w, hdl: $ar(hdl) arnm: $arnm, tbl: $ar(table), \
# cols: $ar(columns), orient: \"$orient\"";
set ntables [llength $ar(table)]
# Non-queryonly screens have more constraints
if {[info exists ar(queryonly)] == 0} {
if {$ntables != 1} {
return -code error "Multi-table screens must be queryonly"
}
_sqlsccheckserial $arnm
}
if {$ntables > 1 && ![info exists ar(joinclause)]} {
return -code error \
"Multi-table screens must have a joinclause entry"
}
# Get column type and size info.
foreach table $ar(table) {
tcsqcolinfo $ar(hdl) $table ar
}
# Check: better to have a nice errmes here than fail later
foreach col $ar(columns) {
if {$col == "\n"} {
continue
}
if {![info exists ar(sqlsc_${col}_len)]} {
return -code error \
"Column $col not found in table(s): $ar(table)"
}
}
frame $w -relief groove -borderwidth 3
if {![info exists ar(nobuttons)] && $usecommonbuttons == 0} {
frame $w.bf
button $w.bf.query -text "Query" -command "sqlscquery $arnm"
pack $w.bf.query -side left -fill x -expand yes
button $w.bf.next -text "Next" -command "sqlscnext $arnm"
pack $w.bf.next -side left -fill x -expand yes
button $w.bf.rew -text "Rewind" -command "sqlscreopen $arnm"
pack $w.bf.rew -side left -fill x -expand yes
button $w.bf.reset -text "Reset" -command "sqlscreset $arnm"
pack $w.bf.reset -side left -fill x -expand yes
if {[info exists ar(queryonly)] == 0} {
if {![info exists ar(noaddbutton)]} {
button $w.bf.add -text "Add" -command "sqlscinsert $arnm"
pack $w.bf.add -side left -fill x -expand yes
}
if {![info exists ar(noupdbutton)] && [_sqlscisupdidx $arnm]} {
button $w.bf.upd -text "Update" -command "sqlscupd $arnm"
pack $w.bf.upd -side left -fill x -expand yes
}
if {[info exists ar(allowdelete)]} {
button $w.bf.del -text "Delete" -command "sqlscdelete $arnm"
pack $w.bf.del -side left -fill x -expand yes
}
}
pack $w.bf -side top -fill both -expand yes
}
if {[info exists ar(notitle)] == 0} {
set title "$arnm"
message $w.tabnm -text $title -width 3i
pack $w.tabnm -side top -fill both -expand yes
}
# Compute label max width to align fields
set maxlab 0
foreach col $ar(columns) {
set len [string length $col]
if {$maxlab < $len} {
set maxlab $len
}
}
# At least: The fields subscreen
frame $w.ff -relief groove -borderwidth 0
pack $w.ff -side top -expand 1 -fill both
set prev ""
set prev_ent ""
set x 0
set y 0
set maxll [_sqlsccomputelinelen $arnm $ar(columns)]
# puts "maxll: $maxll"
if {$maxll != 0} {
set orient "explicit"
}
foreach col $ar(columns) {
# Handle "pseudo columns" things in the list that give placement
# indications
if {$col == "\n"} {
# orient must be "explicit". If there are less columns
# than in the longest line, make the last window span
# the remaining columns
if {$x < $maxll} {
for {} {$x < $maxll} {incr x} {
# puts "$arnm: maxll $maxll, x $x, Spanning"
grid configure $prev -
}
}
incr y
set x 0
continue
}
# Make a list of "real" columns
lappend realcols $col
# For some reason the variable needs to exist for _sqlsclablabel
if {![info exists ar(sqlsc_${col}_value)]} {
set ar(sqlsc_${col}_value) ""
}
if {$sqlsc_names_compat_old} {
# Note that TCL is smart enough to avoid trace loops
trace variable ar(sqlsc_${col}_value) w _sqlscsetoldname
trace variable ar(${col}) w _sqlscsetnewname
}
if {[_sqlsccolattr ar $col nodisplay]} {
continue;
}
# subwin name: there could be dots in the column name if it's
# fully qualified. We replace them. This might create a collision
# in names in very rare cases, (if there is a tabxx.colyy and
# an unqualified column named tabxx_colyy), but this seems a remote
# possibility
regsub {\.} $col _ colw
set sw $w.ff.$colw
if {[info exists ar(initfocus)] && $col == $ar(initfocus)} {
set ar(sqlsc_initfocus_win) $sw.ent
}
# Label widths. Might be possible to gain some space by using
# the actual lengths rather than the max in some cases, but this
# really does not look good
# if {wantopack} {
# set labw [string length $col]
# } else {
# set labw $maxlab
# }
set labw $maxlab
set varnm ${arnm}(sqlsc_${col}_value)
set wwidth $ar(sqlsc_${col}_len)
if {[_sqlsccolattr ar $col noentry]} {
_sqlsclablabel $sw $col $labw $varnm $wwidth
} elseif {[_sqlsccolattr ar $col textcols]} {
set idx [lsearch $ar(textcols) $col]
_sqlsclabtext $sw $col $labw [lindex $ar(textwidths) $idx] \
[lindex $ar(textheights) $idx] [lindex $ar(textopts) $idx]
} elseif {[_sqlsccolattr ar $col choices] ||
[info exists ar(sqlsc_${col}_dbchoices)]} {
# Note that we give priority to the user's list over the
# database's. Especially this allows setting display
# values different from column values.
if {[_sqlsccolattr ar $col choices]} {
# List name comes right after column name
set ind [expr {[lsearch $ar(choices) $col] + 1}]
set choicelistname [lindex $ar(choices) $ind]
} else {
set choicelistname ${arnm}(sqlsc_${col}_dbchoices)
}
set width [_compchoicewidth $choicelistname]
upvar #0 $choicelistname ch
_sqlsclabmenu $sw $col $labw $varnm $width $ch
} else {
set maxlen $ar(sqlsc_${col}_dblen)
_sqlsclabentry $sw $col $labw $varnm $wwidth 0 $maxlen
if {![info exists firstent]} {
set firstent $sw
}
if {$prev_ent != ""} {
_sqlcbindentrynext $prev_ent $sw $arnm
}
bind $sw.ent <FocusIn> "set focusarrayname $arnm"
bind $sw.ent <FocusOut> "set focusarrayname {}"
if {[info exists ar(queryonly)] == 0} {
bind $sw.ent <Escape>a "sqlscinsert $arnm;break"
bind $sw.ent <Escape>u "sqlscupd $arnm;break"
}
bind $sw.ent <Escape>n "sqlscnext $arnm;break"
bind $sw.ent <Escape>r "sqlscreopen $arnm;break"
bind $sw.ent <Escape>w "sqlscreset $arnm;break"
set prev_ent $sw
}
set prev $sw
grid $sw -sticky w -column $x -row $y
if {$orient == "v"} {
incr y
} else {
incr x
}
# We sure could make less of these little effort
grid rowconfigure $w.ff $y -weight 1
grid columnconfigure $w.ff $x -weight 1
}
# Replace column list with the one with the "\n" deleted
set ar(columns) $realcols
# Bind next of last to first entry
if {$prev_ent != ""} {
_sqlcbindentrynext $prev_ent $firstent $arnm
}
pack $w -expand 1 -fill both
# Do we have to create an associated list for query results ?
if {[info exists ar(list_columns)]} {
sqlist $arnm
}
}
#####################################################################
# "List" screen:
# This is actually used for 2 separate things:
# 1- Creating a semi-independant screen. This is like an sqlscreen but:
# - The search values must be programatically set (no user input)
# - The results are shown as a list.
# This is mostly useful for running a subquery from a master screen
# 2- Creating a list image for an sqlscreen. In this case the list screen
# uses the same array as the sqlscreen, and runs the same queries,
# but it does not necessarily display all the columns. When a query is
# run, the chosen columns in all the result rows are shown in the
# list screen. Double-clicking on a line in the list shows the
# corresponding record in the sqlscreen (normally with more details)
proc sqlist {arnm} {
upvar #0 $arnm ar
global sqlsc_def_maxlen
if {[info exists ar(list_columns)]} {
# We're actually part of an sqlscreen
set w $ar(list_window)
if {![_sqlscisupdidx $arnm]} {
return -code error "slave list: need an updateindex to \
link back to the main screen"
}
foreach col $ar(updateindex) {
if {[lsearch $ar(list_columns) $col] == -1} {
return -code error "slave list: column $col is in
updateindex, should be listed in list_columns"
}
}
set collist $ar(list_columns)
} else {
# We're an independant screen
# Indicate that this is a list (used at least by the screen
# linking code)
set w $ar(window)
set ar(isalist) ""
_sqlscsetconparams ar host user passwd
set ar(hdl) [tcsqconnect $host $user $passwd]
tcsquse $ar(hdl) $ar(database)
foreach table $ar(table) {
tcsqcolinfo $ar(hdl) $table ar
}
set collist $ar(columns)
# puts "Collist: $collist"
}
# Compute columns and window widths in characters units
# puts "sqlsc_def_maxlen: $sqlsc_def_maxlen"
set ww [expr {2 * $sqlsc_def_maxlen}]
set width 0
if {[info exists ar(list_colwidths)]} {
set widthlist $ar(list_colwidths)
} else {
set widthlist {}
}
foreach col $collist colwidth $widthlist {
# Create the value entry. This avoids using "info exists"
# all over the place
if {![info exists ar(sqlsc_${col}_value)]} {
set ar(sqlsc_${col}_value) ""
}
if {$colwidth != ""} {
set cw [expr {$colwidth + 3}]
} else {
set cw [expr {$ar(sqlsc_${col}_len) + 3}]
}
lappend tabs $cw
incr width $cw
if {$width > $ww} {
set width $ww
# Don't stop the loop: need to set the values to ""
}
}
# puts "text width $width"
frame $w -relief groove -borderwidth 3
set title "$ar(table)"
if {[info exists ar(lines)]} {
set lines $ar(lines)
} else {
set lines 15
}
# Create the list window elements:
# - a message at the top for the table list
# - a text for the column headings
# - a text and a scrollbar for displaying the actual rows
message $w.tabnm -text $title -width 3i
text $w.collist -setgrid 1 -width $width -height 1 -wrap none \
-relief flat
$w.collist insert end [_sqlsclisttotabbedlist $collist]
# Create and set bold font from default font for this window.
# There doesn't appear to be any easy way to do this. Note
# that if the current font is a named font or if tk returns an X11
# font name (XLFD), we loose, and then choose an arbitrary font.
# It seems that v8.0 sometimes returns an XLFD, but will accept a
# {family size {styles}}. v7.6 only returns and accepts XLFDs of
# course.
set fna [$w.collist cget -font]
if {[llength $fna] != 2} {
set family Courier
set size 12
} else {
set family [lindex $fna 0]
set size [lindex $fna 1]
}
# puts "Family: $family, size: $size"
if {[info commands font] != ""} {
set fn [font create -family $family -size $size]
font configure $fn -weight bold
$w.collist configure -font $fn -state disabled
} else {
# Have to choose a font
# puts "Choosing font myself (courier-bold-r-normal-*-12-*)"
$w.collist configure -font "-*-courier-bold-r-normal-*-12-*"
}
scrollbar $w.scroll -relief sunken -command "$w.list yview"
# set textfont fixed -font $textfont
text $w.list -setgrid 1 -yscroll "$w.scroll set" -relief sunken \
-width $width -height $lines -wrap none
# Compute and set the tab stops according to the font and columns widths
for {set i 0} {$i < 100} {incr i} {append big0 "0000000000"}
set ll [llength $tabs]
set curpos 0
set isfontcmd [expr {[info commands font] != ""}]
for {set i 0} {$i < $ll} {incr i} {
if {$isfontcmd} {
# puts "--Using the font command"
set curpos [expr {$curpos + [font measure [$w.list cget -font] \
[string range $big0 0 [lindex $tabs $i]]]}]
} else {
# Assuming this is 12 points
# puts "--No font command, approximating tabs"
set curpos [expr {$curpos + [expr {[lindex $tabs $i] * 7.2}]}]
}
lappend ntabs [expr {int($curpos)}]
}
# puts "char width lists: $tabs"; puts "Tabs list: $ntabs"
$w.collist configure -tabs $ntabs
$w.list configure -tabs $ntabs
pack $w.tabnm -side top -fill x
pack $w.collist -side top -fill x
pack $w.scroll -side right -fill y
pack $w.list -fill both -expand 1
pack $w -fill both -expand 1
}
# Turn a TCL list into another valid list, using tabs as element
# separators instead of spaces. We insert bogus list elements and
# replace them and any white space surrounding them by a single
# tab. Who said 'not elegant' ?
#
# What we actually do is create an alternate string representation of
# a proper list, with tab separators instead of spaces at the top
# level.
#
# Note that this is NOT the same as "join $list \t". The result of the
# latter would remove the {} around list elements. (we'd need to add a
# level of accolades around each element before calling join, or use
# something like "join $lst "}\t{" and add { and } at each end. Not
# much nicer than the current solution...
proc _sqlsclisttotabbedlist {l} {
# Note : NO blanks in our element!
set myboguslistelt "___sqlsc_bogus_sqlsc___"
foreach elt $l {
lappend out [string trim $elt] $myboguslistelt
}
regsub -all " *$myboguslistelt *" $out "\t" out
# puts "listtotabbedlist: '$out'"
return $out
}
# Run query in a list screen. This is slightly different if we're an
# independant search screen or part of an sqlscreen
proc sqlistquery {arnm {opt ""}} {
upvar #0 $arnm ar
# puts "sqlistquery $arnm";flush stdout
if {[info exists ar(list_window)]} {
set w $ar(list_window)
} else {
set w $ar(window)
}
$w.list configure -state normal
$w.list delete 1.0 end
if {$opt == "reset"} {
return
}
if {![info exists ar(querynum)]} {
# Independant screen
set txt [_sqlscbuildselect ar]
# We don't run the select if there is no where clause (no valueset)
if {[string match "* where *" $txt] == 0} {
return
}
_sqlsclogstmt $txt
set ar(querynum) [tcsqopensel $ar(hdl) $txt]
_sqlsclogcommit
set needunsetquery 1
} else {
# Part of an sqlscreen
tcsqrew $ar(querynum)
set needunsetquery 0
# Indexes of list-columns in whole column list
foreach col $ar(list_columns) {
lappend idxs [lsearch $ar(columns) $col]
}
}
set lnum 1
while {[set rs [tcsqnext $ar(querynum)]] != ""} {
if {[info exists idxs]} {
set lst {}
foreach idx $idxs {
lappend lst [lindex $rs $idx]
}
set tag $w.list_sqlsctag$lnum
$w.list insert end "[_sqlsclisttotabbedlist $lst]\n" $tag
$w.list tag bind $tag <1> \
"_sqslavelistdetailfromtag $w.list $arnm $tag"
# Give the application a chance to set the properties for
# this line
if {[info exists ar(list_lineproc)]} {
uplevel #0 [list $ar(list_lineproc) $w.list $tag $lst]
} else {
# Alternate grey/white to help reading
set bgcolor [expr {($lnum & 1) ? "white" : "grey75"}]
$w.list tag configure $tag -background $bgcolor
}
} else {
$w.list insert end "[_sqlsclisttotabbedlist $rs]\n"
}
incr lnum
}
# Reset current entry if it exists
if {[info exists ar(list_curtag)]} {
$w.list tag configure $ar(list_curtag) -relief flat -borderwidth 3
}
$w.list configure -state disabled
if {$needunsetquery} {
tcsqclosel $ar(querynum)
unset ar(querynum)
} else {
tcsqrew $ar(querynum)
set bid [tcsqnext $ar(querynum)]
}
}
# A small helper proc to avoid embedding detailed widget knowledge in
# the main routine linking the list to the detail screen
proc _sqslavelistdetailfromtag {w arnm tag} {
upvar #0 $arnm ar
# puts "_sqslavelisdetailfromtag: w $w, arnm $arnm, tag: $tag"
set start [lindex [$w tag ranges $tag] 0]
set end [lindex [$w tag ranges $tag] 1]
if {[info exists ar(list_curtag)]} {
#-fgstipple ""
$w tag configure $ar(list_curtag) -relief flat -borderwidth 3
}
set ar(list_curtag) $tag
# -fgstipple gray50
$w tag configure $tag -relief sunken -borderwidth 3
_sqslavelistdetail $arnm [$w get $start $end]
}
# Callback for clicking on a list entry to get the details screen
proc _sqslavelistdetail {arnm line} {
upvar #0 $arnm ar
# puts "sqlslavelistdetail: called with arnm $arnm, line $line";flush stdout
set w $ar(list_window)
# Indicate what we are doing (avoid loops)
set ar(inslavelistdetail) ""
# Reset the main screen
sqlscreset $arnm
# Set the updateindex colums
foreach col $ar(updateindex) {
set idx [lsearch $ar(list_columns) $col]
set ar(sqlsc_${col}_value) [lindex $line $idx]
}
sqlscquery $arnm
unset ar(inslavelistdetail)
}
#######################################################################
# Screen linking stuff:
# Set things up so that the slave query is called each time the
# join column value is set.
proc sqlmasterslave {arnm1 col1 arnm2 col2} {
upvar $arnm1 ar1
lappend ar1(slaves) [list $col1 $arnm2 $col2]
}
# Set things up so that setting the slave's link column also sets the
# master but without resetting the whole master and running a query
# This is to update join columns in a table by running a query in a
# subscreen
proc sqlslavemaster {arnm1 col1 arnm2 col2} {
upvar $arnm1 ar1
lappend ar1(masters) [list $col1 $arnm2 $col2]
}
# Process linked screens after this one is set by a select, next, etc...
proc _sqlscdolinks {arnm} {
upvar #0 $arnm ar
# Avoid loops !
set ar(beingmaster) ""
if {[info exists ar(slaves)]} {
_sqlscdoslaves $arnm
}
if {[info exists ar(masters)]} {
_sqlscdomasters $arnm
}
unset ar(beingmaster)
}
# Set the slave's link column value, reset the other ones, and run a
# query.
proc _sqlscslavequery {arnm1 col1 arnm2 col2} {
upvar #0 $arnm1 ar1
upvar #0 $arnm2 ar2
# puts "sqlscslavequery: $arnm1 $col1 $arnm2 $col2"
if {[info exists ar2(isalist)] == 1} {
sqlistquery $arnm2 reset
# Note we're often called with a null value: during resets
if {[string trim $ar1(sqlsc_${col1}_value)] != ""} {
set ar2(sqlsc_${col2}_value) $ar1(sqlsc_${col1}_value)
sqlistquery $arnm2
}
} else {
sqlscreset $arnm2
# Run slave query only if master value not null
# Note we're often called with a null value: during resets
if {[string trim $ar1(sqlsc_${col1}_value)] != ""} {
set ar2(sqlsc_${col2}_value) $ar1(sqlsc_${col1}_value)
sqlscquery $arnm2
}
}
}
# Process slave screens: call sqlscslavequery for each one which is not
# further up this link chain
proc _sqlscdoslaves {arnm1} {
upvar #0 $arnm1 ar1
# puts "Doing slaves for $arnm1"
foreach slist $ar1(slaves) {
set arnm2 [lindex $slist 1]
upvar #0 $arnm2 ar2
if {[info exists ar2(beingmaster)]} {
# puts "$arnm2: being link origin"
continue
}
set col1 [lindex $slist 0]
set col2 [lindex $slist 2]
# puts "arnm1 $arnm1 col1 $col1, arnm2 $arnm2, col2 $col2"
_sqlscslavequery $arnm1 $col1 $arnm2 $col2
}
}
# Process master screens: set up the link column value if the screen
# is not further up this link chain
proc _sqlscdomasters {arnm1} {
upvar #0 $arnm1 ar1
# puts "Doing masters for $arnm1"
foreach slist $ar1(masters) {
set arnm2 [lindex $slist 1]
upvar #0 $arnm2 ar2
if {[info exists ar2(beingmaster)]} {
# puts "$arnm2: being link origin"
continue
}
set col1 [lindex $slist 0]
set col2 [lindex $slist 2]
# puts "arnm1 $arnm1 col1 $col1, arnm2 $arnm2, col2 $col2"
set ar2(sqlsc_${col2}_value) $ar1(sqlsc_${col1}_value)
}
}
# Return entry widget name
proc sqlsc_entrywidget {arnm col} {
upvar #0 $arnm ar
regsub {\.} $col _ colw
return $ar(window).ff.$colw.ent
}
# Return label widget name
proc sqlsc_labelwidget {arnm col} {
upvar #0 $arnm ar
regsub {\.} $col _ colw
return $ar(window).ff.$colw.lab
}