rivet/packages/dio/dio_Mysql.tcl

# -- 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.

package require DIO
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

}