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 #1 $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     if {[llength $map] % 2} {
 984       error "view map must have an even number of items"
 985     }
 986     set ZONECFG(view-map) $map
 987   }
 988
 989   array set ZONECFG {
 990     type static
 991     view-map {* =}
 992   }
 993 }
 994
 995 ## Top-level configuration.  Allow most zone options to be set here, so that
 996 ## one can set defaults for multiple zones conveniently.
 997 define-configuration-space toplevel ZONECFG {
 998   include zone
 999
1000   define-list all-views {}
1001   define-simple conf-file "/var/lib/zoneconf/config/%v.conf"
1002   define-simple max-zone-size [expr {512*1024}]
1003   define-list reconfig-command {/usr/sbin/rndc reconfig}
1004
1005   define scope {body} { preserving-config ZONECFG { uplevel 1 $body } }
1006
1007   define zone {name {body {}}} {
1008     global ZONES
1009     preserving-config ZONECFG {
1010       array set ZONECFG \
1011           [list name $name \
1012                 type static]
1013       uplevel 1 [list confspc-eval zone $body]
1014       lappend ZONES [array get ZONECFG]
1015     }
1016   }
1017 }
1018
1019 ###--------------------------------------------------------------------------
1020 ### Processing the results.
1021
1022 proc zone-file-name {view config} {
1023   ## Return the relative file name for the zone described by CONFIG, relative
1024   ## to the given VIEW.  An absolute filename may be derived later, depending
1025   ## on whether the zone data is static and the calling host is the master
1026   ## for the zone.
1027
1028   array set zone $config
1029   return [string map [list \
1030                           "%v" $view \
1031                           "%z" $zone(name)] \
1032               $zone(zone-file)]
1033 }
1034
1035 proc output-file-name {view} {
1036   ## Return the output file name for the given VIEW.
1037
1038   global ZONECFG
1039   return [string map [list %v $view] $ZONECFG(conf-file)]
1040 }
1041
1042 proc compute-zone-properties {view config} {
1043   ## Derive interesting information from the zone configuration plist CONFIG,
1044   ## relative to the stated VIEW.  Return a new plist.
1045
1046   array set zone $config
1047
1048   ## See whether the zone matches the view.
1049   set match 0
1050   foreach wanted $zone(views) {
1051     if {[string match $wanted $view]} { set match 1; break }
1052   }
1053   if {!$match} { return {config-type ignore} }
1054
1055   ## Transform the view name according to the view map.
1056   foreach {inview outview} $zone(view-map) {
1057     if {![string match $inview $view]} { continue }
1058     switch -exact -- $outview {
1059       = { set zone(mapped-view) $view }
1060       default { set zone(mapped-view) $outview }
1061     }
1062     break
1063   }
1064
1065   ## Find out where the master is supposed to be.
1066   set zone(config-type) ignore
1067   if {[info exists zone(mapped-view)]} {
1068     foreach {outview hosts} $zone(master-map) {
1069       if {[string match $outview $zone(mapped-view)]} {
1070         set zone(masters) $hosts
1071         set zone(config-type) slave
1072         foreach host $hosts {
1073           if {[local-address-p $host]} {
1074             set zone(config-type) master
1075           }
1076         }
1077         break
1078       }
1079     }
1080   }
1081
1082   ## Main dispatch for zone categorization.
1083   switch -exact -- $zone(config-type) {
1084     master {
1085       switch -exact -- $zone(type) {
1086         static {
1087           set zone(file-name) \
1088               [file join $zone(master-dir) \
1089                    [zone-file-name $zone(mapped-view) $config]]
1090         }
1091         dynamic {
1092           set zone(file-name) [file join $zone(slave-dir) \
1093                                    [zone-file-name $view $config]]
1094         }
1095       }
1096     }
1097     slave {
1098       set zone(file-name) [file join $zone(slave-dir) \
1099                                [zone-file-name $view $config]]
1100     }
1101   }
1102
1103   ## Done.
1104   return [array get zone]
1105 }
1106
1107 proc write-ddns-update-policy {prefix chan config} {
1108   ## Write an `update-policy' stanza to CHAN for the zone described by the
1109   ## CONFIG plist.  The PREFIX is written to the start of each line.
1110
1111   array set zone $config
1112   puts $chan "${prefix}update-policy {"
1113   set policyskel "${prefix}\t%s %s %s \"%s\" %s;"
1114
1115   foreach item $zone(ddns-policy) {
1116     set* {verb ident type name} [lrange $item 0 3]
1117     set rrtypes [lrange $item 4 end]
1118     puts $chan [format $policyskel \
1119                     $verb \
1120                       $ident \
1121                       $type \
1122                       $name \
1123                       $rrtypes]
1124   }
1125
1126   puts $chan [format $policyskel \
1127                   grant \
1128                     $zone(ddns-key) \
1129                     subdomain \
1130                     $zone(name) \
1131                     $zone(ddns-types)]
1132
1133   puts $chan "${prefix}};"
1134 }
1135
1136 proc write-zone-stanza {view chan config} {
1137   ## Write a `zone' stanza to CHAN for the zone described by the CONFIG
1138   ## plist in the given VIEW.
1139
1140   array set zone [compute-zone-properties $view $config]
1141   if {[string equal $zone(config-type) "ignore"]} { return }
1142
1143   ## Create the directory for the zone files.
1144   set dir [file dirname $zone(file-name)]
1145   if {![file isdirectory $dir]} {
1146     file mkdir $dir
1147     exec chmod $zone(dir-mode) $dir
1148   }
1149
1150   ## Write the configuration fragment.
1151   puts $chan "\nzone \"$zone(name)\" {"
1152   switch -glob -- $zone(config-type) {
1153     master {
1154       puts $chan "\ttype master;"
1155       puts $chan "\tfile \"$zone(file-name)\";"
1156       switch -exact -- $zone(type) {
1157         dynamic { write-ddns-update-policy "\t" $chan $config }
1158       }
1159     }
1160     slave {
1161       puts $chan "\ttype slave;"
1162       set masters {}
1163       foreach host $zone(masters) { lappend masters [host-addr $host] }
1164       puts $chan "\tmasters { [join $masters {; }]; };"
1165       puts $chan "\tfile \"$zone(file-name)\";"
1166       switch -exact -- $zone(type) {
1167         dynamic { puts $chan "\tallow-update-forwarding { any; };" }
1168       }
1169     }
1170   }
1171   puts $chan "};";
1172 }
1173
1174 ###--------------------------------------------------------------------------
1175 ### Command-line interface.
1176
1177 set CONFFILE "/etc/bind/zones.in"
1178
1179 defcmd outputs {} {
1180   help-text "List the output file names to stdout."
1181 } {
1182   global ZONECFG CONFFILE
1183
1184   confspc-eval toplevel [list source $CONFFILE]
1185   foreach view $ZONECFG(all-views) { puts [output-file-name $view] }
1186 }
1187
1188 defcmd update {} {
1189   help-text "Generate BIND configuration files."
1190 } {
1191   global ZONECFG ZONES CONFFILE
1192
1193   confspc-eval toplevel [list source $CONFFILE]
1194   set win false
1195   unwind-protect {
1196     foreach view $ZONECFG(all-views) {
1197       set out($view) [output-file-name $view]
1198       set chan($view) [open "$out($view).new" w]
1199       set now [clock format [clock seconds] -format "%Y-%m-%d %H:%M:%S"]
1200       puts $chan($view) "### -*-conf-javaprop-*-"
1201       puts $chan($view) "### Generated at $now: do not edit"
1202       foreach zone $ZONES {
1203         write-zone-stanza $view $chan($view) $zone
1204       }
1205     }
1206     set win true
1207   } {
1208     foreach view $ZONECFG(all-views) { close $chan($view) }
1209     if {$win} {
1210       foreach view $ZONECFG(all-views) {
1211         file rename -force -- "$out($view).new" $out($view)
1212       }
1213       eval exec $ZONECFG(reconfig-command)
1214     } else {
1215       file delete -force -- "$out($view).new"
1216     }
1217   }
1218 }
1219
1220 defcmd install {user view name} {
1221   help-text "Install a new zone file.
1222
1223 The file is for the given zone NAME and the \(user-side) VIEW.  The file is
1224 provided by the named USER"
1225 } {
1226   global QUIS ZONECFG ZONES CONFFILE errorInfo errorCode
1227
1228   confspc-eval toplevel [list source $CONFFILE]
1229
1230   file mkdir [file join $ZONECFG(master-dir) "tmp"]
1231
1232   set cleanup {}
1233   unwind-protect {
1234
1235     set matchview {}
1236     foreach iview $ZONECFG(all-views) {
1237       foreach info $ZONES {
1238         array unset zone
1239         array set zone [compute-zone-properties $iview $info]
1240         if {[string equal $user $zone(user)] && \
1241                 [string equal "$zone(config-type)/$zone(type)" \
1242                      "master/static"] && \
1243                 [string equal $zone(name) $name] && \
1244                 [string equal $zone(mapped-view) $view]} {
1245           lappend matchview $iview
1246           if {![info exists matchinfo]} { set matchinfo [array get zone] }
1247         }
1248       }
1249     }
1250     if {![llength $matchview]} {
1251       optparse-error "No match for zone `$name' in view `$view'"
1252     }
1253     array unset zone
1254     array set zone $matchinfo
1255
1256     set pid [pid]
1257     for {set i 0} {$i < 1000} {incr i} {
1258       set tmp [file join $ZONECFG(master-dir) "tmp" \
1259                    "tmp.$pid.$i.$user.$name"]
1260       if {![catch { set chan [open $tmp {WRONLY CREAT EXCL}] } msg]} {
1261         break
1262       } elseif {[string equal [lindex $errorCode 0] POSIX] && \
1263                     ![string equal [lindex $errorCode 1] EEXIST]} {
1264         error $msg $errorInfo $errorCode
1265       }
1266     }
1267     if {![info exists chan]} { error "failed to create temporary file" }
1268     set cleanup [list file delete $tmp]
1269
1270     set total 0
1271     while {true} {
1272       set stuff [read stdin 4096]
1273       if {![string length $stuff]} { break }
1274       puts -nonewline $chan $stuff
1275       incr total [string bytelength $stuff]
1276       if {$total > $ZONECFG(max-zone-size)} {
1277         error "zone file size limit exceeded"
1278       }
1279     }
1280     close $chan
1281
1282     set cmd {}
1283     foreach item $zone(checkzone-command) {
1284       lappend cmd [string map [list \
1285                                    "%z" $name \
1286                                    "%v" $view \
1287                                    "%f" $tmp] \
1288                        $item]
1289     }
1290     set rc [catch {
1291       set out [eval exec $cmd]
1292     } msg]
1293     if {$rc} { set out $msg }
1294     set out "| [string map [list "\n" "\n| "] $out]"
1295     if {$rc} {
1296       puts stderr "$QUIS: zone check failed..."
1297       puts stderr $out
1298       exit 1
1299     } else {
1300       puts "$QUIS: zone check output..."
1301       puts $out
1302     }
1303
1304     file rename -force -- $tmp $zone(file-name)
1305     set cleanup {}
1306     foreach view $matchview {
1307       set cmd {}
1308       foreach item $zone(reload-command) {
1309         lappend cmd [string map [list \
1310                                      "%v" $view \
1311                                      "%z" $zone(name)] \
1312                          $item]
1313       }
1314       eval exec $cmd
1315     }
1316   } {
1317     eval $cleanup
1318   }
1319 }
1320
1321 ###--------------------------------------------------------------------------
1322 ### Main program.
1323
1324 set VERSION "1.0.0"
1325 set USAGE() " \[-OPTIONS] SUBCOMMAND \[ARGUMENTS...]"
1326
1327 define-options OPTS {
1328   option {
1329     short "h"; long "help"
1330     action { eval cmd/help [optparse-words]; exit }
1331   }
1332   option {
1333     short "v"; long "version"
1334     action { puts "$QUIS, version $VERSION"; exit }
1335   }
1336   option {
1337     short "c"; long "config"; arg required
1338     action { set CONFFILE [optparse-arg] }
1339   }
1340 }
1341
1342 with-option-parser $OPTS $argv {
1343   optparse-option
1344   set argv [optparse-words]
1345 }
1346
1347 if {![llength $argv]} { usage-error }
1348 dispatch [lindex $argv 0] [lrange $argv 1 end]
1349
1350 ###----- That's all, folks --------------------------------------------------