Overview | Index by: file name |
procedure name |
procedure call |
annotation
sysconf.tcl
(annotations | original source)
#
# 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/>.
#
#//#
# Procedures for handling MikroConf command specifications.
#
# This file encapsulates procedures and data structures for the following:
# * registering new commands/attributes/confmodes/authmodes
# * finding information about registered commands/attributes
# * internal representation of the command line hierarchy and confmodes/authmodes.
# * running system configuration data structure
# * retrieve running/startup configuration
# * save running config, load startup config
#
# @assume Dependency on the structure of the DOM tree.
#//#
package require tdom 0.8.2
package require struct::set 2.2.1
package require struct::list 1.6.1
package require grammar::fa 0.3
package require grammar::fa::op 0.4
namespace eval sysconf {
namespace import ::session::close_session ::session::create_bg_session ::module::api::ferror
namespace export loadspecs remove print match authmode confmode execute runningConf startupConf loadConf saveConf inuse
# The DOM data structure that stores the command specifications.
dom createDocumentNode sysconf
#################
# Load/Remove/Print Specifications
#################
# Load command specifications from an XML file into the internal data representation.
# In case of parse or other error, we catch them in here, and log it.
#
# @param filepath The source file itself.
# @error
proc loadspecs {filepath} {
Global BASE_DIR
log::Debug "Loading command specs from $filepath"
variable sysconf
variable parser [expat \
-namespace \
-final 1 \
-baseurl [tDOM::baseURL $BASE_DIR/] \
-externalentitycommand tDOM::extRefHandler \
-paramentityparsing always \
-ignorewhitecdata 1]
#package require tnc 0.3.0
#tnc $parser enable ;# for DTD validation
tdom $parser enable
if {[catch {
$parser parsefile $filepath
} errMsg errStack]} {
tdom $parser remove
$parser free
log::Critical -error -stack $errStack "Failed to parse command specifications $filepath: " $errMsg
}
set doc [tdom $parser getdoc]
$doc documentElement root
$sysconf appendChild $root
$sysconf deleteXPathCache
$doc delete ;# Also deletes any node command
}
# Check if a module is in use by some session (user or background or remote), or not.
#
# @return '1' if in use, '0' otherwise.
proc inuse {name} {
variable sysconf
set nodes [$sysconf selectNodes [format {/module[@name='%s']} $name]]
# Check first to see if a session is currently on an Authmode or Confmode
# owned by this module. If so then we cannot unload it.
foreach node $nodes {
foreach sid [concat [::session::bg_sessions] [::session::user_sessions]] {
Session $sid CONFMODE AUTHMODE
if {[$node selectNodes [format {boolean(confmode[@name='%s'])} $CONFMODE]] ||
[$node selectNodes [format {boolean(authmode[@name='%s'])} $AUTHMODE]]} {
return 1
}
}
}
return 0
}
# Remove all command specifications associated with a module name.
#
# @param name The module name.
proc remove {name} {
variable sysconf
log::Debug "Unloading command specs for module: $name"
set nodes [$sysconf selectNodes [format {/module[@name='%s']} $name]]
foreach node $nodes {
$node delete
}
}
# Return the running configuration as XML, or a subparts of it, depetermined by a XPath query.
#
# @param arguments The arguments accepted by the 'asXML' sub-command of domDoc/domNode.
# @param query XPath query to determine the nodes whose subtrees will be concatanated and printed.
# @return An XML string.
proc print {{arguments {}} {query {}}} {
variable sysconf
if {$query eq {}} {
return [$sysconf asXML {*}$arguments]
} else {
set ret {}
set nodes [$sysconf selectNodes $query]
foreach node $nodes {
append ret [$node asXML {*}$arguments] "\n"
}
return $ret
}
}
#################
# Command/Argument matching
#################
# It looks for MikroConf commands and arguments that can be placed
# in the word that the cursor is pointing at, and have as prefix the existing
# word part.
#
# Matching of commands is based solely on their names.
#
# An argument can be of type:
# 1. exact : One possible value is permitted, and this is the name of the argument
# as found in the name=".." parameter of the argument tag. This argument type
# can be abbreviated.
# 2. list : A fixed finite list of alternatives that is defined in the XML specifications
# for the command. This argument type can be abbreviated.
# 3. dlist : A dynamic finite list of alternatives that is automatically generated on
# runtime. This argument type can be abbreviated.
# 4. any : Any value fits in this category. The validity is determined by the command
# handler on execution. This argument type cannot be abbreviated. It can coexist
# with the previous types, in which case if there is no exact match with any of the
# exact/list/dlist alternatives, it is caught by this one, however if there is an exact
# match, it takes precedence. It is not considered by TAB expansion, which only
# considers types 1-3. In-line help (?) on the other hand always lists it, along with
# any matching types of 1-3.
# 5. fixed : The value of this element must hold a serialized Tcl array mapping
# names to help messages. Command expansion (TAB) will consider the
# names as valid alternatives, whereas in-line help (with ?) will display the
# names as alternatives along with the corresponding help messages. The
# "fixed" type is useful for brevity purposes, and performance. Instead of
# having a complex automaton with multiple "exact" element types, you
# only have one element and only one state in the automaton.
#
# All words except the last one are expected to be unambiguous, meaning that
# (after aplying proper precedence rules) match to exactly one possible entity
# (argument or command).
#
# To resolve collisions between literals coming from "list" "dlist" "fixed" or "exact" types
# with the "any" type that accepts any string, we give precedence to the former types, if and
# only if there is an exact match. For example "running-config" will match the "exact" type
# with name "running-config", but "running" will match the "any" type if it is supported in the
# argument position being processed.
#
# For the last argument the procedure returns information based on a list of provided flags.
#
# Supported flags:
# -no : Indicates whether the command is a negation (starts with no) or not.
# -type : For commands it returns the string "command" and for arguments the string "argument".
# -pos : The position in the command list when the last word that is interpreted as command resides.
# After this point, all remaining words are arguments.
# -nodes : For commands it returns the matching nodes, INCLUDING structural paths.
# For arguments, it returns the single command node the arguments belongs to.
# -count : For commands it returns the number of matching commands, EXCLUDING structural paths.
# For arguments, it returns the number of matching arguments, of all types; it does not consider
# type precedence (e.g. "exact" has higher precedence then "any" type).
# -names : Returns matching names (command & argument names). For commands structural nodes
# are not considered.
# -values : Returns matching values (command names & argument values).
# This is used by Tab completion.
# -types : The types of the arguments that are valid for the specified argument position.
# -help : Return a list of tuples for each matching argument/command of the form: {Name Description}.
# For commands structural nodes are not considered. This is used by question mark help.
# -final : 1 indicates that the command can be executed as it is.
# 0 that it is not specific enough or complete yet.
# -vector : Return a list of tuples of the form: <argname value>, one for each argument in cmdlist.
# <argname> is the unique name of the argument and <value> is the value provided in the cmdlist
# by the user.
#
# Note: "no" is counted in -count, -help, -values, -names, but not in -vector.
#
# The command supports returning information for multiple flags with a single call. This is
# for performance reasons. It is more efficient to run the algorithm once and retrieve as much
# information as possible, than running it multiple times for different types of info.
# When multiple flags are specified then the result is a list of lists. One sub-list for each flag in the
# order they are provided (from left to right).
#
# Note: Any backslashes in the input command string are substituted (removed) first before processing it.
#
# @param sid Session Id.
# @param options A combination of: "-count", "-names", "-values", "-help", "-final"
# @param cmdline The command line string to operate on.
# @param wordIndex The word index the cursor is pointing at in the cmdline list.
# @return Returns the matched names/values for each provided flag in order.
# @error
proc match {sid options cmdline wordIndex} {
variable sysconf
Session $sid CONFMODE
set AUTHPRIV [authmode $sid privilege]
# Substitute backslashes. This removes the end-of-line escapes.
set cmdline [subst -nocommands -novariables $cmdline]
# Just to make sure that backslash substitutions didn't result in a non-command.
# Note: "puts {a}n" is a complete command (info complete), but NOT a list (string is list).
if {! [info complete $cmdline] || ! [string is list $cmdline]} { ;# the empty string is a list
error "command string is not a valid command"
}
# Can happen if TAB/? is pressed on a "\"
#if {[lindex $cmdline $wordIndex] eq "\\"} { return }
# The configuration modes within which we are searching for a match
# 'pool' always holds the matching nodes up to the current point of processing.
set pool [$sysconf selectNodes [format {/module/tree[@conf='%s'][@priv<=%s]} $CONFMODE $AUTHPRIV]]
if {[lempty $pool]} { ;# No commands for current Authmode/Confmode combination.
error "no commands within scope"
}
# Skip leading "\"
#if {$i eq "\\"} { incr i }
# Indicates that the command is a negation.
set NO 0
# Match against command names first
for {set i 0} {$i <= $wordIndex} {incr i} {
# Note: wordIndex can point after the end of the cmdline (wordIndex == [llength $cmdline] + 1),
# see pos2index for details. However, there is no problem with the following algorithm because
# [lindex {a b} 3] == {}, and, starts-with(anything, {}), matches.
set prefix [lindex $cmdline $i]
# Check if it is a negative command. It must start with a "no" word.
# Note: "no" cannot be abbreviated.
# Note: if $wordIndex == $i it means we refer to "no" and looking for alternatives there.
if {$i == 0 && $prefix eq "no" && $wordIndex > $i} {
set NO 1
continue
}
# Skip "\"
#if {$prefix eq "\\"} { continue }
# The node pool for the next iteration.
set all [list]
foreach n $pool {
if {$NO} {
# Select all commands that have the right prefix & permission & (for negations) support "no"
# With priv: lappend all {*}[$n selectNodes [format {command[starts-with(@name, '%s')][@priv<=%s]/no/..} $prefix $AUTHPRIV]]
lappend all {*}[$n selectNodes [format {command[starts-with(@name, '%s')]/no/..} $prefix]]
# Select all paths that have the right prefix and lead to at least one command that has the right permission and (for negations) supports "no"
set all2 [$n selectNodes [format {path[starts-with(@name, '%s')]} $prefix]]
foreach n2 $all2 {
if {[$n2 selectNodes {boolean(.//command/no)}]} {
lappend all $n2
}
}
# With priv attribute on commands:
#set all2 [$n selectNodes [format {path[starts-with(@name, '%s')]} $prefix]]
#foreach n2 $all2 {
# if {[$n2 selectNodes [format {boolean(.//command[@priv<=%s]/no)} $AUTHPRIV]]} {
# lappend all $n2
# }
#}
} else {
# Select all commands that have the right prefix & permission
# With priv: lappend all {*}[$n selectNodes [format {command[starts-with(@name, '%s')][@priv<=%s]} $prefix $AUTHPRIV]]
lappend all {*}[$n selectNodes [format {command[starts-with(@name, '%s')]} $prefix]]
# Select all paths that have the right prefix and lead to at least one command that has the right permission
lappend all {*}[$n selectNodes [format {path[starts-with(@name, '%s')]} $prefix]]
# With priv attribute on commands:
#set nodes [$n selectNodes [format {path[starts-with(@name, '%s')]} $prefix]]
#foreach n2 $nodes {
# if {[$n2 selectNodes [format {boolean(.//command[@priv<=%s])} $AUTHPRIV]]} {
# lappend all $n2
# }
#}
}
}
catch { unset nodes }
# Filter out those paths that have no description, meaning that they don't _define_ a path, but rather have a structural role.
# Note: We require that when a structural path matches, the original also matches. This in practice is guaranteed with
# module dependencies: By having the modules that use a path to depend on the module that defines it.
# @assume Inter-module dependencies expressed in the form of 'module require' should guarantee that when a
# structural path exists, its original also exists (the owner).
set unique [list]
foreach n $all {
if {[$n selectNodes {boolean(desc)}] || [$n selectNodes {boolean(no/desc)}]} {
lappend unique $n
}
}
# Count unique matches
set count [llength $unique]
# Check if we reached the end of the string without encountering an argument.
if {$i == $wordIndex} {
set Result [list]
foreach option $options {
set result [list]
switch -exact -- $option {
"-no" {
set result $NO
}
"-type" {
set result "command"
}
"-pos" {
set result {} ;# We haven't encountered the last argument yet.
}
"-nodes" {
# Note: We match structural paths.
set result $all
}
"-count" {
# Note: We don't match structural paths.
set result [llength $unique]
if {$i == 0 && [string match "${prefix}*" "no"]} {
foreach n $pool {
# With priv:
#if {[$n selectNodes [format {boolean(.//command[@priv<=%s]/no)} $AUTHPRIV]]}
if {[$n selectNodes {boolean(.//command/no)}]} {
incr result
break
}
}
}
}
"-names" -
"-values" {
# Note: We don't match structural paths.
foreach n $unique {
lappend result [$n selectNodes {string(@name)}]
}
# Append "no" if there is an accessible command that supports negation.
if {$i == 0 && [string match "${prefix}*" "no"]} {
foreach n $pool {
# With priv:
#if {[$n selectNodes [format {boolean(.//command[@priv<=%s]/no)} $AUTHPRIV]]}
if {[$n selectNodes {boolean(.//command/no)}]} {
lappend result "no"
break
}
}
}
set result [lsort $result]
}
"-help" {
# Note: We don't match structural paths.
foreach n $unique {
if {$NO && [$n selectNodes {boolean(no/desc)}]} { ;# If it doesn't have no/desc, use desc instead.
lappend result [list [$n getAttribute name] [$n selectNodes {string(no/desc/text())}]]
} else {
lappend result [list [$n getAttribute name] [$n selectNodes {string(desc/text())}]]
}
}
# Append "no" if there is an accessible command that supports negation.
if {$i == 0 && [string match "${prefix}*" "no"]} {
foreach n $pool {
# With priv:
#if {[$n selectNodes [format {boolean(.//command[@priv<=%s]/no)} $AUTHPRIV]]}
if {[$n selectNodes {boolean(.//command/no)}]} {
lappend result [list no {Negate a command; cancel its effect; or restore default behavior}]
break
}
}
}
# Sort.
set result [lsort -index 0 $result]
}
"-vector" {
# We haven't reached arguments, so no vector.
}
"-types" {
# We haven't reached arguments, so no types.
}
"-final" {
# Special Case:
# We pressed ? on an empty word, and there is only one option for this word available
# which is also final. Therefore without taking $prefix into consideration, ENTER will
# be displayed although the user hasn't entered anything in this word.
set result [expr {! [lempty $prefix] && [isCmdFinal $NO $unique]}]
}
default {
log::Error -error "Unsupported sub-command"
}
} ;# switch
if {[llength $options] > 1} {
lappend Result $result
} else {
set Result $result
}
} ;# foreach
return $Result
}
if {$count == 0} {
ferror "unknown command at the indicated position" $i
} elseif {$count > 1} {
# Retrive node names
set names [list]
foreach n $unique {
lappend names [$n getAttribute name]
}
ferror "ambiguous command at the indicated position; ambiguitiy between:\n $names" $i
} else { ;# == 1
if {[$unique nodeName] eq "command"} {
# Next word will be an argument
set pool $unique
set lastcmd_pos $i
incr i ;# since we break, 'i' is not increased by 'for' to point to next word, as it would otherwise.
break
} else {
set pool $all
}
}
} ;# match next word, which is a command or path
catch { unset all unique count names }
# To reach here it means that we point to an argument.
# The next word in the cmdline is an argument (pointed by $i now), followed by (possibly) more arguments.
# These variables have value from before: i, wordIndex, pool, NO, options, cmdline, lastcmd_pos
# Case: Command does not support arguments, but an argument is supplied.
if {(! $NO && ! [$pool selectNodes {boolean(syntax)}]) || \
($NO && ! [$pool selectNodes {boolean(no/syntax)}])} {
if {$i == $wordIndex} { ;# Last word.
# Special Case:
# A ? is pressed on an empty word after a final command.
# Since we reach here, it means that the previous word is a command.
# Thus the ? is refering to its first argument, but the command doesn't
# support arguments. Enter is possible at this point, because no
# argument is provided yet, and no argument is required.
if {"-final" in $options && [lempty [lindex $cmdline $i]] && [isCmdFinal $NO $pool]} {
set res {}
foreach opt $options {
switch -exact -- $opt {
"-final" { lappend res 1 }
"-pos" { lappend res [expr {[llength $cmdline] - 1}] }
"-count" { lappend res 0 }
"-no" { lappend res $NO }
"-type" { lappend res "command" }
default { lappend res {} }
}
}
return $res
}
return ;# signifies unnecessary argument.
} else { ;# There are more words.
ferror "unnecessary argument at indicated position" $i
}
}
compute_fa fa $NO $pool
set startstates [fa startstates]
set finalstates [fa finalstates]
set state $startstates ;# A deterministic automaton has always only one start state.
# -1 Indicates that previous word was a command.
# 1 Indicates that previous word was an argument and it was final.
# 0 Indicates that previous word was an argument and it was NOT final.
set prevFinal -1
# Now match arguments
for {} {$i <= $wordIndex} {incr i} {
set prefix [lindex $cmdline $i]
# Skip "\"
#if {$prefix eq "\\"} { continue }
# Validity check: Only one argument of type "any" is allowed.
set alternatives [fa symbols@ $state]
set any_type_no 0
foreach a $alternatives {
if {$NO && [$pool selectNodes [format {boolean(no/argument[@name='%s']/type[@name='any'])} $a]]} { ;# give priority to arguments under <no>
incr any_type_no [$pool selectNodes [format {boolean(no/argument[@name='%s']/type[@name='any'])} $a]]
} else {
incr any_type_no [$pool selectNodes [format {boolean(argument[@name='%s']/type[@name='any'])} $a]]
}
}
if {$any_type_no > 1} {
fa destroy
ferror "inherently ambiguous argument" $i
}
unset any_type_no
set argList [list] ;# {type name values} , ....
array set fixedList {} ;# name => value of type "fixed", which is actually an array of value => help
foreach name $alternatives {
if {$NO && [$pool selectNodes [format {boolean(no/argument[@name='%s'])} $name]]} { ;# give priority to arguments under <no>
set type [$pool selectNodes [format {string(no/argument[@name='%s']/type/@name)} $name]]
set value [$pool selectNodes [format {string(no/argument[@name='%s']/type/text())} $name]]
} else {
set type [$pool selectNodes [format {string(argument[@name='%s']/type/@name)} $name]]
set value [$pool selectNodes [format {string(argument[@name='%s']/type/text())} $name]]
}
switch -exact -- $type {
"exact" {
if {$prefix eq $name} {
lappend argList [list "match" $name $name]
} elseif {[string match ${prefix}* $name]} {
lappend argList [list "exact" $name $name]
}
}
"list" {
set matches [list]
foreach v $value {
if {$prefix eq $v} {
lappend argList [list "match" $name $v]
} elseif {[string match ${prefix}* $v]} {
lappend matches $v
}
}
if {! [lempty $matches]} {
lappend argList [list "list" $name $matches]
}
unset matches
}
"dlist" {
set modname [$pool selectNodes {string(ancestor-or-self::module/@name)}]
if {[catch {
# Evaluate dlist handler in its module's namespace.
namespace inscope ::module::$modname {*}$value $sid
} result errStack]} {
fa destroy
log::Alert -error -stack $errStack "Failed to retrieve dynamic list for argument \"$name\" in command \"$cmdline\" :" $result
}
unset modname
set matches [list]
foreach v $result {
if {$prefix eq $v} {
lappend argList [list "match" $name $v]
} elseif {[string match ${prefix}* $v]} {
lappend matches $v
}
}
lappend argList [list "dlist" $name $matches]
unset matches
}
"fixed" {
array set arr $value
foreach n [array names arr] {
if {$prefix eq $n} {
lappend argList [list "match" $name $n]
unset arr($n)
} elseif {! [string match ${prefix}* $n]} {
unset arr($n)
}
}
if {! [lempty [array names arr]]} {
lappend argList [list "fixed" $name [array names arr]]
set fixedList($name) [array get arr]
}
unset arr
}
"any" {
lappend argList [list "any" $name {}]
}
default {
fa destroy
log::Alert -error "unknown argument type \"$type\""
}
} ;# switch
}
catch { unset type name value alternatives }
set count [llength $argList]
lassign {} types names values
for {set n 0} {$n < $count} {incr n} {
lappend types [lindex $argList $n 0]
lappend names [lindex $argList $n 1]
lappend values {*}[lindex $argList $n 2] ;# {*} because it can be empty, and we don't want empty lists.
}
# Break if we reached the last word.
# The reason we have this here, is because we want to perform the
# previous computations also when we process the last word.
if {$i == $wordIndex} {
break
}
# We save this information because in order to determine if an argument position
# is final, we need it to know if the previous argument position was final.
# For example when we press ? on an empty last word on the command line, and the
# previous argument was final.
set prevFinal [isArgFinal $NO $pool $argList $prefix $count $types $values $names $startstates $finalstates $state $prevFinal]
if {$count == 0} {
fa destroy
ferror "erroneous argument at the indicated position" $i
} elseif {$count > 1} {
set matches [llength [lsearch -exact -all $types "match"]]
# Many matches should not happen.
if {$matches > 1} {
ferror "inherently ambiguous argument" $i
# Exact match takes precedence.
} elseif {$matches == 1} {
set name [lindex $names [lsearch -exact $types "match"]]
lappend vector $name $prefix
set state [fa next $state $name]
unset name
# Otherwise "any" catches all.
} elseif {"any" in $types} {
# We accept it since it matches on the "any" type.
set name [lindex $names [lsearch -exact $types "any"]] ;# We know that is in the same list possition.
lappend vector $name $prefix ;# store the actual value entered on the command line.
set state [fa next $state $name]
unset name
# Without any and exact match, it's an error.
} else {
fa destroy
ferror "ambiguous argument at the indicated position; ambiguitiy between:\n $names" $i
}
} else { ;# == 1
if {$types eq "any"} {
lappend vector $names $prefix
} else {
lappend vector $names $values
}
set state [fa next $state $names]
}
}
unset i
fa destroy ;# For good.
# Now process the last argument. Since $wordIndex can point after $cmdline, this last argument
# can be non-existing.
# These variables have value from before:
# pool, wordIndex, state, names, types, values, count, prevFinal, startstates, finalstates, vector
set Result [list]
foreach option $options {
set result [list]
switch -exact -- $option {
"-no" {
set result $NO
}
"-type" {
set result "argument"
}
"-types" {
set result $types
}
"-pos" {
set result $lastcmd_pos
}
"-nodes" {
set result $pool
}
"-count" {
# We count all types. This cannot be used as to determine if a command is complete.
# Use -final for this.
set result $count
}
"-names" {
set result $names
}
"-values" {
# The "any" type cannot be returned in any meaningful form.
set result [lsort $values]
}
"-help" {
foreach n $names {
if {[info exists fixedList($n)]} {
foreach {n2 desc} $fixedList($n) {
lappend result [list $n2 $desc]
}
} else {
if {$NO && [$pool selectNodes [format {boolean(no/argument[@name='%s']/desc)} $n]]} {
set desc [$pool selectNodes [format {string(no/argument[@name='%s']/desc/text())} $n]]
} else {
if {$NO && [$pool selectNodes [format {boolean(argument[@name='%s']/nodesc)} $n]]} { ;# If it doesn't have nodesc, use desc instead.
set desc [$pool selectNodes [format {string(argument[@name='%s']/nodesc/text())} $n]]
} else {
set desc [$pool selectNodes [format {string(argument[@name='%s']/desc/text())} $n]]
}
}
lappend result [list $n $desc]
}
}
set result [lsort -index 0 $result]
}
"-vector" {
if {[llength $values] == 1} { ;# exact match
# Find the name whose one of its values is $values.
for {set t 0} {$t < $count} {incr t} {
if {$values in [lindex $argList $t 2]} {
lappend vector [lindex $argList $t 1] $values
break
}
}
} elseif {"any" in $types} {
set n [lindex [lsearch -exact -inline -index 0 $argList "any"] 1] ;# Find the name that has type "any".
lappend vector $n $prefix ;# store the actual value entered on the command line.
} else {
# To mark that it is not determined yet, we add an empty list along with the provided value.
lappend vector {} $prefix
}
set result $vector
}
"-final" {
set result [isArgFinal $NO $pool $argList $prefix $count $types $values $names $startstates $finalstates $state $prevFinal]
}
default {
log::Error -error "Unsupported sub-command"
}
} ;# switch
if {[llength $options] > 1} {
lappend Result $result
} else {
set Result $result
}
} ;# foreach
return $Result
}
# When the cursor is placed on a path or command, find whether the command line
# up and including the word where the cursor is placed, can be executed as it is.
#
# @param NO Boolean. Whether we have a negation command or not.
# @param node The command node in the DOM tree.
# @return '1' if command is final, '0' otherwise.
proc isCmdFinal {NO node} {
# In summary:
# llength $node == 1 && node is command && ( without syntax || fa start == fa final)
if {[llength $node] == 1 && [$node nodeName] eq "command"} {
if {$NO} {
set no {no/}
} else {
set no {}
}
if {! [$node selectNodes [format {boolean(%ssyntax)} $no]]} {
return 1
}
# else
compute_fa fa1 $NO $node
if {[fa1 startstates] in [fa1 finalstates]} {
fa1 destroy
return 1
}
fa1 destroy
}
return 0
}
# When the cursor is placed on an argument, find whether the command line
# up and including the word where the cursor is placed, can be executed as it is.
#
# @param NO Boolean. Whether we have a negation command or not.
# @param node The node of the command the argument belongs to.
# @param argList List of arguments that match with the prefix: {type name values} ....
# @param prefix The prefix of the word the cursor is placed.
# @param count The number of matching arguments (or valid arguments).
# @param types The types of all valid arguments concatenated.
# @param values The matching values of all valid arguments concatenated.
# @param names The names of all valid arguments concatenated.
# @param startstate The name of the start state of the automaton.
# @param finalstates The names of final states of the automaton.
# @param curstate The name of the current state.
# @param prevFinal Whether the previous word was a command (-1), a final state (1) or else (0).
# @return '1' if argument is final, '0' otherwise.
proc isArgFinal {NO node argList prefix count types values names startstate finalstates curstate prevFinal} {
# Algorithm:
# An argument is final in the following cases:
# 1. prefix eq "" && previous word is a command && startstate in finalstates
# 2. prefix eq "" && previous word is an argument && previous argument is final
# 3. prefix ne "" && $values == 1 && (state after name($values)) in finalstates
# 4. prefix ne "" && "any" in $types && $values != 1 && (state after name(any)) in finalstates
# Anything else results in a non-final argument.
# Case 1 & 2.
if {[lempty $prefix]} {
# Case 1.
if {$prevFinal == -1 && $startstate in $finalstates} {
return 1
}
# Case 2.
if {$prevFinal == 1} {
return 1
}
# Case 3 & 4.
} else {
# Case 3.
if {[llength $values] == 1} {
# Find the name whose one of its values is $values.
for {set t 0} {$t < $count} {incr t} {
if {$values in [lindex $argList $t 2]} {
set name [lindex $argList $t 1]
if {[nextState $NO $node $curstate $name] in $finalstates} {
return 1
}
break
}
}
}
# Case 4.
if {"any" in $types && [llength $values] != 1} {
# Find the name that has type "any".
set name [lindex [lsearch -exact -inline -index 0 $argList "any"] 1]
if {[nextState $NO $node $curstate $name] in $finalstates} {
return 1
}
}
}
return 0
}
# Returns the state of the automaton after consuming $symbol from $curstate.
#
# @param NO Boolean. Whether we have a negation command or not.
# @param node The node of the command the argument belongs to.
# @param curstate The name of the current state.
# @param symbol The symbol to consume.
# @return The state of the automaton after consuming $symbol from $curstate.
proc nextState {NO node curstate symbol} {
compute_fa fa2 $NO $node
set nextstate [fa2 next $curstate $symbol] ;# Consume $symbol.
fa2 destroy
return $nextstate
}
################################
# Command Execution
################################
# This command attempts to find if a given command is a mikroconf command and if so, it executes it.
#
# @param command The command name and arguments to execute.
# @return The result of the execution or a formatted error message.
# @error
proc execute {sid cmdline} {
Session $sid CONFMODE
set AUTHPRIV [authmode $sid privilege]
set pos [expr {[llength $cmdline] - 1}]
# The following can generate an error, which we let propagate.
lassign [match $sid {-no -final -count -vector -nodes -names -type -pos -types} $cmdline $pos] no final count vector node names type position types
if {$count eq ""} { ;# 'match' returned nothing, which means:
ferror "unnecessary argument at indicated position" $pos
} elseif {$count == 0} {
ferror "unknown $type at the indicated position" $pos
} elseif {$count > 1} {
if {$type eq "command"} {
ferror "ambiguous command at the indicated position; ambiguitiy between:\n $names" $pos
} else { ;# argument
if {[llength [lsearch -all $types "match"]] > 1 || [llength [lsearch -all $types "any"]] > 1} {
ferror "inherently ambiguous argument" $pos
}
if {"match" ni $types && "any" ni $types} {
ferror "ambiguous argument at the indicated position; ambiguitiy between:\n $names" $pos
}
}
}
if {! $final} {
if {$type eq "command"} {
error "incompete command"
} else { ;# argument
set p 0
foreach {t v} $vector { ;# type value
if {[lempty $t]} { ;# Marks no match against argument at position $p
ferror "illegal argument at the indicated position" [expr {$pos + $p}]
}
incr p
}
error "insufficient number of arguments"
}
}
set cmd [$node selectNodes {string(exec/text())}]
set modname [$node selectNodes {string(ancestor-or-self::module/@name)}]
# Create a memory fifo to capture handler output.
# Contrary to "return", this method allows for the output up to an error to be recovered, and printed.
# If we were using only the return value from the handler, then output that has been appened to the result
# before an error, would not be accessible after the error.
set out [fifo]
fconfigure $out -buffering full -blocking 0 -translation binary
# Handler procs should take care of classifying and logging errors using the helper procs in helper.tcl.
if {[catch {
namespace inscope ::module::$modname {*}$cmd $cmdline $position $sid $out $no $vector
} result options]} {
# Print the output up to the error.
flush $out
set result "[read $out]${result}"
} else {
# Append handler's result to handler's output.
if {! [lempty $result]} {
puts $out $result
}
flush $out
set result [read $out]
}
close $out
return -options $options $result
}
#################
# AUTHMODE
#################
# Operations on Authmodes.
# Supported: init, set, get, parent, list, exists, getstring, setstring, privilege, exit.
#
# @param sid Session Id.
# @param op Operation.
# @param mode The authentication mode name or string, depending on the operation.
# @error
proc authmode {sid op {mode {}}} {
variable sysconf
Session -rw $sid AUTHMODE AUTHROOT AUTHSTRING POLICY
switch -exact -- $op {
"init" {
sysconf authmode $sid set $AUTHROOT
}
"set" { ;# 'mode' is the authmode to switch to.
if {! [authmode $sid exists $mode]} {
log::Error -error "Authmode \"$mode\" does not exist, while switching authmode"
}
set AUTHMODE $mode
set AUTHSTRING [$sysconf selectNodes [format {string(/module/authmode[@name='%s']/@string)} $AUTHMODE]]
# Enforce policy that corresponds to newly set AUTHMODE.
if {! [lempty $POLICY]} {
Thread::bgsend $sid [list policy $POLICY]
} else {
Thread::bgsend $sid [list policy $mode]
}
return
}
"get" { ;# Get current authmode
return $AUTHMODE
}
"parent" { ;# 'mode' _if_ set is the authmode to look for the parent of.
if {[lempty $mode]} {
set mode $AUTHMODE
}
if {$mode eq $AUTHROOT} {
log::Warning -error "Root authmode has no parent"
}
set node [$sysconf selectNodes [format {/module/authmode[@name='%s']} $mode]]
if {[llength $node] != 1} {
log::Critical -error "Multiple AUTHMODEs with same name were found:" $node
}
return [$node getAttribute parent]
}
"list" { ;# Get all registered authmodes
set ret [list]
set nodes [$sysconf selectNodes {/module/authmode}]
foreach node $nodes {
lappend ret [$node getAttribute name]
}
return $ret
}
"exists" { ;# 'mode' is the name of the authmode that we test if it exists.
return [$sysconf selectNodes [format {boolean(/module/authmode[@name='%s'])} $mode]]
}
"getstring" { ;# Get display string associated with an the current authmode
return $AUTHSTRING
}
"setstring" { ;# 'mode' is the new display string of the current authmode to set to.
# It has effect only on the local session
set AUTHSTRING $mode
}
"privilege" { ;# Get privilege level of current authmode
return [$sysconf selectNodes [format {string(/module/authmode[@name='%s']/@privilege)} $AUTHMODE]]
}
"exit" { ;# Exit current authmode and move to the parent
# Ignore if already on root
if {$AUTHMODE eq $AUTHROOT} { return }
authmode $sid set [authmode $sid parent]
}
default {
error "Unsupported sub-command"
}
}
}
#################
# CONFMODE
#################
# Operations on Confmodes
# Supported: init, set, get, parent, list, exists, getstring, setstring, exit, store
#
# @param sid Session Id.
# @param op Operation.
# @param mode The configuration mode name or string, depending on the operation.
# @error
proc confmode {sid op {mode {}}} {
variable sysconf
Session -rw $sid CONFMODE CONFROOT CONFSTRING USER CONFSTORE
switch -exact -- $op {
"init" {
sysconf confmode $sid set $CONFROOT
}
"set" { ;# 'mode' is the confmode to switch to.
if {! [confmode $sid exists $mode]} {
log::Error -error "Confmode \"$mode\" does not exist, while switching confmode"
}
set CONFMODE $mode
set CONFSTRING [$sysconf selectNodes [format {string(/module/confmode[@name='%s']/@string)} $CONFMODE]]
return
}
"get" { ;# Get current confmode
return $CONFMODE
}
"parent" { ;# 'mode' _if_ set is the confmode to look for the parent of.
if {[lempty $mode]} {
set mode $CONFMODE
}
if {$mode eq $CONFROOT} {
log::Warning -error "Already in root confmode"
}
set node [$sysconf selectNodes [format {/module/confmode[@name='%s']} $mode]]
if {[llength $node] != 1} {
log::Critical -error "Multiple CONFMODEs with same name were found:" $node
}
return [$node getAttribute parent]
}
"list" { ;# Get all registered confmodes
set ret {}
set nodes [$sysconf selectNodes {/module/confmode}]
foreach node $nodes {
lappend ret [$node getAttribute name]
}
return $ret
}
"exists" { ;# 'mode' is the name of the confmode that we test if it exists.
return [$sysconf selectNodes [format {boolean(/module/confmode[@name='%s'])} $mode]]
}
"getstring" { ;# Get display string associated with an the current confmode
return $CONFSTRING
}
"setstring" { ;# 'mode' is the new display string of the current confmode to set to.
# It has effect only on the local session
set CONFSTRING $mode
}
"store" {
if {[lempty $mode]} {
return $CONFSTORE
} else {
set CONFSTORE $mode
}
}
"exit" { ;# Exit current confmode and move to the parent
# Terminate session if already on root.
# Only user sessions can terminate this way.
if {$CONFMODE eq $CONFROOT && $USER} {
::session::close_session $sid "User request"
} else {
confmode $sid set [confmode $sid parent]
}
}
default {
error "Unsupported sub-command"
}
}
}
################################
# MainConf
################################
# Generate the Running Configuration.
#
# @param parent The mainconf section to generate the running configuration for.
# @return The Running Configuration for $parent.
# @error
proc runningConf {{parent root}} {
variable sysconf
set result "" ;# The running configuration string.
set section_n [$sysconf selectNodes [format {/module/mainconf[@parent='%s']} $parent]]
set print_n [$sysconf selectNodes [format {.//command/print[@section='%s']} $parent]]
set children [list]
foreach n $section_n {
# Order Type Parent-node Module-name Section-name
lappend children [list \
[$n selectNodes {string(@order)}] \
{section} \
$parent \
[$n selectNodes {string(ancestor-or-self::module/@name)}] \
[$n selectNodes {string(@name)}]]
}
foreach n $print_n {
# Order Type Parent-node Module-name Handler-code
lappend children [list \
[$n selectNodes {string(@order)}] \
{print} \
$parent \
[$n selectNodes {string(ancestor-or-self::module/@name)}] \
[$n selectNodes {string(text())}]]
}
# Enforce order.
set children [lsort -increasing -integer -index 0 $children]
# Process a child at a time.
foreach child $children {
lassign $child order type parent modname value
set res {}
switch -exact -- $type {
"section" {
set res [runningConf $value]
}
"print" {
if {[catch {
# If 'base' is the module name, then evaluate callback on ::module::base namespace.
namespace inscope ::module::$modname {*}$value
} res errStack]} {
log::Emergency -error -stack $errStack "Failed to retrieve running configuration: " "section:$parent" "module:$modname" "code:$value" $res
}
}
}
if {! [lempty $res]} {
append result $res
}
}
return $result
}
# Retrieve Startup Configuration
#
# @return Startup Configuration
# @error
proc startupConf {} {
Global STARTUP_CONFIG_FILE
if {! [file exists $STARTUP_CONFIG_FILE]} {
error "Startup configuration is absent"
}
if {[catch {
set text [::fileutil::cat $STARTUP_CONFIG_FILE]
} errMsg errStack]} {
log::Emergency -error -stack $errStack "Failure while reading Start-up Configuration File: " $errMsg
}
return $text
}
# Apply Startup Config, resulting in Running Config == Startup Config.
# Log but ignore any errors.
#
# @assume Existance of "priv" authmode and "global" conf mode.
#
# @param text Configuration text to apply. If not provided then the startup-config is applied.
# @error
proc loadConf {{text {}}} {
if {[lempty $text]} {
Global STARTUP_CONFIG_FILE
if {[catch {
set text [startupConf]
} errMsg errStack]} {
log::Emergency -error -stack $errStack "Failed to load Start-up configuration: " $errMsg
}
}
# Create a new session to evaluate running-config. By doing this we make sure that
# 1. The interpreter/session is not altered in any way that would make execution of
# running-config to fail.
# 2. We request that the session enters directly to "configure terminal" mode, as
# all running-conf commands belong to this mode, but without explicitly switching
# to it. We also enter directly to privileged mode.
set sid [create_bg_session CONFIG "priv" "global"]
Session $sid SLAVE
if {[catch {
Thread::bgsend $sid [list $SLAVE eval $text]
} errMsg errStack]} {
log::Critical -stack $errStack "Startup configuration error: " $errMsg
# Report in the form of an event that a startup configuration directive failed to be applied.
# Useful to record such failures and maybe respond to them.
#
# @param The failure message.
# @param The error stack of the failure.
event generate STARTUP_CONFIG FAILED [list $errMsg $errStack]
}
close_session $sid "Evaluation of running-config finished"
}
# Write Running Config to Startup Config
#
# @error
proc saveConf {} {
Global TMP_DIR STARTUP_CONFIG_FILE
if {[catch {
set text [runningConf]
} errMsg errStack]} {
log::Emergency -error -stack $errStack "Failed to generate Running Configuration: " $errMsg
}
if {[file exists STARTUP_CONFIG_FILE]} {
file copy -force -- $STARTUP_CONFIG_FILE [file join $TMP_DIR $STARTUP_CONFIG_FILE]
}
if {[catch {
set fd [open $STARTUP_CONFIG_FILE w]
puts $fd $text
close $fd
} errMsg errStack]} {
file rename -force -- [file join $TMP_DIR $STARTUP_CONFIG_FILE] $STARTUP_CONFIG_FILE
catch { close $fd }
log::Emergency -error -stack $errStack "Failure while writing Start-up Configuration File: " $errMsg
}
catch { file delete [file join $TMP_DIR $STARTUP_CONFIG_FILE]] }
# Emitted after MikroConf's Startup Configuration is saved.
# Can be used from distributions to copy the updated Startup config to a safe place.
#
# @param The full path to the startup-config file in the file system.
event generate STARTUP_CONFIG SAVE $STARTUP_CONFIG_FILE
}
# Get a Finate Automaton (::grammar::fa) from embedded <syntax> specifications.
# Cache the generated fa by inserting it in the memory-resident DOM tree inside a <grammar> tag, which is a sibling of <syntax>.
#
# @param name Command name.
# @param NO Set if looking for the finate automaton that describes the negative form of the command.
# @param node The DOM node of the command.
# @return The command name of the finate automaton that corresponds to the found <syntax> specification.
# @error
proc compute_fa {name NO node} {
variable sysconf
if {$NO} {
set no {no/}
} else {
set no {}
}
if {! [$node selectNodes [format {boolean(%ssyntax)} $no]]} {
log::Critical -error "Node \"[$node getAttribute name]\" does not specify a syntax"
}
::grammar::fa $name
if {[$node selectNodes [format {boolean(%sgrammar)} $no]]} {
# <grammar> is cached.
if {[catch {
$name deserialize [$node selectNodes [format {string(%sgrammar/text())} $no]]
} errMsg errStack]} {
$name destroy
log::Critical -error -stack $errStack "Failed to deserialize syntax for node \"[$node getAttribute name]\":" $errMsg
}
} else {
# We need to convert <syntax> to <grammar>.
if {[catch {
$name fromRegex [$node selectNodes [format {string(%ssyntax/text())} $no]]
} errMsg errStack]} {
$name destroy
log::Critical -error -stack $errStack "Failed to parse command syntax \"[$syntax_e nodeValue]\" for node \"[$node getAttribute name]\" :" $errMsg
}
$name determinize
$sysconf createElement grammar grammar_e
$grammar_e appendFromList [list #text [$name serialize]]
$node appendChild $grammar_e
}
return $name
}
namespace ensemble create
} ;# End of Namespace
Overview | Index by: file name |
procedure name |
procedure call |
annotation
File generated 2010-03-13 at 22:28.