mdw@git.distorted.org.uk Git - zoneconf/blob - bin/zoneconf

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