chiark - git - mdw - zoneconf/blob - zoneconf.in

   1 #! @TCLSH@
   2 ### -*-tcl-*-
   3 ###
   4 ### Generate `named.conf' stanze for multiple views.
   5 ###
   6 ### (c) 2011 Mark Wooding
   7 ###
   8
   9 ###----- Licensing notice ---------------------------------------------------
  10 ###
  11 ### This program is free software; you can redistribute it and/or modify
  12 ### it under the terms of the GNU General Public License as published by
  13 ### the Free Software Foundation; either version 2 of the License, or
  14 ### (at your option) any later version.
  15 ###
  16 ### This program is distributed in the hope that it will be useful,
  17 ### but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ### GNU General Public License for more details.
  20 ###
  21 ### You should have received a copy of the GNU General Public License
  22 ### along with this program; if not, write to the Free Software Foundation,
  23 ### Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  24
  25 ###--------------------------------------------------------------------------
  26 ### Utility functions.
  27
  28 proc pushnew {var args} {
  29   ## Append each of the ARGS onto the list VAR if they're not there already.
  30
  31   upvar 1 $var list
  32   foreach item $list { set found($item) t }
  33   foreach item $args {
  34     if {![info exists found($item)]} {
  35       lappend list $item
  36       set found($item) t
  37     }
  38   }
  39 }
  40
  41 proc merge-lists {lists} {
  42   ## Merge the given LISTS into a single list, respecting the order of the
  43   ## items in the original list.  If that's not possible, signal an error.
  44   ## Any ambiguity is resolved by choosing the item from the earlier list.
  45
  46   ## Strip out any empty lists in the input.
  47   set nlists {}
  48   foreach list $lists {
  49     if {[llength $list]} { lappend nlists $list }
  50   }
  51   set lists $nlists
  52
  53   ## Clear the output list.
  54   set output {}
  55
  56   ## Now pick out items one by one.
  57   while {[llength $lists]} {
  58
  59     ## Find the candidate items
  60     set cand {}
  61     foreach list $lists { pushnew cand [lindex $list 0] }
  62
  63     ## Remove candidate items which are not first in some other list.
  64     set ncand {}
  65     foreach cand $cand {
  66       foreach list $lists {
  67         if {[lsearch -exact $list $cand] <= 0} { lappend ncand $cand }
  68       }
  69     }
  70     set cand $ncand
  71
  72     ## If there's nothing left, report an error.
  73     if {![llength $cand]} {
  74       error "Inconsistent lists in `merge-lists'."
  75     }
  76
  77     ## Otherwise take the first item.
  78     set chosen [lindex $cand 0]
  79     lappend output $chosen
  80
  81     ## Remove the chosen item from the input lists.
  82     set nlists {}
  83     foreach list $lists {
  84       if {[string equal $chosen [lindex $list 0]]} {
  85         set list [lrange $list 1 end]
  86         if {![llength $list]} { continue }
  87       }
  88       lappend nlists $list
  89     }
  90     set lists $nlists
  91   }
  92
  93   return $output
  94 }
  95
  96 proc adjust-uplevel {spec offset} {
  97   ## Adjust an `uplevel' SPEC by OFFSET to take account of intervening call
  98   ## frames.  If SPEC begins with `#' then it is left alone; otherwise it is
  99   ## incremented by OFFSET.
 100
 101   switch -glob -- $spec {
 102     \#* { return $spec }
 103     default { return [expr {$spec + $offset}] }
 104   }
 105 }
 106
 107 proc unwind-protect {body cleanup} {
 108   ## Evaluate BODY; then evaluate CLEANUP, regardless of whether BODY
 109   ## returned normally or did something complicated.  If CLEANUP completes
 110   ## normally then the final result is that of BODY (including any errors or
 111   ## abnormal returns it made); otherwise the result of CLEANUP takes
 112   ## precedence and the results of BODY are discarded.
 113
 114   catch { uplevel 1 $body } bodyval bodyopts
 115   if {[catch { uplevel 1 $cleanup } cleanval cleanopts]} {
 116     return -options $cleanopts $cleanval
 117   } else {
 118     return -options $bodyopts $bodyval
 119   }
 120 }
 121
 122 proc let {args} {
 123   ## Syntax: let VAR VALUE ... BODY
 124   ##
 125   ## Evaluate BODY with the VARs bound to the VALUEs.  Reestore the previous
 126   ## values when the BODY returns.
 127
 128   ## Parse the argument syntax.
 129   if {[llength $args] % 2 == 0} {
 130     error "bad number of arguments to `let'"
 131   }
 132   set body [lindex $args end]
 133
 134   ## Now work through the bindings, setting the variables to their new
 135   ## values.  As we go, also build up code in `cleanup' to restore everything
 136   ## the way it's meant to be.
 137   set cleanup {}
 138   set i 0
 139   foreach {var value} [lrange $args 0 end-1] {
 140     upvar 1 $var fluid-$i
 141     if {[info exists fluid-$i]} {
 142       append cleanup "set fluid-$i [list [set fluid-$i]]\n"
 143     } else {
 144       append cleanup "unset fluid-$i\n"
 145     }
 146     set fluid-$i $value
 147     incr i
 148   }
 149
 150   ## Now evaluate the body.
 151   unwind-protect { uplevel 1 $body } $cleanup
 152 }
 153
 154 proc set* {names values} {
 155   ## Set each of the variables listed in NAMES to the corresponding element
 156   ## of VALUES.  The two lists must have the same length.
 157
 158   if {[llength $names] != [llength $values]} {
 159     error "length mismatch"
 160   }
 161   foreach name $names value $values {
 162     upvar 1 $name var
 163     set var $value
 164   }
 165 }
 166
 167 proc run {what command args} {
 168   ## Run a command, reporting the result.  WHAT is shown in the output;
 169   ## COMMAND are the command and arguments as a list; these are substituted
 170   ## according to the string map ARGS.  Return true if the command succeeded,
 171   ## false if it failed.
 172
 173   global QUIS
 174
 175   ## Substitute tokens in the command.
 176   set cmd {}
 177   set subst [concat [list "%%" "%"] $args]
 178   foreach item $command { lappend cmd [string map $subst $item] }
 179
 180   ## Run the command.
 181   set rc [catch {
 182     set out [eval exec -ignorestderr $cmd 2>@1]
 183   } msg]
 184
 185   ## Sort out the report.
 186   if {$rc} { set out $msg }
 187   set out "| [string map [list "\n" "\n| "] $out]"
 188
 189   ## Announce the result.
 190   if {$rc} {
 191     puts stderr "$QUIS: $what failed..."
 192     puts stderr $out
 193     return false
 194   } else {
 195     puts "$QUIS: $what output..."
 196     puts $out
 197     return true
 198   }
 199 }
 200
 201 ###--------------------------------------------------------------------------
 202 ### Configuration spaces.
 203 ###
 204 ### A configuration space is essentially a collection of Tcl commands and a
 205 ### global array which the commands act on.  The commands live in their own
 206 ### namespace and their availability can be altered by modifying the
 207 ### namespace path.  The basic idea is to support a structured configuration
 208 ### language with short directive names and where the available directives
 209 ### varies in a context-sensitive manner.
 210 ###
 211 ### A configuration space can include other spaces, and they can include
 212 ### further spaces.  The graph of inclusions must be acyclic; further, since
 213 ### the available commands are determined using the C3 linearization
 214 ### algorithm, the relation in which a space precedes the spaces it includes,
 215 ### and a space A precedes another space B if a third space includes A before
 216 ### B, must be a partial order, and the linearizations of all of the spaces
 217 ### must be monotonic.  Don't worry about that if you don't know what it
 218 ### means.  If you don't do anything weird, it'll probably be all right.
 219
 220 proc confspc-create {space confvar} {
 221   ## Define a new configuration space called SPACE.  You must do this before
 222   ## defining directives or including other spaces.
 223
 224   global CONFSPC_CMD CONFSPC_INCL CONFSPC_CPL CONFSPC_CHANGE CONFSPC_VAR
 225   if {![info exists CONFSPC_CMD($space)]} {
 226     set CONFSPC_CMD($space) {}
 227     set CONFSPC_INCL($space) {}
 228     set CONFSPC_CPL($space) [list $space]
 229     set CONFSPC_CHANGE($space) 0
 230     set CONFSPC_VAR($space) $confvar
 231     namespace eval ::confspc::$space {}
 232   }
 233 }
 234
 235 ## Change sequence numbers are used to decide whether the linearized
 236 ## inclusion caches are up to date.
 237 set CONFSPC_LASTCHANGESEQ 0
 238 set CONFSPC_CHANGESEQ 0
 239
 240 proc confspc-command {space name bvl body} {
 241   ## Define a configuration directive NAME in SPACE, accepting the arguments
 242   ## specified by the BVL, and executing BODY when invoked.  The SPACE's
 243   ## configuration array is available within the BODY.
 244
 245   global CONFSPC_CMD CONFSPC_VAR
 246   pushnew CONFSPC_CMD($space) $name
 247
 248   ## Define the configuration command in the caller's namespace.
 249   set ns [uplevel 1 { namespace current }]
 250   eval [list proc ${ns}::conf/$space/$name $bvl \
 251             "global $CONFSPC_VAR($space)\n$body"]
 252   namespace eval $ns [list namespace export conf/$space/$name]
 253
 254   ## Now arrange for this command to exist properly in the configuration
 255   ## space.
 256   namespace eval ::confspc::$space \
 257       [list namespace import ${ns}::conf/$space/$name]
 258   catch {
 259     namespace eval ::confspc::$space [list rename $name {}]
 260   }
 261   namespace eval ::confspc::$space \
 262       [list rename conf/$space/$name $name]
 263 }
 264
 265 proc confspc-include {space includes} {
 266   ## Arrange for SPACE to include the directives from the INCLUDES spaces.
 267
 268   global CONFSPC_INCL CONFSPC_LASTCHANGESEQ CONFSPC_CHANGESEQ
 269   pushnew CONFSPC_INCL($space) $includes
 270   if {$CONFSPC_CHANGESEQ <= $CONFSPC_LASTCHANGESEQ} {
 271     set CONFSPC_CHANGESEQ [expr {$CONFSPC_LASTCHANGESEQ + 1}]
 272   }
 273 }
 274
 275 proc confspc-update {space} {
 276   ## Update cached data for SPACE and its included spaces.  We recompute the
 277   ## space's class-precedence list, for which we use the C3 linearization
 278   ## algorithm, which has known good properties.
 279
 280   global CONFSPC_CPL CONFSPC_CHANGE CONFSPC_INCL
 281   global CONFSPC_CHANGESEQ CONFSPC_LASTCHANGESEQ
 282   set CONFSPC_LASTCHANGESEQ $CONFSPC_CHANGESEQ
 283
 284   ## If the space is already up-to-date, do nothing.
 285   if {$CONFSPC_CHANGE($space) == $CONFSPC_CHANGESEQ} { return }
 286
 287   ## Arrange for the included spaces to be up-to-date, and gather the CPLs
 288   ## together so we can merge them.
 289   set merge {}
 290   lappend merge [concat $space $CONFSPC_INCL($space)]
 291   foreach included $CONFSPC_INCL($space) {
 292     confspc-update $included
 293     lappend merge $CONFSPC_CPL($included)
 294   }
 295
 296   ## Do the merge and update the change indicator.
 297   set CONFSPC_CPL($space) [merge-lists $merge]
 298   set CONFSPC_CHANGE($space) $CONFSPC_CHANGESEQ
 299 }
 300
 301 proc confspc-path {ns cpl} {
 302   ## Update namespace NS's command path so that it has (only) the
 303   ## directives of the given CPL.  Pass an empty CPL to clear the
 304   ## configuration space hacking.
 305
 306   set path {}
 307
 308   ## Add the new namespaces to the front.
 309   foreach spc $cpl { lappend path ::confspc::$spc }
 310
 311   ## Now add the existing path items, with any existing confspc hacking
 312   ## stripped out.
 313   foreach item [namespace eval $ns { namespace path }] {
 314     if {![string match "::confspc::*" $item]} { lappend npath $item }
 315   }
 316
 317   ## Commit the result.
 318   namespace eval $ns [list namespace path $path]
 319 }
 320
 321 proc confspc-set {ns space} {
 322   ## Set the command path for namespace NS to include the configuration
 323   ## directives of SPACE (and its included spaces).
 324
 325   global CONFSPC_CPL
 326   confspc-update $space
 327   confspc-path $ns $CONFSPC_CPL($space)
 328 }
 329
 330 proc confspc-eval {space body} {
 331   ## Evaluate BODY in the current namespace, but augmented with the
 332   ## directives from the named SPACE.  The command path of the current
 333   ## namespace is restored afterwards.
 334
 335   set ns [uplevel 1 { namespace current }]
 336   set path [namespace eval $ns { namespace path }]
 337   unwind-protect {
 338     confspc-set $ns $space
 339     uplevel 1 $body
 340   } {
 341     namespace eval $ns [list namespace path $path]
 342   }
 343 }
 344
 345 proc preserving-config {confvar body} {
 346   ## Evaluate BODY, but on exit restore the CONFVAR array so that the BODY
 347   ## has no lasting effect on it.
 348
 349   upvar #0 $confvar CONFIG
 350   set old [array get CONFIG]
 351   unwind-protect {
 352     uplevel 1 $body
 353   } {
 354     array unset CONFIG
 355     array set CONFIG $old
 356   }
 357 }
 358
 359 confspc-create confspc CONFSPC_CONFIG
 360
 361 confspc-command confspc include {args} {
 362   ## Include the named configuration spaces in the current one.
 363
 364   confspc-include $CONFSPC_CONFIG(space) $args
 365 }
 366
 367 confspc-command confspc define {name bvl body} {
 368   ## Define a directive NAME in the current space, taking arguments BVL, and
 369   ## having the given BODY.
 370
 371   confspc-command $CONFSPC_CONFIG(space) $name $bvl $body
 372 }
 373
 374 confspc-command confspc define-simple {setting default} {
 375   ## Define a directive SETTING which sets the appropriately prefixed entry
 376   ## in the CONFIG array to its single arguments, and immediately set the
 377   ## CONFIG entry to DEFAULT.
 378
 379   global CONFSPC_VAR
 380   set space $CONFSPC_CONFIG(space)
 381   upvar #0 $CONFSPC_VAR($space) config
 382   confspc-command $space $setting arg \
 383       "set $CONFSPC_VAR($space)($CONFSPC_CONFIG(prefix)$setting) \$arg"
 384   set config($CONFSPC_CONFIG(prefix)$setting) $default
 385 }
 386
 387 confspc-command confspc define-list {setting default} {
 388   ## Define a directive SETTING which sets the appropriately prefixed entry
 389   ## in the CONFIG array to its entire argument list, and immediately set the
 390   ## CONFIG entry to DEFAULT (which should be a Tcl list, not a collection of
 391   ## arguments).
 392
 393   global CONFSPC_VAR
 394   set space $CONFSPC_CONFIG(space)
 395   upvar #0 $CONFSPC_VAR($space) config
 396   confspc-command $space $setting args \
 397       "set $CONFSPC_VAR($space)($CONFSPC_CONFIG(prefix)$setting) \$args"
 398   set config($CONFSPC_CONFIG(prefix)$setting) $default
 399 }
 400
 401 confspc-command confspc prefix {prefix} {
 402   set CONFSPC_CONFIG(prefix) $prefix
 403 }
 404
 405 proc define-configuration-space {space confvar body} {
 406   ## Define a new configuration space named SPACE.  The BODY is Tcl code,
 407   ## though it may make use of `include' and `define'.
 408
 409   global CONFSPC_CONFIG
 410   set ns [uplevel 1 { namespace current }]
 411   set oldpath [namespace eval $ns { namespace path }]
 412   confspc-create $space $confvar
 413   unwind-protect {
 414     preserving-config CONFSPC_CONFIG {
 415       array set CONFSPC_CONFIG [list space $space \
 416                                     prefix ""]
 417       confspc-set $ns confspc
 418       uplevel 1 $body
 419     }
 420   } {
 421     namespace eval $ns [list namespace path $oldpath]
 422   }
 423 }
 424
 425 ###--------------------------------------------------------------------------
 426 ### Option parsing.
 427 ###
 428 ### The option parsing machinery makes extensive use of a state array
 429 ### OPTPARSE_STATE in order to maintain its context.  The procedure
 430 ### `with-option-parser' establishes this array correctly, and preserves any
 431 ### existing state, so there should be no trouble with multiple parsers in
 432 ### the same program.
 433
 434 proc optparse-more-p {} {
 435   ## Answer whether there are more argument words available.
 436
 437   upvar #0 OPTPARSE_STATE state
 438   if {[llength $state(words)]} { return true } else { return false }
 439 }
 440
 441 proc optparse-next-word {} {
 442   ## Return the next word in the argument list.  It is an error if there are
 443   ## no more words left.
 444
 445   upvar #0 OPTPARSE_STATE state
 446   set word [lindex $state(words) 0]
 447   set state(words) [lrange $state(words) 1 end]
 448   return $word
 449 }
 450
 451 proc optparse-error {message} {
 452   ## Report an error message and exit.
 453
 454   global QUIS
 455   puts stderr "$QUIS: $message"
 456   exit 1
 457 }
 458
 459 proc optparse-option/short {var} {
 460   ## Parse the next short option from the current cluster.  If there are no
 461   ## more short options, set the mode back to `free' and call back into
 462   ## `optparse-option/free'.
 463   ##
 464   ## See the description of `optparse-option/free' for the interface
 465   ## implemented by this procedure.
 466
 467   ## Get hold of my state and the caller's array.
 468   upvar #0 OPTPARSE_STATE state
 469   upvar 1 $var opt
 470
 471   ## Work out what to do based on the remaining length of the cluster.  (The
 472   ## cluster shouldn't be empty because the mode should only be set to
 473   ## `short' if there is an initial nonempty cluster to parse, and we set it
 474   ## back to `free' when we consume the final character from the cluster.)
 475   ## Specifically, set `argp' according to whether we have a potential
 476   ## argument in the cluster, and `name' to the option character extracted.
 477   array unset opt
 478   switch [string length $state(rest)] {
 479     0 {
 480       error "empty cluster"
 481     }
 482     1 {
 483       set argp false
 484       set state(mode) free
 485       set name $state(rest)
 486     }
 487     default {
 488       set argp true
 489       set name [string index $state(rest) 0]
 490       set state(rest) [string range $state(rest) 1 end]
 491     }
 492   }
 493
 494   ## Try to look up the option in the map.
 495   if {![dict exists $state(short-map) $name]} {
 496     optparse-error "Unknown option `$state(prefix)$name'"
 497   }
 498   array set opt [dict get $state(short-map) $name]
 499   set state(name) $name
 500
 501   ## Collect an argument if one is required.
 502   catch { unset state(arg) }
 503   switch -glob -- "$opt(arg),$argp" {
 504     "required,false" {
 505       if {![optparse-more-p]} {
 506         optparse-error "Option `$state(prefix)$name' requires an argument"
 507       }
 508       set state(arg) [optparse-next-word]
 509     }
 510     "required,true" - "optional,true" {
 511       set state(arg) $state(rest)
 512       set state(mode) free
 513     }
 514   }
 515
 516   ## Report success.
 517   return 1
 518 }
 519
 520 proc optparse-option/free {var} {
 521   ## Parse the next option from the argument list.  This procedure is called
 522   ## to process a new argument word, i.e., we are in `free' mode.  It
 523   ## analyses the next argument word and either processes it internally or
 524   ## sets the mode appropriately and calls a specialized handler
 525   ## `optparse-option/MODE' for that mode.
 526   ##
 527   ## The interface works as follows.  If an option was found, then the array
 528   ## VAR is set according to the option's settings dictionary; and state
 529   ## variables are set as follows.
 530   ##
 531   ## prefix     The prefix character(s) to write before the option name in
 532   ##            messages, e.g., `--' for long options.
 533   ##
 534   ## name       The option name without any prefix attached.
 535   ##
 536   ## arg        The option's argument, if there is one; otherwise unset.
 537
 538   upvar #0 OPTPARSE_STATE state
 539   upvar 1 $var opt
 540
 541   ## Set stuff up.
 542   array unset opt
 543   catch { unset state(arg) }
 544   if {![optparse-more-p]} { return 0 }
 545   set word [optparse-next-word]
 546
 547   ## Work out what to do based on the word.  The order of these tests is
 548   ## critically important.
 549   switch -glob -- $word {
 550
 551     "--" {
 552       ## End-of-options marker.
 553
 554       return 0
 555     }
 556
 557     "--*" {
 558       ## Long option.
 559
 560       set state(prefix) "--"
 561
 562       ## If there's an equals sign, the name is the bit to the left; keep the
 563       ## remainder as an argument.
 564       set eq [string first "=" $word 2]
 565       if {$eq >= 0} {
 566         set name [string range $word 2 [expr {$eq - 1}]]
 567         set state(arg) [string range $word [expr {$eq + 1}] end]
 568         set argp true
 569       } else {
 570         set name [string range $word 2 end]
 571         set argp false
 572       }
 573       set state(name) name
 574
 575       ## Look the name up in the map.
 576       if {[dict exists $state(long-map) $name]} {
 577         array set opt [dict get $state(long-map) $name]
 578       } else {
 579         set matches [dict keys $state(long-map) "$name*"]
 580         switch -exact -- [llength $matches] {
 581           1 { array set opt [dict get $state(long-map) [lindex $matches 0]] }
 582           0 { optparse-error "Unknown option `--$name'" }
 583           default {
 584             optparse-error "Ambiaguous option `--$name' \
 585             (matches: --[join $matches {, --}])"
 586           }
 587         }
 588       }
 589
 590       ## Now check whether we want an argument.  The missing cases are
 591       ## because we are already in the correct state.
 592       switch -glob -- "$opt(arg),$argp" {
 593         "none,true" {
 594           optparse-error "Option `$name' doesn't accept an argument"
 595         }
 596         "required,false" {
 597           if {![optparse-more-p]} {
 598             optparse-error "Option `$name' requires an argument"
 599           }
 600           set state(arg) [optparse-next-word]
 601         }
 602       }
 603
 604       ## Done.  We consumed either one or two entire argument words, so we
 605       ## should remain in the `free' state.
 606       return 1
 607     }
 608
 609     "-?*" {
 610       ## Short option.  Set state, initialize the cluster, and go.
 611
 612       set state(rest) [string range $word 1 end]
 613       set state(mode) short
 614       set state(prefix) "-"
 615       return [optparse-option/short opt]
 616     }
 617
 618     default {
 619       ## Some non-option thing.  Under POSIX rules, this ends the parse.  (We
 620       ## could do something more adventurous later.)
 621
 622       set state(words) [concat [list $word] $state(words)]
 623       return 0
 624     }
 625   }
 626 }
 627
 628 proc optparse-arg-p {} {
 629   ## Return the whether the most recently processed option had an argument.
 630
 631   upvar #0 OPTPARSE_STATE state
 632   return [info exists state(arg)]
 633 }
 634
 635 proc optparse-arg {} {
 636   ## Return the argument from the most recently processed option.  It is an
 637   ## error if no argument was supplied.
 638
 639   upvar #0 OPTPARSE_STATE state
 640   return $state(arg)
 641 }
 642
 643 proc optparse-words {} {
 644   ## Return the remaining unparsed argument words as a list.
 645
 646   upvar #0 OPTPARSE_STATE state
 647   return $state(words)
 648 }
 649
 650 proc optparse-option {} {
 651   ## Parse the next option(s).  The action taken depends on the option
 652   ## dictionary: if an `action' is provided then it is evaluated in the
 653   ## caller's context; otherwise the option's `tag' is returned.
 654
 655   upvar #0 OPTPARSE_STATE state
 656   while 1 {
 657     if {![optparse-option/$state(mode) opt]} {
 658       return done
 659     } elseif {[info exists opt(action)]} {
 660       uplevel 1 $opt(action)
 661     } elseif {[info exists opt(tag)]} {
 662       return $opt(tag)
 663     } else {
 664       error "Don't know what to do with option `$state(prefix)$state(name)'"
 665     }
 666   }
 667 }
 668
 669 proc with-option-parser {state words body} {
 670   ## Establish an option parsing context, initialized with the STATE
 671   ## (constructed using `define-options') and the lits of argument WORDS.
 672   ## The BODY may use `optparse-option', `optparse-arg', etc. to parse the
 673   ## options.
 674
 675   global OPTPARSE_STATE
 676   set old [array get OPTPARSE_STATE]
 677
 678   unwind-protect {
 679     array unset OPTPARSE_STATE
 680     array set OPTPARSE_STATE $state
 681     set OPTPARSE_STATE(mode) free
 682     set OPTPARSE_STATE(words) $words
 683     uplevel 1 $body
 684   } {
 685     array set OPTPARSE_STATE $old
 686   }
 687 }
 688
 689 define-configuration-space optparse-option OPTCFG {
 690   define-list short {}
 691   define-list long {}
 692   define action {act} { set OPTCFG(action) $act }
 693   define tag {tag} { set OPTCFG(tag) $tag }
 694   define-simple arg none
 695 }
 696
 697 define-configuration-space optparse OPTCFG {
 698   define option {body} {
 699     upvar #0 OPTPARSE_STATE state
 700     uplevel 1 [list confspc-eval optparse-option $body]
 701     set opt [array get OPTCFG]
 702     foreach kind {long short} {
 703       foreach name $OPTCFG($kind) {
 704         if {[dict exists $state($kind-map) $name]} {
 705           error "Already have an option with $kind name `$name'"
 706         }
 707         dict set state($kind-map) $name $opt
 708       }
 709     }
 710   }
 711 }
 712
 713 proc define-options {statevar body} {
 714   ## Define an option state, and write it to STATEVAR.  The BODY may contain
 715   ## `optparse' configuration directives to define the available options.
 716
 717   global OPTPARSE_STATE
 718   upvar 1 $statevar state
 719   set old [array get OPTPARSE_STATE]
 720   unwind-protect {
 721     array unset OPTPARSE_STATE
 722     if {[info exists state]} {
 723       array set OPTPARSE_STATE $state
 724     } else {
 725       array set OPTPARSE_STATE {
 726         long-map {}
 727         short-map {}
 728       }
 729     }
 730     uplevel 1 [list confspc-eval optparse $body]
 731     set state [array get OPTPARSE_STATE]
 732   } {
 733     array set OPTPARSE_STATE $old
 734   }
 735 }
 736
 737 ###--------------------------------------------------------------------------
 738 ### Subcommand handling.
 739
 740 ## Determine the program name.
 741 set QUIS [file tail $argv0]
 742
 743 ## This is fluid-bound to the name of the current command.
 744 set COMMAND {}
 745
 746 proc find-command {name} {
 747   ## Given a command NAME as typed by the user, find the actual command and
 748   ## return it.
 749
 750   global HELP
 751   set matches [info commands cmd/$name*]
 752   set cmds {}
 753   set doc {}
 754   foreach match $matches {
 755     set cmd [string range $match 4 end]
 756     lappend cmds $cmd
 757     if {[info exists HELP($cmd)]} { lappend doc $cmd }
 758   }
 759   switch -exact -- [llength $cmds] {
 760     1 { return [lindex $cmds 0] }
 761     0 { optparse-error "Unknown command `$name'" }
 762   }
 763   if {[llength $doc]} { set cmds $doc }
 764   switch -exact -- [llength $cmds] {
 765     1 { return [lindex $cmds 0] }
 766     0 { optparse-error "Unknown command `$name'" }
 767     default { optparse-error "Ambiguous command `$name' -- matches: $cmds" }
 768   }
 769 }
 770
 771 proc usage {cmd} {
 772   ## Return a usage message for CMD.  The message is taken from the `USAGE'
 773   ## array if that contains an entry for CMD (it should not include the
 774   ## command name, and should begin with a leading space); otherwise a
 775   ## message is constructed by examining the argument names and defaulting
 776   ## arrangements of the Tcl command cmd/CMD.
 777   ##
 778   ## By convention, the main program is denoted by an empty CMD name.
 779
 780   global USAGE
 781   if {[info exists USAGE($cmd)]} {
 782     set usage $USAGE($cmd)
 783   } else {
 784     set usage ""
 785     foreach arg [info args cmd/$cmd] {
 786       if {[string equal $arg "args"]} {
 787         append usage " ..."
 788       } elseif {[info default cmd/$cmd $arg hunoz]} {
 789         append usage " \[[string toupper $arg]\]"
 790       } else {
 791         append usage " [string toupper $arg]"
 792       }
 793     }
 794   }
 795   return $usage
 796 }
 797
 798 proc usage-error {} {
 799   ## Report a usage error in the current command.  The message is obtained by
 800   ## the `usage' procedure.
 801
 802   global QUIS COMMAND
 803   if {[string length $COMMAND]} { set cmd " $COMMAND" } else { set cmd "" }
 804   puts stderr "Usage: $QUIS$cmd[usage $COMMAND]"
 805   exit 1
 806 }
 807
 808 proc dispatch {name argv} {
 809   ## Invokes the handler for CMD, passing it the argument list ARGV.  This
 810   ## does some minimal syntax checking by examining the argument list to the
 811   ## command handler procedure cmd/COMMAND and issuing a usage error if
 812   ## there's a mismatch.
 813
 814   global COMMAND
 815   let COMMAND [find-command $name] {
 816
 817     ## Decode the argument list of the handler and set min and max
 818     ## appropriately.
 819     set args [info args cmd/$COMMAND]
 820     if {![llength $args]} {
 821       set* {min max} {0 0}
 822     } else {
 823       if {[string equal [lindex $args end] "args"]} {
 824         set max inf
 825         set args [lrange $args 0 end-1]
 826       } else {
 827         set max [llength $args]
 828       }
 829       set min 0
 830       foreach arg $args {
 831         if {[info default cmd/$COMMAND $arg hunoz]} { break }
 832         incr min
 833       }
 834     }
 835
 836     ## Complain if the number of arguments is inappropriate.
 837     set n [llength $argv]
 838     if {$n < $min || ($max != inf && $n > $max)} { usage-error }
 839
 840     ## Invoke the handler.
 841     eval cmd/$COMMAND $argv
 842   }
 843 }
 844
 845 define-configuration-space subcommand SUBCMD {
 846   define-simple help-text -
 847   define-simple usage-text -
 848 }
 849
 850 proc defcmd {name bvl defs body} {
 851   ## Define a command NAME with arguments BVL.  The `usage-text' and
 852   ## `help-text' commands can be used in DEFS to set messages for the new
 853   ## command.
 854
 855   global SUBCMD USAGE HELP
 856
 857   preserving-config SUBCMD {
 858     confspc-eval subcommand { uplevel 1 $defs }
 859     foreach tag {usage-text help-text} array {USAGE HELP} {
 860       if {![string equal $SUBCMD($tag) -]} {
 861         set ${array}($name) $SUBCMD($tag)
 862       }
 863     }
 864   }
 865   proc cmd/$name $bvl $body
 866 }
 867
 868 ## Standard subcommand handler to show information about the program or its
 869 ## subcommands.  To use this, you need to set a bunch of variables.
 870 ##
 871 ## USAGE(cmd)           Contains the usage message for cmd -- including
 872 ##                      leading space -- to use instead of the `usage'
 873 ##                      procedure's automagic.
 874 ##
 875 ## HELP(cmd)            Contains descriptive text -- not including a final
 876 ##                      trailing newline -- about the command.
 877 ##
 878 ## VERSION              The program's version number.
 879 ##
 880 ## The `defcmd' procedure can be used to set these things up conveniently.
 881 defcmd help {args} {
 882   usage-text " \[SUBCOMMAND ...]"
 883   help-text "Show help on the given SUBCOMMANDs, or on the overall program."
 884 } {
 885   global QUIS VERSION USAGE HELP
 886   if {[llength $args]} {
 887     foreach name $args {
 888       set cmd [find-command $name]
 889       puts "Usage: $QUIS $cmd[usage $cmd]"
 890       if {[info exists HELP($cmd)]} { puts "\n$HELP($cmd)" }
 891     }
 892   } else {
 893     puts "$QUIS, version $VERSION\n"
 894     puts "Usage: $QUIS$USAGE()\n"
 895     if {[info exists HELP()]} { puts "$HELP()\n" }
 896     puts "Subcommands available:"
 897     foreach name [info commands cmd/*] {
 898       set cmd [string range $name 4 end]
 899       puts "\t$cmd[usage $cmd]"
 900     }
 901   }
 902 }
 903
 904 ###--------------------------------------------------------------------------
 905 ### Build the configuration space for zone files.
 906
 907 proc host-addr {host} {
 908   ## Given a HOST name, return a list of its addresses.
 909
 910   if {![string match $host {*[!0-9.]*}]} { return $host }
 911   set adns [open [list | adnshost +Dc -s $host] r]
 912   unwind-protect {
 913     set addrs {}
 914     while {[gets $adns line] >= 0} {
 915       set* {name type fam addr} $line
 916       switch -glob -- $type:$fam {
 917         A:INET { lappend addrs $addr }
 918       }
 919     }
 920     return [lindex $addrs 0]
 921   } {
 922     close $adns
 923   }
 924 }
 925
 926 proc host-canonify {host} {
 927   ## Given a HOST name, return a canonical version of it.
 928
 929   set adns [open [list | adnshost -Dc -s $host] r]
 930   unwind-protect {
 931     while {[gets $adns line] >= 0} {
 932       switch -exact -- [lindex $line 1] {
 933         CNAME { return [lindex $line 2] }
 934         A - AAAA { return [lindex $line 0] }
 935       }
 936     }
 937     error "failed to canonify $host"
 938   } {
 939     close $adns
 940   }
 941 }
 942
 943 proc local-address-p {addr} {
 944   ## Answer whether the ADDR is one of the host's addresses.
 945
 946   if {[catch { set sk [socket -server {} -myaddr $addr 0] }]} {
 947     return false
 948   } else {
 949     close $sk
 950     return true
 951   }
 952 }
 953
 954 ## The list of zones configured by the user.
 955 set ZONES {}
 956
 957 ## Dynamic zone update policy specifications.
 958 define-configuration-space policy ZONECFG {
 959   define allow {identity nametype name args} {
 960     lappend ZONECFG(ddns-policy) \
 961         [concat grant [list $identity $nametype $name] $args]
 962   }
 963   define deny {identity nametype name args} {
 964     lappend ZONECFG(ddns-policy) \
 965         [concat deny [list $identity $nametype $name] $args]
 966   }
 967 }
 968
 969 ## Dynamic zone details.
 970 define-configuration-space dynamic ZONECFG {
 971   prefix "ddns-"
 972   define-simple key "ddns"
 973   define-simple auto-dnssec off
 974   define-list types {A TXT PTR}
 975
 976   define policy {body} {
 977     set ZONECFG(ddns-policy) {}
 978     uplevel 1 [list confspc-eval policy $body]
 979   }
 980
 981   set ZONECFG(ddns-policy) {}
 982 }
 983
 984 ## Everything about a zone.
 985 set HOME "@pkgstatedir@"
 986 set BINDPROGS "@bindprogsdir@"
 987 define-configuration-space zone ZONECFG {
 988   define-simple user root
 989   define-simple home-dir $HOME
 990   define-simple static-dir "$HOME/static"
 991   define-simple dynamic-dir "$HOME/dynamic"
 992   define-simple dir-mode 2775
 993   define-simple zone-file "%v/%z.zone"
 994   define-simple soa-format increment
 995   define-simple allow-query nil
 996   define-list views *
 997   define-list sign-views {}
 998   define-list signzone-command \
 999       [list "$BINDPROGS/dnssec-signzone" \
1000            "-g" \
1001            "-S" \
1002            "-K%h/key" \
1003            "-d%h/ds" \
1004            "-s-3600" "-e+176400" "-i90000" \
1005            "-N%q" \
1006            "-o%z" \
1007            "-f%o" \
1008            "%f"]
1009   define-list reload-command [list "$BINDPROGS/rndc" "reload" "%z" "IN" "%v"]
1010   define-list autosign-command [list "$BINDPROGS/rndc" "sign" "%z" "IN" "%v"]
1011   define-list checkzone-command \
1012       [list "$BINDPROGS/named-checkzone" \
1013            "-ifull" \
1014            "-kfail" \
1015            "-Mfail" \
1016            "-nfail" \
1017            "-Sfail" \
1018            "-Wfail" \
1019            "%z" "%f"]
1020
1021   define setvar {name value} {
1022     dict set ZONECFG(var) $name $value
1023   }
1024
1025   define primary {map} {
1026     ## There's a grim hack here: a primary-address entry may have the form
1027     ## REAL!FAKE.  If the REAL address is not a local address then this
1028     ## is used as the master address; otherwise the FAKE address is used.
1029     ## This is useful for inter-view updates of dynamic zones on the same
1030     ## host.  I suggest abusing 127.0.0.0/8 addresses for this kind of
1031     ## chicanery.
1032     if {[llength $map] % 2} {
1033       error "master map must have an even number of items"
1034     }
1035     set ZONECFG(master-map) $map
1036   }
1037
1038   define dynamic {{body {}}} {
1039     array set ZONECFG [list type dynamic]
1040     uplevel 1 [list confspc-eval dynamic $body]
1041   }
1042
1043   define view-map {map} {
1044
1045     ## OK, this needs careful documentation.
1046     ##
1047     ## The local nameserver presents a number of views according to its
1048     ## configuration.  It is our purpose here to generate a configuration
1049     ## snippet for such a view.
1050     ##
1051     ## A user might have several different views of a zone which are meant to
1052     ## be presented to different clients.  These map on to the server views
1053     ## in a one-to-many fashion.  The `view-map' option defines this mapping.
1054     ## The argument is a list of alternating SERVER-VIEW USER-VIEW pairs; the
1055     ## SERVER-VIEW may be a glob pattern; the USER-VIEW may be the special
1056     ## token `=' to mean `same as the SERVER-VIEW'.
1057     ##
1058     ## We only keep one copy of the zone file for each user view: if the user
1059     ## view is used by many server views, then the zone stanza for each of
1060     ## those views refers to the same zone file.
1061
1062     if {[llength $map] % 2} {
1063       error "view map must have an even number of items"
1064     }
1065     set ZONECFG(view-map) $map
1066   }
1067
1068   array set ZONECFG {
1069     type static
1070     view-map {* =}
1071   }
1072 }
1073
1074 ## Top-level configuration.  Allow most zone options to be set here, so that
1075 ## one can set defaults for multiple zones conveniently.
1076 define-configuration-space toplevel ZONECFG {
1077   include zone
1078
1079   define-list all-views {}
1080   define-simple conf-file "$HOME/config/%v.conf"
1081   define-simple max-zone-size [expr {512*1024}]
1082   define-list reconfig-command {/usr/sbin/rndc reconfig}
1083
1084   define scope {body} {
1085     preserving-config ZONECFG { uplevel 1 $body }
1086   }
1087
1088   define zone {name {body {}}} {
1089     global ZONES
1090     preserving-config ZONECFG {
1091       array set ZONECFG \
1092           [list name $name \
1093                 type static]
1094       uplevel 1 [list confspc-eval zone $body]
1095       lappend ZONES [array get ZONECFG]
1096     }
1097   }
1098 }
1099
1100 ###--------------------------------------------------------------------------
1101 ### Processing the results.
1102
1103 proc zone-file-name {view config} {
1104   ## Return the relative file name for the zone described by CONFIG, relative
1105   ## to the given VIEW.  An absolute filename may be derived later, depending
1106   ## on whether the zone data is static and the calling host is the master
1107   ## for the zone.
1108
1109   array set zone $config
1110   return [string map [list \
1111                           "%v" $view \
1112                           "%z" $zone(name)] \
1113               $zone(zone-file)]
1114 }
1115
1116 proc output-file-name {view} {
1117   ## Return the output file name for the given VIEW.
1118
1119   global ZONECFG
1120   return [string map [list %v $view] $ZONECFG(conf-file)]
1121 }
1122
1123 proc compute-zone-properties {view config} {
1124   ## Derive interesting information from the zone configuration plist CONFIG,
1125   ## relative to the stated server VIEW.  Return a new plist.
1126
1127   array set zone $config
1128
1129   ## See whether the zone matches the view.
1130   set match 0
1131   foreach wanted $zone(views) {
1132     if {[string match $wanted $view]} { set match 1; break }
1133   }
1134   if {!$match} { return {config-type ignore} }
1135
1136   ## Transform the view name according to the view map.
1137   foreach {inview outview} $zone(view-map) {
1138     if {![string match $inview $view]} { continue }
1139     switch -exact -- $outview {
1140       = { set zone(mapped-view) $view }
1141       default { set zone(mapped-view) $outview }
1142     }
1143     break
1144   }
1145
1146   ## Find out where the master is supposed to be.
1147   set zone(config-type) ignore
1148   if {[info exists zone(mapped-view)]} {
1149     foreach {outview hosts} $zone(master-map) {
1150       if {[string match $outview $zone(mapped-view)]} {
1151         set masters {}
1152         set zone(config-type) slave
1153         foreach host $hosts {
1154           set bang [string first "!" $host]
1155           if {$bang >= 0} {
1156             set after [string range $host [expr {$bang + 1}] end]
1157             if {$bang} {
1158               set before [string range $host 0 [expr {$bang - 1}]]
1159             } else {
1160               set before $after
1161             }
1162             if {[local-address-p $before]} {
1163               set host $after
1164             } else {
1165               set host $before
1166             }
1167           } elseif {[local-address-p $host]} {
1168             set zone(config-type) master
1169           }
1170           lappend masters $host
1171         }
1172         set zone(masters) $masters
1173         break
1174       }
1175     }
1176   }
1177
1178   ## Work out the file names.
1179   switch -glob -- $zone(config-type):$zone(type) {
1180     master:static {
1181       set dir $zone(static-dir)
1182       set nameview $zone(mapped-view)
1183     }
1184     default {
1185       set dir $zone(dynamic-dir)
1186       set nameview $view
1187     }
1188   }
1189   set zone(file-name) [file join $dir \
1190                            [zone-file-name $nameview $config]]
1191
1192   ## Find out whether this zone wants signing.
1193   set zone(sign) false
1194   switch -glob -- $zone(config-type):$zone(type) {
1195     master:static {
1196       foreach sview $zone(sign-views) {
1197         if {[string match $zone(mapped-view) $sview]} { set zone(sign) true }
1198       }
1199     }
1200   }
1201   if {$zone(sign)} {
1202     set zone(server-file-name) "$zone(file-name).sig"
1203   } else {
1204     set zone(server-file-name) $zone(file-name)
1205   }
1206
1207   ## Done.
1208   return [array get zone]
1209 }
1210
1211 proc write-ddns-update-policy {prefix chan config} {
1212   ## Write an `update-policy' stanza to CHAN for the zone described by the
1213   ## CONFIG plist.  The PREFIX is written to the start of each line.
1214
1215   array set zone $config
1216   puts $chan "${prefix}update-policy {"
1217   set policyskel "${prefix}\t%s %s %s \"%s\" %s;"
1218
1219   foreach item $zone(ddns-policy) {
1220     set* {verb ident type name} [lrange $item 0 3]
1221     set rrtypes [lrange $item 4 end]
1222     puts $chan [format $policyskel \
1223                     $verb \
1224                     $ident \
1225                     $type \
1226                     $name \
1227                     $rrtypes]
1228   }
1229
1230   puts $chan [format $policyskel \
1231                   grant \
1232                     $zone(ddns-key) \
1233                     subdomain \
1234                     $zone(name) \
1235                     $zone(ddns-types)]
1236
1237   puts $chan "${prefix}};"
1238 }
1239
1240 proc sign-zone-file {info soafmt infile} {
1241   ## Sign the zone described by INFO.  The input zone file is INPUT; the SOA
1242   ## should be updated according to SOAFMT.
1243
1244   global QUIS
1245
1246   array set zone $info
1247   set outfile "$zone(server-file-name).new"
1248   if {![run "sign zone `$zone(name)' in view `$zone(mapped-view)'" \
1249             $zone(signzone-command) \
1250             "%h" $zone(home-dir) \
1251             "%m" $zone(static-dir) \
1252             "%s" $zone(dynamic-dir) \
1253             "%z" $zone(name) \
1254             "%f" $infile \
1255             "%o" $outfile \
1256             "%q" $soafmt]} {
1257     file delete -force $outfile
1258     return false
1259   }
1260   file rename -force $outfile $zone(server-file-name)
1261   return true
1262 }
1263
1264 proc write-zone-stanza {view chan config} {
1265   ## Write a `zone' stanza to CHAN for the zone described by the CONFIG
1266   ## plist in the given VIEW.
1267
1268   array set zone [compute-zone-properties $view $config]
1269   if {[string equal $zone(config-type) "ignore"]} { return }
1270
1271   ## Create the directory for the zone files.
1272   set dir [file dirname $zone(file-name)]
1273   if {![file isdirectory $dir]} {
1274     file mkdir $dir
1275     exec chmod $zone(dir-mode) $dir
1276   }
1277
1278   ## Write the configuration fragment.
1279   puts $chan "\nzone \"$zone(name)\" {"
1280   switch -glob -- $zone(config-type) {
1281     master {
1282       puts $chan "\ttype master;"
1283       puts $chan "\tfile \"$zone(server-file-name)\";"
1284       switch -exact -- $zone(type) {
1285         dynamic {
1286           write-ddns-update-policy "\t" $chan $config
1287           if {![string equal $zone(ddns-auto-dnssec) off]} {
1288             puts $chan "\tauto-dnssec $zone(ddns-auto-dnssec);"
1289           }
1290         }
1291       }
1292     }
1293     slave {
1294       puts $chan "\ttype slave;"
1295       set masters {}
1296       foreach host $zone(masters) { lappend masters [host-addr $host] }
1297       puts $chan "\tmasters { [join $masters {; }]; };"
1298       puts $chan "\tfile \"$zone(file-name)\";"
1299       switch -exact -- $zone(type) {
1300         dynamic { puts $chan "\tallow-update-forwarding { any; };" }
1301       }
1302     }
1303   }
1304   if {![string equal $zone(allow-query) nil]} {
1305     puts $chan "\tallow-query {$zone(allow-query)};"
1306   }
1307   puts $chan "};";
1308 }
1309
1310 ###--------------------------------------------------------------------------
1311 ### Command-line interface.
1312
1313 set CONFFILE "@pkgconfdir@/zones.in"
1314
1315 defcmd outputs {} {
1316   help-text "List the output file names to stdout."
1317 } {
1318   global ZONECFG CONFFILE
1319
1320   confspc-eval toplevel [list source $CONFFILE]
1321   foreach view $ZONECFG(all-views) { puts [output-file-name $view] }
1322 }
1323
1324 defcmd update {} {
1325   help-text "Generate BIND configuration files."
1326 } {
1327   global ZONECFG ZONES CONFFILE
1328
1329   ## Read the configuration.
1330   confspc-eval toplevel [list source $CONFFILE]
1331
1332   ## Safely update the files.
1333   set win false
1334   unwind-protect {
1335
1336     ## Work through each server view.
1337     foreach view $ZONECFG(all-views) {
1338
1339       ## Open an output file.
1340       set out($view) [output-file-name $view]
1341       set chan($view) [open "$out($view).new" w]
1342
1343       ## Write a header.
1344       set now [clock format [clock seconds] -format "%Y-%m-%d %H:%M:%S"]
1345       puts $chan($view) "### -*-conf-javaprop-*-"
1346       puts $chan($view) "### Generated at $now: do not edit"
1347
1348       ## Now print a stanza for each zone in the view.
1349       foreach zone $ZONES {
1350         write-zone-stanza $view $chan($view) $zone
1351       }
1352     }
1353
1354     ## Done: don't delete the output.
1355     set win true
1356   } {
1357
1358     ## Close the open files.
1359     foreach view $ZONECFG(all-views) {
1360       catch { close $chan($view) }
1361     }
1362
1363     ## If we succeeded, rename the output files into their proper places;
1364     ## otherwise, delete them.
1365     if {$win} {
1366       foreach view $ZONECFG(all-views) {
1367         file rename -force -- "$out($view).new" $out($view)
1368       }
1369       eval exec $ZONECFG(reconfig-command)
1370     } else {
1371       catch { file delete -force -- "$out($view).new" }
1372     }
1373   }
1374 }
1375
1376 defcmd install {user view name} {
1377   help-text "Install a new zone file.
1378
1379 The file is for the given zone NAME and \(user-side) VIEW.  The file is
1380 provided by the named USER."
1381 } {
1382   global QUIS ZONECFG ZONES CONFFILE errorInfo errorCode
1383
1384   ## Read the configuration.
1385   confspc-eval toplevel [list source $CONFFILE]
1386
1387   ## Make sure there's a temporary directory.
1388   file mkdir [file join $ZONECFG(home-dir) "tmp"]
1389
1390   ## Keep track of cleanup jobs.
1391   set cleanup {}
1392   unwind-protect {
1393
1394     ## Find out which server views are affected by this update.
1395     set matchview {}
1396     foreach iview $ZONECFG(all-views) {
1397       foreach info $ZONES {
1398         array unset zone
1399         array set zone [compute-zone-properties $iview $info]
1400         if {[string equal $user $zone(user)] && \
1401                 [string equal "$zone(config-type)/$zone(type)" \
1402                      "master/static"] && \
1403                 [string equal $zone(name) $name] && \
1404                 [string equal $zone(mapped-view) $view]} {
1405           lappend matchview $iview
1406           if {![info exists matchinfo]} { set matchinfo [array get zone] }
1407         }
1408       }
1409     }
1410     if {![llength $matchview]} {
1411       optparse-error "No match for zone `$name' in view `$view'"
1412     }
1413     array unset zone
1414     array set zone $matchinfo
1415
1416     ## Make a new temporary file to read the zone into.
1417     set pid [pid]
1418     for {set i 0} {$i < 1000} {incr i} {
1419       set tmp [file join $ZONECFG(home-dir) "tmp" \
1420                    "tmp.$pid.$i.$user.$name"]
1421       if {![catch { set chan [open $tmp {WRONLY CREAT EXCL}] } msg]} {
1422         break
1423       } elseif {[string equal [lindex $errorCode 0] POSIX] && \
1424                     ![string equal [lindex $errorCode 1] EEXIST]} {
1425         error $msg $errorInfo $errorCode
1426       }
1427     }
1428     if {![info exists chan]} { error "failed to create temporary file" }
1429     set cleanup [list file delete $tmp]
1430
1431     ## Read the zone data from standard input into the file.
1432     set total 0
1433     while {true} {
1434       set stuff [read stdin 4096]
1435       if {![string length $stuff]} { break }
1436       puts -nonewline $chan $stuff
1437       incr total [string bytelength $stuff]
1438       if {$total > $ZONECFG(max-zone-size)} {
1439         error "zone file size limit exceeded"
1440       }
1441     }
1442     close $chan
1443
1444     ## Check the zone for sanity.
1445     if {![run "zone check" $zone(checkzone-command) \
1446               "%z" $name \
1447               "%v" $view \
1448               "%f" $tmp]} {
1449       eval $cleanup
1450       exit 1
1451     }
1452
1453     ## If the zone wants signing, better to do that now.
1454     if {$zone(sign) && ![sign-zone-file $matchinfo keep $tmp]} {
1455       eval $cleanup
1456       exit 2
1457     }
1458
1459     ## All seems good: stash the file in the proper place and reload the
1460     ## necessary server views.
1461     file rename -force -- $tmp $zone(file-name)
1462     set cleanup {}
1463     foreach view $matchview {
1464       if {![run "reload zone `$zone(name) in view `$view'" \
1465                 $zone(reload-command) \
1466                 "%v" $view \
1467                 "%z" $zone(name)]} {
1468         exit 3
1469       }
1470     }
1471   } {
1472     eval $cleanup
1473   }
1474 }
1475
1476 defcmd sign {} {
1477   help-text "Sign DNSSEC zones."
1478 } {
1479   global QUIS ZONECFG ZONES CONFFILE
1480
1481   set rc 0
1482
1483   ## Read the configuration.
1484   confspc-eval toplevel [list source $CONFFILE]
1485
1486   ## Grind through all of the zones.
1487   array unset seen
1488   foreach view $ZONECFG(all-views) {
1489     foreach info $ZONES {
1490
1491       ## Fetch the zone information.
1492       array unset zone
1493       set compinfo [compute-zone-properties $view $info]
1494       array set zone $compinfo
1495       if {![string equal $zone(config-type) master]} { continue }
1496
1497       if {[string equal $zone(type) static] && $zone(sign)} {
1498         ## Static zone: re-sign it if we haven't seen this user view before,
1499         ## and then reload.
1500
1501         ## Sign the zone file if we haven't tried before.
1502         set id [list $zone(name) $zone(mapped-view)]
1503         if {![info exists seen($id)]} {
1504           if {[sign-zone-file $compinfo $zone(soa-format) \
1505                    $zone(server-file-name)]} {
1506             set seen($id) true
1507           } else {
1508             set rc 2
1509             set seen($id) failed
1510           }
1511         }
1512
1513         ## If we succeeded, reload the zone in this server view.
1514         if {[string equal $seen($id) true]} {
1515           if {![run "reload zone `$zone(name) in server view `$view'" \
1516                     $zone(reload-command) \
1517                     "%z" $zone(name) \
1518                     "%v" $view]} {
1519             set rc 2
1520           }
1521         }
1522       } elseif {[string equal $zone(type) dynamic] &&
1523                 ![string equal $zone(ddns-auto-dnssec) off]} {
1524         ## Dynamic zone: get BIND to re-sign it.
1525
1526         if {![run "re-sign zone `$zone(name) in server view `$view'" \
1527                   $zone(autosign-command) \
1528                   "%z" $zone(name) \
1529                   "%v" $view]} {
1530           set rc 2
1531         }
1532       }
1533     }
1534   }
1535   exit $rc
1536 }
1537
1538 ###--------------------------------------------------------------------------
1539 ### Main program.
1540
1541 set VERSION "@VERSION@"
1542 set USAGE() " \[-OPTIONS] SUBCOMMAND \[ARGUMENTS...]"
1543
1544 define-options OPTS {
1545   option {
1546     short "h"; long "help"
1547     action { eval cmd/help [optparse-words]; exit }
1548   }
1549   option {
1550     short "v"; long "version"
1551     action { puts "$QUIS, version $VERSION"; exit }
1552   }
1553   option {
1554     short "c"; long "config"; arg required
1555     action { set CONFFILE [optparse-arg] }
1556   }
1557 }
1558
1559 with-option-parser $OPTS $argv {
1560   optparse-option
1561   set argv [optparse-words]
1562 }
1563
1564 if {![llength $argv]} { usage-error }
1565 dispatch [lindex $argv 0] [lrange $argv 1 end]
1566
1567 ###----- That's all, folks --------------------------------------------------