#!/usr/bin/env wish
package require sqlsc
#option add *font {Arial 12}
#option add *Button*font {Arial 12 bold}
#option add *Label*font {Arial 12 bold}
#option add *Message*font {Arial 12 bold}
# Things that you may want to change
set username ""
set hostname ""
set password ""
catch {set username $env(SQLSCUSER)}
catch {set hostname $env(SQLSCHOST)}
catch {set password $env(SQLSCPASSWORD)}
# Environment and initialization
# There is some special handling when CDKITDB is set, you don't want it
catch {unset env(CDKITDB)}
set dbname "wines"
# Process args
set mode "query"
if {[lsearch $argv "-input"] != -1} {
set mode "update"
}
# sqlscreens global options
set sqlscnobell 1
# Local config (can be changed through menu entry)
# This decides if we show entries with a botcnt of 0 (ghosts) or not
set show0count 0
set pssdsp [expr {$password == "" ? "not set" : "set"}]
puts "--Connecting to: host: $hostname, user: $username, password: $pssdsp"
# Cleanup on exit ?
proc onexit {} {
exit 0
}
# Create top level and auxiliary windows
proc createwindows {{w ""}} {
global mode
frame $w.menu -relief raised -borderwidth 1
pack $w.menu -side top -fill x -expand 1
menubutton $w.menu.file -text "File" -menu $w.menu.file.m
menu $w.menu.file.m
.menu.file.m add command -label "Quit" -command onexit
pack $w.menu.file -side left
menubutton $w.menu.config -text "Config" -menu $w.menu.config.m
menu $w.menu.config.m
.menu.config.m add command -label "Wine sort order" -command setsortorder
.menu.config.m add command -label "Misc parameters" -command \
{setparams .params}
pack $w.menu.config -side left
frame $w.buttons
button $w.buttons.quit -text "Quit" -command onexit
button $w.buttons.qmode -text "Query mode" -command {setmode query}
uplevel #0 set qbutton $w.buttons.qmode
button $w.buttons.emode -text "Update mode" -command {setmode update}
uplevel #0 set ebutton $w.buttons.emode
button $w.buttons.touch -text "Touch winerec" -command {touchwine}
uplevel #0 set touchbutton $w.buttons.touch
if {$mode == "query"} {
$w.buttons.qmode configure -state disabled
$w.buttons.touch configure -state disabled
} else {
$w.buttons.emode configure -state disabled
}
pack $w.buttons.quit $w.buttons.touch $w.buttons.qmode $w.buttons.emode \
-side left -fill x -expand 1
frame $w.f1
frame $w.f2
toplevel .winelist
toplevel .tastings
pack .buttons .f1 -side top -fill both -expand yes
pack .f1 .f2 -side left
}
# Change the 'order by' clause for wines
proc setsortorder {} {
global sortorder wines
getanswer "Wines' sort order (Ex: 'year, minyear desc'), <CR> to commit" \
sortorder
puts "--$sortorder";flush stdout
set wines(ordercols) $sortorder
}
# Create checkbuttons to set misc parameters
proc setparams {w} {
toplevel $w
button $w.exit -text "close" -command "destroy $w"
pack $w.exit -side top -expand yes -fill x
checkbutton $w.show0count -text "show ghosts" -variable show0count
pack $w.show0count -side top
}
# Limit wine searches to non-zero bottle counts, except if option is set
proc befwinequery {args} {
global show0count wines
# puts "--befwinequery: show0count: $show0count"
if {$show0count == 0 && $wines(sqlsc_botcnt_value) == ""} {
set wines(sqlsc_botcnt_value) ">0"
}
return 0
}
# Set automatic fields before inserting a new record
proc befwineinsert {args} {
global wines
if {[info exists wines(sqlsc_curuprice_value)] && \
$wines(sqlsc_curuprice_value) == ""} {
set wines(sqlsc_curuprice_value) $wines(sqlsc_unitprice_value)
}
if {[info exists wines(sqlsc_botcnt_value)] && \
$wines(sqlsc_botcnt_value) == ""} {
set wines(sqlsc_botcnt_value) $wines(sqlsc_purchcnt_value)
}
return 0
}
# Change the current mode (input or query)
proc setmode {mode} {
global wines origins producers providers tastings ebutton qbutton \
touchbutton
switch $mode {
query {
$ebutton configure -state normal
$touchbutton configure -state disabled
$qbutton configure -state disabled
}
update {
$qbutton configure -state normal
$touchbutton configure -state normal
$ebutton configure -state disabled
}
default {return -code error "setmode: bad mode '$mode'"}
}
set saved_id $wines(sqlsc_stockid_value)
sqlscreendelete wines
sqlscreendelete origins
sqlscreendelete producers
sqlscreendelete providers
sqlscreendelete tastings
createsqlscreens $mode
if {$saved_id != ""} {
set wines(sqlsc_stockid_value) $saved_id
sqlscquery wines
}
}
proc touchwine {} {
global wines
set wineid $wines(sqlsc_stockid_value)
set comment "$wines(sqlsc_comments_value)."
tcsqexec $wines(hdl) "UPDATE wines set comments = \"$comment\"
WHERE stockid = $wineid"
set comment [string trimright $comment "."]
tcsqexec $wines(hdl) "UPDATE wines set comments = \"$comment\"
WHERE stockid = $wineid"
}
# Set color according to bottle count in the wine list. See comments
# in createsqlscreens
proc setlinecolor {w tag res} {
set botcnt [lindex $res 0]
switch $botcnt {
1 {$w tag configure $tag -background red}
2 {$w tag configure $tag -background orange}
3 {$w tag configure $tag -background yellow}
default {$w tag configure $tag -background green}
}
}
# Create the query screens, in 'query' or 'update' mode. We have two
# modes because of the way we handle the "origin" field.
# The database was designed at a time where we could not have
# multi-table query screens. We'd use this and an integer join column
# now, but there would still be a different mode for updates (can't
# update through a multi-table screen).
proc createsqlscreens {mode} {
# puts "--createsqlscreens: mode $mode"
global wines origins producers providers tastings
global dbname table hostname username password
# Save some typing for common entries. Note that host/user/passwd are
# optional. Using table names as array names makes such things easy,
# but is by no means mandatory.
foreach table {wines providers producers origins tastings} {
set ${table}(database) $dbname
set ${table}(table) $table
set ${table}(sqlschost) $hostname
set ${table}(sqlscuser) $username
set ${table}(sqlscpasswd) $password
if {$mode != "update"} {
set ${table}(queryonly) ""
}
}
# Wines screen
set wines(window) .f1.wines
set wines(columns) {
name \n
origin \n
color \n
year \n
minyear maxyear \n
purchdate purchcnt \n
unitprice \n
botcnt bottype \n
comments \n
curuprice \n
stockid producer provider
}
set wines(updateindex) stockid
set wines(initfocus) name
# Limit the visible length for some fields
foreach fld {name comments origin} {
set wines(sqlsc_${fld}_len) 50
}
# Choice lists (wine colors and bottle sizes). These fields are
# enums so that a choice would be automatically generated. We
# override the automatic choice for colors as a demo for setting
# different display/db values.
global colors
set colors {{Red red} {White white} {Pink pink} \
{{Sweet White} {sweet white}}}
set wines(choices) {
color colors
}
set wines(allowdelete) ""
set wines(nodisplay) {stockid producer provider}
set wines(autopercentboth) {name origin}
# Auxiliary list screen
set wines(list_columns) {botcnt name year stockid}
# set wines(list_colwidths) {2 50 4 8}
set wines(list_window) .winelist.winelist
# The following ensures that the 'setlinecolor' procedure will be
# called for each line in the result list. The arguments are the list
# window name (this is actually a text widget), the tag name for the
# line, and the list of values for the columns in this record. In this
# example, we turn the line red if the bottle count is 1, etc...
# (botcnt is the first entry in our list_columns list). The
# result is real ugly but Ok for demo purposes I guess.
set wines(list_lineproc) setlinecolor
# The origins column in the wines table is a join column to the
# origins table. This should actually be an int (origid), but we like
# to sort on it, and do partial searches (Ex: Bordeaux%)
# It is different in an entry or search screen:
# It is set as "noentry" in the entry screen, so that only
# values from the origins table are allowed
# It is normal for the query screen, so that we can use "like"
# This is the main reason why we have -input and -query options.
# We would rather use a multi-table query screen with the current
# sqlscreen version, but this was not available when wines was designed
if {$mode == "update"} {
set wines(noentry) {origin}
}
# initial 'order by' clause (can be changed by menu entry):
global sortorder
set sortorder "color, minyear, year"
set wines(ordercols) $sortorder
set wines(beforequery) befwinequery
set wines(beforeinsert) befwineinsert
set wines(botcnt) ""
# Create wines screen
sqlscreen wines
# Tastings screen: has a text (blob) field
set tastings(window) .tastings.tastings
set tastings(noentry) {tastid}
set tastings(nodisplay) {stockid}
set tastings(texts) {{text 20 70}}
set tastings(ordercols) {tdate DESC}
sqlscreen tastings
# Providers and producers screens. These are much alike.
foreach table {producers providers} {
set ${table}(window) .f2.$table
# Restrict some field widths to reduce total screen width
foreach col {name address1 address2 comments} {
set ${table}(sqlsc_${col}_len) 55
}
set ${table}(sqlsc_city_len) 30
set ${table}(sqlsc_tel_len) 14
set ${table}(sqlsc_fax_len) 14
set ${table}(sqlsc_zip_len) 8
set ${table}(columns) {
name \n
address1 \n
address2 \n
zip tel fax \n
comments \n
id
}
set ${table}(nodisplay) id
set ${table}(updateindex) id
set ${table}(autopercentboth) name
sqlscreen $table
}
# Origins screen
set origins(window) .f1.org
set origins(sqlsc_origin_len) 50
# Don't want to use the origid colums
set origins(columns) {origin}
#set origins(nobuttons) ""
set origins(notitle) ""
set origins(queryonly) ""
set origins(ordercols) origin
set origins(autopercentboth) origin
sqlscreen origins
# Finally create links between screens.
# Note that we use non-symetric links both in input and query
# mode. This is almost mandatory for input: we don't want to
# reset the wines screen to set the producer!
# For querying, this is more a matter of taste. Symetric links
# make it easier to query for all wines from some producer (saves
# 2 mouse clicks), but make it impossible to add other conditions
# to such a search
sqlmasterslave wines provider providers id
sqlmasterslave wines producer producers id
sqlmasterslave wines origin origins origin
sqlmasterslave wines stockid tastings stockid
sqlslavemaster providers id wines provider
sqlslavemaster producers id wines producer
sqlslavemaster origins origin wines origin
}
createwindows ""
createsqlscreens $mode
# Get a value for something and set it in a global variable
proc getanswer { what varname { w .query } } {
# puts "getanswer: what $what, varname $varname, w $w"; flush stdout
catch {destroy $w}
toplevel $w -class Dialog
wm title $w "Question"
wm iconname $w Dialog
_sqlsclabentry $w.tn "$what" [expr {[string length "$what"] + 5}] \
$varname 20
bind $w.tn.ent <KeyPress-Return> "destroy $w"
grab $w
focus $w.tn.ent
pack $w.tn -expand 1 -fill x
tkwait window $w
}