# # Copyright (C) 2010 Alexandros Stergiakis # # 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 . # #//# # 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 #//# 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? # 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