# copyright (C) 1997-2001 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

set rcsId {$Id: module.tcl,v 2.22 2001/02/28 21:00:47 jfontain Exp $}


class module {

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

    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)                        ### when multiple interpreters can be used ###
                }
                default {
                    interp delete $($this,interpreter)
                }
            }
        }
        if {[info exists ($this,namespace)]} {
            namespace delete ::$($this,namespace)
        }
        deleteIndex $this
    }

    proc newIndex {name} {              ;# find a new index for the module, by eventually finding a hole in that module indices list
        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 index $($this,index)
        if {$index==0} {                                                                               ;# first instance of a module
            set namespace $name                                                                          ;# use original module name
        } else {
            set namespace ${name}<$index>                                          ;# this is another instance of an existing module
        }

        set directory [pwd]
        cd $::packageDirectory($name)                                        ;# switch to module directory only during loading phase

        set interpreter [interp create]                                                ;# use a separate interpreter for each module
        $interpreter eval {                    ;# since Tk is not loaded in module interpreter, provide a background error procedure
            proc bgerror {error} {
                puts stderr $::errorInfo
                exit 1
            }
        }
        $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
        $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)
        namespace eval ::$namespace [subst -nocommands {proc update {args} {$interpreter eval ::${name}::update \$args}}]
        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
        # 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
    }

    proc updated {this args} {                             ;# Tcl module data was just updated. ignore already known trace arguments
        set namespace $($this,namespace)
        lifoLabel::push $global::messenger "$namespace data update..."
        update idletasks
        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) [$($this,interpreter) eval "set ::$($this,name)::data(updates)"]   ;# copy updates counter
        lifoLabel::pop $global::messenger
    }

    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 "print 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
        set extension [file extension $file]
        switch $extension {
            .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 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::utilityFunctions
        # initialize static part of data:
        array set ::${namespace}::data [$interpreter eval hash_string(%${name}::data)]
        proc ::${namespace}::update {} "                                                                  ;# create update procedure
            variable data
            lifoLabel::push $global::messenger {$namespace data update...}
            $interpreter eval ${name}::update()
            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) \[$interpreter eval \\$${name}::data{updates}\]                                ;# copy updates counter
            lifoLabel::pop $global::messenger
        "
        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()"
        }
        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 1.1} message]} {                                                ;# load Python library
            error "$message\nis the tclpython package installed?"
        }
        set interpreter [python::interp new]                                                                               ;# create
        set ($this,interpreter) $interpreter                                               ;# the Python interpreter for this module

        $interpreter eval "import sys\nsys.path.insert(0, '.')"             ;# so that module can be imported from current directory
        $interpreter eval {from types import FunctionType}                       ;# to be able to find out whether a function exists
        $interpreter eval {import re}                                    ;# regular expressions are required by internal Python code
        $interpreter eval "import $name"                                                             ;# and import the Python module
        $interpreter eval $python::utilityFunctions
        # initialize static part of data:
        array set ::${namespace}::data [$interpreter eval "print formstring($name.form)"]
        proc ::${namespace}::update {} "                                                                  ;# create update procedure
            variable data
            lifoLabel::push $global::messenger {$namespace data update...}
            $interpreter eval $name.update()
            array unset data {\[0-9\]*,\[0-9\]*}                                 ;# first clear dynamic data (so rows can disappear)
            array set data \[$interpreter eval {print datastring($name.data)}\]                                 ;# copy dynamic data
            set data(updates) \[$interpreter eval {print $name.form\['updates'\]}]                           ;# copy updates counter
            lifoLabel::pop $global::messenger
        "
        set ($this,initialize) [$interpreter eval "try: print type($name.initialize) == FunctionType\nexcept: print 0"]
        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 eval $name.initialize({\$argument})
            "
        }
        set ($this,terminate) [$interpreter eval "try: print type($name.terminate) == FunctionType\nexcept: print 0"]
        if {$($this,terminate)} {                                                                      ;# create terminate procedure
            proc ::${namespace}::terminate {} "$interpreter eval $name.terminate()"
        }
        set ($this,version) [$interpreter eval "print $name.__version__"]
    }

}
