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