| # -- dio_Mysql.tcl -- Mysql backend. |
| |
| # Licensed to the Apache Software Foundation (ASF) under one |
| # or more contributor license agreements. See the NOTICE file |
| # distributed with this work for additional information |
| # regarding copyright ownership. The ASF licenses this file |
| # to you 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$ |
| |
| package provide dio_Mysql 0.4 |
| |
| namespace eval DIO { |
| ::itcl::class Mysql { |
| inherit Database |
| |
| constructor {args} {eval configure $args} { |
| if { [catch {package require Mysqltcl}] \ |
| && [catch {package require mysqltcl}] \ |
| && [catch {package require mysql}] } { |
| return -code error "No MySQL Tcl package available" |
| } |
| |
| eval configure $args |
| |
| if {[::rivet::lempty $db]} { |
| if {[::rivet::lempty $user]} { |
| set user $::env(USER) |
| } |
| set db $user |
| } |
| } |
| |
| destructor { |
| close |
| } |
| |
| method open {} { |
| set command "mysqlconnect" |
| |
| if {![::rivet::lempty $user]} { lappend command -user $user } |
| if {![::rivet::lempty $pass]} { lappend command -password $pass } |
| if {![::rivet::lempty $port]} { lappend command -port $port } |
| if {![::rivet::lempty $host]} { lappend command -host $host } |
| #if {![::rivet::lempty $encoding]} { lappend command -encoding $encoding } |
| |
| if {$clientargs != ""} { |
| set command [lappend command {*}$clientargs] |
| } |
| |
| #puts stderr "evaluating $command" |
| |
| if {[catch $command error]} { return -code error $error } |
| |
| set conn $error |
| |
| if {![::rivet::lempty $db]} { mysqluse $conn $db } |
| } |
| |
| method close {} { |
| if {![info exists conn]} { return } |
| catch {mysqlclose $conn} |
| unset conn |
| } |
| |
| method exec {req} { |
| if {![info exists conn] || ![mysqlping $conn]} { open } |
| |
| set cmd mysqlexec |
| # |
| # if {[::string tolower [lindex $req 0]] == "select"} { set cmd mysqlsel } |
| # select is a 6 characters word, so let's see if the query is a select |
| # |
| set q [::string trim $req] |
| |
| # set q [::string tolower $q] |
| # set q [::string range $q 0 5] |
| # if {[::string match select $q]} { set cmd mysqlsel } |
| |
| if {[regexp -nocase {^\(*\s*select\s+} $q]} { 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] || ![mysqlping $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 {[::rivet::lempty $offset]} { |
| return " LIMIT $limit" |
| } |
| return " LIMIT [expr $offset - 1],$limit" |
| } |
| |
| method handle {} { |
| if {![info exists conn] || ![mysqlping $conn]} { open } |
| return $conn |
| } |
| |
| method makeDBFieldValue {table_name field_name val {convert_to {}}} { |
| |
| if {[info exists specialFields(${table_name}@${field_name})]} { |
| switch $specialFields(${table_name}@${field_name}) { |
| |
| 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 { |
| |
| # we try to be coherent with the original purpose of this method whose |
| # goal is endow the class with a uniform way to handle timestamps. |
| # E.g.: Package session expects this case to return a timestamp in seconds |
| # so that differences with timestamps returned by [clock seconds] |
| # can be done and session expirations are computed consistently. |
| # (Bug #53703) |
| |
| 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 |
| |
| return [clock seconds] |
| |
| } else { |
| return "UNIX_TIMESTAMP($field_name)" |
| } |
| } |
| default { |
| |
| if {[::string compare $val, "now"] == 0} { |
| set secs [clock seconds] |
| } else { |
| set secs [clock scan $val] |
| } |
| |
| # this is kind of going back and forth from the same |
| # format, |
| |
| #set my_val [clock format $secs -format {%Y-%m-%d %T}] |
| return "FROM_UNIXTIME('$secs')" |
| } |
| } |
| } |
| NULL { |
| if {[::string toupper $val] == "NULL"} { |
| return $val |
| } else { |
| return "'[quote $val]'" |
| } |
| } |
| default { |
| # no special code for that type!! |
| return "'[quote $val]'" |
| } |
| } |
| |
| } else { |
| return "'[quote $val]'" |
| } |
| |
| } |
| |
| public variable db "" { |
| if {[info exists conn] && [mysqlping $conn]} { |
| mysqluse $conn $db |
| } |
| } |
| |
| protected method handle_client_arguments {cargs} { |
| |
| # we assign only the accepted options |
| |
| set clientargs {} |
| |
| foreach {a v} $cargs { |
| |
| if {($a == "-encoding") || \ |
| ($a == "-localfiles") || \ |
| ($a == "-ssl") || \ |
| ($a == "-sslkey") || \ |
| ($a == "-sslcert") || \ |
| ($a == "-sslca") || \ |
| ($a == "-sslcapath") || \ |
| ($a == "-sslcipher") || \ |
| ($a == "-socket")} { |
| lappend clientargs $a $v |
| } |
| |
| } |
| } |
| |
| 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 |
| |
| } |