#! @TCLSH@
### -*-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-simple auto-dnssec off
  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.
set HOME "@pkgstatedir@"
set BINDPROGS "@bindprogsdir@"
define-configuration-space zone ZONECFG {
  define-simple user root
  define-simple home-dir $HOME
  define-simple static-dir "$HOME/static"
  define-simple dynamic-dir "$HOME/dynamic"
  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 \
      [list "$BINDPROGS/dnssec-signzone" \
	   "-g" \
	   "-S" \
	   "-K%h/key" \
	   "-d%h/ds" \
	   "-s-3600" "-e+176400" "-i90000" \
	   "-N%q" \
	   "-o%z" \
	   "-f%o" \
	   "%f"]
  define-list reload-command [list "$BINDPROGS/rndc" "reload" "%z" "IN" "%v"]
  define-list autosign-command [list "$BINDPROGS/rndc" "sign" "%z" "IN" "%v"]
  define-list checkzone-command \
      [list "$BINDPROGS/named-checkzone" \
	   "-ifull" \
	   "-kfail" \
	   "-Mfail" \
	   "-nfail" \
	   "-Sfail" \
	   "-Wfail" \
	   "%z" "%f"]

  define setvar {name value} {
    dict set ZONECFG(var) $name $value
  }

  define primary {map} {
    ## There's a grim hack here: a primary-address entry may have the form
    ## REAL!FAKE.  If the REAL address is not a local address then this
    ## is used as the master address; otherwise the FAKE address is used.
    ## This is useful for inter-view updates of dynamic zones on the same
    ## host.  I suggest abusing 127.0.0.0/8 addresses for this kind of
    ## chicanery.
    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 "$HOME/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 masters {}
	set zone(config-type) slave
	foreach host $hosts {
	  set bang [string first "!" $host]
	  if {$bang >= 0} {
	    set after [string range $host [expr {$bang + 1}] end]
	    if {$bang} {
	      set before [string range $host 0 [expr {$bang - 1}]]
	    } else {
	      set before $after
	    }
	    if {[local-address-p $before]} {
	      set host $after
	    } else {
	      set host $before
	    }
	  } elseif {[local-address-p $host]} {
	    set zone(config-type) master
	  }
	  lappend masters $host
	}
	set zone(masters) $masters
	break
      }
    }
  }

  ## Work out the file names.
  switch -glob -- $zone(config-type):$zone(type) {
    master:static {
      set dir $zone(static-dir)
      set nameview $zone(mapped-view)
    }
    default {
      set dir $zone(dynamic-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 soafmt infile} {
  ## 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
  set outfile "$zone(server-file-name).new"
  if {![run "sign zone `$zone(name)' in view `$zone(mapped-view)'" \
	    $zone(signzone-command) \
	    "%h" $zone(home-dir) \
	    "%m" $zone(static-dir) \
	    "%s" $zone(dynamic-dir) \
	    "%z" $zone(name) \
	    "%f" $infile \
	    "%o" $outfile \
	    "%q" $soafmt]} {
    file delete -force $outfile
    return false
  }
  file rename -force $outfile $zone(server-file-name)
  return true
}

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
	  if {![string equal $zone(ddns-auto-dnssec) off]} {
	    puts $chan "\tauto-dnssec $zone(ddns-auto-dnssec);"
	  }
	}
      }
    }
    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 "@pkgconfdir@/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) {
      catch { 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 {
      catch { 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(home-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(home-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 {$zone(sign) && ![sign-zone-file $matchinfo keep $tmp]} {
      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(soa-format) \
		   $zone(server-file-name)]} {
	    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(ddns-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 "@VERSION@"
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 --------------------------------------------------