Am Samstag 14 Januar 2006 16:55 schrieb David N. Welton:
> Arnulf Wiedemann wrote:
> > Hello,
> > I have now running the Session package together with DIO with a
> > dio_Oracle module since 2 weeks in a production environment. The testing
> > environment is running with dio_Mysql. There seem to be no problems. In
> > the production environment there are about 50 different users.
> >
> > I had to make some smaller modifications to session_class.tcl and dio.tcl
> > to make them run with Mysql and Oracle.
> >
> > If someone is interested, please let me know.
>
> I don't use either one (truth be told, I don't use DIO either), but if
> Karl or Damon don't respond, I'd be happy to check in your patch to
> subversion.
Hi David,
thanks for the offer to update. I did not hear anything form Karl or Damon.
Here are the modified files and one new file: dio_Oracle.tcl
Thanks,
Arnulf
# 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_Mysql.tcl 265421 2004-10-29 20:17:54Z karl $
package provide dio_Mysql 0.1
namespace eval DIO {
::itcl::class Mysql {
inherit Database
constructor {args} {eval configure $args} {
# if {[catch {package require Mysqltcl}] \
# && [catch {package require mysql}]} {
# return -code error "No MySQL 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 "mysqlconnect"
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 {[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
}
if {[catch {mysqlcol $conn -current name} fields]} { set fields "" }
set obj [result Mysql -resultid $conn \
-numrows [::list $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
}
method sql_limit_syntax {limit {offset ""}} {
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} {
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 {
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 cod for that type!!
return "'[quote $val]'"
}
}
} else {
return "'[quote $val]'"
}
}
public variable db "" {
if {[info exists conn]} {
mysqluse $conn $db
}
}
public variable interface "Mysql"
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
}
# dio.tcl -- implements a database abstraction layer.
# 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.tcl 292493 2005-09-29 17:57:55Z karl $
catch {package require Tclx}
package require Itcl
set auto_path [linsert $auto_path 0 [file dirname [info script]]]
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]
}
uplevel \#0 package require dio_$interface
return [uplevel \#0 ::DIO::$interface $obj $args]
}
##
# DATABASE CLASS
##
::itcl::class Database {
constructor {args} {
eval configure $args
}
destructor {
close
}
#
# result - generate a new DIO result object for the specified database
# interface, with key-value pairs that get configured into the new
# result object.
#
protected method result {interface args} {
return [eval uplevel \#0 ::DIO::${interface}Result \#auto $args]
}
#
# quote - given a string, return the same string with any single
# quote characters preceded by a backslash
#
method quote {string} {
regsub -all {'} $string {\'} string
return $string
}
#
# build_select_query - build a select query based on given arguments,
# which can include a table name, a select statement, switches to
# turn on boolean AND or OR processing, and possibly
# some key-value pairs that cause the where clause to be
# generated accordingly
#
protected method build_select_query {args} {
set bool AND
set first 1
set req ""
set myTable $table
set what "*"
# for each argument passed us...
# (we go by integers because we mess with the index based on
# what we find)
for {set i 0} {$i < [llength $args]} {incr i} {
# fetch the argument we're currently processing
set elem [lindex $args $i]
switch -- [::string tolower $elem] {
"-and" {
# -and -- switch to AND-style processing
set bool AND
}
"-or" {
# -or -- switch to OR-style processing
set bool OR
}
"-table" {
# -table -- identify which table the query is about
set myTable [lindex $args [incr i]]
}
"-select" {
# -select -
set what [lindex $args [incr i]]
}
default {
# it wasn't -and, -or, -table, or -select...
# if the first character of the element is a dash,
# it's a field name and a value
if {[::string index $elem 0] == "-"} {
set field [::string range $elem 1 end]
set elem [lindex $args [incr i]]
# if it's the first field being processed, append
# WHERE to the SQL request we're generating
if {$first} {
append req " WHERE"
set first 0
} else {
# it's not the first variable in the comparison
# expression, so append the boolean state, either
# AND or OR
append req " $bool"
}
# convert any asterisks to percent signs in the
# value field
regsub -all {\*} $elem {%} elem
# if there is a percent sign in the value
# field now (having been there originally or
# mapped in there a moment ago), the SQL aspect
# is appended with a "field LIKE value"
if {[::string first {%} $elem] != -1} {
append req " $field LIKE [makeDBFieldValue $myTable $field $elem]"
} elseif {[regexp {^([<>]) *([0-9.]*)$} $elem _ fn val]} {
# value starts with <, or >, then space,
# and a something
append req " $field$fn$val"
} elseif {[regexp {^([<>]=) *([0-9.]*)$} $elem _ fn val]} {
# value starts with <= or >=, space, and something.
append req " $field$fn$val"
} else {
# otherwise it's a straight key=value comparison
append req " $field=[makeDBFieldValue $myTable $field $elem]"
}
continue
}
append req " $elem"
}
}
}
return "select $what from $myTable $req"
}
#
# build_insert_query -- given an array name, a list of fields, and
# possibly a table name, return a SQL insert statement inserting
# into the named table (or the object's table variable, if none
# is specified) for all of the fields specified, with their values
# coming from the array
#
protected method build_insert_query {arrayName fields {myTable ""}} {
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 }
lappend vars "$field"
lappend vals "[makeDBFieldValue $myTable $field $array($field)]"
}
return "insert into $myTable ([join $vars {,}]) VALUES ([join $vals {,}])"
}
#
# build_update_query -- given an array name, a list of fields, and
# possibly a table name, return a SQL update statement updating
# the named table (or using object's table variable, if none
# is named) for all of the fields specified, with their values
# coming from the array
#
# note that after use a where clause still neds to be added or
# you might update a lot more than you bargained for
#
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 }
lappend string "$field=[makeDBFieldValue $myTable $field $array($field)]"
}
return "update $myTable SET [join $string {,}]"
}
#
# lassign_array - given a list, an array name, and a variable number
# of arguments consisting of variable names, assign each element in
# the list, in turn, to elements corresponding to the variable
# arguments, into the named array. From TclX.
#
protected method lassign_array {list arrayName args} {
upvar 1 $arrayName array
foreach elem $list field $args {
set array($field) $elem
}
}
#
# configure_variable - given a variable name and a string, if the
# string is empty return the variable name, otherwise set the
# variable to the string.
#
protected method configure_variable {varName string} {
if {[lempty $string]} { return [cget -$varName] }
configure -$varName $string
}
#
# build_where_key_clause - given a list of one or more key fields and
# a corresponding list of one or more key values, construct a
# SQL where clause that boolean ANDs all of the key-value pairs
# together.
#
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 = [makeDBFieldValue $table $myKeyfield $myKey]"
}
# multiple fields, construct it as a where-and
set req " WHERE 1 = 1"
foreach field $myKeyfield key $myKey {
append req " AND $field=[makeDBFieldValue $table $field $key]"
}
return $req
}
##
## makekey -- Given an array containing a key-value pairs and
# an optional list of key fields (we use the object's keyfield
# if none is specified)...
#
# if we're doing auto keys, create and return a new key,
# otherwise if it's a single key, just return its value
# from the array, else if it's multiple keys, return all their
# values as a list
##
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
}
#
# string - execute a SQL request and only return a string of one row.
#
method string {req} {
set res [exec $req]
set val [$res next -list]
$res destroy
return $val
}
#
# list - execute a request and return a list of the first element of each
# row returned.
#
method list {req} {
set res [exec $req]
set list ""
$res forall -list line {
lappend list [lindex $line 0]
}
$res destroy
return $list
}
#
# array - execute a request and setup an array containing elements
# with the field names as the keys and the first row results as
# the values
#
method array {req arrayName} {
upvar 1 $arrayName $arrayName
set res [exec $req]
set ret [$res next -array $arrayName]
$res destroy
return $ret
}
#
# forall - execute a SQL select and iteratively fill the named array
# with elements named with the matching field names, containing the
# matching values, executing the specified code body for each, in turn.
#
method forall {req arrayName body} {
upvar 1 $arrayName $arrayName
set res [exec $req]
$res forall -array $arrayName {
uplevel 1 $body
}
if {[$res error]} {
set errinf [$res errorinfo]
$res destroy
return -code error "Got '$errinf' executing '$req'"
}
set ret [$res numrows]
$res destroy
return $ret
}
#
# table_check - internal method to populate the data array with
# a -table element containing the table name, a -keyfield element
# containing the key field or list of key fields, and a list of
# key-value pairs to get set into the data table.
#
# afterwards, it's an error if -table or -keyfield hasn't somehow been
# determined.
#
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)
}
#
# key_check - given a list of key fields and a list of keys, it's
# an error if there aren't the same number of each, and if it's
# autokey, there can't be more than one key.
#
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."
}
}
#
# fetch - given a key (or list of keys) an array name, and some
# extra key-value arguments like -table and -keyfield, fetch
# the key into the array
#
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]} {
set errinf [$res errorinfo]
$res destroy
return -code error "Got '$errinf' executing '$req'"
}
set return [expr [$res numrows] > 0]
$res next -array $arrayName
$res destroy
return $return
}
#
# store - given an array containing key-value pairs and optional
# arguments like -table and -keyfield, insert or update the
# corresponding table entry.
#
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]} {
set errinf [$res errorinfo]
$res destroy
return -code error "Got '$errinf' executing '$req'"
}
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]
if {[$res error]} {
set errinf [$res errorinfo]
$res destroy
return -code error "Got '$errinf' executing '$req'"
}
$res destroy
return 1
}
#
# insert - a pure insert, without store's somewhat clumsy
# efforts to see if it needs to be an update rather than
# an insert -- this shouldn't require fields, it's broken
#
method insert {table arrayName} {
upvar 1 $arrayName $arrayName $arrayName array
set req [build_insert_query array [::array names array] $table]
set res [exec $req]
if {[$res error]} {
set errinf [$res errorinfo]
$res destroy
return -code error "Got '$errinf' executing '$req'"
}
$res destroy
return 1
}
#
# delete - delete matching record from the specified table
#
method delete {key args} {
table_check $args
set req "delete from $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'"
}
set return [$res numrows]
$res destroy
return $return
}
#
# keys - return all keys in a tbale
#
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
}
#
# search - construct and execute a SQL select statement using
# build_select_query style and return the result handle.
#
method search {args} {
set req [eval build_select_query $args]
return [exec $req]
}
#
# count - return a count of the specified (or current) table.
#
method count {args} {
table_check $args
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.
##
method open {args} {}
method close {args} {}
method exec {args} {}
method nextkey {args} {}
method lastkey {args} {}
method now {} {}
##
## Functions to get and set public variables.
##
method interface {{string ""}} { configure_variable interface $string }
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 }
protected variable specialFields
public variable interface ""
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
#
# DIO Result object
#
::itcl::class Result {
constructor {args} {
eval configure $args
}
destructor { }
method destroy {} {
::itcl::delete object $this
}
#
# configure_variable - given a variable name and a string, if the
# string is empty return the variable name, otherwise set the
# variable to the string.
#
protected method configure_variable {varName string} {
if {[lempty $string]} { return [cget -$varName] }
configure -$varName $string
}
#
# lassign_array - given a list, an array name, and a variable number
# of arguments consisting of variable names, assign each element in
# the list, in turn, to elements corresponding to the variable
# arguments, into the named array. From TclX.
#
protected method lassign_array {list arrayName args} {
upvar 1 $arrayName array
foreach elem $list field $args {
set array($field) $elem
}
}
#
# seek - set the current row ID (our internal row cursor, if you will)
# to the specified row ID
#
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
}
#
# forall -- walk the result object, executing the code body over it
#
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
} ; ## namespace eval DIO
package provide DIO 1.0
--
-- Define SQL tables for session management code
--
-- $Id: session-create.sql,v 1.1 2004/01/05 21:08:26 karl Exp $
--
--
create table rivet_session(
ip_address inet,
session_start_time timestamp,
session_update_time timestamp,
session_id varchar,
UNIQUE( session_id )
);
create table rivet_session_cache(
session_id varchar REFERENCES rivet_session(session_id) ON DELETE
CASCADE,
package_ varchar,
key_ varchar,
data varchar,
UNIQUE( session_id, package_, key_ )
);
create index rivet_session_cache_idx ON rivet_session_cache( session_id );
#
# Session - Itcl object for web session management for Rivet
#
# $Id: session-class.tcl 265428 2004-11-05 16:28:59Z karl $
#
# Copyright 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.
package provide Session 1.0
package require Itcl
::itcl::class Session {
# true if the page being processed didn't have a previous session
public variable isNewSession 1
# contains the reason why this session is a new session, or "" if it isn't
public variable newSessionReason ""
# the routine that will handle saving data, could use DIO, could use
# flatfiles, etc.
public variable saveHandler ""
# the name of the DIO object that we'll use to access the database
public variable dioObject "DIO"
# the name of the cookie used to set the session ID
public variable cookieName "rivetSession"
# the probability that garbage collection will occur in percent.
public variable gcProbability 1
# the number of seconds after which data will be seen as "garbage"
# and cleaned up -- defaults to 1 day
public variable gcMaxLifetime 86400
# the substring you want to check each HTTP referer for. If the
# referer was sent by the browser and the substring is not found,
# the session will be deleted.
public variable refererCheck ""
public variable entropyFile "/dev/urandom"
# the number of bytes which will be read from the entropy file
public variable entropyLength 0
# set the scramble code to something unique for the site or the
# app or whatever, to slightly increase the unguessability of
# session ids
public variable scrambleCode "some random string"
# the lifetime of the cookie in minutes. 0 means until the browser
# is closed.
public variable cookieLifetime 0
# the lifetime of the session in seconds. this will be updated if
# additional pages are fetched while the session is still alive.
public variable sessionLifetime 7200
# if a request is being processed, a session is active, and this many
# seconds have elapsed since the session was created or the session
# update time was last updated, the session update time will be updated
# (the session being in use extends the session lifetime)
public variable sessionRefreshInterval 900
# the webserver subpath that the session cookie applies to -- defaults
# to /
public variable cookiePath "/"
# the domain to set in the session cookie
public variable cookieDomain ""
# the status of the last operation, "" if ok
public variable status
# specifies whether cookies should only be sent over secure connections
public variable cookieSecure 0
# the name of the table that session info will be stored in
public variable sessionTable "rivet_session"
# the name of the table that contains cached session data
public variable sessionCacheTable "rivet_session_cache"
# the file that debug messages will be written to
public variable debugFile stdout
# set debug mode to 1 to trace through and see the session object
# do its thing
public variable debugMode 1
constructor {args} {
eval configure $args
$dioObject registerSpecialField rivet_session session_update_time NOW
$dioObject registerSpecialField rivet_session session_start_time NOW
}
method status {args} {
if {$args == ""} {
return $status
}
set status $args
}
# get_entropy_bytes - read entropyLength bytes from a random data
# device, such as /dev/random or /dev/urandom, available on some
# systems as a way to generate random data
#
# if entropyLength is 0 (the default) or entropyFile isn't defined
# or doesn't open successfully, returns an empty string
#
method get_entropy_bytes {} {
if {$entropyLength == 0 || $entropyFile == ""} {
return ""
}
if {[catch {open $entropyFile} fp] == 1} {
return ""
}
set entropyBytes [read $fp $entropyLength]
close $fp
if {[binary scan $entropyBytes h* data]} {
debug "get_entropy_bytes: returning '$data'"
return $data
}
error "software bug - binary scan behaved unexpectedly"
}
#
# gen_session_id - generate a session ID by md5'ing as many things
# as we can get our hands on.
#
method gen_session_id {args} {
package require md5
# if the Apache unique ID module is installed, the environment
# variable UNIQUE_ID will have been set. If not, we'll get an
# empty string, which won't hurt anything.
set uniqueID [env UNIQUE_ID]
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 -hex -- $sessionIdKey]
}
#
# do_garbage_collection - delete dead sessions from the session table.
# corresponding session table cache entries will automatically be
# deleted as well (assuming they've been defined with ON DELETE CASCADE)
#
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 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"
set result [$dioObject exec $del_cmd]
$result destroy
}
#
# consider_garbage_collection - perform a garbage collection gcProbability
# percent of the time. For example, if gcProbability is 1, about 1 in
# every 100 times this routine is called, garbage collection will be
# performed.
#
method consider_garbage_collection {} {
if {rand() <= $gcProbability / 100.0} {
do_garbage_collection
}
}
#
# set_session_cookie - set a session cookie to the specified value --
# other cookie attributes are controlled by variables defined in the
# object
#
method set_session_cookie {value} {
cookie set $cookieName $value \
-path $cookiePath \
-minutes $cookieLifetime \
-secure $cookieSecure
}
#
# id - get the session ID of the current browser
#
# returns a session ID if their session cookie matches a current session.
# returns an empty string if they do not have a session.
#
# status will be set to an empty string if all is ok, "timeout" if
# the session had timed out, "no_cookie" if no cookie was previously
# defined (session id could still be valid though -- first visit)
#
# ...caches the results in the info array to avoid calls to the database
# in subsequent requests for the user ID from the same page, a common
# occurrence.
#
method id {} {
::request::global sessionInfo
status ""
# if we already know the session ID, we're done.
# (i.e. we've already validated them earlier in the
# handling of the current page.)
if {[info exists sessionInfo(sessionID)]} {
debug "id called, returning cached ID '$sessionInfo(sessionID)'"
return $sessionInfo(sessionID)
}
#
# see if they have a session cookie. if they don't,
# set status and return.
#
set sessionCookie [cookie get $cookieName]
if {$sessionCookie == ""} {
# they did not have a cookie set, they are not logged in
status "no_cookie"
debug "id: no session cookie '$cookieName'"
return ""
}
# there is a session Cookie, grab the remote address of the connection,
# see if our state table says he has logged into us from this
# address within our login timeout window and we've given him
# this session
debug "id: found session cookie '$cookieName' value '$sessionCookie'"
set a(session_id) $sessionCookie
set a(ip_address) [env REMOTE_ADDR]
# see if there's a record matching the session ID cookie and
# IP address
set kf [list session_id ip_address]
set key [$dioObject makekey a $kf]
if {![$dioObject fetch $key a -table $sessionTable -keyfield $kf]} {
debug "id: no entry in the session table for session '$sessionCookie' and address [env REMOTE_ADDR]: [$dioObject errorinfo]"
status "no_session"
return ""
}
## Carve the seconds out of the session_update_time field in the
# $sessionTable table. Trim off the timezone at the end.
set secs [clock scan [string range $a(session_update_time) 0 18]]
# if the session has timed out, delete the session and return -1
if {[expr $secs + $sessionLifetime] < [clock seconds]} {
$dioObject delete $key -table $sessionTable -keyfield $kf
debug "id: session '$sessionCookie' timed out"
status "timeout"
return ""
}
# Their session is still alive. If the session refresh
# interval time has expired, update the session update time in the
# database (we don't update every time they request a page for
# performance reasons) The idea is it's been at least 15 minutes or
# something like that since they've logged in, and they're still
# doing stuff, so reset their session update time to now
if {[expr $secs + $sessionRefreshInterval] < [clock seconds]} {
debug "session '$sessionCookie' alive, refreshing session update time"
set a(session_update_time) now
if {![$dioObject store a -table $sessionTable -keyfield $kf]} {
debug "id: Failed to store $sessionTable: [$dioObject errorinfo]"
puts "Failed to store $sessionTable: [$dioObject errorinfo]"
}
}
#
# THEY VALIDATED. Cache the session ID in the sessionInfo array
# that will only exist for the handling of this request, set that
# this is not a new session (at least one previous request has been
# handled with this session ID) and return the session ID
#
debug "id: active session, '$a(session_id)'"
set sessionInfo(sessionID) $a(session_id)
set isNewSession 0
return $a(session_id)
}
#
# store - given a package name, a key string, and a data string,
# store the data in the rivet session cache
#
method store {packageName key data} {
set a(session_id) [id]
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_]
if {![$dioObject store a -table $sessionCacheTable -keyfield $kf]} {
puts "Failed to store $sessionCacheTable '$kf'"
parray a
error [$dioObject errorinfo]
}
}
#
# fetch - given a package name and a key, return the data stored
# for this session
#
method fetch {packageName key} {
set kf [list session_id package_ key_]
set a(session_id) [id]
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]'"
return ""
}
debug "fetch session data succeeded, package_ '$packageName', key_ '$key', result '$a(data)'"
return $a(data)
}
#
# delete - given a user ID and looking at their IP address we inherited
# from the environment (thanks, webserver), remove them from the session
# table. (the session table is how the server remembers stuff about
# sessions)
#
method delete_session {{session_id ""}} {
variable conf
set ip_address [env REMOTE_ADDR]
if {$session_id == ""} {
set session_id [id]
}
debug "delete session $session_id"
set kf [list session_id ip_address]
$dioObject delete [list $session_id $ip_address] -table $sessionTable -keyfield $kf
## NEED TO delete saved session data here too, from the
# $sessionCacheTable structure.
}
#
# create_session - Generate a session ID and store the session in the
# session table.
#
# returns the session_id
#
method create_session {} {
global conf
## Create their session by storing their session information in
# the session table.
set a(ip_address) [env REMOTE_ADDR]
set a(session_start_time) now
set a(session_update_time) now
set a(session_id) [gen_session_id $a(ip_address)]
set kf [list ip_address session_id]
if {![$dioObject store a -table $sessionTable -keyfield $kf]} {
debug "Failed to store $sessionTable: [$dioObject errorinfo]"
puts "Failed to store $sessionTable: [$dioObject errorinfo]"
}
debug "create_session: ip $a(ip_address), id '$a(session_id)'"
return $a(session_id)
}
#
# activate - find the session ID if they have one. if they don't, create
# one and drop a cookie on them.
#
method activate {} {
::request::global sessionInfo
debug "activate: checking out the situation"
# a small percentage of the time, try to delete stale session data
consider_garbage_collection
set id [id]
if {$id != ""} {
debug "activate: returning session id '$id'"
return $id
}
# it's a new session, save the reason for why it's a new session,
# set that it's a new session, drop a session cookie on the browser
# that issued this request, set the session ID cache variable, and
# return the cookie ID
set newSessionReason [status]
debug "activate: new session, reason '$newSessionReason'"
set id [create_session]
set isNewSession 1
set_session_cookie $id
set sessionInfo(sessionID) $id
debug "activate: created session '$id' and set cookie (theoretically)"
return $id
}
#
# is_new_sesion - return a 1 if it's a new session, else a zero if there
# were one or more prior pages creating and/or using this session ID
#
method is_new_session {} {
return $isNewSession
}
#
# new_session_reason - return the reason why a session is new, either
# it didn't have a cookie "no_cookie", there was a cookie but no
# matching session "no_session", or there was a cookie and a session
# but the session has timed out "timeout". if the session isn't new,
# returns ""
#
method new_session_reason {} {
return $newSessionReason
}
#
# debug - output a debugging message
#
method debug {message} {
if {$debugMode} {
puts $debugFile "$this (debug) $message<br>"
flush $debugFile
}
}
}
# 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
}
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
