#
#    Copyright (C) 2010 Alexandros Stergiakis <alsterg@gmail.com>
#
#    This program is free software: you can redistribute it and/or modify
#    it under the terms of the GNU Affero General Public License as
#    published by the Free Software Foundation, either version 3 of the
#    License, or (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU Affero General Public License for more details.
#
#    You should have received a copy of the GNU Affero General Public License
#    along with this program.  If not, see <http://www.gnu.org/licenses/>.
#

#//#
# MikroConf modules are regular Tcl packages, that are loaded using the newer "Tcl modules"
# mechanism. We create a wrapper of this mechanism here, because we need to keep track some
# extra information regarding MikroConf modules, like the exact dependency tree.
#
# @author Alexandros Stergiakis <alsterg@gmail.com>
#//#

namespace eval ::module {
namespace export provide require reset version loaded available loadall init resetall reloadall

variable Modules {} ;# In the order they are loaded.
variable Module2Ver

# Declare that a module is provided. A mere wrapper to "package provide".
#
# @param args Same as in "package provide".
proc provide {name {ver {}}} {
    variable Modules
    variable Module2Ver
    
    package provide $name {*}$ver
    lappend Modules $name
    set Module2Ver($name) $ver
}

# Load a required module, and its dependencies.
#
# Sytanx:
#       module require name ?version?
# <version> strings adhere to the syntax of the "package require" Tcl command.
#
# @depends On the syntax for 'package require' sub-command.
# @assume Any module is loaded on MikroConf start, so that it is possible to print messages to stdout.
#
# @param args Arguments according to the syntax specification above
# @return returns the version of the package (just loaded or already loaded)
# @error
proc require {name args} {
    variable Modules
    
    if {$name ni $Modules} {
        if {[catch {
            set ver [package require $name {*}$args]
            ::module::${name}::constructor
        } errMsg errStack]} {
            log::Alert -error -stack $errStack Emergency "Failed to load module \"$name\": " $errMsg
        }
        
        log::Debug "Module $name version $ver was loaded successfully"
    }
}

# Initialize a module's configuration state.
# All running configuration pertaining to this module will be lost.
#
# @param name Name of package
# @error
proc reset {name} {
    variable Modules
    
    if {$name ni $Modules} {
        log::Error -error "Cannot reset module ${name}; module is not loaded"
    }

    if {[catch {
        ::module::${name}::reset
    } errMsg errStack]} {
        log::Emergency -error -stack $errStack "Failed to reset module \"$name\": " $errMsg
    }
    
    log::Debug "Module $name resetted successfully"
}

# Initialize the configuration state of the whole system (all loaded modules).
#
# @error
proc resetall {} {
    variable Modules
    
    log::Info "Resetting all MikroConf modules: $Modules"
    
    # Need to reset starting from the leefs of the dependency tree.
    foreach name [lreverse $Modules] {
        reset $name
    }
}

# Reload all module code.
#
# @error
proc reloadall {} {
    variable Modules
    
    log::Info "Reloading all MikroConf modules: $Modules"
    
    # Need to reset starting from the root of the dependency tree.
    foreach name $Modules {
        ::module::${name}::destructor
        ::module::${name}::constructor
    }
}

# Return the version of a loaded module.
#
# @assume Requested module is loaded.
# @param mod Name of package
# @return Version string.
proc version {name} {
    variable Module2Ver
    return $Module2Ver($name)
}

# Return all loaded modules in order of first to last loaded.
#
# @return A list of loaded modules, or empty list if no module is loaded.
proc loaded {} {
    variable Modules
    return $Modules
}

# List all the modules that can be loaded and their versions.
#
# @assume All module files are in the same directory (no subdirectories): MODULES_DIR.
#
# @return A list of the form: filename1 modname1 modversion1 filename2 modname2 modversion2 ... \
The list is sorted according to filename.
proc available {} {
    Global MODULES_DIR
    set result [list]
    set RE {([[:alpha:]][:[:alnum:]]*)-([[:digit:]].*)\.tm}
    foreach mod [lsort [glob -nocomplain -directory $MODULES_DIR -types f *.tm]] {
        set mod [file tail $mod]
        if {[regexp $RE $mod filename modname modver]} {
            lappend result $filename $modname $modver
        }
    }
    return $result
}

# Load as many modules as possible from the available ones.
# Ignore already loaded, those loaded with different version, and load failures.
# In effect, try to load as many modules as possible.
proc loadall {} {
    Global SKIP_MODULES
    
    foreach {filename name version} [available] {
        if {$name ni $SKIP_MODULES && $name ni [loaded]} {
            catch { require $name } ;# errors are reported within proc require.
        }
    }
}

# Set-up Module loading.
proc init {} {
    Global MODULES_DIR
    
    # We use the newer Tcl Modules architecture to find MikroConf modules.
    # Tcl Extensions are still discoverable via the older mechanism.
    
    # Remove all current path entries from the search path
    foreach path [::tcl::tm::path list] {
        ::tcl::tm::path remove $path
    }
    
    # Add our module path entry
    ::tcl::tm::path add $MODULES_DIR
    
    # Note: "package require" does not respect the namespace hierarchy. The namespace of
    # the module will always be loaded relatively to ::, even if we use "namespace inscope".
    # Therefore we expect that modules declare their namespace within ::module
    namespace eval ::module {}
}

namespace ensemble create

} ;# End of Namespace

