This is an automated email from the ASF dual-hosted git repository.
mxmanghi pushed a commit to branch tdbc
in repository https://gitbox.apache.org/repos/asf/tcl-rivet.git
The following commit(s) were added to refs/heads/tdbc by this push:
new ff128c3 getting rid of the first attempt at writing TDBC.
dio_Tdbc.tcl will be the real place where TDBC is implemented
ff128c3 is described below
commit ff128c34cba8cff13634184867b99539705d7e90
Author: Massimo Manghi <mxman...@apache.org>
AuthorDate: Fri May 17 16:08:17 2024 +0200
getting rid of the first attempt at writing TDBC. dio_Tdbc.tcl will be the
real place where TDBC is implemented
---
rivet/packages/dio/dio_Tdbc.tcl | 295 ++++++++++++++++------------------------
rivet/packages/dio/tdbc.tcl | 2 -
2 files changed, 118 insertions(+), 179 deletions(-)
diff --git a/rivet/packages/dio/dio_Tdbc.tcl b/rivet/packages/dio/dio_Tdbc.tcl
index d251f0d..4156d2f 100644
--- a/rivet/packages/dio/dio_Tdbc.tcl
+++ b/rivet/packages/dio/dio_Tdbc.tcl
@@ -1,228 +1,169 @@
-# dio_Tdbc.tcl -- Tdbc compatibility layer
+# tdbc.tcl -- connector for tdbc, the Tcl database abstraction layer
#
-# Copyright 2000-2005 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.
-#
-# DIO compatibility layer with Tdbc
+# Copyright 2024 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
#
-# $Id$
+# 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 dio_Tdbc 0.1
-
-namespace eval DIO {
+package require DIO
+package require tdbc
+package provide dio_Tdbc 0.2
+namespace eval DIO {
::itcl::class Tdbc {
inherit Database
- private variable dbhandle
- public variable interface "Tdbc"
- private common conncnt 0
-
- public variable backend "" {
-
- if {$backend == "mysql"} {
-
- package require tdbc::mysql
-
- } elseif {$backend == "postgres"} {
-
- package require tdbc::postgres
-
- } elseif {$backend == "sqlite3"} {
-
- package require tdbc::sqlite3
-
- } elseif {$backend == "odbc"} {
-
- package require tdbc::odbc
-
- } elseif {$backend == ""} {
-
- return -code error "DIO Tdbc needs a backend be specified"
+ private variable connector_n
+ private variable connector
+ private variable tdbc_arguments [list -encoding \
+ -isolation \
+ -readonly \
+ -timeout]
- } else {
-
- return -code error "backend '$backend' not supported"
+ constructor {interface_name args} {eval configure {*}$args} {
+ set connector_n 0
+ set connector ""
- }
+ # I should check this one: we only accept connector
+ # interfaces that map into tdbc's
+ set interface "tdbc::[::string tolower $interface_name]"
+ package require ${interface}
}
-# -- destructor
-#
-#
+ destructor { }
- constructor {args} { eval configure $args } {
- if {[catch {package require tdbc}]} {
+ private method check_connector {} {
+ if {$connector == ""} { open }
+ }
- return -code error "No Tdbc package available"
+ public method open {} {
+ set connector_cmd "${interface}::connection create
$interface#$connector_n"
+ if {$user != ""} { lappend connector_cmd -user $user }
+ if {$db != ""} { lappend connector_cmd -db $db }
+ if {$pass != ""} { lappend connector_cmd -password $pass }
+ if {$port != ""} { lappend connector_cmd -port $port }
+ if {$host != ""} { lappend connector_cmd -host $host }
- }
+ if {$clientargs != ""} { lappend connector_cmd {*}$clientargs }
- eval configure $args
+ puts "evaluating $connector_cmd"
- if {[lempty $db]} {
- if {[lempty $user]} {
- set user $::env(USER)
- }
- set db $user
- }
+ set connector [eval $connector_cmd]
+ incr connector_n
}
- destructor { close }
-
-# --close
-#
-# we take inspiration from the DIO_Mysql class for handling
-# the basic connection data
-
public method close {} {
- if {![info exists dbhandle]} { return }
- catch { $dbhandle close }
-
- unset dbhandle
+ if {$connector == ""} { return }
+ $connector close
+ set connector ""
}
-# -- open
-#
-# Opening a connection with this class means that the member
-# variable specifying the backend was properly set
-#
-
- public method open {} {
- if {$backend == ""} {
- return -code error "no backend set"
+ protected method handle_client_arguments {cargs} {
+ set clientargs {}
+ lmap {k v} $cargs {
+ if {[lsearch $k $tdbcarguments] >= 0} {
+ lappend clientargs $k $v
+ }
}
- set command [::list ::tdbc::${backend}::connection create
tdbc[incr conncnt]]
-
- 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 $host }
- if {![lempty $db]} { lappend command -database $db }
-
- if {[catch {
- set dbhandle [eval $command]
- } e]} { return -code error $e }
-
-
- return -code ok
}
-# -- exec
-#
-# sql code central method. A statement object
-# is created from the sql string and then executed
-#
-
public method exec {sql} {
+ $this check_connector
- if {![info exists dbhandle]} { $this open }
-
- set sqlstat [$dbhandle prepare $sql]
-
- if {[catch {set res [$sqlstat execute]} err]} {
- set obj [result Tdbc -error 1 -errorinfo $err]
- } else {
- set obj [result Tdbc -resultid $res \
- -sqlstatement $sqlstat \
- -numrows [$res rowcount] \
- -fields [::list [$res columns]]]
- }
-
- #$res nextlist cols
- #puts "rows: [$res rowcount]"
- #puts "cols: $cols"
-
- return $obj
- }
+ # tdbc doesn't like ';' at the end of a SQL statement
-# -- execute
-#
-# extended version of the standard DIO method exec that
-# makes room for an extra argument storing the dictionary
-# of variables to be substituted in the SQL statement
-#
+ if {[::string index $sql end] == ";"} {set sql [::string range
$sql 0 end-1]}
+ set is_select [regexp -nocase {^\(*\s*select\s+} $sql]
- public method execute {sql {substitute_d ""}} {
+ set sql_st [$connector prepare $sql]
- if {![info exists dbhandle]} { $this open }
+ # errorinfo is a public variable of the
+ # parent class Database. Not a good
+ # object design practice
- set sqlstat [$dbhandle prepare $sql]
- if {$substitute_d != ""} {
- set cmd [list $sqlstat execute $substitude_d]
+ if {[catch {set tdbc_result [$sql_st execute]} errorinfo]} {
+ return [$this result TDBC -error 1 -errorinfo $errorinfo
-isselect false]
} else {
- set cmd [list $sqlstat execute]
- }
+ # we must store also the TDBC SQL statement as it owns
+ # the TDBC results set represented by tdbc_result. Closing
+ # a tdbc::statement closes also any active tdbc::resultset
+ # owned by it
- if {[catch {set res [eval $cmd]} err} {
- set obj [result Tdbc -error 1 -errorinfo $err]
- } else {
- set obj [result Tdbc -resultid $res \
- -numrows [$res rowcount] \
- -fields [$res columns]]
+ set result_obj [$this result TDBC -resultid $tdbc_result \
+ -statement $sql_st \
+ -isselect $is_select \
+ -fields [::list
[$tdbc_result columns]]]
}
-
- $sqlstat close
- return $obj
- }
-
-
-# -- handle
-#
-# accessor to the internal connection handle.
-#
-
- public method handle {} {
- return $dbhandle
}
-
}
-#
-# -- Class TdbcResult
-#
-# Class wrapping a Tdbc resultset object and adapting it
-# to the DIO Results interface
-#
-
- ::itcl::class TdbcResult {
+ ::itcl::class TDBCResult {
inherit Result
+ public variable isselect false
+ public variable statement
+
+ public variable rowid
+ public variable cached_rows
+ public variable columns
+
+ constructor {args} {
+ eval configure $args
+ set cached_rows {}
+ set columns {}
+ set rowid 0
+ set rownum 0
+ set statement ""
+ }
+ destructor {}
- public variable sqlstatement
+ public method destroy {} {
+ if {$statement != ""} { $statement close }
- constructor {args} {
- eval configure $args
+ Result::destroy
}
- destructor {
- catch {$sqlstatement close}
+ public method current_row {} {return $rowid}
+ public method cached_results {} {return $cached_rows}
+
+ public method nextrow {} {
+ if {[llength $cached_rows] == 0} {
+ if {![$resultid nextrow -as lists row]} {
+ return ""
+ }
+ } else {
+ set cached_rows [lassign $cached_rows row]
+ }
+ incr rowid
+ return $row
}
-# -- nextrow
-#
-# Returns the list of values selected by a SQL command.
-# Values appear in the list with the same order of
-# the columns names returned by the 'columns' object command
-#
+ public method numrows {} {
+ if {$isselect} {
- public method nextrow {} {
- $resultid nextlist v
- return $v
+ # this is not scaling well at all but tdbc is not telling
+ # the number of columns for a select so must determine it
+ # from the whole set of results
+
+ if {[llength $cached_rows] == 0} {
+ set cached_rows [$resultid allrows -as lists
-columnsvariable columns]
+ }
+ return [expr [llength $cached_rows] + $rowid]
+ } else {
+ return [$resultid rowcount]
+ }
}
}
diff --git a/rivet/packages/dio/tdbc.tcl b/rivet/packages/dio/tdbc.tcl
index 9c2268d..4156d2f 100644
--- a/rivet/packages/dio/tdbc.tcl
+++ b/rivet/packages/dio/tdbc.tcl
@@ -108,8 +108,6 @@ namespace eval DIO {
-fields [::list
[$tdbc_result columns]]]
}
}
-
-
}
::itcl::class TDBCResult {
---------------------------------------------------------------------
To unsubscribe, e-mail: commits-unsubscr...@tcl.apache.org
For additional commands, e-mail: commits-h...@tcl.apache.org
