# copyright (C) 1997-2005 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: module.tcl,v 2.66 2005/02/20 18:05:18 jfontain Exp $


class module {

    proc module {this name index args} switched {$args} {
        # index may be forced (when coming from a save file), left empty for automatic generation
        if {[string length $index] == 0} {
            set index [newIndex $name]                                       ;# note: the first instance of a module gets 0 as index
        } else {                                                                                    ;# index was passed as parameter
            addIndex $name $index
        }
        set ($this,name) $name
        set ($this,index) $index
        switched::complete $this
    }

    proc ~module {this} {
        if {$($this,terminate)} {
            ::$($this,namespace)::terminate                                        ;# invoke module terminate procedure if it exists
        }
        if {[info exists ($this,interpreter)]} {
            switch $($this,type) {
                perl {
                    perl::interp delete $($this,interpreter)
                }
                python {
                    python::interp delete $($this,interpreter)
                }
                default {
                    interp delete $($this,interpreter)
                }
            }
        }
        if {[info exists ($this,namespace)]} {
            namespace delete ::$($this,namespace)
        }
        deleteIndex $this
    }

    proc options {this} {
        return [list\
            [list -state {} {}]\
        ]
    }

    proc set-state {this value} {
if {$global::withGUI} {
        switch $value {
            {} {
                return                                                                                ;# undefined (yet), do nothing
            }
            busy - idle {}
            error {
                set ($this,errorTime) [clock seconds]
            }
            default error
        }
        displayModuleState $($this,namespace) $value
}
    }

    # find a new index for the module, by eventually finding a hole in that module indices list.
    # important: giving the index of a module that was just deleted to a new module (of the same name of course) is mandatory for
    # module reloading to work properly
    proc newIndex {name} {                                                   ;# note: the first instance of a module gets 0 as index
        variable indices

        if {![info exists indices($name)]} {
            set indices($name) {}
        }
        set new 0
        foreach index $indices($name) {
            if {$index != $new} break                                                                                ;# found a hole
            incr new
        }
        set indices($name) [lsort -integer [concat $indices($name) $new]]
        return $new
    }

    proc addIndex {name index} {
        variable indices

        if {![info exists indices($name)]} {
            set indices($name) $index
            return
        }
        if {[lsearch -exact $indices($name) $index] >= 0} {
            error "trying to add an existing index: $index"
        }
        set indices($name) [lsort -integer [concat $indices($name) $index]]
    }

    proc deleteIndex {this} {
        variable indices

        set name $($this,name)
        ldelete indices($name) $($this,index)
        if {[llength $indices($name)] == 0} {
            unset indices($name)
        }
    }

    proc load {this} {              ;# load a module in its own interpreter, in order to allow multiple instances of the same module
        set name $($this,name)
        set namespace ${name}<$($this,index)>
        set directory [pwd]
        cd $::package(directory,$name)                                       ;# switch to module directory only during loading phase
        set interpreter [interp create]                                                ;# use a separate interpreter for each module
if {$global::withGUI} {
        $interpreter eval {                    ;# since Tk is not loaded in module interpreter, provide a background error procedure
            proc bgerror {error} {
                puts stderr $::errorInfo
                exit 1
            }
        }
} else {                                       ;# for asynchronous modules, handle background errors exactly as for synchronous ones
        $interpreter alias writeLog writeLog
        interp eval $interpreter "namespace eval global {set debug $::global::debug}"
        $interpreter eval {
            proc bgerror {message} {
                if {$::global::debug} {
                    writeLog $::errorInfo critical
                } else {
                    writeLog $message critical
                }
            }
        }
}
        $interpreter eval "set auto_path [list $::auto_path]"                        ;# set packages paths list in child interpreter
        catch {$interpreter eval {package require {}}}    ;# then seek all packages locations (many pkgIndex.tcl files sourced here)
        # then intercept source command to be able to detect Perl modules:
        $interpreter eval {rename source _source}; $interpreter alias source ::module::source $this $interpreter
        namespace eval ::$namespace {}                                                                    ;# create module namespace
        set ($this,namespace) $namespace                                                         ;# needed when loading Perl modules
        set ($this,terminate) 0                                            ;# needed in case loading fails and destructor is invoked
        # initialize counter copy to a minimal value (in case it is not done in the module body):
        set ::${namespace}::data(updates) $global::32BitIntegerMinimum
        set ::${namespace}::data(identifier) $namespace              ;# initialize identifier which may be overridden in module code
        if {[info exists ::package(exact,$name)]} {
           $interpreter eval "package require -exact $name $::package(version,$name)"                       ;# module is loaded here
        } else {
           $interpreter eval "package require $name"                                                        ;# module is loaded here
        }
        # we never get here if there is an error when the module is loaded
        switch $($this,type) {
            perl - python {
                # a Perl or Python module would have been loaded right above and taken care of its initialization
                # child interpreter is not needed since Perl or Python modules require their own interpreter,
                # already created at this point
                interp delete $interpreter
                validateColumnTitles $this
            }
            default {
                set ($this,interpreter) $interpreter                                          ;# the Tcl interpreter for this module
                loadTcl $this                                                                     ;# finish Tcl modules related work
            }
        }
        cd $directory                                                                                   ;# restore current directory
    }

