# copyright (C) 1997-2006 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu

# $Id: odbcquery.tcl,v 1.18 2006/03/16 21:29:56 jfontain Exp $


package provide odbcquery [lindex {$Revision: 1.18 $} 1]
if {[catch {package require Thread 2.5}]} {
    package require tclodbc 2                                       ;# so that it works with both UNIX 2.2.1 et Windows 2.3 versions
} else {                                               ;# use threads so that core is not blocked on connection problems with server
    package require stooop 4.1
    namespace import stooop::*
    package require threads 1
    namespace eval odbcquery {
        variable thread
        set thread(busy) 0
        set thread(worker) [new worker]
        worker::evaluate $thread(worker) {
            package require tclodbc 2                               ;# so that it works with both UNIX 2.2.1 et Windows 2.3 versions
        }
    }
}


namespace eval odbcquery {

    array set data {
        updates 0
        0,label {} 0,type integer 0,message {row number in order of arrival}
        pollTimes {10 5 20 30 60 120 300}
        switches {--dsn 1 --password 1 -q 1 --query 1 --swap 0 -t 1 --table 1 --user 1}
        persistent 1
        sort {0 increasing}
    }
    set file [open odbcquery.htm]
    set data(helpText) [read $file]                                                           ;# initialize HTML help data from file
    close $file
    if {[info exists thread]} {                     ;# show on last line of this module help window that we are running with threads
        regsub -nocase </body> $data(helpText) "<p><i>(currently running in threaded mode)</i>\n\\0" data(helpText)
    }

    proc initialize {optionsName} {
        upvar 1 $optionsName options
        variable thread
        variable connection
        variable data
        variable statement

        if {![info exists options(--dsn)]} {
            error {data source name (--dsn) must be specified}
        }
        catch {set query $options(-q)}
        catch {set query $options(--query)}                                                                     ;# favor long option
        catch {set table $options(-t)}
        catch {set table $options(--table)}                                                                     ;# favor long option
        if {[info exists query] && [info exists table]} {
            error {use either table or query option but not both}
        }
        if {[info exists query]} {
            set statement $query
        } elseif {[info exists table]} {
            set statement "select * from $table"
        } else {
            error {either query (-q (--query)) or table (-t (--table)) must be specified}
        }
        set user $::tcl_platform(user)                                                                                 ;# by default
        catch {set user $options(--user)}
        set arguments [list $options(--dsn)]
        catch {lappend arguments $user}
        catch {lappend arguments $options(--password)}
        if {[info exists thread]} {
            set connection [worker::wait $thread(worker) "database odbc $arguments"]                 ;# use a unique connection name
        } else {
            set connection [eval database odbc $arguments]                                           ;# use a unique connection name
        }
        set data(identifier) odbcquery($options(--dsn))
        if {[info exists thread]} {
            worker::evaluate $thread(worker) "$connection statement $connection.query [list $statement]"
            set lists [worker::evaluate $thread(worker) "$connection.query columns label type typename displaysize"]
        } else {
            $connection statement $connection.query $statement
            set lists [$connection.query columns label type typename displaysize]
        }
        set column 1
        foreach list $lists {
            foreach {name code type width} $list {}
            set data($column,label) $name
            if {($code == -6) || ($code == -5) || (($code >= 2) && ($code <= 8))} {                                  ;# numeric type
                set data($column,type) real                     ;# so that cell may be dropped in viewers that expect a numeric type
                set data($column,message) "$name ($type)"            ;# do not display width, which equals zero, at least with MySQL
            } elseif {($code == -1) || ($code == 1) || ($code == 12)} {                                               ;# string type
                set data($column,type) ascii
                set data($column,anchor) left
                set data($column,message) "$name (${type}($width))"
            } else {
                set data($column,type) ascii
                set data($column,message) "$name ($type)"
            }
            incr column
        }
        if {[info exists options(--swap)]} {
            for {set index 0} {$index < $column} {incr index} {
                lappend indices $index
            }
            set data(views) [list [list indices $indices swap 1]]
        }
        if {[info exists thread]} {
            worker::evaluate $thread(worker) "$connection.query execute"
            while {[llength [worker::evaluate $thread(worker) "$connection.query fetch"]] > 0} {}
            worker::evaluate $thread(worker) "$connection.query drop"
        } else {
            $connection.query execute
            while {[llength [$connection.query fetch]] > 0} {}
            $connection.query drop
        }
    }

    proc update {} {
        variable thread

        if {[info exists thread]} {
            if {$thread(busy)} return
            set thread(busy) 1
        }
        query
    }

    proc query {{result {}} {errorInformation {}}} {
        variable thread
        variable connection
        variable statement
        variable data

        array unset data {[0-9]*,[0-9]*}                                                                    ;# clear data every time
        set error 0
        if {[info exists thread]} {
            if {[string length $result] == 0} {                                                        ;# launch query in background
                worker::evaluate $thread(worker)\
                    "$connection statement $connection.query [list $statement]; $connection.query execute; list 1"\
                    odbcquery::query
                return                                       ;# this procedure is invoked back with a non-empty result (1) when done
            } elseif {[string length $errorInformation] > 0} {                                                   ;# an error occured
                set error 1
                set message $result
            }                                                                           ;# else the query was executed with no error
        } else {
            set error [catch {$connection statement $connection.query $statement; $connection.query execute} message]
        }
        if {$error} {                                                                                     ;# problem reaching server
            flashMessage "error: $message"                                                                ;# problem reaching server
        } else {
            set row 0
            while {1} {
                if {[info exists thread]} {
                    # no need for background work since the whole data is already in this client (mysql_store_result() used):
                    set list [worker::evaluate $thread(worker) "$connection.query fetch"]
                } else {
                    set list [$connection.query fetch]
                }
                if {[llength $list] == 0} break
                set data($row,0) $row
                set column 1
                foreach value $list {
                    set data($row,$column) $value
                    incr column
                }
                incr row
            }
        }
        # ignore connection errors at this point (they will be reported at next poll):
        if {[info exists thread]} {
            catch {worker::evaluate $thread(worker) "$connection.query drop"}
        } else {
            catch {$connection.query drop}
        }
        if {[info exists thread]} {
            set thread(busy) 0
        }
        incr data(updates)
    }

    proc terminate {} {
        variable thread
        variable connection

        if {![info exists connection]} return                                        ;# connection may have failed in initialization
        if {[info exists thread]} {
            worker::evaluate $thread(worker) "$connection disconnect" list                ;# try to disconnect while ignoring errors
            delete $thread(worker)
        } else {
            catch {$connection disconnect}
        }
    }

}
