From 2a65b7cf92492d551ba81513ca0bf4655e430905 Mon Sep 17 00:00:00 2001
Message-Id: <2a65b7cf92492d551ba81513ca0bf4655e430905.1715078004.git.mdw@distorted.org.uk>
From: Mark Wooding <mdw@chiark.greenend.org.uk>
Date: Fri, 5 Aug 2011 23:54:19 +0100
Subject: [PATCH] zoneconf: Program for managing multi-viewed DNS
 configurations.
Organization: Straylight/Edgeware

From: Mark Wooding <mdw@distorted.org.uk>

I'm sure I had another Git repository of this somewhere, but I'm blowed
if I can find it anywhere.  Oh, well: I don't think there was much
interesting history in it anyway.
---
 .gitignore        |    2 +
 .userv/rc         |   20 +
 bin/ssh-install   |   11 +
 bin/userv-install |   10 +
 bin/zoneconf      | 1348 +++++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 1391 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 .userv/rc
 create mode 100755 bin/ssh-install
 create mode 100755 bin/userv-install
 create mode 100755 bin/zoneconf

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..c1a6249
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+.ssh
+config
diff --git a/.userv/rc b/.userv/rc
new file mode 100644
index 0000000..b0a0867
--- /dev/null
+++ b/.userv/rc
@@ -0,0 +1,20 @@
+### -*-conf-*-
+### userv services for zoneconf
+
+if ( glob service install
+   & grep calling-user-shell /etc/shells
+   )
+	require-fd 0 read
+	require-fd 1-2 write
+	no-suppress-args
+	execute bin/uinstall
+fi
+
+if ( glob service update
+   & glob calling-user root
+   )
+	require-fd 0 read
+	require-fd 1-2 write
+	no-suppress-args
+	execute bin/zoneconf update
+fi
diff --git a/bin/ssh-install b/bin/ssh-install
new file mode 100755
index 0000000..0e323b9
--- /dev/null
+++ b/bin/ssh-install
@@ -0,0 +1,11 @@
+#! /bin/sh
+
+set -e
+set -- $SSH_ORIGINAL_COMMAND
+case $# in
+  2) ;;
+  *) echo >&2 "Usage: $0 VIEW ZONE"; exit 1 ;;
+esac
+
+view="$1" zone="$2"
+exec bin/zoneconf install "$SSH_USER" "$view" "$zone"
diff --git a/bin/userv-install b/bin/userv-install
new file mode 100755
index 0000000..c81faa8
--- /dev/null
+++ b/bin/userv-install
@@ -0,0 +1,10 @@
+#! /bin/sh
+
+set -e
+case $# in
+  2) ;;
+  *) echo >&2 "Usage: $0 VIEW ZONE"; exit 1 ;;
+esac
+
+view="$1" zone="$2"
+exec bin/zoneconf install "$USERV_USER" "$view" "$zone"
diff --git a/bin/zoneconf b/bin/zoneconf
new file mode 100755
index 0000000..fd8531f
--- /dev/null
+++ b/bin/zoneconf
@@ -0,0 +1,1348 @@
+#! /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]