+++ /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 are not first in some other list.
- set ncand {}
- foreach cand $cand {
- foreach list $lists {
- if {[lsearch -exact $list $cand] <= 0} { lappend ncand $cand }
- }
- }
- set cand $ncand
-
- ## 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
- }
-}
-
-proc run {what command args} {
- ## Run a command, reporting the result. WHAT is shown in the output;
- ## COMMAND are the command and arguments as a list; these are substituted
- ## according to the string map ARGS. Return true if the command succeeded,
- ## false if it failed.
-
- global QUIS
-
- ## Substitute tokens in the command.
- set cmd {}
- set subst [concat [list "%%" "%"] $args]
- foreach item $command { lappend cmd [string map $subst $item] }
-
- ## Run the command.
- set rc [catch {
- set out [eval exec -ignorestderr $cmd 2>@1]
- } msg]
-
- ## Sort out the report.
- if {$rc} { set out $msg }
- set out "| [string map [list "\n" "\n| "] $out]"
-
- ## Announce the result.
- if {$rc} {
- puts stderr "$QUIS: $what failed..."
- puts stderr $out
- return false
- } else {
- puts "$QUIS: $what output..."
- puts $out
- return true
- }
-}
-
-###--------------------------------------------------------------------------
-### 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 #0 $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-simple soa-format increment
- define-list views *
- define-list sign-views {}
- define-list signzone-command {
- /usr/sbin/dnssec-signzone
- -g
- -S
- -K/var/lib/bind/key
- -d/var/lib/bind/ds
- -s-3600 -e+176400
- -N%q
- -o%z
- -f%o
- %f
- }
- define-simple auto-dnssec off
- define-list reload-command {/usr/sbin/rndc reload %z IN %v}
- define-list autosign-command {/usr/sbin/rndc sign %z IN %v}
- define-list checkzone-command {
- /usr/sbin/named-checkzone
- -ifull
- -kfail
- -Mfail
- -nfail
- -Sfail
- -Wfail
- %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} {
-
- ## OK, this needs careful documentation.
- ##
- ## The local nameserver presents a number of views according to its
- ## configuration. It is our purpose here to generate a configuration
- ## snippet for such a view.
- ##
- ## A user might have several different views of a zone which are meant to
- ## be presented to different clients. These map on to the server views
- ## in a one-to-many fashion. The `view-map' option defines this mapping.
- ## The argument is a list of alternating SERVER-VIEW USER-VIEW pairs; the
- ## SERVER-VIEW may be a glob pattern; the USER-VIEW may be the special
- ## token `=' to mean `same as the SERVER-VIEW'.
- ##
- ## We only keep one copy of the zone file for each user view: if the user
- ## view is used by many server views, then the zone stanza for each of
- ## those views refers to the same zone file.
-
- 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 server 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
- }
- }
- }
-
- ## Work out the file names.
- switch -glob -- $zone(config-type):$zone(type) {
- master:static {
- set dir $zone(master-dir)
- set nameview $zone(mapped-view)
- }
- default {
- set dir $zone(slave-dir)
- set nameview $view
- }
- }
- set zone(file-name) [file join $dir \
- [zone-file-name $nameview $config]]
-
- ## Find out whether this zone wants signing.
- set zone(sign) false
- switch -glob -- $zone(config-type):$zone(type) {
- master:static {
- foreach sview $zone(sign-views) {
- if {[string match $zone(mapped-view) $sview]} { set zone(sign) true }
- }
- }
- }
- if {$zone(sign)} {
- set zone(server-file-name) "$zone(file-name).sig"
- } else {
- set zone(server-file-name) $zone(file-name)
- }
-
- ## 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 sign-zone-file {info input soafmt} {
- ## Sign the zone described by INFO. The input zone file is INPUT; the SOA
- ## should be updated according to SOAFMT.
-
- global QUIS
-
- array set zone $info
- return [run "zone `$zone(name)' in view `$zone(mapped-view)'" \
- $zone(signzone-command) \
- "%z" $zone(name) \
- "%f" $zone(file-name) \
- "%o" $zone(server-file-name) \
- "%q" $soafmt]
-}
-
-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(server-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)\";"
- if {![string equal $zone(auto-dnssec) off]} {
- puts $chan "\tauto-dnssec $zone(auto-dnssec);"
- }
- 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
-
- ## Read the configuration.
- confspc-eval toplevel [list source $CONFFILE]
-
- ## Safely update the files.
- set win false
- unwind-protect {
-
- ## Work through each server view.
- foreach view $ZONECFG(all-views) {
-
- ## Open an output file.
- set out($view) [output-file-name $view]
- set chan($view) [open "$out($view).new" w]
-
- ## Write a header.
- 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"
-
- ## Now print a stanza for each zone in the view.
- foreach zone $ZONES {
- write-zone-stanza $view $chan($view) $zone
- }
- }
-
- ## Done: don't delete the output.
- set win true
- } {
-
- ## Close the open files.
- foreach view $ZONECFG(all-views) { close $chan($view) }
-
- ## If we succeeded, rename the output files into their proper places;
- ## otherwise, delete them.
- 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 \(user-side) VIEW. The file is
-provided by the named USER"
-} {
- global QUIS ZONECFG ZONES CONFFILE errorInfo errorCode
-
- ## Read the configuration.
- confspc-eval toplevel [list source $CONFFILE]
-
- ## Make sure there's a temporary directory.
- file mkdir [file join $ZONECFG(master-dir) "tmp"]
-
- ## Keep track of cleanup jobs.
- set cleanup {}
- unwind-protect {
-
- ## Find out which server views are affected by this update.
- 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
-
- ## Make a new temporary file to read the zone into.
- 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]
-
- ## Read the zone data from standard input into the file.
- 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
-
- ## Check the zone for sanity.
- if {![run "zone check" $zone(checkzone-command) \
- "%z" $name \
- "%v" $view \
- "%f" $tmp]} {
- eval $cleanup
- exit 1
- }
-
- ## If the zone wants signing, better to do that now.
- if {![sign-zone-file $matchinfo $tmp keep]} {
- eval $cleanup
- exit 2
- }
-
- ## All seems good: stash the file in the proper place and reload the
- ## necessary server views.
- file rename -force -- $tmp $zone(file-name)
- set cleanup {}
- foreach view $matchview {
- if {![run "reload zone `$zone(name) in view `$view'" \
- $zone(reload-command) \
- "%v" $view \
- "%z" $zone(name)]} {
- exit 3
- }
- }
- } {
- eval $cleanup
- }
-}
-
-defcmd sign {} {
- help-text "Sign DNSSEC zones."
-} {
- global QUIS ZONECFG ZONES CONFFILE
-
- set rc 0
-
- ## Read the configuration.
- confspc-eval toplevel [list source $CONFFILE]
-
- ## Grind through all of the zones.
- array unset seen
- foreach view $ZONECFG(all-views) {
- foreach info $ZONES {
-
- ## Fetch the zone information.
- array unset zone
- set compinfo [compute-zone-properties $view $info]
- array set zone $compinfo
- if {![string equal $zone(config-type) master]} { continue }
-
- if {[string equal $zone(type) static] && $zone(sign)} {
- ## Static zone: re-sign it if we haven't seen this user view before,
- ## and then reload.
-
- ## Sign the zone file if we haven't tried before.
- set id [list $zone(name) $zone(mapped-view)]
- if {![info exists seen($id)]} {
- if {[sign-zone-file $compinfo \
- $zone(file-name) $zone(soa-format)]} {
- set seen($id) true
- } else {
- set rc 2
- set seen($id) failed
- }
- }
-
- ## If we succeeded, reload the zone in this server view.
- if {[string equal $seen($id) true]} {
- if {![run "reload zone `$zone(name) in server view `$view'" \
- $zone(reload-command) \
- "%z" $zone(name) \
- "%v" $view]} {
- set rc 2
- }
- }
- } elseif {[string equal $zone(type) dynamic] &&
- ![string equal $zone(auto-dnssec) off]} {
- ## Dynamic zone: get BIND to re-sign it.
-
- if {![run "re-sign zone `$zone(name) in server view `$view'" \
- $zone(autosign-command) \
- "%z" $zone(name) \
- "%v" $view]} {
- set rc 2
- }
- }
- }
- }
- exit $rc
-}
-
-###--------------------------------------------------------------------------
-### 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 / blobdiff