Make your own free website on Tripod.com

Pragana's Tcl Guide


Old notes


Stealing other's code

Our developing and coding time slot is very short, so if we plan doing large software projects, we have to find a way to partition the hard work with others. A simple way is to literally steal code from the others, without even have to understand fully what the other have done in detail.
This week we discuss how to do it with tcl's send command. I am doing a simple form editor for database applications, and stealing the visual designing code from Stewart's Visual Tcl. We can do this easily, because the widget tree being edited by Visual Tcl is separate from the main program and the send command could be used to query the other application (vtcl) about the widget properties and bindings.

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.
The other navigation procedures are straightforward.
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.
Back Home