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