You are viewing a plain text version of this content. The canonical link for it is here.
Posted to rivet-dev@tcl.apache.org by da...@apache.org on 2002/04/17 21:09:41 UTC
cvs commit: tcl-rivet/rivet/packages/dio dio.tcl diodisplay.tcl pkgIndex.tcl
damonc 02/04/17 12:09:41
Added: rivet/packages/dio dio.tcl diodisplay.tcl pkgIndex.tcl
Log:
Adding a new package called 'DIO' (Database Interface Objects).
This package is a set of classes built to handle SQL databases in a generic
interface. It is still under development, but it's pretty well stable
under Postgres and pretty nice under MySQL as well.
The other package is 'DIODisplay' which is a set of classes built to display
database interfaces on the web using DIO objects to do the real back-end
work.
Documentation will follow shortly.
Revision Changes Path
1.1 tcl-rivet/rivet/packages/dio/dio.tcl
Index: dio.tcl
===================================================================
catch {package require Tclx}
package require Itcl
package provide DIO 1.0
namespace eval ::DIO {
proc handle {interface args} {
set obj #auto
set first [lindex $args 0]
if {![lempty $first] && [string index $first 0] != "-"} {
set obj [lindex $args 0]
set args [lreplace $args 0 0]
}
return [uplevel #0 ::DIO::$interface $obj $args]
}
##
# DATABASE CLASS
##
::itcl::class Database {
constructor {args} {
eval configure $args
}
destructor {
close
}
protected method result {interface args} {
return [eval uplevel #0 ::DIO::${interface}Result #auto $args]
}
method quote {string} {
regsub -all {'} $string {\'} string
return $string
}
protected method build_select_query {args} {
set bool AND
set first 1
set waiting 0
set req "select * from $table"
if {[lempty $args]} { return $req }
append req " WHERE"
foreach elem $args {
switch -nocase -- $elem {
"-and" { set bool AND }
"-or" { set bool OR }
default {
if {$waiting} {
if {$first} {
set first 0
} else {
append req " $bool"
}
append req " $switch='[quote $elem]'"
set waiting 0
continue
}
if {[cindex $elem 0] == "-"} {
set switch [crange $elem 1 end]
set waiting 1
continue
}
append req " $elem"
}
}
}
return $req
}
protected method build_insert_query {arrayName fields {myTable ""}} {
upvar 1 $arrayName array
if {[lempty $myTable]} { set myTable $table }
foreach field $fields {
if {![info exists array($field)]} { continue }
append vars "$field,"
append vals "'[quote $array($field)]',"
}
set vals [::string range $vals 0 end-1]
set vars [::string range $vars 0 end-1]
return "insert into $myTable ($vars) VALUES ($vals)"
}
protected method build_update_query {arrayName fields {myTable ""}} {
upvar 1 $arrayName array
if {[lempty $myTable]} { set myTable $table }
foreach field $fields {
if {![info exists array($field)]} { continue }
append string "$field='[quote $array($field)]',"
}
set string [::string range $string 0 end-1]
return "update $myTable SET $string"
}
protected method lassign_array {list arrayName args} {
upvar 1 $arrayName array
foreach elem $list field $args {
set array($field) $elem
}
}
protected method configure_variable {varName string} {
if {[lempty $string]} { return [cget -$varName] }
configure -$varName $string
}
protected method build_key_where_clause {myKeyfield myKey} {
## If we're not using multiple keyfields, just return a simple
## where clause.
if {[llength $myKeyfield] < 2} {
return " WHERE $myKeyfield = '[quote $myKey]'"
}
set first 1
set req ""
foreach field $myKeyfield key $myKey {
if {$first} {
append req " WHERE $field='[quote $key]'"
set first 0
} else {
append req " AND $field='[quote $key]'"
}
}
return $req
}
##
## Given an array of values, return a key that would be used in this
## database to store this array.
##
method makekey {arrayName {myKeyfield ""}} {
if {[lempty $myKeyfield]} { set myKeyfield $keyfield }
if {[lempty $myKeyfield]} {
return -code error "No -keyfield specified in object"
}
upvar 1 $arrayName array
## If we're not using multiple keyfields, we want to check and see
## if we're using auto keys. If we are, create a new key and
## return it. If not, just return the value of the single keyfield
## in the array.
if {[llength $myKeyfield] < 2} {
if {$autokey} {
set array($myKeyfield) [$this nextkey]
} else {
if {![info exists array($myKeyfield)]} {
return -code error \
"${arrayName}($myKeyfield) does not exist"
}
}
return $array($myKeyfield)
}
## We're using multiple keys. Return a list of all the keyfield
## values.
foreach field $myKeyfield {
if {![info exists array($field)]} {
return -code error "$field does not exist in $arrayName"
}
lappend key $array($field)
}
return $key
}
method destroy {} {
::itcl::delete object $this
}
method search {args} {
set req [eval build_select_query $args]
return [exec $req]
}
###
## Execute a request and only return a string of the row.
###
method string {req} {
set res [exec $req]
set val [$res next -list]
$res destroy
return $val
}
###
## Execute a request and return a list of the first element of each row.
###
method list {req} {
set res [exec $req]
set list ""
while {[$res next -list line]} {
lappend list [lindex $line 0]
}
$res destroy
return $list
}
###
## Execute a request and setup an array with the row fetched.
###
method array {req arrayName} {
upvar 1 $arrayName $arrayName
set res [exec $req]
set ret [$res next -array $arrayName]
$res destroy
return $ret
}
protected method table_check {list {tableVar myTable} {keyVar myKeyfield}} {
upvar 1 $tableVar $tableVar $keyVar $keyVar
set data(-table) $table
set data(-keyfield) $keyfield
::array set data $list
if {[lempty $data(-table)]} {
return -code error "-table not specified in DIO object"
}
if {[lempty $data(-keyfield)]} {
return -code error "-keyfield not specified in DIO object"
}
set $tableVar $data(-table)
set $keyVar $data(-keyfield)
}
protected method key_check {myKeyfield myKey} {
if {[llength $myKeyfield] < 2} { return }
if {$autokey} {
return -code error "Cannot have autokey and multiple keyfields"
}
if {[llength $myKeyfield] != [llength $myKey]} {
return -code error "Bad key length."
}
}
method fetch {key arrayName args} {
table_check $args
key_check $myKeyfield $key
upvar 1 $arrayName $arrayName
set req "select * from $myTable"
append req [build_key_where_clause $myKeyfield $key]
set res [$this exec $req]
if {[$res error]} {
$res destroy
return 0
}
set return [expr [$res numrows] > 0]
$res next -array $arrayName
$res destroy
return $return
}
method store {arrayName args} {
table_check $args
upvar 1 $arrayName $arrayName $arrayName array
if {[llength $myKeyfield] > 1 && $autokey} {
return -code error "Cannot have autokey and multiple keyfields"
}
set key [makekey $arrayName $myKeyfield]
set req "select * from $myTable"
append req [build_key_where_clause $myKeyfield $key]
set res [exec $req]
if {[$res error]} {
$res destroy
return 0
}
set numrows [$res numrows]
set fields [$res fields]
$res destroy
if {$numrows} {
set req [build_update_query array $fields $myTable]
append req [build_key_where_clause $myKeyfield $key]
} else {
set req [build_insert_query array $fields $myTable]
}
set res [exec $req]
set return [expr [$res error] == 0]
$res destroy
return $return
}
method delete {key args} {
table_check $args
set req "delete from $myTable"
append req [build_key_where_clause $myKeyfield $key]
set res [exec $req]
set return [expr [$res error] == 0]
$res destroy
return $return
}
method keys {args} {
table_check $args
set req "select * from $myTable"
set obj [$this exec $req]
set keys ""
$obj forall -array a {
lappend keys [makekey a $myKeyfield]
}
$obj destroy
return $keys
}
##
## These are methods which should be defined by each individual database
## class.
##
method open {args} {}
method close {args} {}
method exec {args} {}
method nextkey {args} {}
method lastkey {args} {}
##
## Functions to get and set public variables.
##
method errorinfo {{string ""}} { configure_variable errorinfo $string }
method db {{string ""}} { configure_variable db $string }
method table {{string ""}} { configure_variable table $string }
method keyfield {{string ""}} { configure_variable keyfield $string }
method autokey {{string ""}} { configure_variable autokey $string }
method sequence {{string ""}} { configure_variable sequence $string }
method user {{string ""}} { configure_variable user $string }
method pass {{string ""}} { configure_variable pass $string }
method host {{string ""}} { configure_variable host $string }
method port {{string ""}} { configure_variable port $string }
public variable errorinfo ""
public variable db ""
public variable table ""
public variable sequence ""
public variable user ""
public variable pass ""
public variable host ""
public variable port ""
public variable keyfield "" {
if {[llength $keyfield] > 1 && $autokey} {
return -code error "Cannot have autokey and multiple keyfields"
}
}
public variable autokey 0 {
if {[llength $keyfield] > 1 && $autokey} {
return -code error "Cannot have autokey and multiple keyfields"
}
}
} ; ## ::itcl::class Database
::itcl::class Result {
constructor {args} {
eval configure $args
}
destructor { }
method destroy {} {
::itcl::delete object $this
}
protected method configure_variable {varName string} {
if {[lempty $string]} { return [cget -$varName] }
configure -$varName $string
}
protected method lassign_array {list arrayName args} {
upvar 1 $arrayName array
foreach elem $list field $args {
set array($field) $elem
}
}
method seek {newrowid} {
set rowid $newrowid
}
method cache {{size "all"}} {
set cacheSize $size
if {$size == "all"} { set cacheSize $numrows }
## Delete the previous cache array.
catch {unset cacheArray}
set autostatus $autocache
set currrow $rowid
set autocache 1
seek 0
set i 0
while {[next -list list]} {
if {[incr i] >= $cacheSize} { break }
}
set autocache $autostatus
seek $currrow
set cached 1
}
method forall {type varName body} {
upvar 1 $varName $varName
set currrow $rowid
seek 0
while {[next $type $varName]} {
uplevel 1 $body
}
set rowid $currrow
return
}
method next {type {varName ""}} {
set return 1
if {![lempty $varName]} {
upvar 1 $varName var
set return 0
}
catch {unset var}
set list ""
## If we have a cached result for this row, use it.
if {[info exists cacheArray($rowid)]} {
set list $cacheArray($rowid)
} else {
set list [$this nextrow]
if {[lempty $list]} {
if {$return} { return }
set var ""
return 0
}
if {$autocache} { set cacheArray($rowid) $list }
}
incr rowid
switch -- $type {
"-list" {
if {$return} {
return $list
} else {
set var $list
}
}
"-array" {
if {$return} {
foreach field $fields elem $list {
lappend var $field $elem
}
return $var
} else {
eval lassign_array [list $list] var $fields
}
}
"-keyvalue" {
foreach field $fields elem $list {
lappend var -$field $elem
}
if {$return} { return $var }
}
default {
incr rowid -1
return -code error \
"In-valid type: must be -list, -array or -keyvalue"
}
}
return [expr [lempty $list] == 0]
}
method resultid {{string ""}} { configure_variable resultid $string }
method fields {{string ""}} { configure_variable fields $string }
method rowid {{string ""}} { configure_variable rowid $string }
method numrows {{string ""}} { configure_variable numrows $string }
method error {{string ""}} { configure_variable error $string }
method errorcode {{string ""}} { configure_variable errorcode $string }
method errorinfo {{string ""}} { configure_variable errorinfo $string }
method autocache {{string ""}} { configure_variable autocache $string }
public variable resultid ""
public variable fields ""
public variable rowid 0
public variable numrows 0
public variable error 0
public variable errorcode 0
public variable errorinfo ""
public variable autocache 1
protected variable cached 0
protected variable cacheSize 0
protected variable cacheArray
} ; ## ::itcl::class Result
::itcl::class Postgresql {
inherit Database
constructor {args} {eval configure $args} {
package require Pgtcl
set_conn_defaults
eval configure $args
}
destructor {
close
}
## Setup our variables with the default conninfo from Postgres.
private method set_conn_defaults {} {
foreach list [pg_conndefaults] {
set var [lindex $list 0]
set val [lindex $list end]
switch -- $var {
"dbname" { set db $val }
default { set $var $val }
}
}
}
method open {} {
set command "pg_connect"
set info ""
if {![lempty $user]} { append info " user=$user" }
if {![lempty $pass]} { append info " password=$pass" }
if {![lempty $host]} { append info " host=$host" }
if {![lempty $port]} { append info " port=$port" }
if {![lempty $db]} { append info " dbname=$db" }
if {![lempty $info]} { append command " -conninfo [::list $info]" }
if {[catch $command error]} { return -code error $error }
set conn $error
}
method close {} {
if {![info exists conn]} { return }
pg_disconnect $conn
unset conn
}
method exec {req} {
if {![info exists conn]} { open }
set command pg_exec
if {[catch {$command $conn $req} result]} { return -code error $result }
set errorinfo ""
set obj [result Postgresql -resultid $result]
if {[$obj error]} { set errorinfo [$obj errorinfo] }
return $obj
}
method nextkey {} {
return [$this string "select nextval( '$sequence' )"]
}
method lastkey {} {
return [$this string "select last_value from $sequence"]
}
## If they change DBs, we need to close the connection and re-open it.
public variable db "" {
if {[info exists conn]} {
close
open
}
}
private variable conn
} ; ## ::itcl::class Postgresql
::itcl::class PostgresqlResult {
inherit Result
constructor {args} {
eval configure $args
if {[lempty $resultid]} {
return -code error "No resultid specified while creating result"
}
set numrows [pg_result $resultid -numTuples]
set fields [pg_result $resultid -attributes]
set errorcode [pg_result $resultid -status]
set errorinfo [pg_result $resultid -error]
if {$errorcode != "PGRES_COMMAND_OK" \
&& $errorcode != "PGRES_TUPLES_OK"} { set error 1 }
## Reconfigure incase we want to overset the default values.
eval configure $args
}
destructor {
pg_result $resultid -clear
}
method clear {} {
pg_result $resultid -clear
}
method nextrow {} {
if {$rowid >= $numrows} { return }
return [pg_result $resultid -getTuple $rowid]
}
} ; ## ::itcl::class PostgresqlResult
::itcl::class Mysql {
inherit Database
constructor {args} {eval configure $args} {
package require Mysqltcl
eval configure $args
if {[lempty $db]} {
if {[lempty $user]} {
set user $::env(USER)
}
set db $user
}
}
destructor {
close
}
method open {} {
set command "mysqlconnect"
if {![lempty $user]} { lappend command -user $user }
if {![lempty $pass]} { lappend command -pass $pass }
if {![lempty $host]} { lappend command -host $host }
if {![lempty $port]} { lappend command -port $port }
if {[catch $command error]} { return -code error $error }
set conn $error
if {![lempty $db]} { mysqluse $conn $db }
}
method close {} {
if {![info exists conn]} { return }
catch {mysqlclose $conn}
unset conn
}
method exec {req} {
if {![info exists conn]} { open }
set cmd mysqlexec
if {[::string tolower [lindex $req 0]] == "select"} { set cmd mysqlsel }
set errorinfo ""
if {[catch {$cmd $conn $req} error]} {
set errorinfo $error
set obj [result Mysql -error 1 -errorinfo [::list $error]]
return $obj
}
set fields [mysqlcol $conn -current name]
set obj [result Mysql -resultid $conn \
-numrows $error -fields [::list $fields]]
return $obj
}
method lastkey {} {
if {![info exists conn]} { return }
return [mysqlinsertid $conn]
}
method quote {string} {
if {![catch {mysqlquote $string} result]} { return $result }
regsub -all {'} $string {\'} string
return $string
}
public variable db "" {
if {[info exists conn]} {
mysqluse $conn $db
}
}
private variable conn
} ; ## ::itcl::class Mysql
::itcl::class MysqlResult {
inherit Result
constructor {args} {
eval configure $args
}
destructor {
}
method nextrow {} {
return [mysqlnext $resultid]
}
} ; ## ::itcl::class MysqlResult
} ; ## namespace eval DIO
1.1 tcl-rivet/rivet/packages/dio/diodisplay.tcl
Index: diodisplay.tcl
===================================================================
package require Itcl
package require DIO
catch { package require form }
package provide DIODisplay 1.0
catch { ::itcl::delete class DIODisplay }
::itcl::class ::DIODisplay {
constructor {args} {
eval configure $args
load_response
if {[lempty $DIO]} {
return -code error "You must specify a DIO object"
}
if {[lempty $form]} {
set form [namespace which [::form #auto -defaults response]]
}
}
destructor {
if {$cleanup} { do_cleanup }
}
method destroy {} {
::itcl::delete object $this
}
method configure_variable {varName string} {
if {[lempty $string]} { return [set $varName] }
configure -$varName $string
}
method is_function {name} {
if {[lsearch $functions $name] > -1} { return 1 }
if {[lsearch $allfunctions $name] > -1} { return 1 }
return 0
}
method do_cleanup {} {
## Destroy all the fields created.
foreach field $allfields { catch { $field destroy } }
## Destroy the DIO object.
$DIO destroy
## Destroy the form object.
$form destroy
}
method handle_error {error} {
global errorCode
global errorInfo
puts "<PRE>"
puts "ERROR: $errorInfo"
puts "</PRE>"
}
method show {} {
set mode Main
if {[info exists response(mode)]} { set mode $response(mode) }
if {![is_function $mode]} {
puts "In-valid function"
abort_page
return
}
catch $mode error
if {$cleanup} { destroy }
if {![lempty $error]} { $errorhandler $error }
}
method showview {} {
puts "<TABLE>"
foreach field $fields {
$field showview
}
puts "</TABLE>"
}
method showform {} {
get_field_values array
$form start
$form hidden DIODfromMode -value $response(mode)
$form hidden DIODkey -value [$DIO makekey array]
puts "<TABLE>"
foreach field $fields {
$field showform
}
puts "</TABLE>"
puts "<TABLE>"
puts "<TR>"
puts "<TD>"
$form submit mode -value "Save"
puts "</TD>"
puts "<TD>"
$form submit mode -value "Cancel"
puts "</TD>"
puts "</TR>"
puts "</TABLE>"
}
method showrow {arrayName} {
upvar 1 $arrayName a
set fieldList $fields
if {![lempty $rowfields]} { set fieldList $rowfields }
puts "<TR>"
foreach field $fieldList {
if {![info exists a($field)]} {
puts "<TD></TD>"
} else {
puts "<TD>$a($field)</TD>"
}
}
if {![lempty $rowfunctions]} {
puts "<TD NOWRAP>"
set f [::form #auto]
$f start
$f hidden query -value [$DIO makekey a]
$f select mode -values $rowfunctions
$f submit submit -value "Go"
$f end
puts "</TD>"
}
puts "</TR>"
}
method rowheader {} {
set fieldList $fields
if {![lempty $rowfields]} { set fieldList $rowfields }
puts "<TABLE BORDER WIDTH=\"$rowwidth\">"
puts "<TR>"
foreach field $fieldList {
puts "<TD><B>"
if {[catch { puts [$field text] }]} { puts $field }
puts "</TD>"
}
puts "<TD><CENTER><B>Functions</TD>"
puts "</TR>"
}
method rowfooter {} {
puts "</TABLE>"
}
## Define a new function.
method function {name} {
lappend allfunctions $name
}
## Define a field in the object.
method field {name args} {
import_keyvalue_pairs data $args
lappend fields $name
lappend allfields $name
set class DIODisplayField
if {[info exists data(type)]} {
if {![lempty [::itcl::find classes *DIODisplayField$data(type)]]} {
set class DIODisplayField$data(type)
}
}
eval $class $name -name $name -form $form $args
set FieldTextMap([$name text]) $name
}
method fetch {key arrayName} {
upvar 1 $arrayName $arrayName
return [$DIO fetch $key $arrayName]
}
method store {arrayName} {
upvar 1 $arrayName $arrayName
return [$DIO store $arrayName]
}
method delete {key} {
return [$DIO delete $key]
}
method pretty_fields {list} {
foreach field $list {
lappend fieldList [$field text]
}
return $fieldList
}
method set_field_values {arrayName} {
upvar 1 $arrayName array
foreach var [array names array] {
catch { $var value $array($var) }
}
}
method get_field_values {arrayName} {
upvar 1 $arrayName array
foreach field $allfields {
set array($field) [$field value]
}
}
method DisplayRequest {req} {
set res [$DIO exec $req]
if {[$res numrows] <= 0} {
puts "Could not find any matching records."
abort_page
return
}
rowheader
$res forall -array a {
showrow a
}
rowfooter
$res destroy
}
method Main {} {
$form start
puts "<TABLE>"
puts "<TR>"
puts "<TD>Functions:</TD>"
puts "<TD>"
$form select mode -values $functions
puts "</TD>"
puts "</TR>"
set useFields $fields
if {![lempty $searchfields]} { set useFields $searchfields }
puts "<TR>"
puts "<TD>Search By:</TD>"
puts "<TD>"
$form select searchBy -values [pretty_fields $useFields]
puts "</TD>"
puts "</TR>"
puts "<TR>"
puts "<TD>Query:</TD>"
puts "<TD>"
$form text query
puts "</TD>"
puts "</TR>"
puts "<TR>"
puts "<TD COLSPAN=2>"
$form submit submit
puts "</TD>"
puts "</TR>"
puts "</TABLE>"
}
method Search {} {
set searchField $FieldTextMap($response(searchBy))
set table [$DIO table]
set req "SELECT * FROM $table
WHERE $searchField LIKE '[$DIO quote $response(query)]'"
DisplayRequest $req
}
method List {} {
set table [$DIO table]
set req "SELECT * FROM $table"
DisplayRequest $req
}
method Add {} {
showform
}
method Edit {} {
if {![fetch $response(query) array]} {
puts "That record does not exist in the database."
abort_page
return
}
set_field_values array
showform
}
##
## When we save, we want to set all the fields' values and then get
## them into a new array. We do this because we want to clean any
## unwanted variables out of the array but also because some fields
## have special handling for their values, and we want to make sure
## we get the right value.
##
method Save {} {
## We need to see if the key exists. If they are adding a new
## entry, we just want to see if the key exists. If they are
## editing an entry, we need to see if they changed the keyfield
## while editing. If they didn't change the keyfield, there's no
## reason to check it.
if {$response(DIODfromMode) == "Add"} {
set key [$DIO makekey response]
fetch $key a
} else {
set key $response(DIODkey)
set newkey [$DIO makekey response]
## If we have a new key, and the newkey doesn't exist in the
## database, we are moving this record to a new key, so we
## need to delete the old key.
if {$key != $newkey} {
if {![fetch $newkey a]} {
delete $key
}
}
}
if {[array exists a]} {
puts "That record already exists in the database."
abort_page
return
}
set_field_values response
get_field_values storeArray
store storeArray
headers redirect [env DOCUMENT_NAME]
}
method Delete {} {
if {![fetch $response(query) array]} {
puts "That record does not exist in the database."
abort_page
return
}
if {!$confirmdelete} {
DoDelete
return
}
puts "<CENTER>"
puts "<TABLE>"
puts "<TR>"
puts "<TD COLSPAN=2>"
puts "Are you sure you want to delete this record from the database?"
puts "</TD>"
puts "</TR>"
puts "<TR>"
puts "<TD>"
puts "<CENTER>"
set f [::form #auto]
$f start
$f hidden mode -value DoDelete
$f hidden query -value $response(query)
$f submit submit -value Yes
$f end
puts "</TD>"
puts "<TD>"
puts "<CENTER>"
set f [::form #auto]
$f start
$f submit submit -value No
$f end
puts "</TD>"
puts "</TR>"
puts "</TABLE>"
puts "</CENTER>"
}
method DoDelete {} {
delete $response(query)
headers redirect [env DOCUMENT_NAME]
}
method Details {} {
if {![fetch $response(query) array]} {
puts "That record does not exist in the database."
abort_page
return
}
set_field_values array
showview
}
proc Cancel {} {
headers redirect [env DOCUMENT_NAME]
}
###
## Define variable functions for each variable.
###
method fields {{list ""}} {
if {[lempty $list]} { return $fields }
foreach field $list {
if {[lsearch $allfields $field] < 0} {
return -code error "Field $field does not exist."
}
}
set fields $list
}
method searchfields {{list ""}} {
if {[lempty $list]} { return $searchfields }
foreach field $list {
if {[lsearch $allfields $field] < 0} {
return -code error "Field $field does not exist."
}
}
set searchfields $list
}
method rowfields {{list ""}} {
if {[lempty $list]} { return $rowfields }
foreach field $list {
if {[lsearch $allfields $field] < 0} {
return -code error "Field $field does not exist."
}
}
set rowfields $list
}
method DIO {{string ""}} { configure_variable DIO $string }
method errorhandler {{string ""}} {configure_variable errorhandler $string }
method title {{string ""}} { configure_variable title $string }
method functions {{string ""}} { configure_variable functions $string }
method pagesize {{string ""}} { configure_variable pagesize $string }
method form {{string ""}} { configure_variable form $string }
method cleanup {{string ""}} { configure_variable cleanup $string }
method rowfunctions {{string ""}} {configure_variable rowfunctions $string}
method rowwidth {{string ""}} {configure_variable rowwidth $string}
method confirmdelete {{string ""}} {
configure_variable confirmdelete $string
}
public variable DIO ""
public variable errorhandler "handle_error"
public variable title ""
public variable fields ""
public variable searchfields ""
public variable functions "Search List Add Edit Delete Details"
public variable pagesize 25
public variable form ""
public variable cleanup 1
public variable confirmdelete 1
public variable rowfields ""
public variable rowfunctions "Details Edit Delete"
public variable rowwidth "100%"
public variable response
private variable allfunctions \
"Search List Add Edit Delete Details Main Save DoDelete Cancel"
private variable allfields ""
private variable FieldTextMap
} ; ## ::itcl::class DIODisplay
catch { ::itcl::delete class ::DIODisplayField }
::itcl::class ::DIODisplayField {
constructor {args} {
## We want to simulate Itcl's configure command, but we want to
## check for arguments that are not variables of our object. If
## they're not, we save them as arguments to the form when this
## field is displayed.
import_keyvalue_pairs data $args
foreach var [array names data] {
if {![info exists $var]} {
lappend formargs -$var $data($var)
} else {
set $var $data($var)
}
}
if {[lempty $text]} { set text [pretty [split $name _]] }
}
destructor {
}
method destroy {} {
::itcl::delete object $this
}
method pretty {string} {
set words ""
foreach w $string {
lappend words \
[string toupper [string index $w 0]][string range $w 1 end]
}
return [join $words " "]
}
method configure_variable {varName string} {
if {[lempty $string]} { return [set $varName] }
configure -$varName $string
}
method showview {} {
puts "<TR>"
puts "<TD><B>$text</B>:</TD>"
puts "<TD>$value</TD>"
puts "</TR>"
}
method showform {} {
puts "<TR>"
puts "<TD ALIGN=RIGHT><B>$text</B>:</TD>"
puts "<TD>"
if {$readonly} {
puts "$value"
} else {
eval $form $type $name -value [list $value] $formargs
}
puts "</TD>"
puts "</TR>"
}
method form {{string ""}} { configure_variable form $string }
method formargs {{string ""}} { configure_variable formargs $string }
method name {{string ""}} { configure_variable name $string }
method text {{string ""}} { configure_variable text $string }
method type {{string ""}} { configure_variable type $string }
method value {{string ""}} { configure_variable value $string }
method readonly {{string ""}} { configure_variable readonly $string }
public variable form ""
public variable formargs ""
public variable name ""
public variable text ""
public variable value ""
public variable type "text"
public variable readonly 0
} ; ## ::itcl::class DIODisplayField
catch { ::itcl::delete class ::DIODisplayFieldyesno }
::itcl::class ::DIODisplayFieldboolean {
inherit ::DIODisplayField
constructor {args} {eval configure $args} {
eval configure $args
}
method add_true_value {string} {
lappend trueValues $string
}
method showform {} {
puts "<TR>"
puts "<TD ALIGN=RIGHT><B>$text</B>:</TD>"
puts "<TD>"
if {[boolean_value]} {
$form default_value $name $true
} else {
$form default_value $name $false
}
eval $form radiobuttons $name -values [list "$true $false"] $formargs
puts "</TD>"
puts "</TR>"
}
method showview {} {
puts "<TR>"
puts "<TD><B>$text</B>:</TD>"
puts "<TD>"
if {[boolean_value]} {
puts $true
} else {
puts $false
}
puts "</TD>"
puts "</TR>"
}
method boolean_value {} {
set val [string tolower $value]
if {[lsearch -exact $values $val] > -1} { return 1 }
return 0
}
public variable true "Yes"
public variable false "No"
public variable values "1 y yes t true on"
public variable value "" {
if {[boolean_value]} {
set value $true
} else {
set value $false
}
}
}
1.1 tcl-rivet/rivet/packages/dio/pkgIndex.tcl
Index: pkgIndex.tcl
===================================================================
package ifneeded DIO 1.0 [list source [file join $dir dio.tcl]]
package ifneeded DIODisplay 1.0 [list source [file join $dir diodisplay.tcl]]
---------------------------------------------------------------------
To unsubscribe, e-mail: rivet-dev-unsubscribe@tcl.apache.org
For additional commands, e-mail: rivet-dev-help@tcl.apache.org
Re: cvs commit: tcl-rivet/rivet/packages/dio dio.tcl diodisplay.tcl pkgIndex.tcl
Posted by "David N. Welton" <da...@dedasys.com>.
Damon Courtney <da...@your.unreality.com> writes:
> > Cool stuff! Have you looked at Michael Cleverly's 'nstcl'
> > routines? They have some good database layer stuff too.
> > How about Oracle? Mysql and Postgres are the only two I care
> > about, but Oracle would be a good third one to have.
> I already plan on adding Oracle support. I just need to get an
> Oracle server to test on. 0-] I made it so that adding a new
> database type takes a new class with like 5 methods. Really
> easy. 0-] The rest is all generic in a parent "Database" class.
Great stuff... this seems to be something the Tcl comunity has been
pining for for a long time!
> > Are you guys going to announce this more widely? It's a pretty
> > cool effort. If it takes off, it might make sense to make it its
> > own project, even!
> I planned on it. This is actually something I worked on before
> I started working with Karl. I just finished it while working for
> him and decided to use it for his stuff. Incase we ever need to
> switch to a different database.
> And, when I release all this code into Rivet, you'll be able to
> operate all the exact same code under any database supported by DIO
> with no re-writing of code at all. There'll be a config where you
> just specify your database type, and all the DIO objects will be
> created with that type. 0-] Really slick.
If you are amenable, once it's up and working and you're satisfied
with it, we can take it back out of Rivet and make it its own ASF
project, to give it a little bit more of a spotlight.
--
David N. Welton
Consulting: http://www.dedasys.com/
Personal: http://www.dedasys.com/davidw/
Free Software: http://www.dedasys.com/freesoftware/
Apache Tcl: http://tcl.apache.org/
---------------------------------------------------------------------
To unsubscribe, e-mail: rivet-dev-unsubscribe@tcl.apache.org
For additional commands, e-mail: rivet-dev-help@tcl.apache.org
Re: cvs commit: tcl-rivet/rivet/packages/dio dio.tcl diodisplay.tcl
pkgIndex.tcl
Posted by Damon Courtney <da...@your.unreality.com>.
> Cool stuff! Have you looked at Michael Cleverly's 'nstcl' routines?
> They have some good database layer stuff too.
>
> How about Oracle? Mysql and Postgres are the only two I care about,
> but Oracle would be a good third one to have.
I already plan on adding Oracle support. I just need to get an Oracle
server to test on. 0-] I made it so that adding a new database type takes
a new class with like 5 methods. Really easy. 0-] The rest is all generic
in a parent "Database" class.
> Are you guys going to announce this more widely? It's a pretty cool
> effort. If it takes off, it might make sense to make it its own
> project, even!
I planned on it. This is actually something I worked on before I
started working with Karl. I just finished it while working for him and
decided to use it for his stuff. Incase we ever need to switch to a
different database.
And, when I release all this code into Rivet, you'll be able to operate
all the exact same code under any database supported by DIO with no
re-writing of code at all. There'll be a config where you just specify your
database type, and all the DIO objects will be created with that type. 0-]
Really slick.
Damon
---------------------------------------------------------------------
To unsubscribe, e-mail: rivet-dev-unsubscribe@tcl.apache.org
For additional commands, e-mail: rivet-dev-help@tcl.apache.org
Re: cvs commit: tcl-rivet/rivet/packages/dio dio.tcl diodisplay.tcl pkgIndex.tcl
Posted by "David N. Welton" <da...@dedasys.com>.
damonc@apache.org writes:
> This package is a set of classes built to handle SQL databases in
> a generic interface. It is still under development, but it's
> pretty well stable under Postgres and pretty nice under MySQL as
> well.
Cool stuff! Have you looked at Michael Cleverly's 'nstcl' routines?
They have some good database layer stuff too.
How about Oracle? Mysql and Postgres are the only two I care about,
but Oracle would be a good third one to have.
Are you guys going to announce this more widely? It's a pretty cool
effort. If it takes off, it might make sense to make it its own
project, even!
--
David N. Welton
Consulting: http://www.dedasys.com/
Personal: http://www.dedasys.com/davidw/
Free Software: http://www.dedasys.com/freesoftware/
Apache Tcl: http://tcl.apache.org/
---------------------------------------------------------------------
To unsubscribe, e-mail: rivet-dev-unsubscribe@tcl.apache.org
For additional commands, e-mail: rivet-dev-help@tcl.apache.org