--- /dev/null
+#! /usr/bin/tclsh8.5
+### -*-tcl-*-
+###
+### Generate `named.conf' stanze for multiple views.
+###
+### (c) 2011 Mark Wooding
+###
+
+###----- Licensing notice ---------------------------------------------------
+###
+### This program is free software; you can redistribute it and/or modify
+### it under the terms of the GNU General Public License as published by
+### the Free Software Foundation; either version 2 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 General Public License for more details.
+###
+### You should have received a copy of the GNU General Public License
+### along with this program; if not, write to the Free Software Foundation,
+### Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+###--------------------------------------------------------------------------
+### Utility functions.
+
+proc pushnew {var args} {
+ ## Append each of the ARGS onto the list VAR if they're not there already.
+
+ upvar 1 $var list
+ foreach item $list { set found($item) t }
+ foreach item $args {
+ if {![info exists found($item)]} {
+ lappend list $item
+ set found($item) t
+ }
+ }
+}
+
+proc merge-lists {lists} {
+ ## Merge the given LISTS into a single list, respecting the order of the
+ ## items in the original list. If that's not possible, signal an error.
+ ## Any ambiguity is resolved by choosing the item from the earlier list.
+
+ ## Strip out any empty lists in the input.
+ set nlists {}
+ foreach list $lists {
+ if {[llength $list]} { lappend nlists $list }
+ }
+ set lists $nlists
+
+ ## Clear the output list.
+ set output {}
+
+ ## Now pick out items one by one.
+ while {[llength $lists]} {
+
+ ## Find the candidate items
+ set cand {}
+ foreach list $lists { pushnew cand [lindex $list 0] }
+
+ ## Remove candidate items which have not the first in some other list.
+ set ncand {}
+ foreach cand $cand {
+ foreach list $lists {
+ if {[lsearch -exact $list $cand] < 0} { lappend ncand $cand }
+ }
+ }
+
+ ## If there's nothing left, report an error.
+ if {![llength $cand]} {
+ error "Inconsistent lists in `merge-lists'."
+ }
+
+ ## Otherwise take the first item.
+ set chosen [lindex $cand 0]
+ lappend output $chosen
+
+ ## Remove the chosen item from the input lists.
+ set nlists {}
+ foreach list $lists {
+ if {[string equal $chosen [lindex $list 0]]} {
+ set list [lrange $list 1 end]
+ if {![llength $list]} { continue }
+ }
+ lappend nlists $list
+ }
+ set lists $nlists
+ }
+
+ return $output
+}
+
+proc adjust-uplevel {spec offset} {
+ ## Adjust an `uplevel' SPEC by OFFSET to take account of intervening call
+ ## frames. If SPEC begins with `#' then it is left alone; otherwise it is
+ ## incremented by OFFSET.
+
+ switch -glob -- $spec {
+ \#* { return $spec }
+ default { return [expr {$spec + $offset}] }
+ }
+}
+
+proc unwind-protect {body cleanup} {
+ ## Evaluate BODY; then evaluate CLEANUP, regardless of whether BODY
+ ## returned normally or did something complicated. If CLEANUP completes
+ ## normally then the final result is that of BODY (including any errors or
+ ## abnormal returns it made); otherwise the result of CLEANUP takes
+ ## precedence and the results of BODY are discarded.
+
+ catch { uplevel 1 $body } bodyval bodyopts
+ if {[catch { uplevel 1 $cleanup } cleanval cleanopts]} {
+ return -options $cleanopts $cleanval
+ } else {
+ return -options $bodyopts $bodyval
+ }
+}
+
+proc let {args} {
+ ## Syntax: let VAR VALUE ... BODY
+ ##
+ ## Evaluate BODY with the VARs bound to the VALUEs. Reestore the previous
+ ## values when the BODY returns.
+
+ ## Parse the argument syntax.
+ if {[llength $args] % 2 == 0} {
+ error "bad number of arguments to `let'"
+ }
+ set body [lindex $args end]
+
+ ## Now work through the bindings, setting the variables to their new
+ ## values. As we go, also build up code in `cleanup' to restore everything
+ ## the way it's meant to be.
+ set cleanup {}
+ set i 0
+ foreach {var value} [lrange $args 0 end-1] {
+ upvar 1 $var fluid-$i
+ if {[info exists fluid-$i]} {
+ append cleanup "set fluid-$i [list [set fluid-$i]]\n"
+ } else {
+ append cleanup "unset fluid-$i\n"
+ }
+ set fluid-$i $value
+ incr i
+ }
+
+ ## Now evaluate the body.
+ unwind-protect { uplevel 1 $body } $cleanup
+}
+
+proc set* {names values} {
+ ## Set each of the variables listed in NAMES to the corresponding element
+ ## of VALUES. The two lists must have the same length.
+
+ if {[llength $names] != [llength $values]} {
+ error "length mismatch"
+ }
+ foreach name $names value $values {
+ upvar 1 $name var
+ set var $value
+ }
+}
+
+###--------------------------------------------------------------------------
+### Configuration spaces.
+###
+### A configuration space is essentially a collection of Tcl commands and a
+### global array which the commands act on. The commands live in their own
+### namespace and their availability can be altered by modifying the
+### namespace path. The basic idea is to support a structured configuration
+### language with short directive names and where the available directives
+### varies in a context-sensitive manner.
+###
+### A configuration space can include other spaces, and they can include
+### further spaces. The graph of inclusions must be acyclic; further, since
+### the available commands are determined using the C3 linearization
+### algorithm, the relation in which a space precedes the spaces it includes,
+### and a space A precedes another space B if a third space includes A before
+### B, must be a partial order, and the linearizations of all of the spaces
+### must be monotonic. Don't worry about that if you don't know what it
+### means. If you don't do anything weird, it'll probably be all right.
+
+proc confspc-create {space confvar} {
+ ## Define a new configuration space called SPACE. You must do this before
+ ## defining directives or including other spaces.
+
+ global CONFSPC_CMD CONFSPC_INCL CONFSPC_CPL CONFSPC_CHANGE CONFSPC_VAR
+ if {![info exists CONFSPC_CMD($space)]} {
+ set CONFSPC_CMD($space) {}
+ set CONFSPC_INCL($space) {}
+ set CONFSPC_CPL($space) [list $space]
+ set CONFSPC_CHANGE($space) 0
+ set CONFSPC_VAR($space) $confvar
+ namespace eval ::confspc::$space {}
+ }
+}
+
+## Change sequence numbers are used to decide whether the linearized
+## inclusion caches are up to date.
+set CONFSPC_LASTCHANGESEQ 0
+set CONFSPC_CHANGESEQ 0
+
+proc confspc-command {space name bvl body} {
+ ## Define a configuration directive NAME in SPACE, accepting the arguments
+ ## specified by the BVL, and executing BODY when invoked. The SPACE's
+ ## configuration array is available within the BODY.
+
+ global CONFSPC_CMD CONFSPC_VAR
+ pushnew CONFSPC_CMD($space) $name
+
+ ## Define the configuration command in the caller's namespace.
+ set ns [uplevel 1 { namespace current }]
+ eval [list proc ${ns}::conf/$space/$name $bvl \
+ "global $CONFSPC_VAR($space)\n$body"]
+ namespace eval $ns [list namespace export conf/$space/$name]
+
+ ## Now arrange for this command to exist properly in the configuration
+ ## space.
+ namespace eval ::confspc::$space \
+ [list namespace import ${ns}::conf/$space/$name]
+ catch {
+ namespace eval ::confspc::$space [list rename $name {}]
+ }
+ namespace eval ::confspc::$space \
+ [list rename conf/$space/$name $name]
+}
+
+proc confspc-include {space includes} {
+ ## Arrange for SPACE to include the directives from the INCLUDES spaces.
+
+ global CONFSPC_INCL CONFSPC_LASTCHANGESEQ CONFSPC_CHANGESEQ
+ pushnew CONFSPC_INCL($space) $includes
+ if {$CONFSPC_CHANGESEQ <= $CONFSPC_LASTCHANGESEQ} {
+ set CONFSPC_CHANGESEQ [expr {$CONFSPC_LASTCHANGESEQ + 1}]
+ }
+}
+
+proc confspc-update {space} {
+ ## Update cached data for SPACE and its included spaces. We recompute the
+ ## space's class-precedence list, for which we use the C3 linearization
+ ## algorithm, which has known good properties.
+
+ global CONFSPC_CPL CONFSPC_CHANGE CONFSPC_INCL
+ global CONFSPC_CHANGESEQ CONFSPC_LASTCHANGESEQ
+ set CONFSPC_LASTCHANGESEQ $CONFSPC_CHANGESEQ
+
+ ## If the space is already up-to-date, do nothing.
+ if {$CONFSPC_CHANGE($space) == $CONFSPC_CHANGESEQ} { return }
+
+ ## Arrange for the included spaces to be up-to-date, and gather the CPLs
+ ## together so we can merge them.
+ set merge {}
+ lappend merge [concat $space $CONFSPC_INCL($space)]
+ foreach included $CONFSPC_INCL($space) {
+ confspc-update $included
+ lappend merge $CONFSPC_CPL($included)
+ }
+
+ ## Do the merge and update the change indicator.
+ set CONFSPC_CPL($space) [merge-lists $merge]
+ set CONFSPC_CHANGE($space) $CONFSPC_CHANGESEQ
+}
+
+proc confspc-path {ns cpl} {
+ ## Update namespace NS's command path so that it has (only) the
+ ## directives of the given CPL. Pass an empty CPL to clear the
+ ## configuration space hacking.
+
+ set path {}
+
+ ## Add the new namespaces to the front.
+ foreach spc $cpl { lappend path ::confspc::$spc }
+
+ ## Now add the existing path items, with any existing confspc hacking
+ ## stripped out.
+ foreach item [namespace eval $ns { namespace path }] {
+ if {![string match "::confspc::*" $item]} { lappend npath $item }
+ }
+
+ ## Commit the result.
+ namespace eval $ns [list namespace path $path]
+}
+
+proc confspc-set {ns space} {
+ ## Set the command path for namespace NS to include the configuration
+ ## directives of SPACE (and its included spaces).
+
+ global CONFSPC_CPL
+ confspc-update $space
+ confspc-path $ns $CONFSPC_CPL($space)
+}
+
+proc confspc-eval {space body} {
+ ## Evaluate BODY in the current namespace, but augmented with the
+ ## directives from the named SPACE. The command path of the current
+ ## namespace is restored afterwards.
+
+ set ns [uplevel 1 { namespace current }]
+ set path [namespace eval $ns { namespace path }]
+ unwind-protect {
+ confspc-set $ns $space
+ uplevel 1 $body
+ } {
+ namespace eval $ns [list namespace path $path]
+ }
+}
+
+proc preserving-config {confvar body} {
+ ## Evaluate BODY, but on exit restore the CONFVAR array so that the BODY
+ ## has no lasting effect on it.
+
+ upvar #1 $confvar CONFIG
+ set old [array get CONFIG]
+ unwind-protect {
+ uplevel 1 $body
+ } {
+ array unset CONFIG
+ array set CONFIG $old
+ }
+}
+
+confspc-create confspc CONFSPC_CONFIG
+
+confspc-command confspc include {args} {
+ ## Include the named configuration spaces in the current one.
+
+ confspc-include $CONFSPC_CONFIG(space) $args
+}
+
+confspc-command confspc define {name bvl body} {
+ ## Define a directive NAME in the current space, taking arguments BVL, and
+ ## having the given BODY.
+
+ confspc-command $CONFSPC_CONFIG(space) $name $bvl $body
+}
+
+confspc-command confspc define-simple {setting default} {
+ ## Define a directive SETTING which sets the appropriately prefixed entry
+ ## in the CONFIG array to its single arguments, and immediately set the
+ ## CONFIG entry to DEFAULT.
+
+ global CONFSPC_VAR
+ set space $CONFSPC_CONFIG(space)
+ upvar #0 $CONFSPC_VAR($space) config
+ confspc-command $space $setting arg \
+ "set $CONFSPC_VAR($space)($CONFSPC_CONFIG(prefix)$setting) \$arg"
+ set config($CONFSPC_CONFIG(prefix)$setting) $default
+}
+
+confspc-command confspc define-list {setting default} {
+ ## Define a directive SETTING which sets the appropriately prefixed entry
+ ## in the CONFIG array to its entire argument list, and immediately set the
+ ## CONFIG entry to DEFAULT (which should be a Tcl list, not a collection of
+ ## arguments).
+
+ global CONFSPC_VAR
+ set space $CONFSPC_CONFIG(space)
+ upvar #0 $CONFSPC_VAR($space) config
+ confspc-command $space $setting args \
+ "set $CONFSPC_VAR($space)($CONFSPC_CONFIG(prefix)$setting) \$args"
+ set config($CONFSPC_CONFIG(prefix)$setting) $default
+}
+
+confspc-command confspc prefix {prefix} {
+ set CONFSPC_CONFIG(prefix) $prefix
+}
+
+proc define-configuration-space {space confvar body} {
+ ## Define a new configuration space named SPACE. The BODY is Tcl code,
+ ## though it may make use of `include' and `define'.
+
+ global CONFSPC_CONFIG
+ set ns [uplevel 1 { namespace current }]
+ set oldpath [namespace eval $ns { namespace path }]
+ confspc-create $space $confvar
+ unwind-protect {
+ preserving-config CONFSPC_CONFIG {
+ array set CONFSPC_CONFIG [list space $space \
+ prefix ""]
+ confspc-set $ns confspc
+ uplevel 1 $body
+ }
+ } {
+ namespace eval $ns [list namespace path $oldpath]
+ }
+}
+
+###--------------------------------------------------------------------------
+### Option parsing.
+###
+### The option parsing machinery makes extensive use of a state array
+### OPTPARSE_STATE in order to maintain its context. The procedure
+### `with-option-parser' establishes this array correctly, and preserves any
+### existing state, so there should be no trouble with multiple parsers in
+### the same program.
+
+proc optparse-more-p {} {
+ ## Answer whether there are more argument words available.
+
+ upvar #0 OPTPARSE_STATE state
+ if {[llength $state(words)]} { return true } else { return false }
+}
+
+proc optparse-next-word {} {
+ ## Return the next word in the argument list. It is an error if there are
+ ## no more words left.
+
+ upvar #0 OPTPARSE_STATE state
+ set word [lindex $state(words) 0]
+ set state(words) [lrange $state(words) 1 end]
+ return $word
+}
+
+proc optparse-error {message} {
+ ## Report an error message and exit.
+
+ global QUIS
+ puts stderr "$QUIS: $message"
+ exit 1
+}
+
+proc optparse-option/short {var} {
+ ## Parse the next short option from the current cluster. If there are no
+ ## more short options, set the mode back to `free' and call back into
+ ## `optparse-option/free'.
+ ##
+ ## See the description of `optparse-option/free' for the interface
+ ## implemented by this procedure.
+
+ ## Get hold of my state and the caller's array.
+ upvar #0 OPTPARSE_STATE state
+ upvar 1 $var opt
+
+ ## Work out what to do based on the remaining length of the cluster. (The
+ ## cluster shouldn't be empty because the mode should only be set to
+ ## `short' if there is an initial nonempty cluster to parse, and we set it
+ ## back to `free' when we consume the final character from the cluster.)
+ ## Specifically, set `argp' according to whether we have a potential
+ ## argument in the cluster, and `name' to the option character extracted.
+ array unset opt
+ switch [string length $state(rest)] {
+ 0 {
+ error "empty cluster"
+ }
+ 1 {
+ set argp false
+ set state(mode) free
+ set name $state(rest)
+ }
+ default {
+ set argp true
+ set name [string index $state(rest) 0]
+ set state(rest) [string range $state(rest) 1 end]
+ }
+ }
+
+ ## Try to look up the option in the map.
+ if {![dict exists $state(short-map) $name]} {
+ optparse-error "Unknown option `$state(prefix)$name'"
+ }
+ array set opt [dict get $state(short-map) $name]
+ set state(name) $name
+
+ ## Collect an argument if one is required.
+ catch { unset state(arg) }
+ switch -glob -- "$opt(arg),$argp" {
+ "required,false" {
+ if {![optparse-more-p]} {
+ optparse-error "Option `$state(prefix)$name' requires an argument"
+ }
+ set state(arg) [optparse-next-word]
+ }
+ "required,true" - "optional,true" {
+ set state(arg) $state(rest)
+ set state(mode) free
+ }
+ }
+
+ ## Report success.
+ return 1
+}
+
+proc optparse-option/free {var} {
+ ## Parse the next option from the argument list. This procedure is called
+ ## to process a new argument word, i.e., we are in `free' mode. It
+ ## analyses the next argument word and either processes it internally or
+ ## sets the mode appropriately and calls a specialized handler
+ ## `optparse-option/MODE' for that mode.
+ ##
+ ## The interface works as follows. If an option was found, then the array
+ ## VAR is set according to the option's settings dictionary; and state
+ ## variables are set as follows.
+ ##
+ ## prefix The prefix character(s) to write before the option name in
+ ## messages, e.g., `--' for long options.
+ ##
+ ## name The option name without any prefix attached.
+ ##
+ ## arg The option's argument, if there is one; otherwise unset.
+
+ upvar #0 OPTPARSE_STATE state
+ upvar 1 $var opt
+
+ ## Set stuff up.
+ array unset opt
+ catch { unset state(arg) }
+ if {![optparse-more-p]} { return 0 }
+ set word [optparse-next-word]
+
+ ## Work out what to do based on the word. The order of these tests is
+ ## critically important.
+ switch -glob -- $word {
+
+ "--" {
+ ## End-of-options marker.
+
+ return 0
+ }
+
+ "--*" {
+ ## Long option.
+
+ set state(prefix) "--"
+
+ ## If there's an equals sign, the name is the bit to the left; keep the
+ ## remainder as an argument.
+ set eq [string first "=" $word 2]
+ if {$eq >= 0} {
+ set name [string range $word 2 [expr {$eq - 1}]]
+ set state(arg) [string range $word [expr {$eq + 1}] end]
+ set argp true
+ } else {
+ set name [string range $word 2 end]
+ set argp false
+ }
+ set state(name) name
+
+ ## Look the name up in the map.
+ if {[dict exists $state(long-map) $name]} {
+ array set opt [dict get $state(long-map) $name]
+ } else {
+ set matches [dict keys $state(long-map) "$name*"]
+ switch -exact -- [llength $matches] {
+ 1 { array set opt [dict get $state(long-map) [lindex $matches 0]] }
+ 0 { optparse-error "Unknown option `--$name'" }
+ default {
+ optparse-error "Ambiaguous option `--$name' \
+ (matches: --[join $matches {, --}])"
+ }
+ }
+ }
+
+ ## Now check whether we want an argument. The missing cases are
+ ## because we are already in the correct state.
+ switch -glob -- "$opt(arg),$argp" {
+ "none,true" {
+ optparse-error "Option `$name' doesn't accept an argument"
+ }
+ "required,false" {
+ if {![optparse-more-p]} {
+ optparse-error "Option `$name' requires an argument"
+ }
+ set state(arg) [optparse-next-word]
+ }
+ }
+
+ ## Done. We consumed either one or two entire argument words, so we
+ ## should remain in the `free' state.
+ return 1
+ }
+
+ "-?*" {
+ ## Short option. Set state, initialize the cluster, and go.
+
+ set state(rest) [string range $word 1 end]
+ set state(mode) short
+ set state(prefix) "-"
+ return [optparse-option/short opt]
+ }
+
+ default {
+ ## Some non-option thing. Under POSIX rules, this ends the parse. (We
+ ## could do something more adventurous later.)
+
+ set state(words) [concat [list $word] $state(words)]
+ return 0
+ }
+ }
+}
+
+proc optparse-arg-p {} {
+ ## Return the whether the most recently processed option had an argument.
+
+ upvar #0 OPTPARSE_STATE state
+ return [info exists state(arg)]
+}
+
+proc optparse-arg {} {
+ ## Return the argument from the most recently processed option. It is an
+ ## error if no argument was supplied.
+
+ upvar #0 OPTPARSE_STATE state
+ return $state(arg)
+}
+
+proc optparse-words {} {
+ ## Return the remaining unparsed argument words as a list.
+
+ upvar #0 OPTPARSE_STATE state
+ return $state(words)
+}
+
+proc optparse-option {} {
+ ## Parse the next option(s). The action taken depends on the option
+ ## dictionary: if an `action' is provided then it is evaluated in the
+ ## caller's context; otherwise the option's `tag' is returned.
+
+ upvar #0 OPTPARSE_STATE state
+ while 1 {
+ if {![optparse-option/$state(mode) opt]} {
+ return done
+ } elseif {[info exists opt(action)]} {
+ uplevel 1 $opt(action)
+ } elseif {[info exists opt(tag)]} {
+ return $opt(tag)
+ } else {
+ error "Don't know what to do with option `$state(prefix)$state(name)'"
+ }
+ }
+}
+
+proc with-option-parser {state words body} {
+ ## Establish an option parsing context, initialized with the STATE
+ ## (constructed using `define-options') and the lits of argument WORDS.
+ ## The BODY may use `optparse-option', `optparse-arg', etc. to parse the
+ ## options.
+
+ global OPTPARSE_STATE
+ set old [array get OPTPARSE_STATE]
+
+ unwind-protect {
+ array unset OPTPARSE_STATE
+ array set OPTPARSE_STATE $state
+ set OPTPARSE_STATE(mode) free
+ set OPTPARSE_STATE(words) $words
+ uplevel 1 $body
+ } {
+ array set OPTPARSE_STATE $old
+ }
+}
+
+define-configuration-space optparse-option OPTCFG {
+ define-list short {}
+ define-list long {}
+ define action {act} { set OPTCFG(action) $act }
+ define tag {tag} { set OPTCFG(tag) $tag }
+ define-simple arg none
+}
+
+define-configuration-space optparse OPTCFG {
+ define option {body} {
+ upvar #0 OPTPARSE_STATE state
+ uplevel 1 [list confspc-eval optparse-option $body]
+ set opt [array get OPTCFG]
+ foreach kind {long short} {
+ foreach name $OPTCFG($kind) {
+ if {[dict exists $state($kind-map) $name]} {
+ error "Already have an option with $kind name `$name'"
+ }
+ dict set state($kind-map) $name $opt
+ }
+ }
+ }
+}
+
+proc define-options {statevar body} {
+ ## Define an option state, and write it to STATEVAR. The BODY may contain
+ ## `optparse' configuration directives to define the available options.
+
+ global OPTPARSE_STATE
+ upvar 1 $statevar state
+ set old [array get OPTPARSE_STATE]
+ unwind-protect {
+ array unset OPTPARSE_STATE
+ if {[info exists state]} {
+ array set OPTPARSE_STATE $state
+ } else {
+ array set OPTPARSE_STATE {
+ long-map {}
+ short-map {}
+ }
+ }
+ uplevel 1 [list confspc-eval optparse $body]
+ set state [array get OPTPARSE_STATE]
+ } {
+ array set OPTPARSE_STATE $old
+ }
+}
+
+###--------------------------------------------------------------------------
+### Subcommand handling.
+
+## Determine the program name.
+set QUIS [file tail $argv0]
+
+## This is fluid-bound to the name of the current command.
+set COMMAND {}
+
+proc find-command {name} {
+ ## Given a command NAME as typed by the user, find the actual command and
+ ## return it.
+
+ global HELP
+ set matches [info commands cmd/$name*]
+ set cmds {}
+ set doc {}
+ foreach match $matches {
+ set cmd [string range $match 4 end]
+ lappend cmds $cmd
+ if {[info exists HELP($cmd)]} { lappend doc $cmd }
+ }
+ switch -exact -- [llength $cmds] {
+ 1 { return [lindex $cmds 0] }
+ 0 { optparse-error "Unknown command `$name'" }
+ }
+ if {[llength $doc]} { set cmds $doc }
+ switch -exact -- [llength $cmds] {
+ 1 { return [lindex $cmds 0] }
+ 0 { optparse-error "Unknown command `$name'" }
+ default { optparse-error "Ambiguous command `$name' -- matches: $cmds" }
+ }
+}
+
+proc usage {cmd} {
+ ## Return a usage message for CMD. The message is taken from the `USAGE'
+ ## array if that contains an entry for CMD (it should not include the
+ ## command name, and should begin with a leading space); otherwise a
+ ## message is constructed by examining the argument names and defaulting
+ ## arrangements of the Tcl command cmd/CMD.
+ ##
+ ## By convention, the main program is denoted by an empty CMD name.
+
+ global USAGE
+ if {[info exists USAGE($cmd)]} {
+ set usage $USAGE($cmd)
+ } else {
+ set usage ""
+ foreach arg [info args cmd/$cmd] {
+ if {[string equal $arg "args"]} {
+ append usage " ..."
+ } elseif {[info default cmd/$cmd $arg hunoz]} {
+ append usage " \[[string toupper $arg]\]"
+ } else {
+ append usage " [string toupper $arg]"
+ }
+ }
+ }
+ return $usage
+}
+
+proc usage-error {} {
+ ## Report a usage error in the current command. The message is obtained by
+ ## the `usage' procedure.
+
+ global QUIS COMMAND
+ if {[string length $COMMAND]} { set cmd " $COMMAND" } else { set cmd "" }
+ puts stderr "Usage: $QUIS$cmd[usage $COMMAND]"
+ exit 1
+}
+
+proc dispatch {name argv} {
+ ## Invokes the handler for CMD, passing it the argument list ARGV. This
+ ## does some minimal syntax checking by examining the argument list to the
+ ## command handler procedure cmd/COMMAND and issuing a usage error if
+ ## there's a mismatch.
+
+ global COMMAND
+ let COMMAND [find-command $name] {
+
+ ## Decode the argument list of the handler and set min and max
+ ## appropriately.
+ set args [info args cmd/$COMMAND]
+ if {![llength $args]} {
+ set* {min max} {0 0}
+ } else {
+ if {[string equal [lindex $args end] "args"]} {
+ set max inf
+ set args [lrange $args 0 end-1]
+ } else {
+ set max [llength $args]
+ }
+ set min 0
+ foreach arg $args {
+ if {[info default cmd/$COMMAND $arg hunoz]} { break }
+ incr min
+ }
+ }
+
+ ## Complain if the number of arguments is inappropriate.
+ set n [llength $argv]
+ if {$n < $min || ($max != inf && $n > $max)} { usage-error }
+
+ ## Invoke the handler.
+ eval cmd/$COMMAND $argv
+ }
+}
+
+define-configuration-space subcommand SUBCMD {
+ define-simple help-text -
+ define-simple usage-text -
+}
+
+proc defcmd {name bvl defs body} {
+ ## Define a command NAME with arguments BVL. The `usage-text' and
+ ## `help-text' commands can be used in DEFS to set messages for the new
+ ## command.
+
+ global SUBCMD USAGE HELP
+
+ preserving-config SUBCMD {
+ confspc-eval subcommand { uplevel 1 $defs }
+ foreach tag {usage-text help-text} array {USAGE HELP} {
+ if {![string equal $SUBCMD($tag) -]} {
+ set ${array}($name) $SUBCMD($tag)
+ }
+ }
+ }
+ proc cmd/$name $bvl $body
+}
+
+## Standard subcommand handler to show information about the program or its
+## subcommands. To use this, you need to set a bunch of variables.
+##
+## USAGE(cmd) Contains the usage message for cmd -- including
+## leading space -- to use instead of the `usage'
+## procedure's automagic.
+##
+## HELP(cmd) Contains descriptive text -- not including a final
+## trailing newline -- about the command.
+##
+## VERSION The program's version number.
+##
+## The `defcmd' procedure can be used to set these things up conveniently.
+defcmd help {args} {
+ usage-text " \[SUBCOMMAND ...]"
+ help-text "Show help on the given SUBCOMMANDs, or on the overall program."
+} {
+ global QUIS VERSION USAGE HELP
+ if {[llength $args]} {
+ foreach name $args {
+ set cmd [find-command $name]
+ puts "Usage: $QUIS $cmd[usage $cmd]"
+ if {[info exists HELP($cmd)]} { puts "\n$HELP($cmd)" }
+ }
+ } else {
+ puts "$QUIS, version $VERSION\n"
+ puts "Usage: $QUIS$USAGE()\n"
+ if {[info exists HELP()]} { puts "$HELP()\n" }
+ puts "Subcommands available:"
+ foreach name [info commands cmd/*] {
+ set cmd [string range $name 4 end]
+ puts "\t$cmd[usage $cmd]"
+ }
+ }
+}
+
+###--------------------------------------------------------------------------
+### Build the configuration space for zone files.
+
+proc host-addr {host} {
+ ## Given a HOST name, return a list of its addresses.
+
+ if {![string match $host {*[!0-9.]*}]} { return $host }
+ set adns [open [list | adnshost +Dc -s $host] r]
+ unwind-protect {
+ set addrs {}
+ while {[gets $adns line] >= 0} {
+ set* {name type fam addr} $line
+ switch -glob -- $type:$fam {
+ A:INET { lappend addrs $addr }
+ }
+ }
+ return [lindex $addrs 0]
+ } {
+ close $adns
+ }
+}
+
+proc host-canonify {host} {
+ ## Given a HOST name, return a canonical version of it.
+
+ set adns [open [list | adnshost -Dc -s $host] r]
+ unwind-protect {
+ while {[gets $adns line] >= 0} {
+ switch -exact -- [lindex $line 1] {
+ CNAME { return [lindex $line 2] }
+ A - AAAA { return [lindex $line 0] }
+ }
+ }
+ error "failed to canonify $host"
+ } {
+ close $adns
+ }
+}
+
+proc local-address-p {addr} {
+ ## Answer whether the ADDR is one of the host's addresses.
+
+ if {[catch { set sk [socket -server {} -myaddr $addr 0] }]} {
+ return false
+ } else {
+ close $sk
+ return true
+ }
+}
+
+## The list of zones configured by the user.
+set ZONES {}
+
+## Dynamic zone update policy specifications.
+define-configuration-space policy ZONECFG {
+ define allow {identity nametype name args} {
+ lappend ZONECFG(ddns-policy) \
+ [concat grant [list $identity $nametype $name] $args]
+ }
+ define deny {identity nametype name args} {
+ lappend ZONECFG(ddns-policy) \
+ [concat deny [list $identity $nametype $name] $args]
+ }
+}
+
+## Dynamic zone details.
+define-configuration-space dynamic ZONECFG {
+ prefix "ddns-"
+ define-simple key "ddns"
+ define-list types {A TXT PTR}
+
+ define policy {body} {
+ set ZONECFG(ddns-policy) {}
+ uplevel 1 [list confspc-eval policy $body]
+ }
+
+ set ZONECFG(ddns-policy) {}
+}
+
+## Everything about a zone.
+define-configuration-space zone ZONECFG {
+ define-simple user root
+ define-simple master-dir "/var/lib/bind"
+ define-simple slave-dir "/var/cache/bind"
+ define-simple dir-mode 2775
+ define-simple zone-file "%v/%z.zone"
+ define-list views *
+ define-list reload-command {/usr/sbin/rndc reload %z IN %v}
+ define-list checkzone-command {
+ /usr/sbin/named-checkzone
+ -i full
+ -k fail
+ -M fail
+ -n fail
+ -S fail
+ -W fail
+ %z
+ %f
+ }
+
+ define primary {map} {
+ if {[llength $map] % 2} {
+ error "master map must have an even number of items"
+ }
+ set ZONECFG(master-map) $map
+ }
+
+ define dynamic {{body {}}} {
+ array set ZONECFG [list type dynamic]
+ uplevel 1 [list confspc-eval dynamic $body]
+ }
+
+ define view-map {map} {
+ if {[llength $map] % 2} {
+ error "view map must have an even number of items"
+ }
+ set ZONECFG(view-map) $map
+ }
+
+ array set ZONECFG {
+ type static
+ view-map {* =}
+ }
+}
+
+## Top-level configuration. Allow most zone options to be set here, so that
+## one can set defaults for multiple zones conveniently.
+define-configuration-space toplevel ZONECFG {
+ include zone
+
+ define-list all-views {}
+ define-simple conf-file "/var/lib/zoneconf/config/%v.conf"
+ define-simple max-zone-size [expr {512*1024}]
+ define-list reconfig-command {/usr/sbin/rndc reconfig}
+
+ define scope {body} { preserving-config ZONECFG { uplevel 1 $body } }
+
+ define zone {name {body {}}} {
+ global ZONES
+ preserving-config ZONECFG {
+ array set ZONECFG \
+ [list name $name \
+ type static]
+ uplevel 1 [list confspc-eval zone $body]
+ lappend ZONES [array get ZONECFG]
+ }
+ }
+}
+
+###--------------------------------------------------------------------------
+### Processing the results.
+
+proc zone-file-name {view config} {
+ ## Return the relative file name for the zone described by CONFIG, relative
+ ## to the given VIEW. An absolute filename may be derived later, depending
+ ## on whether the zone data is static and the calling host is the master
+ ## for the zone.
+
+ array set zone $config
+ return [string map [list \
+ "%v" $view \
+ "%z" $zone(name)] \
+ $zone(zone-file)]
+}
+
+proc output-file-name {view} {
+ ## Return the output file name for the given VIEW.
+
+ global ZONECFG
+ return [string map [list %v $view] $ZONECFG(conf-file)]
+}
+
+proc compute-zone-properties {view config} {
+ ## Derive interesting information from the zone configuration plist CONFIG,
+ ## relative to the stated VIEW. Return a new plist.
+
+ array set zone $config
+
+ ## See whether the zone matches the view.
+ set match 0
+ foreach wanted $zone(views) {
+ if {[string match $wanted $view]} { set match 1; break }
+ }
+ if {!$match} { return {config-type ignore} }
+
+ ## Transform the view name according to the view map.
+ foreach {inview outview} $zone(view-map) {
+ if {![string match $inview $view]} { continue }
+ switch -exact -- $outview {
+ = { set zone(mapped-view) $view }
+ default { set zone(mapped-view) $outview }
+ }
+ break
+ }
+
+ ## Find out where the master is supposed to be.
+ set zone(config-type) ignore
+ if {[info exists zone(mapped-view)]} {
+ foreach {outview hosts} $zone(master-map) {
+ if {[string match $outview $zone(mapped-view)]} {
+ set zone(masters) $hosts
+ set zone(config-type) slave
+ foreach host $hosts {
+ if {[local-address-p $host]} {
+ set zone(config-type) master
+ }
+ }
+ break
+ }
+ }
+ }
+
+ ## Main dispatch for zone categorization.
+ switch -exact -- $zone(config-type) {
+ master {
+ switch -exact -- $zone(type) {
+ static {
+ set zone(file-name) \
+ [file join $zone(master-dir) \
+ [zone-file-name $zone(mapped-view) $config]]
+ }
+ dynamic {
+ set zone(file-name) [file join $zone(slave-dir) \
+ [zone-file-name $view $config]]
+ }
+ }
+ }
+ slave {
+ set zone(file-name) [file join $zone(slave-dir) \
+ [zone-file-name $view $config]]
+ }
+ }
+
+ ## Done.
+ return [array get zone]
+}
+
+proc write-ddns-update-policy {prefix chan config} {
+ ## Write an `update-policy' stanza to CHAN for the zone described by the
+ ## CONFIG plist. The PREFIX is written to the start of each line.
+
+ array set zone $config
+ puts $chan "${prefix}update-policy {"
+ set policyskel "${prefix}\t%s %s %s \"%s\" %s;"
+
+ foreach item $zone(ddns-policy) {
+ set* {verb ident type name} [lrange $item 0 3]
+ set rrtypes [lrange $item 4 end]
+ puts $chan [format $policyskel \
+ $verb \
+ $ident \
+ $type \
+ $name \
+ $rrtypes]
+ }
+
+ puts $chan [format $policyskel \
+ grant \
+ $zone(ddns-key) \
+ subdomain \
+ $zone(name) \
+ $zone(ddns-types)]
+
+ puts $chan "${prefix}};"
+}
+
+proc write-zone-stanza {view chan config} {
+ ## Write a `zone' stanza to CHAN for the zone described by the CONFIG
+ ## plist in the given VIEW.
+
+ array set zone [compute-zone-properties $view $config]
+ if {[string equal $zone(config-type) "ignore"]} { return }
+
+ ## Create the directory for the zone files.
+ set dir [file dirname $zone(file-name)]
+ if {![file isdirectory $dir]} {
+ file mkdir $dir
+ exec chmod $zone(dir-mode) $dir
+ }
+
+ ## Write the configuration fragment.
+ puts $chan "\nzone \"$zone(name)\" {"
+ switch -glob -- $zone(config-type) {
+ master {
+ puts $chan "\ttype master;"
+ puts $chan "\tfile \"$zone(file-name)\";"
+ switch -exact -- $zone(type) {
+ dynamic { write-ddns-update-policy "\t" $chan $config }
+ }
+ }
+ slave {
+ puts $chan "\ttype slave;"
+ set masters {}
+ foreach host $zone(masters) { lappend masters [host-addr $host] }
+ puts $chan "\tmasters { [join $masters {; }]; };"
+ puts $chan "\tfile \"$zone(file-name)\";"
+ switch -exact -- $zone(type) {
+ dynamic { puts $chan "\tallow-update-forwarding { any; };" }
+ }
+ }
+ }
+ puts $chan "};";
+}
+
+###--------------------------------------------------------------------------
+### Command-line interface.
+
+set CONFFILE "/etc/bind/zones.in"
+
+defcmd outputs {} {
+ help-text "List the output file names to stdout."
+} {
+ global ZONECFG CONFFILE
+
+ confspc-eval toplevel [list source $CONFFILE]
+ foreach view $ZONECFG(all-views) { puts [output-file-name $view] }
+}
+
+defcmd update {} {
+ help-text "Generate BIND configuration files."
+} {
+ global ZONECFG ZONES CONFFILE
+
+ confspc-eval toplevel [list source $CONFFILE]
+ set win false
+ unwind-protect {
+ foreach view $ZONECFG(all-views) {
+ set out($view) [output-file-name $view]
+ set chan($view) [open "$out($view).new" w]
+ set now [clock format [clock seconds] -format "%Y-%m-%d %H:%M:%S"]
+ puts $chan($view) "### -*-conf-javaprop-*-"
+ puts $chan($view) "### Generated at $now: do not edit"
+ foreach zone $ZONES {
+ write-zone-stanza $view $chan($view) $zone
+ }
+ }
+ set win true
+ } {
+ if {$win} {
+ foreach view $ZONECFG(all-views) {
+ file rename -force -- "$out($view).new" $out($view)
+ }
+ eval exec $ZONECFG(reconfig-command)
+ } else {
+ file delete -force -- "$out($view).new"
+ }
+ }
+}
+
+defcmd install {user view name} {
+ help-text "Install a new zone file.
+
+The file is for the given zone NAME and the \(user-side) VIEW. The file is
+provided by the named USER"
+} {
+ global QUIS ZONECFG ZONES CONFFILE errorInfo errorCode
+
+ confspc-eval toplevel [list source $CONFFILE]
+
+ file mkdir [file join $ZONECFG(master-dir) "tmp"]
+
+ set cleanup {}
+ unwind-protect {
+
+ set matchview {}
+ foreach iview $ZONECFG(all-views) {
+ foreach info $ZONES {
+ array unset zone
+ array set zone [compute-zone-properties $iview $info]
+ if {[string equal $user $zone(user)] && \
+ [string equal "$zone(config-type)/$zone(type)" \
+ "master/static"] && \
+ [string equal $zone(name) $name] && \
+ [string equal $zone(mapped-view) $view]} {
+ lappend matchview $iview
+ if {![info exists matchinfo]} { set matchinfo [array get zone] }
+ }
+ }
+ }
+ if {![llength $matchview]} {
+ optparse-error "No match for zone `$name' in view `$view'"
+ }
+ array unset zone
+ array set zone $matchinfo
+
+ set pid [pid]
+ for {set i 0} {$i < 1000} {incr i} {
+ set tmp [file join $ZONECFG(master-dir) "tmp" \
+ "tmp.$pid.$i.$user.$name"]
+ if {![catch { set chan [open $tmp {WRONLY CREAT EXCL}] } msg]} {
+ break
+ } elseif {[string equal [lindex $errorCode 0] POSIX] && \
+ ![string equal [lindex $errorCode 1] EEXIST]} {
+ error $msg $errorInfo $errorCode
+ }
+ }
+ if {![info exists chan]} { error "failed to create temporary file" }
+ set cleanup [list file delete $tmp]
+
+ set total 0
+ while {true} {
+ set stuff [read stdin 4096]
+ if {![string length $stuff]} { break }
+ puts -nonewline $chan $stuff
+ incr total [string bytelength $stuff]
+ if {$total > $ZONECFG(max-zone-size)} {
+ error "zone file size limit exceeded"
+ }
+ }
+ close $chan
+
+ set cmd {}
+ foreach item $zone(checkzone-command) {
+ lappend cmd [string map [list \
+ "%z" $name \
+ "%v" $view \
+ "%f" $tmp] \
+ $item]
+ }
+ set rc [catch {
+ set out [eval exec $cmd]
+ } msg]
+ if {$rc} { set out $msg }
+ set out "| [string map [list "\n" "\n| "] $out]"
+ if {$rc} {
+ puts stderr "$QUIS: zone check failed..."
+ puts stderr $out
+ exit 1
+ } else {
+ puts "$QUIS: zone check output..."
+ puts $out
+ }
+
+ file rename -force -- $tmp $zone(file-name)
+ set cleanup {}
+ foreach view $matchview {
+ set cmd {}
+ foreach item $zone(reload-command) {
+ lappend cmd [string map [list \
+ "%v" $view \
+ "%z" $zone(name)] \
+ $item]
+ }
+ eval exec $cmd
+ }
+ } {
+ eval $cleanup
+ }
+}
+
+###--------------------------------------------------------------------------
+### Main program.
+
+set VERSION "1.0.0"
+set USAGE() " \[-OPTIONS] SUBCOMMAND \[ARGUMENTS...]"
+
+define-options OPTS {
+ option {
+ short "h"; long "help"
+ action { eval cmd/help [optparse-words]; exit }
+ }
+ option {
+ short "v"; long "version"
+ action { puts "$QUIS, version $VERSION"; exit }
+ }
+ option {
+ short "c"; long "config"; arg required
+ action { set CONFFILE [optparse-arg] }
+ }
+}
+
+with-option-parser $OPTS $argv {
+ optparse-option
+ set argv [optparse-words]
+}
+
+if {![llength $argv]} { usage-error }
+dispatch [lindex $argv 0] [lrange $argv 1 end]
+
+###----- That's all, folks --------------------------------------------------
~mdw / zoneconf / commitdiff