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