    proc loadTcl {this} {
        # the new namespace, "interface" to the protected module namespace in its interpreter, is child of the global namespace
        # allow arguments to be passed to the update procedure specifically for the special trace module
        set name $($this,name)
        set interpreter $($this,interpreter)
        set namespace $($this,namespace)
        switch $name {
            formulas {                                                                      ;# specific interface to formulas module
                namespace eval ::$namespace "proc messages {} {$interpreter eval ::formulas::messages}"
                namespace eval ::$namespace "proc new {row} {$interpreter eval ::formulas::new \$row}"
                namespace eval ::$namespace "proc name {row string} {$interpreter eval ::formulas::name \$row \[list \$string\]}"
                namespace eval ::$namespace "proc value {row value} {$interpreter eval ::formulas::value \$row \[list \$value\]}"
                namespace eval ::$namespace "proc delete {row} {$interpreter eval ::formulas::delete \$row}"
                namespace eval ::$namespace "proc update {} {$interpreter eval ::formulas::update}"
            }
            trace {              ;# no need to display update message for internal trace module, allow arguments to update procedure
                namespace eval ::$namespace "proc update {args} {$interpreter eval ::trace::update \$args}"
            }
            default {
if {$global::withGUI} {
                # module update procedure only invoked if the module is synchronous, update message always being popped when updated
                set message [mc {%s data update...}]
                namespace eval ::$namespace [subst -nocommands {
                    proc update {} {
                        ::variable data

                        switched::configure $this -state busy
                        lifoLabel::push $global::messenger [::format {$message} \$data(identifier)]
                        $interpreter eval ::${name}::update
                        lifoLabel::pop $global::messenger
                    }
                }]
} else {
                namespace eval ::$namespace "proc update {} {$interpreter eval ::${name}::update}"
}
            }
        }
        set ($this,initialize) [procedureExists $this initialize]
        if {$($this,initialize)} {                                                                    ;# initialize procedure exists
            namespace eval ::$namespace [subst -nocommands {        ;# create an interface initialize procedure within new namespace
                proc initialize {arguments} {                     ;# arguments are a list of option / value (eventually empty) pairs
                    $interpreter eval "
                        ::array set _options [list \$arguments]
                        ::${name}::initialize _options
                        ::unset _options
                    "
                }
            }]
        }
        set ($this,terminate) [procedureExists $this terminate]
        if {$($this,terminate)} {
            proc ::${namespace}::terminate {} "$interpreter eval ${name}::terminate"
        }
        set ($this,version) [$interpreter eval "package provide $name"]
        synchronize $this                                                ;# initialize namespace data from module in its interpreter
        validateColumnTitles $this
        $interpreter alias exit exit                                       ;# redirect to parent interpreter (useful in daemon mode)
        # keep on eye on special module data array member "update"
        $interpreter alias _updated ::module::updated $this
        $interpreter eval "trace variable ::${name}::data(updates) w _updated"
        # setup interface to messenger:
        $interpreter alias pushMessage ::modules::pushMessage $name $namespace
        $interpreter alias popMessage ::modules::popMessage
        $interpreter alias flashMessage ::modules::flashMessage $name $namespace
        $interpreter alias traceMessage ::modules::trace $name $namespace
        $interpreter alias createThreshold ::thresholds::create $thresholds::singleton ${namespace}::data
        $interpreter alias currentThresholds ::thresholds::current $thresholds::singleton ${namespace}::data
if {$global::withGUI} {
        if {[string equal $name instance]} {
            $interpreter alias cellHistory ::databaseInstances::cellHistory
            proc ::${namespace}::mapping {row column} "return \[$interpreter eval ${name}::mapping \$row \$column\]"
        }
}
    }

