Our database is done by PostgreSQL, but any other good SQL server could be
employed for the same purposes. Our form design is very preliminary. It only
automates SELECT queries, but could easily be expanded to include UPDATE, INSERT
and DELETE queries as well.
What's a form? A GUI with some connections to a database system, to become easier
writing applications accessing the underlying server. Let us begin by defining
where we are going to store our form definitions. We have chosen to store
the forms in two tables, frm_form and frm_objects. These tables have the
following structure:
The table frm_table defines each form available, invoked by the tcl command
doForm <formname>, including the select query associated to
populate the form fields (and also some internal array variables), selecting
a geometry for the main form window, the form's name and the bindings
for the toplevel window.
The other table, frm_objects, store each widget for the form, having foid as
a link for the former table instance. The oid is unique for each instance of
PostgreSQL rows, even globally. The other table columns are for the type (class)
of the widget, it's name (full path name with the dots, ŕ la Tcl way),
the options as given to the config subcommand, the geometry manager and
it's options for the widget, and the bindings as a list-of-lists:
{<event tag> { commands } <event tag2> { commands2 } ... }
The procedure store_form assumes a pre-existent connection to the database
store at the global variable conn, created by doing
set conn [pg_connect <database>}. The capture argument decides
if we want to take a window hierarchy from our present interpreter or from the
visual tcl's, that must be running at the time of this procedure's invocation.
When capture is on, we use the send command to ask vt.tcl (visual tcl)
application about our objects. Otherwise, we assume some other code has created
the widget hierarchy we are interested at. For instance, we could have
generated the widgets (toplevel and the others) from a TkCon application
attached to our main program. This is the way I do myself sometimes, when the
interface is not to hairy to think about it.
The lines with regsub are for doing a quoting in the apostrophe character, so to not crazing our SQL server. It's just duplicated before sending the query text to the server. The only geometry managers supported by this code are pack, place and grid. Remember not to use any other toplevels or menubar, because their manager is wm.
proc store_form { frm {capture 0}} {
global conn form $frm
set vt vt.tcl
set fquery ""
### get old form foid and query
set query "select oid,query from frm_form where name = '$frm'"
set qryd [pg_exec $conn $query]
if {![catch {set tuple [pg_result $qryd -getTuple 0]}]} {
set foid [lindex $tuple 0]
set fquery [lindex $tuple 1]
pg_result $qryd -clear
### delete all old objects from the form definition table
set query "delete from frm_objects where foid = '$foid'"
set qryd [pg_exec $conn $query]
pg_result $qryd -clear
### delete old form
set query "delete from frm_form where name = '$frm'"
set qryd [pg_exec $conn $query]
}
pg_result $qryd -clear
### create new form
set bindings {}
if {$capture} {
foreach binding [send $vt bind .$frm] {
lappend bindings [list $binding [send $vt bind .$frm $binding]]
}
regsub -all ' $bindings '' bindings
set query "insert into frm_form values( \
'[inputbox .query {Query para o formulário} $fquery 60]',\
'[send $vt wm geometry .$frm]','$frm','$bindings' )"
} else {
foreach binding [bind .$frm] {
lappend bindings [list $binding [bind .$frm $binding]]
}
regsub -all ' $bindings '' bindings
set query "insert into frm_form values( \
'[inputbox .query {Query para o formulário} $fquery 60]',\
'[wm geometry .$frm]','$frm','$bindings' )"
}
set qryd [pg_exec $conn $query]
set foid [pg_result $qryd -oid]
pg_result $qryd -clear
### insert new objects into form definition table
set widlist [form_get_all_children .$frm $capture $vt]
foreach w $widlist {
if {$capture} {
set manager [send $vt winfo manager $w]
} else {
set manager [winfo manager $w]
}
switch $manager {
place -
pack -
grid {
set options ""
if {$capture} {
set ops [send $vt $w config]
} else {
set ops [$w config]
}
foreach op $ops {
if {[lindex $op 3] != [lindex $op 4]} {
append options "[lindex $op 0] \{[lindex $op 4]\} "
}
}
set bindings {}
if {$capture} {
set type [string tolower [send $vt winfo class $w]]
foreach binding [send $vt bind $w] {
lappend bindings [list $binding \
[send $vt bind $w $binding]]
}
regsub -all ' $bindings '' bindings
set query "insert into frm_objects values('$foid','$type',\
'$w','$options',\
'$manager','[send $vt $manager info $w]','$bindings')"
} else {
set type [string tolower [winfo class $w]]
foreach binding [bind $w] {
lappend bindings [list $binding \
[bind $w $binding]]
}
regsub -all ' $bindings '' bindings
set query "insert into frm_objects values('$foid','$type',\
'$w','$options','$manager',\
'[$manager info $w]','$bindings')"
}
set qryd [pg_exec $conn $query]
pg_result $qryd -clear
} }
}
}
When getting all hierarchy, we need all children (and grandchildren) of a
toplevel, not only it's first generation. The following procedure get this
in a recursive form. The variable vt could be changed to another visual editor,
if it it's designed objects are maintained at a separate tree as Visual tcl's.
proc form_get_all_children { w capture vt } {
if {$capture} {
set chlist [send $vt winfo children $w]
} else {
set chlist [winfo children $w]
}
foreach child $chlist {
set chlist [concat $chlist \
[form_get_all_children $child $capture $vt]]
}
return $chlist
}
The reading back of the form is not very difficult, if we know well our data.
Each column of the current instance (row) of the table/query, is stored at an
array element with the same form's name and with the column's (attribute) name
as it's index. If we want an automatic form filling when navigating through the
database table/query, we can include in our form an entry with the option
-textvariable form(column).
proc doForm { frm } {
global conn $frm
set w .$frm
if {[winfo exists $w]} { return }
toplevel $w -class Form
wm iconname $w Form
wm protocol $w WM_DELETE_WINDOW {exit}
catch {set qryd [pg_exec $conn \
"select oid,query,geometry,bindings from frm_form where name='$frm'"]}
set frmdata [pg_result $qryd -getTuple 0]
set query [lindex $frmdata 1]
set ${frm}(#query) $query
set foid [lindex $frmdata 0]
wm geometry $w [lindex $frmdata 2]
foreach binding [lindex $frmdata 3] {
bind $w [lindex $binding 0] [lindex $binding 1]
}
pg_result $qryd -clear
#### retrieve all stored objects for this form
catch {set qryd [pg_exec $conn \
"select type,name,options,manager,mgoptions,bindings \
from frm_objects where foid=$foid"]}
set imax [pg_result $qryd -numTuples]
for {set i 0} {$i<$imax} {incr i} {
set tuple [pg_result $qryd -getTuple $i]
set k 0
foreach v {type name options manager mgoptions bindings} {
set $v [lindex $tuple $k]
incr k
}
eval "$type $name $options"
eval "$manager $name $mgoptions"
foreach binding $bindings {
bind $name [lindex $binding 0] [lindex $binding 1]
}
}
pg_result $qryd -clear
set ${frm}(#recno) 0
set ${frm}(#numTuples) 0
update idletasks
}
The remaining procedures are just for navigating. Our array named with the form's
name will have indexes #numTuples for the number of records retrieved by the
query, #recno for the current record shown (available with the field-name
indexed elements of the array), #qryd as the descriptor of the current query.
This last variable is for internal use of libpgtcl, having no external
meaning. When this variable is null (or don't exists), no query was fired,
so we must first fill it with the query's result.
proc gotorec_form { frm {n 0} } {
global conn $frm
upvar #0 $frm f
if {![info exists f(#qryd)]} {
set query $f(#query)
set qryd [pg_exec $conn [subst $query]]
set tuple [pg_result $qryd -getTuple 0]
set k 0
foreach attr [pg_result $qryd -attributes] {
set f($attr) [lindex $tuple $k]
incr k
}
set f(#numTuples) [pg_result $qryd -numTuples]
set f(#recno) 1
set f(#qryd) $qryd
} elseif {($n <= $f(#numTuples)) && ($n > 0)} {
set f(#recno) $n
set tuple [pg_result $f(#qryd) -getTuple [expr $f(#recno)-1]]
set k 0
foreach attr [pg_result $f(#qryd) -attributes] {
set f($attr) [lindex $tuple $k]
incr k
}
update idletasks
}
}
proc toNext_form { frm } {
global $frm
upvar #0 $frm f
gotorec_form $frm [expr $f(#recno)+1]
}
proc toPrev_form { frm } {
global $frm
upvar #0 $frm f
gotorec_form $frm [expr $f(#recno)-1]
}
proc toFirst_form { frm } {
global $frm
upvar #0 $frm f
gotorec_form $frm 0
}
proc toLast_form { frm } {
global $frm
upvar #0 $frm f
gotorec_form $frm [expr $f(#numTuples)-1]
}
Next week I'll show some simple forms coded for this library above and discuss
some other aspects of it's implementation.