# 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: myprocs.tcl,v 2.32 2006/03/16 21:29:56 jfontain Exp $


package provide myprocs [lindex {$Revision: 2.32 $} 1]
package require miscellaneous 1
if {![catch {package require Thread 2.5}]} {           ;# 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 myprocs {
        variable thread
        set thread(busy) 0
        set thread(worker) [new worker]
    }
}


namespace eval myprocs {

    array set data {
        updates 0
        0,label id 0,type integer 0,message {process identifier}
        1,label user 1,type dictionary 1,message {user name}
        2,label host 2,type dictionary 2,message {host name (eventually followed by client TCP port)}
        3,label database 3,type dictionary 3,message {database name}
        4,label command 4,type ascii 4,message command
        5,label time 5,type dictionary 5,message {process time in d(ays), h(ours), m(inutes) and s(econds)}
        6,label state 6,type dictionary 6,message state
        7,label information 7,type dictionary 7,message {query information} 7,anchor left
        sort {0 decreasing}
        pollTimes {10 5 20 30 60 120 300}
        persistent 1
        switches {--dsn 1 --host 1 --password 1 --port 1 --user 1}
    }
    set file [open myprocs.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 odbc
        variable connection
        variable data

        set user $::tcl_platform(user)                                                                                 ;# by default
        catch {set user $options(--user)}
        if {[info exists options(--dsn)]} {                                               ;# ODBC mode id data source name specified
            set odbc 1
            package require tclodbc 2                               ;# so that it works with both UNIX 2.2.1 et Windows 2.3 versions
            if {[info exists options(--host)] || [info exists options(--port)]} {
                error {--host and --port options incompatible with ODBC mode}
            }
            set arguments [list $options(--dsn)]
            catch {lappend arguments $user}
            catch {lappend arguments $options(--password)}
            if {[info exists thread]} {
                worker::evaluate $thread(worker) {package require tclodbc 2}
                set connection [worker::wait $thread(worker) "database odbc $arguments"]             ;# use a unique connection name
            } else {
                package require tclodbc 2                           ;# so that it works with both UNIX 2.2.1 et Windows 2.3 versions
                set connection [eval database odbc $arguments]                                       ;# use a unique connection name
            }
            set data(identifier) myprocs($options(--dsn))
            if {[info exists thread]} {
                worker::evaluate $thread(worker) "$connection {show processlist}"
            } else {
                $connection {show processlist}                                    ;# first check that user has the process privilege
            }
        } else {
            set odbc 0
            package require mysqltcl
            if {[info exists options(--port)] && (![info exists options(--host)] || [string equal $options(--host) localhost])} {
                error {--port option useless with local socket connection (localhost as host)}
            }
            set arguments {}
            catch {lappend arguments -host $options(--host)}
            catch {lappend arguments -user $user}
            catch {lappend arguments -password $options(--password)}
            catch {lappend arguments -port $options(--port)}
            if {[info exists thread]} {
                worker::evaluate $thread(worker) {package require mysqltcl}
                set connection [worker::wait $thread(worker) "mysqlconnect $arguments"]                           ;# do not hang GUI
                set host [worker::evaluate $thread(worker) "lindex \[mysqlinfo $connection host\] 0"]
            } else {
                package require mysqltcl
                set connection [eval mysqlconnect $arguments]
                set host [lindex [mysqlinfo $connection host] 0]           ;# work around mysqltcl 3 return value: "host via TCP/IP"
            }
            set data(identifier) myprocs($host)
            if {[info exists thread]} {
                worker::evaluate $thread(worker) "mysqlsel $connection {show processlist} -list"
            } else {
                mysqlsel $connection {show processlist} -list                     ;# first check that user has the process privilege
            }
        }
    }

    proc update {} {
        variable thread

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

    proc getProcesses {{result {}} {errorInformation {}}} {
        variable thread
        variable odbc
        variable connection
        variable data

        array unset data {[0-9]*,[0-9]*}                                      ;# refresh data every time since processes come and go
        set error 0
        if {[info exists thread]} {
            if {[string length $result] == 0} {                                                        ;# launch query in background
                if {$odbc} {
                    worker::evaluate $thread(worker)\
                        "$connection statement $connection.query {show processlist}; $connection.query execute; list 1"\
                        myprocs::getProcesses
                } else {
                    worker::evaluate $thread(worker) "mysqlsel $connection {show processlist}; list 1" myprocs::getProcesses
                }
                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 {
            if {$odbc} {
                set error [catch {$connection statement $connection.query {show processlist}; $connection.query execute} message]
            } else {
                set error [catch {mysqlsel $connection {show processlist}} message]
            }
        }
        if {$error} {                                                                                     ;# problem reaching server
            flashMessage "error: $message"
        } else {
            while {1} {
                if {[info exists thread]} {
                    # no need for background work since the whole data is already in this client (mysql_store_result() used):
                    if {$odbc} {
                        set list [worker::evaluate $thread(worker) "$connection.query fetch"]
                    } else {
                        set list [worker::evaluate $thread(worker) "mysqlnext $connection"]
                    }
                } else {
                    if {$odbc} {
                        set list [$connection.query fetch]
                    } else {
                        set list [mysqlnext $connection]
                    }
                }
                if {[llength $list] == 0} break
                set row [lindex $list 0]                                                                              ;# id (unique)
                set column 0
                foreach value $list {
                    # time column (value may be empty when user connecting, ...)
                    if {($column == 5) && ([string length $value] > 0)} {
                        set data($row,$column) [formattedTime $value]
                    } else {
                        set data($row,$column) $value
                    }
                    incr column
                }
            }
        }
        if {$odbc} {
            # 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 odbc
        variable connection

        if {$odbc} {
            catch {$connection disconnect}
        } else {
            catch {mysqlclose $connection}
        }
    }

}
