SQLScreens / Code / Diff of /sqlscreens.tcl

Diff of /sqlscreens.tcl [b83d64] .. [b0e845]

Switch to unified view


...
#### 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
}

#####################
...
      -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
...
# 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
}

#######################################################
...
    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
}

...
    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
}

###################################################################
...
    # 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
}

###################################################################
...

    # 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
}

...
    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
}

#
...
# 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]
...
    _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
}

#############
...
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"
...
    _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
}

#############################
...
    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
}

########
...
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
...
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
...
# 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
...
    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
}

...
    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 
...
 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" 
...
    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
}

...
    _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"
...
    } 

    # 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 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:
...
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
...
    # 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

...
# 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
}
...
# 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
...
    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]
...
    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)
}

...
 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)
...
 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} {
...
proc sqlsc_labelwidget {arnm col} {
    upvar #0 $arnm ar
    regsub {\.} $col _ colw
    return $ar(window).ff.$colw.lab
}



	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)%"