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-list views *
 996   define-list sign-views {}
 997   define-list signzone-command \
 998       [list "$BINDPROGS/dnssec-signzone" \
 999            "-g" \
1000            "-S" \
1001            "-K%h/key" \
1002            "-d%h/ds" \
1003            "-s-3600" "-e+176400" "-i90000" \
1004            "-N%q" \
1005            "-o%z" \
1006            "-f%o" \
1007            "%f"]
1008   define-list reload-command [list "$BINDPROGS/rndc" "reload" "%z" "IN" "%v"]
1009   define-list autosign-command [list "$BINDPROGS/rndc" "sign" "%z" "IN" "%v"]
1010   define-list checkzone-command \
1011       [list "$BINDPROGS/named-checkzone" \
1012            "-ifull" \
1013            "-kfail" \
1014            "-Mfail" \
1015            "-nfail" \
1016            "-Sfail" \
1017            "-Wfail" \
1018            "%z" "%f"]
1019
1020   define setvar {name value} {
1021     dict set ZONECFG(var) $name $value
1022   }
1023
1024   define primary {map} {
1025     ## There's a grim hack here: a primary-address entry may have the form
1026     ## REAL!FAKE.  If the REAL address is not a local address then this
1027     ## is used as the master address; otherwise the FAKE address is used.
1028     ## This is useful for inter-view updates of dynamic zones on the same
1029     ## host.  I suggest abusing 127.0.0.0/8 addresses for this kind of
1030     ## chicanery.
1031     if {[llength $map] % 2} {
1032       error "master map must have an even number of items"
1033     }
1034     set ZONECFG(master-map) $map
1035   }
1036
1037   define dynamic {{body {}}} {
1038     array set ZONECFG [list type dynamic]
1039     uplevel 1 [list confspc-eval dynamic $body]
1040   }
1041
1042   define view-map {map} {
1043
1044     ## OK, this needs careful documentation.
1045     ##
1046     ## The local nameserver presents a number of views according to its
1047     ## configuration.  It is our purpose here to generate a configuration
1048     ## snippet for such a view.
1049     ##
1050     ## A user might have several different views of a zone which are meant to
1051     ## be presented to different clients.  These map on to the server views
1052     ## in a one-to-many fashion.  The `view-map' option defines this mapping.
1053     ## The argument is a list of alternating SERVER-VIEW USER-VIEW pairs; the
1054     ## SERVER-VIEW may be a glob pattern; the USER-VIEW may be the special
1055     ## token `=' to mean `same as the SERVER-VIEW'.
1056     ##
1057     ## We only keep one copy of the zone file for each user view: if the user
1058     ## view is used by many server views, then the zone stanza for each of
1059     ## those views refers to the same zone file.
1060
1061     if {[llength $map] % 2} {
1062       error "view map must have an even number of items"
1063     }
1064     set ZONECFG(view-map) $map
1065   }
1066
1067   array set ZONECFG {
1068     type static
1069     view-map {* =}
1070   }
1071 }
1072
1073 ## Top-level configuration.  Allow most zone options to be set here, so that
1074 ## one can set defaults for multiple zones conveniently.
1075 define-configuration-space toplevel ZONECFG {
1076   include zone
1077
1078   define-list all-views {}
1079   define-simple conf-file "$HOME/config/%v.conf"
1080   define-simple max-zone-size [expr {512*1024}]
1081   define-list reconfig-command {/usr/sbin/rndc reconfig}
1082
1083   define scope {body} {
1084     preserving-config ZONECFG { uplevel 1 $body }
1085   }
1086
1087   define zone {name {body {}}} {
1088     global ZONES
1089     preserving-config ZONECFG {
1090       array set ZONECFG \
1091           [list name $name \
1092                 type static]
1093       uplevel 1 [list confspc-eval zone $body]
1094       lappend ZONES [array get ZONECFG]
1095     }
1096   }
1097 }
1098
1099 ###--------------------------------------------------------------------------
1100 ### Processing the results.
1101
1102 proc zone-file-name {view config} {
1103   ## Return the relative file name for the zone described by CONFIG, relative
1104   ## to the given VIEW.  An absolute filename may be derived later, depending
1105   ## on whether the zone data is static and the calling host is the master
1106   ## for the zone.
1107
1108   array set zone $config
1109   return [string map [list \
1110                           "%v" $view \
1111                           "%z" $zone(name)] \
1112               $zone(zone-file)]
1113 }
1114
1115 proc output-file-name {view} {
1116   ## Return the output file name for the given VIEW.
1117
1118   global ZONECFG
1119   return [string map [list %v $view] $ZONECFG(conf-file)]
1120 }
1121
1122 proc compute-zone-properties {view config} {
1123   ## Derive interesting information from the zone configuration plist CONFIG,
1124   ## relative to the stated server VIEW.  Return a new plist.
1125
1126   array set zone $config
1127
1128   ## See whether the zone matches the view.
1129   set match 0
1130   foreach wanted $zone(views) {
1131     if {[string match $wanted $view]} { set match 1; break }
1132   }
1133   if {!$match} { return {config-type ignore} }
1134
1135   ## Transform the view name according to the view map.
1136   foreach {inview outview} $zone(view-map) {
1137     if {![string match $inview $view]} { continue }
1138     switch -exact -- $outview {
1139       = { set zone(mapped-view) $view }
1140       default { set zone(mapped-view) $outview }
1141     }
1142     break
1143   }
1144
1145   ## Find out where the master is supposed to be.
1146   set zone(config-type) ignore
1147   if {[info exists zone(mapped-view)]} {
1148     foreach {outview hosts} $zone(master-map) {
1149       if {[string match $outview $zone(mapped-view)]} {
1150         set masters {}
1151         set zone(config-type) slave
1152         foreach host $hosts {
1153           set bang [string first "!" $host]
1154           if {$bang >= 0} {
1155             set after [string range $host [expr {$bang + 1}] end]
1156             if {$bang} {
1157               set before [string range $host 0 [expr {$bang - 1}]]
1158             } else {
1159               set before $after
1160             }
1161             if {[local-address-p $before]} {
1162               set host $after
1163             } else {
1164               set host $before
1165             }
1166           } elseif {[local-address-p $host]} {
1167             set zone(config-type) master
1168           }
1169           lappend masters $host
1170         }
1171         set zone(masters) $masters
1172         break
1173       }
1174     }
1175   }
1176
1177   ## Work out the file names.
1178   switch -glob -- $zone(config-type):$zone(type) {
1179     master:static {
1180       set dir $zone(static-dir)
1181       set nameview $zone(mapped-view)
1182     }
1183     default {
1184       set dir $zone(dynamic-dir)
1185       set nameview $view
1186     }
1187   }
1188   set zone(file-name) [file join $dir \
1189                            [zone-file-name $nameview $config]]
1190
1191   ## Find out whether this zone wants signing.
1192   set zone(sign) false
1193   switch -glob -- $zone(config-type):$zone(type) {
1194     master:static {
1195       foreach sview $zone(sign-views) {
1196         if {[string match $zone(mapped-view) $sview]} { set zone(sign) true }
1197       }
1198     }
1199   }
1200   if {$zone(sign)} {
1201     set zone(server-file-name) "$zone(file-name).sig"
1202   } else {
1203     set zone(server-file-name) $zone(file-name)
1204   }
1205
1206   ## Done.
1207   return [array get zone]
1208 }
1209
1210 proc write-ddns-update-policy {prefix chan config} {
1211   ## Write an `update-policy' stanza to CHAN for the zone described by the
1212   ## CONFIG plist.  The PREFIX is written to the start of each line.
1213
1214   array set zone $config
1215   puts $chan "${prefix}update-policy {"
1216   set policyskel "${prefix}\t%s %s %s \"%s\" %s;"
1217
1218   foreach item $zone(ddns-policy) {
1219     set* {verb ident type name} [lrange $item 0 3]
1220     set rrtypes [lrange $item 4 end]
1221     puts $chan [format $policyskel \
1222                     $verb \
1223                     $ident \
1224                     $type \
1225                     $name \
1226                     $rrtypes]
1227   }
1228
1229   puts $chan [format $policyskel \
1230                   grant \
1231                     $zone(ddns-key) \
1232                     subdomain \
1233                     $zone(name) \
1234                     $zone(ddns-types)]
1235
1236   puts $chan "${prefix}};"
1237 }
1238
1239 proc sign-zone-file {info soafmt infile} {
1240   ## Sign the zone described by INFO.  The input zone file is INPUT; the SOA
1241   ## should be updated according to SOAFMT.
1242
1243   global QUIS
1244
1245   array set zone $info
1246   set outfile "$zone(server-file-name).new"
1247   if {![run "sign zone `$zone(name)' in view `$zone(mapped-view)'" \
1248             $zone(signzone-command) \
1249             "%h" $zone(home-dir) \
1250             "%m" $zone(static-dir) \
1251             "%s" $zone(dynamic-dir) \
1252             "%z" $zone(name) \
1253             "%f" $infile \
1254             "%o" $outfile \
1255             "%q" $soafmt]} {
1256     file delete -force $outfile
1257     return false
1258   }
1259   file rename -force $outfile $zone(server-file-name)
1260   return true
1261 }
1262
1263 proc write-zone-stanza {view chan config} {
1264   ## Write a `zone' stanza to CHAN for the zone described by the CONFIG
1265   ## plist in the given VIEW.
1266
1267   array set zone [compute-zone-properties $view $config]
1268   if {[string equal $zone(config-type) "ignore"]} { return }
1269
1270   ## Create the directory for the zone files.
1271   set dir [file dirname $zone(file-name)]
1272   if {![file isdirectory $dir]} {
1273     file mkdir $dir
1274     exec chmod $zone(dir-mode) $dir
1275   }
1276
1277   ## Write the configuration fragment.
1278   puts $chan "\nzone \"$zone(name)\" {"
1279   switch -glob -- $zone(config-type) {
1280     master {
1281       puts $chan "\ttype master;"
1282       puts $chan "\tfile \"$zone(server-file-name)\";"
1283       switch -exact -- $zone(type) {
1284         dynamic {
1285           write-ddns-update-policy "\t" $chan $config
1286           if {![string equal $zone(ddns-auto-dnssec) off]} {
1287             puts $chan "\tauto-dnssec $zone(ddns-auto-dnssec);"
1288           }
1289         }
1290       }
1291     }
1292     slave {
1293       puts $chan "\ttype slave;"
1294       set masters {}
1295       foreach host $zone(masters) { lappend masters [host-addr $host] }
1296       puts $chan "\tmasters { [join $masters {; }]; };"
1297       puts $chan "\tfile \"$zone(file-name)\";"
1298       switch -exact -- $zone(type) {
1299         dynamic { puts $chan "\tallow-update-forwarding { any; };" }
1300       }
1301     }
1302   }
1303   puts $chan "};";
1304 }
1305
1306 ###--------------------------------------------------------------------------
1307 ### Command-line interface.
1308
1309 set CONFFILE "@pkgconfdir@/zones.in"
1310
1311 defcmd outputs {} {
1312   help-text "List the output file names to stdout."
1313 } {
1314   global ZONECFG CONFFILE
1315
1316   confspc-eval toplevel [list source $CONFFILE]
1317   foreach view $ZONECFG(all-views) { puts [output-file-name $view] }
1318 }
1319
1320 defcmd update {} {
1321   help-text "Generate BIND configuration files."
1322 } {
1323   global ZONECFG ZONES CONFFILE
1324
1325   ## Read the configuration.
1326   confspc-eval toplevel [list source $CONFFILE]
1327
1328   ## Safely update the files.
1329   set win false
1330   unwind-protect {
1331
1332     ## Work through each server view.
1333     foreach view $ZONECFG(all-views) {
1334
1335       ## Open an output file.
1336       set out($view) [output-file-name $view]
1337       set chan($view) [open "$out($view).new" w]
1338
1339       ## Write a header.
1340       set now [clock format [clock seconds] -format "%Y-%m-%d %H:%M:%S"]
1341       puts $chan($view) "### -*-conf-javaprop-*-"
1342       puts $chan($view) "### Generated at $now: do not edit"
1343
1344       ## Now print a stanza for each zone in the view.
1345       foreach zone $ZONES {
1346         write-zone-stanza $view $chan($view) $zone
1347       }
1348     }
1349
1350     ## Done: don't delete the output.
1351     set win true
1352   } {
1353
1354     ## Close the open files.
1355     foreach view $ZONECFG(all-views) {
1356       catch { close $chan($view) }
1357     }
1358
1359     ## If we succeeded, rename the output files into their proper places;
1360     ## otherwise, delete them.
1361     if {$win} {
1362       foreach view $ZONECFG(all-views) {
1363         file rename -force -- "$out($view).new" $out($view)
1364       }
1365       eval exec $ZONECFG(reconfig-command)
1366     } else {
1367       catch { file delete -force -- "$out($view).new" }
1368     }
1369   }
1370 }
1371
1372 defcmd install {user view name} {
1373   help-text "Install a new zone file.
1374
1375 The file is for the given zone NAME and \(user-side) VIEW.  The file is
1376 provided by the named USER."
1377 } {
1378   global QUIS ZONECFG ZONES CONFFILE errorInfo errorCode
1379
1380   ## Read the configuration.
1381   confspc-eval toplevel [list source $CONFFILE]
1382
1383   ## Make sure there's a temporary directory.
1384   file mkdir [file join $ZONECFG(home-dir) "tmp"]
1385
1386   ## Keep track of cleanup jobs.
1387   set cleanup {}
1388   unwind-protect {
1389
1390     ## Find out which server views are affected by this update.
1391     set matchview {}
1392     foreach iview $ZONECFG(all-views) {
1393       foreach info $ZONES {
1394         array unset zone
1395         array set zone [compute-zone-properties $iview $info]
1396         if {[string equal $user $zone(user)] && \
1397                 [string equal "$zone(config-type)/$zone(type)" \
1398                      "master/static"] && \
1399                 [string equal $zone(name) $name] && \
1400                 [string equal $zone(mapped-view) $view]} {
1401           lappend matchview $iview
1402           if {![info exists matchinfo]} { set matchinfo [array get zone] }
1403         }
1404       }
1405     }
1406     if {![llength $matchview]} {
1407       optparse-error "No match for zone `$name' in view `$view'"
1408     }
1409     array unset zone
1410     array set zone $matchinfo
1411
1412     ## Make a new temporary file to read the zone into.
1413     set pid [pid]
1414     for {set i 0} {$i < 1000} {incr i} {
1415       set tmp [file join $ZONECFG(home-dir) "tmp" \
1416                    "tmp.$pid.$i.$user.$name"]
1417       if {![catch { set chan [open $tmp {WRONLY CREAT EXCL}] } msg]} {
1418         break
1419       } elseif {[string equal [lindex $errorCode 0] POSIX] && \
1420                     ![string equal [lindex $errorCode 1] EEXIST]} {
1421         error $msg $errorInfo $errorCode
1422       }
1423     }
1424     if {![info exists chan]} { error "failed to create temporary file" }
1425     set cleanup [list file delete $tmp]
1426
1427     ## Read the zone data from standard input into the file.
1428     set total 0
1429     while {true} {
1430       set stuff [read stdin 4096]
1431       if {![string length $stuff]} { break }
1432       puts -nonewline $chan $stuff
1433       incr total [string bytelength $stuff]
1434       if {$total > $ZONECFG(max-zone-size)} {
1435         error "zone file size limit exceeded"
1436       }
1437     }
1438     close $chan
1439
1440     ## Check the zone for sanity.
1441     if {![run "zone check" $zone(checkzone-command) \
1442               "%z" $name \
1443               "%v" $view \
1444               "%f" $tmp]} {
1445       eval $cleanup
1446       exit 1
1447     }
1448
1449     ## If the zone wants signing, better to do that now.
1450     if {$zone(sign) && ![sign-zone-file $matchinfo keep $tmp]} {
1451       eval $cleanup
1452       exit 2
1453     }
1454
1455     ## All seems good: stash the file in the proper place and reload the
1456     ## necessary server views.
1457     file rename -force -- $tmp $zone(file-name)
1458     set cleanup {}
1459     foreach view $matchview {
1460       if {![run "reload zone `$zone(name) in view `$view'" \
1461                 $zone(reload-command) \
1462                 "%v" $view \
1463                 "%z" $zone(name)]} {
1464         exit 3
1465       }
1466     }
1467   } {
1468     eval $cleanup
1469   }
1470 }
1471
1472 defcmd sign {} {
1473   help-text "Sign DNSSEC zones."
1474 } {
1475   global QUIS ZONECFG ZONES CONFFILE
1476
1477   set rc 0
1478
1479   ## Read the configuration.
1480   confspc-eval toplevel [list source $CONFFILE]
1481
1482   ## Grind through all of the zones.
1483   array unset seen
1484   foreach view $ZONECFG(all-views) {
1485     foreach info $ZONES {
1486
1487       ## Fetch the zone information.
1488       array unset zone
1489       set compinfo [compute-zone-properties $view $info]
1490       array set zone $compinfo
1491       if {![string equal $zone(config-type) master]} { continue }
1492
1493       if {[string equal $zone(type) static] && $zone(sign)} {
1494         ## Static zone: re-sign it if we haven't seen this user view before,
1495         ## and then reload.
1496
1497         ## Sign the zone file if we haven't tried before.
1498         set id [list $zone(name) $zone(mapped-view)]
1499         if {![info exists seen($id)]} {
1500           if {[sign-zone-file $compinfo $zone(soa-format) \
1501                    $zone(server-file-name)]} {
1502             set seen($id) true
1503           } else {
1504             set rc 2
1505             set seen($id) failed
1506           }
1507         }
1508
1509         ## If we succeeded, reload the zone in this server view.
1510         if {[string equal $seen($id) true]} {
1511           if {![run "reload zone `$zone(name) in server view `$view'" \
1512                     $zone(reload-command) \
1513                     "%z" $zone(name) \
1514                     "%v" $view]} {
1515             set rc 2
1516           }
1517         }
1518       } elseif {[string equal $zone(type) dynamic] &&
1519                 ![string equal $zone(ddns-auto-dnssec) off]} {
1520         ## Dynamic zone: get BIND to re-sign it.
1521
1522         if {![run "re-sign zone `$zone(name) in server view `$view'" \
1523                   $zone(autosign-command) \
1524                   "%z" $zone(name) \
1525                   "%v" $view]} {
1526           set rc 2
1527         }
1528       }
1529     }
1530   }
1531   exit $rc
1532 }
1533
1534 ###--------------------------------------------------------------------------
1535 ### Main program.
1536
1537 set VERSION "@VERSION@"
1538 set USAGE() " \[-OPTIONS] SUBCOMMAND \[ARGUMENTS...]"
1539
1540 define-options OPTS {
1541   option {
1542     short "h"; long "help"
1543     action { eval cmd/help [optparse-words]; exit }
1544   }
1545   option {
1546     short "v"; long "version"
1547     action { puts "$QUIS, version $VERSION"; exit }
1548   }
1549   option {
1550     short "c"; long "config"; arg required
1551     action { set CONFFILE [optparse-arg] }
1552   }
1553 }
1554
1555 with-option-parser $OPTS $argv {
1556   optparse-option
1557   set argv [optparse-words]
1558 }
1559
1560 if {![llength $argv]} { usage-error }
1561 dispatch [lindex $argv 0] [lrange $argv 1 end]
1562
1563 ###----- That's all, folks --------------------------------------------------