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
commit 12b071cae0847772d7dd33bc9501e7629f43fc2e
Author: Massimo Manghi <mxman...@apache.org>
AuthorDate: Wed May 15 09:21:44 2024 +0200
add tdbc support for DIO
---
rivet/packages/dio/dio.tcl | 8 +--
rivet/packages/dio/dio_Mysql.tcl | 10 +--
rivet/packages/dio/dio_Oracle.tcl | 8 +--
rivet/packages/dio/tdbc.tcl | 146 ++++++++++++++++++++++++++++++++++++++
4 files changed, 159 insertions(+), 13 deletions(-)
diff --git a/rivet/packages/dio/dio.tcl b/rivet/packages/dio/dio.tcl
index c6a27f2..0333336 100644
--- a/rivet/packages/dio/dio.tcl
+++ b/rivet/packages/dio/dio.tcl
@@ -70,11 +70,11 @@ proc handle {interface args} {
#
protected method build_select_query {args} {
- set bool AND
- set first 1
- set req ""
+ set bool AND
+ set first 1
+ set req ""
set myTable $table
- set what "*"
+ set what "*"
# for each argument passed us...
# (we go by integers because we mess with the index based on
diff --git a/rivet/packages/dio/dio_Mysql.tcl b/rivet/packages/dio/dio_Mysql.tcl
index 0c2ca7f..b88ee8e 100644
--- a/rivet/packages/dio/dio_Mysql.tcl
+++ b/rivet/packages/dio/dio_Mysql.tcl
@@ -96,9 +96,9 @@ namespace eval DIO {
return $obj
}
if {[catch {mysqlcol $conn -current name} fields]} { set fields ""
}
- set obj [result Mysql -resultid $conn \
- -numrows [::list $error] \
- -fields [::list $fields]]
+ set obj [result Mysql -resultid $conn \
+ -numrows [::list $error] \
+ -fields [::list $fields]]
return $obj
}
@@ -205,7 +205,7 @@ namespace eval DIO {
}
}
- protected method handle_client_arguments {cargs} {
+ protected method handle_client_arguments {cargs} {
# we assign only the accepted options
@@ -245,7 +245,7 @@ namespace eval DIO {
}
method nextrow {} {
- return [mysqlnext $resultid]
+ return [mysqlnext $resultid -as lists]
}
} ; ## ::itcl::class MysqlResult
diff --git a/rivet/packages/dio/dio_Oracle.tcl
b/rivet/packages/dio/dio_Oracle.tcl
index c2b51d1..1348468 100644
--- a/rivet/packages/dio/dio_Oracle.tcl
+++ b/rivet/packages/dio/dio_Oracle.tcl
@@ -88,8 +88,8 @@ namespace eval DIO {
set my_fields $fields
set fields [::list]
foreach field $my_fields {
- set field [::string tolower $field]
- lappend fields $field
+ set field [::string tolower $field]
+ lappend fields $field
}
set error [::oramsg $_cur rows]
set res_cmd "result"
@@ -98,7 +98,7 @@ namespace eval DIO {
lappend res_cmd -fetch_first_row $is_select
set obj [eval $res_cmd]
if {!$is_select} {
- ::oraclose $_cur
+ ::oraclose $_cur
}
return $obj
}
@@ -175,7 +175,7 @@ namespace eval DIO {
public variable db "" {
if {[info exists conn]} {
- mysqluse $conn $db
+ mysqluse $conn $db
}
}
diff --git a/rivet/packages/dio/tdbc.tcl b/rivet/packages/dio/tdbc.tcl
new file mode 100644
index 0000000..85e4ff3
--- /dev/null
+++ b/rivet/packages/dio/tdbc.tcl
@@ -0,0 +1,146 @@
+# Copyright 2024 Massimo Manghi <mxman...@apache.org>
+#
+# 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 require DIO
+package provide dio::tdbc 0.1
+
+namespace eval DIO {
+ ::itcl::class Tdbc {
+ inherit Database
+
+ private variable connector_n
+ private variable connector
+ private variable tdbc_arguments [list -encoding \
+ -isolation \
+ -readonly \
+ -timeout]
+
+ 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 { }
+
+ private method check_connector {} {
+ if {$connector == ""} { open }
+ }
+
+ 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 }
+
+ puts "evaluating $connector_cmd"
+
+ set connector [eval $connector_cmd]
+ incr connector_n
+ }
+
+ public method close {} {
+ if {$connector == ""} { return }
+ $connector close
+ set connector ""
+ }
+
+ protected method handle_client_arguments {cargs} {
+ set clientargs {}
+ lmap {k v} $cargs {
+ if {[lsearch $k $tdbcarguments] >= 0} {
+ lappend clientargs $k $v
+ }
+ }
+ }
+
+ public method exec {sql} {
+ $this check_connector
+
+ # tdbc doesn't like ';' at the end of a SQL statement
+
+ if {[::string index end $sql] == ";"} {set sql [::string range 0
end-1 $sql]}
+ set is_select [regexp -nocase {^\(*\s*select\s+} $sql]
+
+ set sql_st [$connector prepare $sql]
+
+ # errorinfo is a public variable of the
+ # parent class Database. Not a good
+ # object design practice
+
+ if {[catch {set tdbc_result [$sql_st execute]} errorinfo]} {
+ return [$this result TDBC -error 1 -errorinfo $errorinfo
-isselect false]
+ } else {
+ set result_obj [$this result -resultid $tdbc_result -isselect
$is_select -fields [$tdbc_result columns]]
+ }
+ }
+
+
+ }
+
+ ::itcl::class TDBCResult {
+ inherit Result
+ public variable isselect false
+
+ private variable rowid
+ private variable cached_rows
+ private variable columns
+
+ constructor {args} {
+ eval configure $args
+ set cached_rows {}
+ set columns {}
+ set rowid 0
+ }
+ destructor {}
+
+ public method nextrow {} {
+ if {[llength $cached_rows] == 0} {
+ set row [$resultid nextrow]
+ } else {
+ set row [lindex $cached_rows $rowid]
+ }
+ incr rowid
+ return $row
+ }
+
+ public method numrows {} {
+ if {$isselect} {
+
+ # 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
+
+ set cached_rows [$resultid allrows -as lists -columnsvariable
columns]
+ return [llength $cached_rows]
+ } else {
+ return [$resultid rowcount]
+ }
+ }
+
+ }
+
+
+}
---------------------------------------------------------------------
To unsubscribe, e-mail: commits-unsubscr...@tcl.apache.org
For additional commands, e-mail: commits-h...@tcl.apache.org