    proc updated {this args} {                             ;# Tcl module data was just updated. ignore already known trace arguments
        set namespace $($this,namespace)
        # note: use ::set as this is invoked in the context where the update occurred, and set{} may exist in the module namespace
        set updates [$($this,interpreter) eval "::set ::$($this,name)::data(updates)"]                   ;# retrieve updates counter
        if {$updates <= [set ::${namespace}::data(updates)]} return                        ;# do nothing if counter did not increase
        set asynchronous [asynchronous $this]
if {$global::withGUI} {
        set trace [string equal $($this,name) trace]
        if {$asynchronous && !$trace} {                               ;# no need to display update message for internal trace module
            # module update procedure is never invoked so push update message here:
            lifoLabel::push $global::messenger [format [mc {%s data update...}] [set ::${namespace}::data(identifier)]]
        }
}
        array unset ::${namespace}::data {[0-9]*,[0-9]*}                         ;# first clear dynamic data (so rows can disappear)
        synchronize $this {[0-9]*,[0-9]*}                                            ;# just copy all dynamic data from module array
        set ::${namespace}::data(updates) $updates                                                           ;# copy updates counter
if {$global::withGUI} {
        if {!$trace} {
            updateState $this
            if {$asynchronous} {
                lifoLabel::pop $global::messenger
            }
        }
}
    }

    proc asynchronous {this} {                   ;# whether the module is asynchronous (warning: invoke after module initialization)
        if {[info exists ($this,asynchronous)]} {return $($this,asynchronous)}                                              ;# cache
        set namespace $($this,namespace)
        set ($this,asynchronous) [expr {[lindex [set ::${namespace}::data(pollTimes)] 0] <= 0}]
    }

    proc updateState {this} {
if {$global::withGUI} {
        if {\
            ![string equal $switched::($this,-state) error] ||\
            ([asynchronous $this] && ($($this,errorTime) < ([clock seconds] - 1)))\
        } {                                      ;# in asynchronous module case, error likely to have occured during previous update
            switched::configure $this -state idle
        }                                                                             ;# else error state is sticky till next update
}
    }

    proc clear {this} {                                                     ;# act as if Tcl module code was updated with empty data
        set namespace $($this,namespace)
        array unset ::${namespace}::data {[0-9]*,[0-9]*}                          ;# clear dynamic data (so rows can disappear) then
        set ::${namespace}::data(updates) [set ::${namespace}::data(updates)]                                       ;# force updates
    }

    proc synchronize {this {pattern *}} {                   ;# copy data from Tcl module in its interpreter to module namespace here
        set namespace $($this,namespace)
        set interpreter $($this,interpreter)
        set name $($this,name)
        switch $($this,type) {
            perl {
                # invoked only once in instance initialization, so copying hash only is enough
                array set ::${namespace}::data [$interpreter eval ::hash_string(%${name}::data)]
            }
            python {
                # invoked only once in instance initialization, so copying form data only is enough
                array set ::${namespace}::data [$interpreter eval formstring($name.form)]
            }
            default {
                array set ::${namespace}::data [$interpreter eval "array get ::${name}::data {$pattern}"]
            }
        }
    }

    proc validateColumnTitles {this} {
        foreach {name label} [array get ::$($this,namespace)::data *,label] {
            if {[string first ? $label] >= 0} {
                scan $name %u column
                puts stderr "in $($this,namespace) module, column $column label contains a ? character: \"$label\""
                exit 1
            }
        }
    }

    proc procedureExists {this name} {                     ;# see if procedure exists in module namespace within its own interpreter
        return [$($this,interpreter) eval\
            [subst -nocommands {expr {[string length [namespace eval ::$($this,name) {::info proc $name}]] > 0}}]\
        ]
    }

    # module interpreter source command, to do special processing if the module code is written in Perl
    proc source {this interpreter file} {                                                                       ;# a Tcl interpreter
        switch [file extension $file] {
            .pm {
                set ($this,type) perl          ;# remember that this is a Perl module so that destructor knows in case of load error
                loadPerl $this $file
                # if we got here, act as if the package was provided in the Tcl interpreter
                $interpreter eval "package provide $($this,name) $($this,version)"
            }
            .py {
                set ($this,type) python      ;# remember that this is a Python module so that destructor knows in case of load error
                loadPython $this $file
                # if we got here, act as if the package was provided in the Tcl interpreter
                $interpreter eval "package provide $($this,name) $($this,version)"
            }
            default {
                set ($this,type) tcl
                $interpreter eval _source [list $file]
            }
        }
    }

