Months ago Arnulf Widemann released to rivet some patches
and add-ons that enabled 'dio' and 'session' to work properly
with Mysql and included a brand new dio class for Oracle
I tested during the summer the dio Mysql class using the 0.5
and 1.0 modules and made some minor changes. (I had
also added a file with a suggestion in order to address a problem
with 'session' that arises if the package is used with
mysql 4.x and 5.0)
I'm attaching to this message these things as a diff file
generated by copying the new code into the 1_0 tree and
running a 'svn diff'. regards
--
-- Massimo Manghi
-- Dipartimento di Biologia Evolutiva e Funzionale
-- Universit? degli Studi di Parma
-- Parco Area delle Scienze 11A - 43100 Parma
Index: session/session-class.tcl
===================================================================
--- session/session-class.tcl (revision 449978)
+++ session/session-class.tcl (working copy)
@@ -102,6 +102,8 @@
constructor {args} {
eval configure $args
+ $dioObject registerSpecialField rivet_session session_update_time NOW
+ $dioObject registerSpecialField rivet_session session_start_time NOW
}
method status {args} {
@@ -149,7 +151,7 @@
set sessionIdKey "$uniqueID[clock clicks][pid]$args[clock
seconds]$scrambleCode[get_entropy_bytes]"
debug "gen_session_id - feeding this to md5: '$sessionIdKey'"
- return [::md5::md5 $sessionIdKey]
+ return [::md5::md5 -hex -- $sessionIdKey]
}
#
@@ -159,7 +161,13 @@
#
method do_garbage_collection {} {
debug "do_garbage_collection: performing garbage collection"
- set result [$dioObject exec "delete from $sessionTable where timestamp
'now' - session_update_time > interval '$gcMaxLifetime seconds';"]
+# set result [$dioObject exec "delete from $sessionTable where timestamp
'now' - session_update_time > interval '$gcMaxLifetime seconds';"]
+ set del_cmd "delete from $sessionTable where "
+ append del_cmd [$dioObject makeDBFieldValue $sessionTable
session_update_time now SECS]
+ append del_cmd " - [$dioObject makeDBFieldValue $sessionTable
session_update_time {} SECS]"
+ append del_cmd " > $gcMaxLifetime"
+ debug "do_garbage_collection: > $del_cmd <"
+ set result [$dioObject exec $del_cmd]
$result destroy
}
@@ -294,14 +302,14 @@
#
method store {packageName key data} {
set a(session_id) [id]
- set a(package) $packageName
- set a(key) $key
+ set a(package_) $packageName
+ set a(key_) $key
regsub -all {\\} $data {\\\\} data
set a(data) $data
- debug "store session data, package '$packageName', key '$key', data
'$data'"
- set kf [list session_id package key]
+ debug "store session data, package_ '$packageName', key_ '$key', data
'$data'"
+ set kf [list session_id package_ key_]
if {![$dioObject store a -table $sessionCacheTable -keyfield $kf]} {
puts "Failed to store $sessionCacheTable '$kf'"
@@ -315,21 +323,21 @@
# for this session
#
method fetch {packageName key} {
- set kf [list session_id package key]
+ set kf [list session_id package_ key_]
set a(session_id) [id]
- set a(package) $packageName
- set a(key) $key
+ set a(package_) $packageName
+ set a(key_) $key
set key [$dioObject makekey a $kf]
if {![$dioObject fetch $key a -table $sessionCacheTable -keyfield $kf]}
{
status [$dioObject errorinfo]
- puts "error: [$dioObject errorinfo]"
- debug "fetch session data failed, package '$packageName', key
'$key', error '[$dioObject errorinfo]'"
+ debug "error: [$dioObject errorinfo]"
+ debug "fetch session data failed, package_ '$packageName', key_
'$key', error '[$dioObject errorinfo]'"
return ""
}
- debug "fetch session data succeeded, package '$packageName', key
'$key', result '$a(data)'"
+ debug "fetch session data succeeded, package_ '$packageName', key_
'$key', result '$a(data)'"
return $a(data)
}
@@ -443,6 +451,7 @@
method debug {message} {
if {$debugMode} {
puts $debugFile "$this (debug) $message<br>"
+ flush $debugFile
}
}
}
Index: dio/dio_Postgresql.tcl
===================================================================
--- dio/dio_Postgresql.tcl (revision 449978)
+++ dio/dio_Postgresql.tcl (working copy)
@@ -134,6 +134,16 @@
set errorcode [pg_result $resultid -status]
set errorinfo [pg_result $resultid -error]
+ # if numrows is zero, see if cmdrows returned anything and if it
+ # did, put that in in place of numrows, hiding a postgresql
+ # idiosyncracy from DIO
+ if {$numrows == 0} {
+ set cmdrows [pg_result $resultId -cmdTuples]
+ if {$cmdrows != ""} {
+ set numrows $cmdrows
+ }
+ }
+
if {$errorcode != "PGRES_COMMAND_OK" \
&& $errorcode != "PGRES_TUPLES_OK"} { set error 1 }
Index: dio/dio_Mysql.tcl
===================================================================
--- dio/dio_Mysql.tcl (revision 449978)
+++ dio/dio_Mysql.tcl (working copy)
@@ -16,15 +16,16 @@
# $Id$
-package provide dio_Mysql 0.1
+package provide dio_Mysql 0.2
namespace eval DIO {
::itcl::class Mysql {
inherit Database
constructor {args} {eval configure $args} {
- if {[catch {package require Mysqltcl}] \
- && [catch {package require mysql}]} {
+ if { [catch {package require Mysqltcl}] \
+ && [catch {package require mysqltcl}] \
+ && [catch {package require mysql} ] } {
return -code error "No MySQL Tcl package available"
}
@@ -48,8 +49,9 @@
if {![lempty $user]} { lappend command -user $user }
if {![lempty $pass]} { lappend command -password $pass }
if {![lempty $port]} { lappend command -port $port }
- if {![lempty $host]} { lappend command $host }
-
+ if {![lempty $host]} { lappend command -host $host }
+
+# puts "i'm going to connect mysql: >$command< ($this) <br/>"
if {[catch $command error]} { return -code error $error }
set conn $error
@@ -105,6 +107,51 @@
return $conn
}
+ method makeDBFieldValue {table_name field_name val {convert_to {}}} {
+ if {[info exists specialFields([EMAIL PROTECTED])]} {
+ switch $specialFields([EMAIL PROTECTED]) {
+ DATE {
+ set secs [clock scan $val]
+ set my_val [clock format $secs -format
{%Y-%m-%d}]
+ return "DATE_FORMAT('$my_val', '%Y-%m-%d')"
+ }
+ DATETIME {
+ set secs [clock scan $val]
+ set my_val [clock format $secs -format
{%Y-%m-%d %T}]
+ return "DATE_FORMAT('$my_val', '%Y-%m-%d %T')"
+ }
+ NOW {
+ switch $convert_to {
+ SECS {
+ if {[::string compare $val "now"] == 0} {
+ set secs [clock seconds]
+ set my_val [clock format $secs
-format {%Y%m%d%H%M%S}]
+ return $my_val
+ } else {
+ return
"DATE_FORMAT(session_update_time,'%Y%m%d%H%i%S')"
+ }
+ }
+ default {
+ if {[::string compare $val, "now"] == 0} {
+ set secs [clock seconds]
+ } else {
+ set secs [clock scan $val]
+ }
+ set my_val [clock format $secs -format
{%Y-%m-%d %T}]
+ return "DATE_FORMAT('$my_val', '%Y-%m-%d
%T')"
+ }
+ }
+ }
+ default {
+ # no special code for that type!!
+ return "'[quote $val]'"
+ }
+ }
+ } else {
+ return "'[quote $val]'"
+ }
+ }
+
public variable db "" {
if {[info exists conn]} {
mysqluse $conn $db
@@ -130,7 +177,7 @@
method nextrow {} {
return [mysqlnext $resultid]
}
-
+
} ; ## ::itcl::class MysqlResult
}
Index: dio/pkgIndex.tcl
===================================================================
--- dio/pkgIndex.tcl (revision 449978)
+++ dio/pkgIndex.tcl (working copy)
@@ -1,5 +1,6 @@
package ifneeded DIO 1.0 [list source [file join $dir dio.tcl]]
package ifneeded DIODisplay 1.0 [list source [file join $dir diodisplay.tcl]]
-package ifneeded dio_Mysql 0.1 [list source [file join $dir dio_Mysql.tcl]]
+package ifneeded dio_Mysql 0.2 [list source [file join $dir dio_Mysql.tcl]]
package ifneeded dio_Postgresql 0.1 [list source [file join $dir
dio_Postgresql.tcl]]
package ifneeded dio_Sqlite 0.1 [list source [file join $dir dio_Sqlite.tcl]]
+package ifneeded dio_Oracle 0.2 [list source [file join $dir dio_Oracle.tcl]]
Index: dio/dio.tcl
===================================================================
--- dio/dio.tcl (revision 449978)
+++ dio/dio.tcl (working copy)
@@ -138,7 +138,7 @@
# is appended with a "field LIKE value"
if {[::string first {%} $elem] != -1} {
- append req " $field LIKE '[quote $elem]'"
+ append req " $field LIKE [makeDBFieldValue $myTable
$field $elem]"
} elseif {[regexp {^([<>]) *([0-9.]*)$} $elem _ fn
val]} {
# value starts with <, or >, then space,
# and a something
@@ -148,7 +148,7 @@
append req " $field$fn$val"
} else {
# otherwise it's a straight key=value comparison
- append req " $field='[quote $elem]'"
+ append req " $field=[makeDBFieldValue $myTable
$field $elem]"
}
continue
@@ -171,14 +171,14 @@
upvar 1 $arrayName array
if {[lempty $myTable]} { set myTable $table }
+ set vals [::list]
+ set vars [::list]
foreach field $fields {
if {![info exists array($field)]} { continue }
- append vars "$field,"
- append vals "'[quote $array($field)]',"
+ lappend vars "$field"
+ lappend vals "[makeDBFieldValue $myTable $field $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)"
+ return "insert into $myTable ([join $vars {,}]) VALUES ([join $vals
{,}])"
}
#
@@ -194,12 +194,12 @@
protected method build_update_query {arrayName fields {myTable ""}} {
upvar 1 $arrayName array
if {[lempty $myTable]} { set myTable $table }
+ set string [::list]
foreach field $fields {
if {![info exists array($field)]} { continue }
- append string "$field='[quote $array($field)]',"
+ lappend string "$field=[makeDBFieldValue $myTable $field
$array($field)]"
}
- set string [::string range $string 0 end-1]
- return "update $myTable SET $string"
+ return "update $myTable SET [join $string {,}]"
}
#
@@ -235,19 +235,13 @@
## If we're not using multiple keyfields, just return a simple
## where clause.
if {[llength $myKeyfield] < 2} {
- return " WHERE $myKeyfield = '[quote $myKey]'"
+ return " WHERE $myKeyfield = [makeDBFieldValue $table $myKeyfield
$myKey]"
}
# multiple fields, construct it as a where-and
- set first 1
- set req ""
+ set req " WHERE 1 = 1"
foreach field $myKeyfield key $myKey {
- if {$first} {
- append req " WHERE $field='[quote $key]'"
- set first 0
- } else {
- append req " AND $field='[quote $key]'"
- }
+ append req " AND $field=[makeDBFieldValue $table $field $key]"
}
return $req
}
@@ -499,9 +493,40 @@
}
#
+ # update_with_explicit_key - an update where the key is specified
+ # as an argument to the proc rather than being dug out of the array
+ #
+ # this is a kludge until we come up with a better way to
+ # solve the problem of updating a row where we actually
+ # want to change the value of a key field
+ #
+ method update_with_explicit_key {key arrayName args} {
+ table_check $args
+ key_check $myKeyfield $key
+ upvar 1 $arrayName $arrayName $arrayName array
+
+ set fields [::array names array]
+ set req [build_update_query array $fields $myTable]
+ append req [build_key_where_clause $myKeyfield $key]
+
+ set res [exec $req]
+ if {[$res error]} {
+ set errinf [$res errorinfo]
+ $res destroy
+ return -code error "Got '$errinf' executing '$req'"
+ }
+
+ # this doesn't work on postgres, you've got to use cmdRows,
+ # we need to figure out what to do with this
+ set numrows [$res numrows]
+ $res destroy
+ return $numrows
+ }
+
+ #
# insert - a pure insert, without store's somewhat clumsy
# efforts to see if it needs to be an update rather than
- # an insert
+ # an insert -- this shouldn't require fields, it's broken
#
method insert {table arrayName} {
upvar 1 $arrayName $arrayName $arrayName array
@@ -571,6 +596,14 @@
return [string "select count(*) from $myTable"]
}
+ method makeDBFieldValue {table_name field_name val} {
+ return "'[quote $val]'"
+ }
+
+ method registerSpecialField {table_name field_name type} {
+ set specialFields([EMAIL PROTECTED]) $type
+ }
+
##
## These are methods which should be defined by each individual database
## interface class.
@@ -580,6 +613,7 @@
method exec {args} {}
method nextkey {args} {}
method lastkey {args} {}
+ method now {} {}
##
## Functions to get and set public variables.
@@ -596,6 +630,8 @@
method host {{string ""}} { configure_variable host $string }
method port {{string ""}} { configure_variable port $string }
+ protected variable specialFields
+
public variable interface ""
public variable errorinfo ""
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
