Hi everybody
I'm sending on the list a file including patches for "dio" and "session"
and some new files that add support for Mysql and Oracle.
These patches are 99% work of Arnulf Wiedemann. I tested
the code on Mysql (Arnulf is intensively using the module for Oracle)
and made some minor changes.
Mysql doesn't remove the expired sessions rows from
rivet_session_cache: mysql accepts the syntax 'ON DELETE CASCADE'
for portability when creating the database, but it takes no action
upon deletion of an expired session from 'rivet_session'. Actual
support for this hasn't been added as of version 5.0. In order
to suggest a workaround I added the file
'session-purge-mysql.sql' with a sql statement that
could be run from cron job. Yet the problem of a wider
portabilty of the do_garbage_collect method is open.
regards
-- Massimo Manghi
Index: rivet/packages/session/session-class.tcl
===================================================================
--- rivet/packages/session/session-class.tcl (revision 405803)
+++ rivet/packages/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 "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: rivet/packages/dio/dio_Mysql.tcl
===================================================================
--- rivet/packages/dio/dio_Mysql.tcl (revision 405803)
+++ rivet/packages/dio/dio_Mysql.tcl (working copy)
@@ -23,8 +23,9 @@
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"
}
@@ -105,6 +106,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 +176,7 @@
method nextrow {} {
return [mysqlnext $resultid]
}
-
+
} ; ## ::itcl::class MysqlResult
}
Index: rivet/packages/dio/pkgIndex.tcl
===================================================================
--- rivet/packages/dio/pkgIndex.tcl (revision 405803)
+++ rivet/packages/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: rivet/packages/dio/dio.tcl
===================================================================
--- rivet/packages/dio/dio.tcl (revision 405803)
+++ rivet/packages/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
}
@@ -532,7 +526,7 @@
#
# 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
@@ -602,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.
@@ -611,6 +613,7 @@
method exec {args} {}
method nextkey {args} {}
method lastkey {args} {}
+ method now {} {}
##
## Functions to get and set public variables.
@@ -627,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 ""
# dio_Mysql.tcl -- Mysql backend.
# Copyright 2002-2004 The Apache Software Foundation
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
# http://www.apache.org/licenses/LICENSE-2.0
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
# $Id: dio_Oracle.tcl 265421 2004-10-29 20:17:54Z karl $
package provide dio_Oracle 0.1
namespace eval DIO {
::itcl::class Oracle {
inherit Database
constructor {args} {eval configure $args} {
if {[catch {package require Oratcl}]} {
return -code error "No Oracle Tcl package available"
}
eval configure $args
if {[lempty $db]} {
if {[lempty $user]} {
set user $::env(USER)
}
set db $user
}
}
destructor {
close
}
method open {} {
set command "::oralogon"
if {![lempty $user]} { append command " $user" }
if {![lempty $pass]} { append command "/$pass" }
if {![lempty $host]} { append command "@$host" }
if {![lempty $port]} { append 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 {::oraclose $conn}
unset conn
}
method exec {req} {
if {![info exists conn]} { open }
set _cur [::oraopen $conn]
set cmd ::orasql
set is_select 0
if {[::string tolower [lindex $req 0]] == "select"} {
set cmd ::orasql
set is_select 1
}
set errorinfo ""
#puts "ORA:$is_select:$req:<br>"
if {[catch {$cmd $_cur $req} error]} {
#puts "ORA:error:$error:<br>"
set errorinfo $error
catch {::oraclose $_cur}
set obj [result $interface -error 1 -errorinfo [::list $error]]
return $obj
}
if {[catch {::oracols $_cur name} fields]} { set fields "" }
::oracommit $conn
set my_fields $fields
set fields [::list]
foreach field $my_fields {
set field [::string tolower $field]
lappend fields $field
}
set error [::oramsg $_cur rows]
set res_cmd "result"
lappend res_cmd $interface -resultid $_cur
lappend res_cmd -numrows [::list $error] -fields [::list $fields]
lappend res_cmd -fetch_first_row $is_select
set obj [eval $res_cmd]
if {!$is_select} {
::oraclose $_cur
}
return $obj
}
method lastkey {} {
if {![info exists conn]} { return }
return [mysqlinsertid $conn]
}
method quote {string} {
regsub -all {'} $string {\'} string
return $string
}
method sql_limit_syntax {limit {offset ""}} {
# temporary
return ""
if {[lempty $offset]} {
return " LIMIT $limit"
}
return " LIMIT [expr $offset - 1],$limit"
}
method handle {} {
if {![info exists conn]} { open }
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 "to_date('$my_val', 'YYYY-MM-DD')"
}
DATETIME {
set secs [clock scan $val]
set my_val [clock format $secs -format {%Y-%m-%d %T}]
return "to_date('$my_val', 'YYYY-MM-DD HH24:MI:SS')"
}
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 "to_char($field_name, 'YYYYMMDDHH24MISS')"
}
}
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 "to_date('$my_val', 'YYYY-MM-DD HH24:MI:SS')"
}
}
}
default {
# no special cod for that type!!
return "'[quote $val]'"
}
}
} else {
return "'[quote $val]'"
}
}
public variable db "" {
if {[info exists conn]} {
mysqluse $conn $db
}
}
public variable interface "Oracle"
private variable conn
private variable _cur
} ; ## ::itcl::class Mysql
::itcl::class OracleResult {
inherit Result
public variable fetch_first_row 0
private variable _data ""
private variable _have_first_row 0
constructor {args} {
eval configure $args
if {$fetch_first_row} {
if {[llength [nextrow]] == 0} {
set _have_first_row 0
numrows 0
} else {
set _have_first_row 1
numrows 1
}
}
set fetch_first_row 0
}
destructor {
if {[string length $resultid] > 0} {
catch {::oraclose $resultid}
}
}
method nextrow {} {
if {[string length $resultid] == 0} {
return [::list]
}
if {$_have_first_row} {
set _have_first_row 0
return $_data
}
set ret [::orafetch $resultid -datavariable _data]
switch $ret {
0 {
return $_data
}
1403 {
::oraclose $resultid
set resultid ""
return [::list]
}
default {
# FIXME!! have to handle error here !!
return [::list]
}
}
}
} ; ## ::itcl::class OracleResult
}
--
-- Define SQL tables for session management code
--
-- Author: Arnulf (minor changes by Massimo Manghi)
--
-- 02 May 2006
--
DROP TABLE IF EXISTS `rivet_session`;
create table rivet_session (
ip_address varchar(16) default NULL,
session_start_time datetime default NULL,
session_update_time datetime default NULL,
session_id varchar(64) NOT NULL default '',
PRIMARY KEY (session_id)
);
DROP TABLE IF EXISTS `rivet_session_cache`;
create table rivet_session_cache(
session_id varchar(128) default NULL REFERENCES rivet_session(session_id) ON DELETE CASCADE,
package_ varchar(64) default NULL,
key_ varchar(128) default NULL,
data varchar(256) default NULL,
UNIQUE KEY riv_sess_cache_ix( session_id, key_ ),
KEY rivet_session_cache_idx (session_id)
);
-- create index rivet_session_cache_idx ON rivet_session_cache( session_id );
--
-- Session management database creation for Oracle
--
-- Arnulf
--
CREATE TABLE rivet_session
(ip_address VARCHAR2(23) DEFAULT NULL,
session_start_time DATE DEFAULT NULL,
session_update_time DATE DEFAULT NULL,
session_id VARCHAR2(50) NOT NULL
)
/
ALTER TABLE rivet_session ADD PRIMARY KEY (session_id)
/
CREATE TABLE rivet_session_cache
(session_id VARCHAR2(50) DEFAULT NULL,
package_ VARCHAR2(100) DEFAULT NULL,
key_ VARCHAR2(50) DEFAULT NULL,
data VARCHAR2(255) DEFAULT NULL
)
/
CREATE UNIQUE INDEX riv_sess_cache_ix ON rivet_session_cache
(
session_id,
package_,
key_
)
/
CREATE INDEX rivet_session_cache_idx ON rivet_session_cache
(
session_id
)
-- Note
--
-- 9 May 2006
--
-- Though Mysql sql interpreter supports the specification 'ON CASCADE DELETE' for CREATE TABLE, as of
-- version 5.0 this is only for sql code portability: deleting a row in rivet_session doesn't
-- imply Mysql removes the row in rivet_session_cache sharing the same session_id.
-- This table gets progressively cluttered with rows referring to sessions that are long dead.
--
-- As a possible workaround the programmer may build a cron procedure that runs the following
-- sql statement.
delete rivet_session_cache from rivet_session_cache left join rivet_session as t2 using(session_id) where t2.session_id is null;
-- I don't see any cleaner approach unless the code for the garbage collection in the Session class
-- is modified for sake of portability. (Massimo Manghi)
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