    proc loadPerl {this file} {
        set name $($this,name)                                                                          ;# also the Perl module name
        set namespace $($this,namespace)
        if {[catch {package require tclperl 3} message] && [catch {package require tclperl 2} message]} {       ;# load Perl library
            error "$message\nis the tclperl package installed?"
        }
        set interpreter [perl::interp new]                                                                                 ;# create
        set ($this,interpreter) $interpreter                                                 ;# the Perl interpreter for this module
        $interpreter eval "use $name"                                                                     ;# and use the Perl module
        $interpreter eval $perl::utilities
        # initialize static part of data:
        array set ::${namespace}::data [$interpreter eval ::hash_string(%${name}::data)]
if {$global::withGUI} {
        set message [mc {%s data update...}]
        proc ::${namespace}::update {} "                                                                  ;# create update procedure
            variable data

            switched::configure $this -state busy
            lifoLabel::push $global::messenger \[format {$message} \$data(identifier)\]
            $interpreter eval ${name}::update()
            lifoLabel::pop $global::messenger
        "
} else {                                                                                                 ;# do not use GUI messenger
        proc ::${namespace}::update {} "$interpreter eval ${name}::update()"
}
        proc ::${namespace}::updated {} "
            variable data

            $interpreter eval {
                if (defined(&${name}::updated)) {${name}::updated();}                                 ;# required in threaded module
            }
            set updates \[$interpreter eval \\$${name}::data{updates}\]                                  ;# retrieve updates counter
            if {\$updates > \$data(updates)} {                                             ;# do nothing if counter did not increase
                array unset data {\[0-9\]*,\[0-9\]*}                             ;# first clear dynamic data (so rows can disappear)
                array set data \[$interpreter eval ::array_string(@${name}::data)\]                             ;# copy dynamic data
                set data(updates) \$updates                                                                  ;# copy updates counter
            }
            module::updateState $this
        "
        set threaded [$interpreter eval int(defined(&threads::new))]                  ;# whether threads module was loaded in module
        if {$threaded} {                                                                           ;# module supposedly uses threads
            if {![info exists ::tcl_platform(threaded)] || !$::tcl_platform(threaded)} {
                error "Tcl core with multithreading enabled required with $name module using Perl threads"
            }
            if {[catch {package require tclperl 3.1} message]} {
                error "$message\nversion 3.1 or above required with $name module using Perl threads"
            }
            $interpreter eval "
                sub ${name}::yield(\$) {
                    my \$function = shift;
                    if (\$function ne 'updated') {
                        die(\"only 'updated' is supported as yield() argument at this time\\n\");
                    }
                    \$Tcl::parent->eval(\"::${namespace}::\$function\");                              # synchronize via thread event
                }
            "
        } else {
            $interpreter eval "tie($${name}::data{updates}, 'moodss::Updated', '${namespace}::updated');"           ;# track updates
        }
        set ($this,initialize) [$interpreter eval int(defined(&${name}::initialize))]                      ;# Tcl compatible boolean
        if {[info exists ${namespace}::data(switches)]} {
            array set argumentRequired [set ${namespace}::data(switches)]
        }
        if {$($this,initialize)} {                                                                    ;# create initialize procedure
            if {![info exists argumentRequired]} {
                puts stderr "in $name module, initialize subroutine requires switches to be defined"
                exit 1
            }
            proc ::${namespace}::initialize {arguments} "         ;# arguments are a list of option / value (eventually empty) pairs
                array set argumentRequired [list [array get argumentRequired]]
                set argument {}
                foreach {name value} \$arguments {
                    if {!\$argumentRequired(\$name)} {                                                ;# boolean switch special case
                        set value 1                                                ;# convert empty value to Perl compatible boolean
                    } else {
                        regsub -all {\\\\} \$value {\\\\\\\\} value                                           ;# escape back-slashes
                        regsub -all ' \$value {\\\\\\'} value                                         ;# and simple quote separators
                    }
                    if {\[string length \$argument\] > 0} {append argument ,}
                    append argument '\$name','\$value'            ;# built a list used to initialize a hash in initialize subroutine
                }
                $interpreter eval ${name}::initialize(\$argument)
            "
        }
        set ($this,terminate) [$interpreter eval int(defined(&${name}::terminate))]                        ;# Tcl compatible boolean
        if {$($this,terminate)} {                                                                      ;# create terminate procedure
            proc ::${namespace}::terminate {} "$interpreter eval ${name}::terminate()"
        }
        $interpreter eval "
            sub ${name}::flashMessage(\$;\$) {
                my (\$message, \$seconds) = @_;
                \$Tcl::parent->eval(\"modules::flashMessage $name $namespace [list \$message] \$seconds\");
            }
            sub ${name}::pushMessage(\$) {
                my \$message = shift;
                \$Tcl::parent->eval(\"modules::pushMessage $name $namespace [list \$message]\");
            }
            sub ${name}::popMessage() {\$Tcl::parent->eval('modules::popMessage');}
            sub ${name}::traceMessage(\$) {
                my \$message = shift;
                \$Tcl::parent->eval(\"modules::trace $name $namespace [list \$message]\");
            }
            sub ${name}::after(\$\$) {
                my \$milliseconds = shift;
                my \$script = shift;
                \$Tcl::parent->eval(\"after \$milliseconds [list $interpreter eval [list \$script]]\");
            }
        "
        set ($this,version) [$interpreter eval \$${name}::VERSION]
    }

    proc loadPython {this file} {
        set name $($this,name)                                                                          ;# also the Perl module name
        set namespace $($this,namespace)
        if {[catch {package require tclpython 3} message]} {                        ;# load Python library (see also in modules.tcl)
            error "$message\nis the tclpython package installed?"
        }
        set interpreter [python::interp new]                                                                               ;# create
        set ($this,interpreter) $interpreter                                               ;# the Python interpreter for this module
        $interpreter exec "import sys\nsys.path.insert(0, '.')"             ;# so that module can be imported from current directory
        $interpreter exec {from types import FunctionType}                       ;# to be able to find out whether a function exists
        $interpreter exec {import re}                                    ;# regular expressions are required by internal Python code
        $interpreter exec "import $name"                                                             ;# and import the Python module
        $interpreter exec $python::utilityFunctions
        $interpreter exec "import signal\nsignal.signal(2, signal.SIG_DFL)"      ;# allow keyboard interrupts to stop moodss (as ^C)
        # initialize static part of data:
        array set ::${namespace}::data [$interpreter eval formstring($name.form)]
if {$global::withGUI} {
        set message [mc {%s data update...}]
        proc ::${namespace}::update {} "                                                                  ;# create update procedure
            variable data

            lifoLabel::push $global::messenger \[format {$message} \$data(identifier)\]
            $interpreter exec $name.update()
            set updates \[$interpreter eval {$name.form\['updates'\]}]                                   ;# retrieve updates counter
            if {\$updates > \$data(updates)} {                                             ;# do nothing if counter did not increase
                array unset data {\[0-9\]*,\[0-9\]*}                             ;# first clear dynamic data (so rows can disappear)
                array set data \[$interpreter eval datastring($name.data)\]                                     ;# copy dynamic data
                set data(updates) \$updates                                                                  ;# copy updates counter
            }
            lifoLabel::pop $global::messenger
        "
} else {                                                                                                 ;# do not use GUI messenger
        proc ::${namespace}::update {} "
            variable data

            $interpreter exec $name.update()
            set updates \[$interpreter eval {$name.form\['updates'\]}]
            if {\$updates > \$data(updates)} {
                array unset data {\[0-9\]*,\[0-9\]*}
                array set data \[$interpreter eval datastring($name.data)\]
                set data(updates) \$updates
            }
        "
}
        $interpreter exec "try: result = (type($name.initialize) == FunctionType)\nexcept: result = 0"
        set ($this,initialize) [$interpreter eval result]
        if {[info exists ${namespace}::data(switches)]} {
            array set argumentRequired [set ${namespace}::data(switches)]
        }
        if {$($this,initialize)} {                                                                    ;# create initialize procedure
            if {![info exists argumentRequired]} {
                puts stderr "in $name module, initialize subroutine requires switches to be defined"
                exit 1
            }
            proc ::${namespace}::initialize {arguments} "         ;# arguments are a list of option / value (eventually empty) pairs
                array set argumentRequired [list [array get argumentRequired]]
                set argument {}
                foreach {name value} \$arguments {
                    if {!\$argumentRequired(\$name)} {                                                ;# boolean switch special case
                        set value 1                                                ;# convert empty value to Perl compatible boolean
                    } else {
                        regsub -all {\\\\} \$value {\\\\\\\\} value                                           ;# escape back-slashes
                        regsub -all ' \$value {\\\\\\'} value                                         ;# and simple quote separators
                    }
                    if {\[string length \$argument\] > 0} {append argument ,}
                    append argument '\$name':'\$value'      ;# built a list used to initialize a dictionary in initialize subroutine
                }
                $interpreter exec $name.initialize({\$argument})
            "
        }
        $interpreter exec "try: result = (type($name.terminate) == FunctionType)\nexcept: result = 0"
        set ($this,terminate) [$interpreter eval result]
        if {$($this,terminate)} {                                                                      ;# create terminate procedure
            proc ::${namespace}::terminate {} "$interpreter exec $name.terminate()"
        }
        set ($this,version) [$interpreter eval $name.__version__]
    }

}