namespace eval ::module::api {
    namespace export ferror getall getpos getval puts exec bgexec ptyexec seval command OnError Catch

# Print an error message with an indication of the erroneous word
# and generate an error in the context of the caller.
#
# @assume cmdline exists on the context of the caller and it is a valid list.
#
# @param explanation Explanatory text of the error.
# @param index List index of the erroneous word. Can point after the list.
# @error
proc ferror {explanation index} {
    upvar cmdline cmdline
    upvar sid sid
    
    set prefix [lrange $cmdline 0 $index-1]
    set suffix [lrange $cmdline $index+1 end]
    if {$index >= [llength $cmdline]} {
        set word [ansi $sid -underline -- {     }] ;# because if out of bounds, it doesn't underline anything
    } else {
        set word [ansi $sid -underline -- [lindex $cmdline $index]]
    }
    # If $prefix or $suffix does not exist, then string trim will remove the unecessary space on the left/right of $word.
    return -code error [ansi $sid -color red -bold -- [string trim "Syntax error: $prefix $word $suffix"]]\n$explanation
}

# Find the position on the command line where the value for the argument name
# $argname appears. $index specifies (zero-based) which among possibly many
# arguments with same name be returned. Defaults to 0 (the first found).
# The caller should have a dict "arguments" and a variable "argstart" defined properly.
#
# @param argname The argument name whose possition we are looking for.
# @param index If multiple arguments with $argname name, return the $index one. (zero-based).
# @return The position in the command line the value for "argname" appears.
proc getpos {argname {index 0}} {
    upvar arguments arguments argstart argstart

    for {set i 0} {$i < [llength $arguments]} {incr i 2} {
        if {[lindex $arguments $i] eq $argname} {
            if {$index == 0} {
                return [expr {$argstart + 1 + $i / 2}]
            } else {
                incr index -1
            }
        }
    }
}

# Find in a dictionary named "arguments" on the context of the caller, the
# value for the key $argname within the dictionary. If the key is defined, its
# value is returned, otherwise, $default is returned.
#
# @param argname The argument name whose possition we are looking for.
# @param args If a single extra argument provided, then it is the default value for the key, \
which is used if the key is not present in the dict.
# @return The key value is key "argname" is present, otherwise $default.
# @error
proc getval {argname args} {
    upvar arguments arguments
    if {[dict exists $arguments $argname]} {
        return [dict get $arguments $argname]
    } else {
        if {[lempty $args]} {
            error "default value not provided"
        } else {
            return [lindex $args 0]
        }
    }
}

# From a list named "arguments" in the context of the caller,
# find and return in the order they appear, all the values of all the
# instances of key $key. Remove duplicates; keep only the first instance.
#
# @param key The name of the key, which values will be looked for.
# @return The values for all the instances of $key, returned in the order found in $lst.
proc getall {argname} {
    upvar arguments arguments
    set result [list]
    foreach {var val} $arguments {
        if {$var eq $argname && $val ni $result} {
            lappend result $val
        }
    }
    return $result
}

proc puts {args} {
    upvar out out
    
    switch -exact -- [llength $args] {
        0 { ::puts $out "" }
        1 { ::puts $out [lindex $args 0] }
        2 {
            if {[lindex $args 0] eq "-nonewline"} { ;# nonewline txt
                ::puts -nonewline $out [lindex $args 1]
            } else { ;# chan txt
                ::puts {*}$args
            }
        }
        3 { ;# nonewline chan txt
            ::puts {*}$args
        }
        default { error "syntax error in puts" }
    }
}

# Wrapper for exec.
proc exec {args} {
    log::Debug "Running external program (exec) : $args"
    ::exec {*}$args
}

# Wrapper for bgexec.
# Since bgexec is executed in Master thread, which executes one command handler till
# termination before serving another one, this results to only one bgexec session
# be run at any time from Master.
proc bgexec {args} {
    global bgexec_status
    log::Debug "Running external program (bgexec) : $args"
    ::bgexec ::bgexec_status {*}$args ;# Returns command output
}

# Wrapper for ptyexec.
# One ptyexec session can run for each Session at any time.
proc ptyexec {args} {
    upvar sid sid
    log::Debug "Running external program (ptyexec) : $args"
    Thread::bgsend $sid [list ::pty::ptyexec {*}$args]
}

# Evaluate a script like "eval" but on a Session interpreter. By doing so the script has
# access to constructs pressent only in a specific Session interpreter. The session Id
# is found by looking for a variable named 'sid' on the context of the caller.
#
# The command returns when the script completes evaluation.
# Meanwhile the Master's loop is not blocked.
#
# @param args Same arguments as "eval".
# @returns Same as "eval".
proc seval {script} {
    upvar sid sid
    Thread::bgsend $sid $script
}

# Convenience procedure that catch and logs errors.
#
# @param level Either "Ignore" or a syslog severity level: Debug Info Notice Warning Error Critical Alert Emergency. If "Ignore" then errors will not be logged at all.
# @param name Optional. The name of the proc to apply OnError on. This name is resolved according to namespace rules.
proc OnError {level {name {}}} {
    set level [::textutil::string::cap $level]
    
    if {$level ni [list Ignore Debug Info Notice Warning Error Critical Alert Emergency]} {
        error "Unrecognized level: $level"
    }

    if {[lempty $name]} {
        set name [lindex [info level -1] 0]
        
        # If no namespace specified, we will use the caller's one
        if {[namespace tail $name] eq $name} {
            set ns [uplevel 1 namespace current]
            set name "${ns}::${name}"
        }
    }
    
    trace remove execution $name leave [lindex [trace info execution $name] 0 1]
    
    # We use uplevel because $name can be relative, and need to be resolved in caller's namespace.
    if {$level ne "Ignore"} {
        trace add execution $name leave [list ::module::api::OnError_leave_trace $level]
    }
}

proc OnError_leave_trace {args} {
    lassign $args level command code result
    set command [lindex $command 0]
    
    if {$code ne "0"} {
        global errorInfo
        log::$level -stack $errorInfo "handler \"$command\" : $result"
        #XXX Also include: "module \"$modname\", sid \"$sid\", $code, $::errorCode
    }
}

# 'proc' wrapper for command handlers, to catch and properly log erros.
# Unclassified errors are reported as "Error" severity.
proc command {name arguments body} {
    # If no namespace specified, we will use the caller's one
    if {[namespace tail $name] eq $name} {
        set ns [uplevel 1 namespace current]
        set name "${ns}::${name}"
    }

    proc $name $arguments $body
   
    # By default errors will not be logged.
    uplevel OnError Error $name
}

# Convenience procedure that catch and logs errors
#
# @param level Syslog level: Debug Info Notice Warning Error Critical Alert Emergency.
# @param body The body of code to evaluate on calling scope.
# @param msg Additional error message to display before that generated by 'error'.
proc Catch {level body {msg {}}} {
    if {$level ni [list Debug Info Notice Warning Error Critical Alert Emergency]} {
        error "Unrecognized level: $level"
    }
    
    if {[catch {
        uplevel 1 $body
    } errMsg errStack]} {
        if {[lempty $msg]} {
            log::$level -error -stack $errStack $errMsg
        } else {
            log::$level -error -stack $errStack "$msg: $errMsg"
        }
    }
}

} ;# End of Namespace