4 ### Generate `named.conf' stanze for multiple views.
6 ### (c) 2011 Mark Wooding
9 ###----- Licensing notice ---------------------------------------------------
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.
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.
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.
25 ###--------------------------------------------------------------------------
26 ### Utility functions.
28 proc pushnew {var args} {
29 ## Append each of the ARGS onto the list VAR if they're not there already.
32 foreach item $list { set found($item) t }
34 if {![info exists found($item)]} {
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.
46 ## Strip out any empty lists in the input.
49 if {[llength $list]} { lappend nlists $list }
53 ## Clear the output list.
56 ## Now pick out items one by one.
57 while {[llength $lists]} {
59 ## Find the candidate items
61 foreach list $lists { pushnew cand [lindex $list 0] }
63 ## Remove candidate items which have not the first in some other list.
67 if {[lsearch -exact $list $cand] < 0} { lappend ncand $cand }
71 ## If there's nothing left, report an error.
72 if {![llength $cand]} {
73 error "Inconsistent lists in `merge-lists'."
76 ## Otherwise take the first item.
77 set chosen [lindex $cand 0]
78 lappend output $chosen
80 ## Remove the chosen item from the input lists.
83 if {[string equal $chosen [lindex $list 0]]} {
84 set list [lrange $list 1 end]
85 if {![llength $list]} { continue }
95 proc adjust-uplevel {spec offset} {
96 ## Adjust an `uplevel' SPEC by OFFSET to take account of intervening call
97 ## frames. If SPEC begins with `#' then it is left alone; otherwise it is
98 ## incremented by OFFSET.
100 switch -glob -- $spec {
102 default { return [expr {$spec + $offset}] }
106 proc unwind-protect {body cleanup} {
107 ## Evaluate BODY; then evaluate CLEANUP, regardless of whether BODY
108 ## returned normally or did something complicated. If CLEANUP completes
109 ## normally then the final result is that of BODY (including any errors or
110 ## abnormal returns it made); otherwise the result of CLEANUP takes
111 ## precedence and the results of BODY are discarded.
113 catch { uplevel 1 $body } bodyval bodyopts
114 if {[catch { uplevel 1 $cleanup } cleanval cleanopts]} {
115 return -options $cleanopts $cleanval
117 return -options $bodyopts $bodyval
122 ## Syntax: let VAR VALUE ... BODY
124 ## Evaluate BODY with the VARs bound to the VALUEs. Reestore the previous
125 ## values when the BODY returns.
127 ## Parse the argument syntax.
128 if {[llength $args] % 2 == 0} {
129 error "bad number of arguments to `let'"
131 set body [lindex $args end]
133 ## Now work through the bindings, setting the variables to their new
134 ## values. As we go, also build up code in `cleanup' to restore everything
135 ## the way it's meant to be.
138 foreach {var value} [lrange $args 0 end-1] {
139 upvar 1 $var fluid-$i
140 if {[info exists fluid-$i]} {
141 append cleanup "set fluid-$i [list [set fluid-$i]]\n"
143 append cleanup "unset fluid-$i\n"
149 ## Now evaluate the body.
150 unwind-protect { uplevel 1 $body } $cleanup
153 proc set* {names values} {
154 ## Set each of the variables listed in NAMES to the corresponding element
155 ## of VALUES. The two lists must have the same length.
157 if {[llength $names] != [llength $values]} {
158 error "length mismatch"
160 foreach name $names value $values {
166 ###--------------------------------------------------------------------------
167 ### Configuration spaces.
169 ### A configuration space is essentially a collection of Tcl commands and a
170 ### global array which the commands act on. The commands live in their own
171 ### namespace and their availability can be altered by modifying the
172 ### namespace path. The basic idea is to support a structured configuration
173 ### language with short directive names and where the available directives
174 ### varies in a context-sensitive manner.
176 ### A configuration space can include other spaces, and they can include
177 ### further spaces. The graph of inclusions must be acyclic; further, since
178 ### the available commands are determined using the C3 linearization
179 ### algorithm, the relation in which a space precedes the spaces it includes,
180 ### and a space A precedes another space B if a third space includes A before
181 ### B, must be a partial order, and the linearizations of all of the spaces
182 ### must be monotonic. Don't worry about that if you don't know what it
183 ### means. If you don't do anything weird, it'll probably be all right.
185 proc confspc-create {space confvar} {
186 ## Define a new configuration space called SPACE. You must do this before
187 ## defining directives or including other spaces.
189 global CONFSPC_CMD CONFSPC_INCL CONFSPC_CPL CONFSPC_CHANGE CONFSPC_VAR
190 if {![info exists CONFSPC_CMD($space)]} {
191 set CONFSPC_CMD($space) {}
192 set CONFSPC_INCL($space) {}
193 set CONFSPC_CPL($space) [list $space]
194 set CONFSPC_CHANGE($space) 0
195 set CONFSPC_VAR($space) $confvar
196 namespace eval ::confspc::$space {}
200 ## Change sequence numbers are used to decide whether the linearized
201 ## inclusion caches are up to date.
202 set CONFSPC_LASTCHANGESEQ 0
203 set CONFSPC_CHANGESEQ 0
205 proc confspc-command {space name bvl body} {
206 ## Define a configuration directive NAME in SPACE, accepting the arguments
207 ## specified by the BVL, and executing BODY when invoked. The SPACE's
208 ## configuration array is available within the BODY.
210 global CONFSPC_CMD CONFSPC_VAR
211 pushnew CONFSPC_CMD($space) $name
213 ## Define the configuration command in the caller's namespace.
214 set ns [uplevel 1 { namespace current }]
215 eval [list proc ${ns}::conf/$space/$name $bvl \
216 "global $CONFSPC_VAR($space)\n$body"]
217 namespace eval $ns [list namespace export conf/$space/$name]
219 ## Now arrange for this command to exist properly in the configuration
221 namespace eval ::confspc::$space \
222 [list namespace import ${ns}::conf/$space/$name]
224 namespace eval ::confspc::$space [list rename $name {}]
226 namespace eval ::confspc::$space \
227 [list rename conf/$space/$name $name]
230 proc confspc-include {space includes} {
231 ## Arrange for SPACE to include the directives from the INCLUDES spaces.
233 global CONFSPC_INCL CONFSPC_LASTCHANGESEQ CONFSPC_CHANGESEQ
234 pushnew CONFSPC_INCL($space) $includes
235 if {$CONFSPC_CHANGESEQ <= $CONFSPC_LASTCHANGESEQ} {
236 set CONFSPC_CHANGESEQ [expr {$CONFSPC_LASTCHANGESEQ + 1}]
240 proc confspc-update {space} {
241 ## Update cached data for SPACE and its included spaces. We recompute the
242 ## space's class-precedence list, for which we use the C3 linearization
243 ## algorithm, which has known good properties.
245 global CONFSPC_CPL CONFSPC_CHANGE CONFSPC_INCL
246 global CONFSPC_CHANGESEQ CONFSPC_LASTCHANGESEQ
247 set CONFSPC_LASTCHANGESEQ $CONFSPC_CHANGESEQ
249 ## If the space is already up-to-date, do nothing.
250 if {$CONFSPC_CHANGE($space) == $CONFSPC_CHANGESEQ} { return }
252 ## Arrange for the included spaces to be up-to-date, and gather the CPLs
253 ## together so we can merge them.
255 lappend merge [concat $space $CONFSPC_INCL($space)]
256 foreach included $CONFSPC_INCL($space) {
257 confspc-update $included
258 lappend merge $CONFSPC_CPL($included)
261 ## Do the merge and update the change indicator.
262 set CONFSPC_CPL($space) [merge-lists $merge]
263 set CONFSPC_CHANGE($space) $CONFSPC_CHANGESEQ
266 proc confspc-path {ns cpl} {
267 ## Update namespace NS's command path so that it has (only) the
268 ## directives of the given CPL. Pass an empty CPL to clear the
269 ## configuration space hacking.
273 ## Add the new namespaces to the front.
274 foreach spc $cpl { lappend path ::confspc::$spc }
276 ## Now add the existing path items, with any existing confspc hacking
278 foreach item [namespace eval $ns { namespace path }] {
279 if {![string match "::confspc::*" $item]} { lappend npath $item }
282 ## Commit the result.
283 namespace eval $ns [list namespace path $path]
286 proc confspc-set {ns space} {
287 ## Set the command path for namespace NS to include the configuration
288 ## directives of SPACE (and its included spaces).
291 confspc-update $space
292 confspc-path $ns $CONFSPC_CPL($space)
295 proc confspc-eval {space body} {
296 ## Evaluate BODY in the current namespace, but augmented with the
297 ## directives from the named SPACE. The command path of the current
298 ## namespace is restored afterwards.
300 set ns [uplevel 1 { namespace current }]
301 set path [namespace eval $ns { namespace path }]
303 confspc-set $ns $space
306 namespace eval $ns [list namespace path $path]
310 proc preserving-config {confvar body} {
311 ## Evaluate BODY, but on exit restore the CONFVAR array so that the BODY
312 ## has no lasting effect on it.
314 upvar #1 $confvar CONFIG
315 set old [array get CONFIG]
320 array set CONFIG $old
324 confspc-create confspc CONFSPC_CONFIG
326 confspc-command confspc include {args} {
327 ## Include the named configuration spaces in the current one.
329 confspc-include $CONFSPC_CONFIG(space) $args
332 confspc-command confspc define {name bvl body} {
333 ## Define a directive NAME in the current space, taking arguments BVL, and
334 ## having the given BODY.
336 confspc-command $CONFSPC_CONFIG(space) $name $bvl $body
339 confspc-command confspc define-simple {setting default} {
340 ## Define a directive SETTING which sets the appropriately prefixed entry
341 ## in the CONFIG array to its single arguments, and immediately set the
342 ## CONFIG entry to DEFAULT.
345 set space $CONFSPC_CONFIG(space)
346 upvar #0 $CONFSPC_VAR($space) config
347 confspc-command $space $setting arg \
348 "set $CONFSPC_VAR($space)($CONFSPC_CONFIG(prefix)$setting) \$arg"
349 set config($CONFSPC_CONFIG(prefix)$setting) $default
352 confspc-command confspc define-list {setting default} {
353 ## Define a directive SETTING which sets the appropriately prefixed entry
354 ## in the CONFIG array to its entire argument list, and immediately set the
355 ## CONFIG entry to DEFAULT (which should be a Tcl list, not a collection of
359 set space $CONFSPC_CONFIG(space)
360 upvar #0 $CONFSPC_VAR($space) config
361 confspc-command $space $setting args \
362 "set $CONFSPC_VAR($space)($CONFSPC_CONFIG(prefix)$setting) \$args"
363 set config($CONFSPC_CONFIG(prefix)$setting) $default
366 confspc-command confspc prefix {prefix} {
367 set CONFSPC_CONFIG(prefix) $prefix
370 proc define-configuration-space {space confvar body} {
371 ## Define a new configuration space named SPACE. The BODY is Tcl code,
372 ## though it may make use of `include' and `define'.
374 global CONFSPC_CONFIG
375 set ns [uplevel 1 { namespace current }]
376 set oldpath [namespace eval $ns { namespace path }]
377 confspc-create $space $confvar
379 preserving-config CONFSPC_CONFIG {
380 array set CONFSPC_CONFIG [list space $space \
382 confspc-set $ns confspc
386 namespace eval $ns [list namespace path $oldpath]
390 ###--------------------------------------------------------------------------
393 ### The option parsing machinery makes extensive use of a state array
394 ### OPTPARSE_STATE in order to maintain its context. The procedure
395 ### `with-option-parser' establishes this array correctly, and preserves any
396 ### existing state, so there should be no trouble with multiple parsers in
397 ### the same program.
399 proc optparse-more-p {} {
400 ## Answer whether there are more argument words available.
402 upvar #0 OPTPARSE_STATE state
403 if {[llength $state(words)]} { return true } else { return false }
406 proc optparse-next-word {} {
407 ## Return the next word in the argument list. It is an error if there are
408 ## no more words left.
410 upvar #0 OPTPARSE_STATE state
411 set word [lindex $state(words) 0]
412 set state(words) [lrange $state(words) 1 end]
416 proc optparse-error {message} {
417 ## Report an error message and exit.
420 puts stderr "$QUIS: $message"
424 proc optparse-option/short {var} {
425 ## Parse the next short option from the current cluster. If there are no
426 ## more short options, set the mode back to `free' and call back into
427 ## `optparse-option/free'.
429 ## See the description of `optparse-option/free' for the interface
430 ## implemented by this procedure.
432 ## Get hold of my state and the caller's array.
433 upvar #0 OPTPARSE_STATE state
436 ## Work out what to do based on the remaining length of the cluster. (The
437 ## cluster shouldn't be empty because the mode should only be set to
438 ## `short' if there is an initial nonempty cluster to parse, and we set it
439 ## back to `free' when we consume the final character from the cluster.)
440 ## Specifically, set `argp' according to whether we have a potential
441 ## argument in the cluster, and `name' to the option character extracted.
443 switch [string length $state(rest)] {
445 error "empty cluster"
450 set name $state(rest)
454 set name [string index $state(rest) 0]
455 set state(rest) [string range $state(rest) 1 end]
459 ## Try to look up the option in the map.
460 if {![dict exists $state(short-map) $name]} {
461 optparse-error "Unknown option `$state(prefix)$name'"
463 array set opt [dict get $state(short-map) $name]
464 set state(name) $name
466 ## Collect an argument if one is required.
467 catch { unset state(arg) }
468 switch -glob -- "$opt(arg),$argp" {
470 if {![optparse-more-p]} {
471 optparse-error "Option `$state(prefix)$name' requires an argument"
473 set state(arg) [optparse-next-word]
475 "required,true" - "optional,true" {
476 set state(arg) $state(rest)
485 proc optparse-option/free {var} {
486 ## Parse the next option from the argument list. This procedure is called
487 ## to process a new argument word, i.e., we are in `free' mode. It
488 ## analyses the next argument word and either processes it internally or
489 ## sets the mode appropriately and calls a specialized handler
490 ## `optparse-option/MODE' for that mode.
492 ## The interface works as follows. If an option was found, then the array
493 ## VAR is set according to the option's settings dictionary; and state
494 ## variables are set as follows.
496 ## prefix The prefix character(s) to write before the option name in
497 ## messages, e.g., `--' for long options.
499 ## name The option name without any prefix attached.
501 ## arg The option's argument, if there is one; otherwise unset.
503 upvar #0 OPTPARSE_STATE state
508 catch { unset state(arg) }
509 if {![optparse-more-p]} { return 0 }
510 set word [optparse-next-word]
512 ## Work out what to do based on the word. The order of these tests is
513 ## critically important.
514 switch -glob -- $word {
517 ## End-of-options marker.
525 set state(prefix) "--"
527 ## If there's an equals sign, the name is the bit to the left; keep the
528 ## remainder as an argument.
529 set eq [string first "=" $word 2]
531 set name [string range $word 2 [expr {$eq - 1}]]
532 set state(arg) [string range $word [expr {$eq + 1}] end]
535 set name [string range $word 2 end]
540 ## Look the name up in the map.
541 if {[dict exists $state(long-map) $name]} {
542 array set opt [dict get $state(long-map) $name]
544 set matches [dict keys $state(long-map) "$name*"]
545 switch -exact -- [llength $matches] {
546 1 { array set opt [dict get $state(long-map) [lindex $matches 0]] }
547 0 { optparse-error "Unknown option `--$name'" }
549 optparse-error "Ambiaguous option `--$name' \
550 (matches: --[join $matches {, --}])"
555 ## Now check whether we want an argument. The missing cases are
556 ## because we are already in the correct state.
557 switch -glob -- "$opt(arg),$argp" {
559 optparse-error "Option `$name' doesn't accept an argument"
562 if {![optparse-more-p]} {
563 optparse-error "Option `$name' requires an argument"
565 set state(arg) [optparse-next-word]
569 ## Done. We consumed either one or two entire argument words, so we
570 ## should remain in the `free' state.
575 ## Short option. Set state, initialize the cluster, and go.
577 set state(rest) [string range $word 1 end]
578 set state(mode) short
579 set state(prefix) "-"
580 return [optparse-option/short opt]
584 ## Some non-option thing. Under POSIX rules, this ends the parse. (We
585 ## could do something more adventurous later.)
587 set state(words) [concat [list $word] $state(words)]
593 proc optparse-arg-p {} {
594 ## Return the whether the most recently processed option had an argument.
596 upvar #0 OPTPARSE_STATE state
597 return [info exists state(arg)]
600 proc optparse-arg {} {
601 ## Return the argument from the most recently processed option. It is an
602 ## error if no argument was supplied.
604 upvar #0 OPTPARSE_STATE state
608 proc optparse-words {} {
609 ## Return the remaining unparsed argument words as a list.
611 upvar #0 OPTPARSE_STATE state
615 proc optparse-option {} {
616 ## Parse the next option(s). The action taken depends on the option
617 ## dictionary: if an `action' is provided then it is evaluated in the
618 ## caller's context; otherwise the option's `tag' is returned.
620 upvar #0 OPTPARSE_STATE state
622 if {![optparse-option/$state(mode) opt]} {
624 } elseif {[info exists opt(action)]} {
625 uplevel 1 $opt(action)
626 } elseif {[info exists opt(tag)]} {
629 error "Don't know what to do with option `$state(prefix)$state(name)'"
634 proc with-option-parser {state words body} {
635 ## Establish an option parsing context, initialized with the STATE
636 ## (constructed using `define-options') and the lits of argument WORDS.
637 ## The BODY may use `optparse-option', `optparse-arg', etc. to parse the
640 global OPTPARSE_STATE
641 set old [array get OPTPARSE_STATE]
644 array unset OPTPARSE_STATE
645 array set OPTPARSE_STATE $state
646 set OPTPARSE_STATE(mode) free
647 set OPTPARSE_STATE(words) $words
650 array set OPTPARSE_STATE $old
654 define-configuration-space optparse-option OPTCFG {
657 define action {act} { set OPTCFG(action) $act }
658 define tag {tag} { set OPTCFG(tag) $tag }
659 define-simple arg none
662 define-configuration-space optparse OPTCFG {
663 define option {body} {
664 upvar #0 OPTPARSE_STATE state
665 uplevel 1 [list confspc-eval optparse-option $body]
666 set opt [array get OPTCFG]
667 foreach kind {long short} {
668 foreach name $OPTCFG($kind) {
669 if {[dict exists $state($kind-map) $name]} {
670 error "Already have an option with $kind name `$name'"
672 dict set state($kind-map) $name $opt
678 proc define-options {statevar body} {
679 ## Define an option state, and write it to STATEVAR. The BODY may contain
680 ## `optparse' configuration directives to define the available options.
682 global OPTPARSE_STATE
683 upvar 1 $statevar state
684 set old [array get OPTPARSE_STATE]
686 array unset OPTPARSE_STATE
687 if {[info exists state]} {
688 array set OPTPARSE_STATE $state
690 array set OPTPARSE_STATE {
695 uplevel 1 [list confspc-eval optparse $body]
696 set state [array get OPTPARSE_STATE]
698 array set OPTPARSE_STATE $old
702 ###--------------------------------------------------------------------------
703 ### Subcommand handling.
705 ## Determine the program name.
706 set QUIS [file tail $argv0]
708 ## This is fluid-bound to the name of the current command.
711 proc find-command {name} {
712 ## Given a command NAME as typed by the user, find the actual command and
716 set matches [info commands cmd/$name*]
719 foreach match $matches {
720 set cmd [string range $match 4 end]
722 if {[info exists HELP($cmd)]} { lappend doc $cmd }
724 switch -exact -- [llength $cmds] {
725 1 { return [lindex $cmds 0] }
726 0 { optparse-error "Unknown command `$name'" }
728 if {[llength $doc]} { set cmds $doc }
729 switch -exact -- [llength $cmds] {
730 1 { return [lindex $cmds 0] }
731 0 { optparse-error "Unknown command `$name'" }
732 default { optparse-error "Ambiguous command `$name' -- matches: $cmds" }
737 ## Return a usage message for CMD. The message is taken from the `USAGE'
738 ## array if that contains an entry for CMD (it should not include the
739 ## command name, and should begin with a leading space); otherwise a
740 ## message is constructed by examining the argument names and defaulting
741 ## arrangements of the Tcl command cmd/CMD.
743 ## By convention, the main program is denoted by an empty CMD name.
746 if {[info exists USAGE($cmd)]} {
747 set usage $USAGE($cmd)
750 foreach arg [info args cmd/$cmd] {
751 if {[string equal $arg "args"]} {
753 } elseif {[info default cmd/$cmd $arg hunoz]} {
754 append usage " \[[string toupper $arg]\]"
756 append usage " [string toupper $arg]"
763 proc usage-error {} {
764 ## Report a usage error in the current command. The message is obtained by
765 ## the `usage' procedure.
768 if {[string length $COMMAND]} { set cmd " $COMMAND" } else { set cmd "" }
769 puts stderr "Usage: $QUIS$cmd[usage $COMMAND]"
773 proc dispatch {name argv} {
774 ## Invokes the handler for CMD, passing it the argument list ARGV. This
775 ## does some minimal syntax checking by examining the argument list to the
776 ## command handler procedure cmd/COMMAND and issuing a usage error if
777 ## there's a mismatch.
780 let COMMAND [find-command $name] {
782 ## Decode the argument list of the handler and set min and max
784 set args [info args cmd/$COMMAND]
785 if {![llength $args]} {
788 if {[string equal [lindex $args end] "args"]} {
790 set args [lrange $args 0 end-1]
792 set max [llength $args]
796 if {[info default cmd/$COMMAND $arg hunoz]} { break }
801 ## Complain if the number of arguments is inappropriate.
802 set n [llength $argv]
803 if {$n < $min || ($max != inf && $n > $max)} { usage-error }
805 ## Invoke the handler.
806 eval cmd/$COMMAND $argv
810 define-configuration-space subcommand SUBCMD {
811 define-simple help-text -
812 define-simple usage-text -
815 proc defcmd {name bvl defs body} {
816 ## Define a command NAME with arguments BVL. The `usage-text' and
817 ## `help-text' commands can be used in DEFS to set messages for the new
820 global SUBCMD USAGE HELP
822 preserving-config SUBCMD {
823 confspc-eval subcommand { uplevel 1 $defs }
824 foreach tag {usage-text help-text} array {USAGE HELP} {
825 if {![string equal $SUBCMD($tag) -]} {
826 set ${array}($name) $SUBCMD($tag)
830 proc cmd/$name $bvl $body
833 ## Standard subcommand handler to show information about the program or its
834 ## subcommands. To use this, you need to set a bunch of variables.
836 ## USAGE(cmd) Contains the usage message for cmd -- including
837 ## leading space -- to use instead of the `usage'
838 ## procedure's automagic.
840 ## HELP(cmd) Contains descriptive text -- not including a final
841 ## trailing newline -- about the command.
843 ## VERSION The program's version number.
845 ## The `defcmd' procedure can be used to set these things up conveniently.
847 usage-text " \[SUBCOMMAND ...]"
848 help-text "Show help on the given SUBCOMMANDs, or on the overall program."
850 global QUIS VERSION USAGE HELP
851 if {[llength $args]} {
853 set cmd [find-command $name]
854 puts "Usage: $QUIS $cmd[usage $cmd]"
855 if {[info exists HELP($cmd)]} { puts "\n$HELP($cmd)" }
858 puts "$QUIS, version $VERSION\n"
859 puts "Usage: $QUIS$USAGE()\n"
860 if {[info exists HELP()]} { puts "$HELP()\n" }
861 puts "Subcommands available:"
862 foreach name [info commands cmd/*] {
863 set cmd [string range $name 4 end]
864 puts "\t$cmd[usage $cmd]"
869 ###--------------------------------------------------------------------------
870 ### Build the configuration space for zone files.
872 proc host-addr {host} {
873 ## Given a HOST name, return a list of its addresses.
875 if {![string match $host {*[!0-9.]*}]} { return $host }
876 set adns [open [list | adnshost +Dc -s $host] r]
879 while {[gets $adns line] >= 0} {
880 set* {name type fam addr} $line
881 switch -glob -- $type:$fam {
882 A:INET { lappend addrs $addr }
885 return [lindex $addrs 0]
891 proc host-canonify {host} {
892 ## Given a HOST name, return a canonical version of it.
894 set adns [open [list | adnshost -Dc -s $host] r]
896 while {[gets $adns line] >= 0} {
897 switch -exact -- [lindex $line 1] {
898 CNAME { return [lindex $line 2] }
899 A - AAAA { return [lindex $line 0] }
902 error "failed to canonify $host"
908 proc local-address-p {addr} {
909 ## Answer whether the ADDR is one of the host's addresses.
911 if {[catch { set sk [socket -server {} -myaddr $addr 0] }]} {
919 ## The list of zones configured by the user.
922 ## Dynamic zone update policy specifications.
923 define-configuration-space policy ZONECFG {
924 define allow {identity nametype name args} {
925 lappend ZONECFG(ddns-policy) \
926 [concat grant [list $identity $nametype $name] $args]
928 define deny {identity nametype name args} {
929 lappend ZONECFG(ddns-policy) \
930 [concat deny [list $identity $nametype $name] $args]
934 ## Dynamic zone details.
935 define-configuration-space dynamic ZONECFG {
937 define-simple key "ddns"
938 define-list types {A TXT PTR}
940 define policy {body} {
941 set ZONECFG(ddns-policy) {}
942 uplevel 1 [list confspc-eval policy $body]
945 set ZONECFG(ddns-policy) {}
948 ## Everything about a zone.
949 define-configuration-space zone ZONECFG {
950 define-simple user root
951 define-simple master-dir "/var/lib/bind"
952 define-simple slave-dir "/var/cache/bind"
953 define-simple dir-mode 2775
954 define-simple zone-file "%v/%z.zone"
956 define-list reload-command {/usr/sbin/rndc reload %z IN %v}
957 define-list checkzone-command {
958 /usr/sbin/named-checkzone
969 define primary {map} {
970 if {[llength $map] % 2} {
971 error "master map must have an even number of items"
973 set ZONECFG(master-map) $map
976 define dynamic {{body {}}} {
977 array set ZONECFG [list type dynamic]
978 uplevel 1 [list confspc-eval dynamic $body]
981 define view-map {map} {
982 if {[llength $map] % 2} {
983 error "view map must have an even number of items"
985 set ZONECFG(view-map) $map
994 ## Top-level configuration. Allow most zone options to be set here, so that
995 ## one can set defaults for multiple zones conveniently.
996 define-configuration-space toplevel ZONECFG {
999 define-list all-views {}
1000 define-simple conf-file "/var/lib/zoneconf/config/%v.conf"
1001 define-simple max-zone-size [expr {512*1024}]
1002 define-list reconfig-command {/usr/sbin/rndc reconfig}
1004 define scope {body} { preserving-config ZONECFG { uplevel 1 $body } }
1006 define zone {name {body {}}} {
1008 preserving-config ZONECFG {
1012 uplevel 1 [list confspc-eval zone $body]
1013 lappend ZONES [array get ZONECFG]
1018 ###--------------------------------------------------------------------------
1019 ### Processing the results.
1021 proc zone-file-name {view config} {
1022 ## Return the relative file name for the zone described by CONFIG, relative
1023 ## to the given VIEW. An absolute filename may be derived later, depending
1024 ## on whether the zone data is static and the calling host is the master
1027 array set zone $config
1028 return [string map [list \
1034 proc output-file-name {view} {
1035 ## Return the output file name for the given VIEW.
1038 return [string map [list %v $view] $ZONECFG(conf-file)]
1041 proc compute-zone-properties {view config} {
1042 ## Derive interesting information from the zone configuration plist CONFIG,
1043 ## relative to the stated VIEW. Return a new plist.
1045 array set zone $config
1047 ## See whether the zone matches the view.
1049 foreach wanted $zone(views) {
1050 if {[string match $wanted $view]} { set match 1; break }
1052 if {!$match} { return {config-type ignore} }
1054 ## Transform the view name according to the view map.
1055 foreach {inview outview} $zone(view-map) {
1056 if {![string match $inview $view]} { continue }
1057 switch -exact -- $outview {
1058 = { set zone(mapped-view) $view }
1059 default { set zone(mapped-view) $outview }
1064 ## Find out where the master is supposed to be.
1065 set zone(config-type) ignore
1066 if {[info exists zone(mapped-view)]} {
1067 foreach {outview hosts} $zone(master-map) {
1068 if {[string match $outview $zone(mapped-view)]} {
1069 set zone(masters) $hosts
1070 set zone(config-type) slave
1071 foreach host $hosts {
1072 if {[local-address-p $host]} {
1073 set zone(config-type) master
1081 ## Main dispatch for zone categorization.
1082 switch -exact -- $zone(config-type) {
1084 switch -exact -- $zone(type) {
1086 set zone(file-name) \
1087 [file join $zone(master-dir) \
1088 [zone-file-name $zone(mapped-view) $config]]
1091 set zone(file-name) [file join $zone(slave-dir) \
1092 [zone-file-name $view $config]]
1097 set zone(file-name) [file join $zone(slave-dir) \
1098 [zone-file-name $view $config]]
1103 return [array get zone]
1106 proc write-ddns-update-policy {prefix chan config} {
1107 ## Write an `update-policy' stanza to CHAN for the zone described by the
1108 ## CONFIG plist. The PREFIX is written to the start of each line.
1110 array set zone $config
1111 puts $chan "${prefix}update-policy {"
1112 set policyskel "${prefix}\t%s %s %s \"%s\" %s;"
1114 foreach item $zone(ddns-policy) {
1115 set* {verb ident type name} [lrange $item 0 3]
1116 set rrtypes [lrange $item 4 end]
1117 puts $chan [format $policyskel \
1125 puts $chan [format $policyskel \
1132 puts $chan "${prefix}};"
1135 proc write-zone-stanza {view chan config} {
1136 ## Write a `zone' stanza to CHAN for the zone described by the CONFIG
1137 ## plist in the given VIEW.
1139 array set zone [compute-zone-properties $view $config]
1140 if {[string equal $zone(config-type) "ignore"]} { return }
1142 ## Create the directory for the zone files.
1143 set dir [file dirname $zone(file-name)]
1144 if {![file isdirectory $dir]} {
1146 exec chmod $zone(dir-mode) $dir
1149 ## Write the configuration fragment.
1150 puts $chan "\nzone \"$zone(name)\" {"
1151 switch -glob -- $zone(config-type) {
1153 puts $chan "\ttype master;"
1154 puts $chan "\tfile \"$zone(file-name)\";"
1155 switch -exact -- $zone(type) {
1156 dynamic { write-ddns-update-policy "\t" $chan $config }
1160 puts $chan "\ttype slave;"
1162 foreach host $zone(masters) { lappend masters [host-addr $host] }
1163 puts $chan "\tmasters { [join $masters {; }]; };"
1164 puts $chan "\tfile \"$zone(file-name)\";"
1165 switch -exact -- $zone(type) {
1166 dynamic { puts $chan "\tallow-update-forwarding { any; };" }
1173 ###--------------------------------------------------------------------------
1174 ### Command-line interface.
1176 set CONFFILE "/etc/bind/zones.in"
1179 help-text "List the output file names to stdout."
1181 global ZONECFG CONFFILE
1183 confspc-eval toplevel [list source $CONFFILE]
1184 foreach view $ZONECFG(all-views) { puts [output-file-name $view] }
1188 help-text "Generate BIND configuration files."
1190 global ZONECFG ZONES CONFFILE
1192 confspc-eval toplevel [list source $CONFFILE]
1195 foreach view $ZONECFG(all-views) {
1196 set out($view) [output-file-name $view]
1197 set chan($view) [open "$out($view).new" w]
1198 set now [clock format [clock seconds] -format "%Y-%m-%d %H:%M:%S"]
1199 puts $chan($view) "### -*-conf-javaprop-*-"
1200 puts $chan($view) "### Generated at $now: do not edit"
1201 foreach zone $ZONES {
1202 write-zone-stanza $view $chan($view) $zone
1207 foreach view $ZONECFG(all-views) { close $chan($view) }
1209 foreach view $ZONECFG(all-views) {
1210 file rename -force -- "$out($view).new" $out($view)
1212 eval exec $ZONECFG(reconfig-command)
1214 file delete -force -- "$out($view).new"
1219 defcmd install {user view name} {
1220 help-text "Install a new zone file.
1222 The file is for the given zone NAME and the \(user-side) VIEW. The file is
1223 provided by the named USER"
1225 global QUIS ZONECFG ZONES CONFFILE errorInfo errorCode
1227 confspc-eval toplevel [list source $CONFFILE]
1229 file mkdir [file join $ZONECFG(master-dir) "tmp"]
1235 foreach iview $ZONECFG(all-views) {
1236 foreach info $ZONES {
1238 array set zone [compute-zone-properties $iview $info]
1239 if {[string equal $user $zone(user)] && \
1240 [string equal "$zone(config-type)/$zone(type)" \
1241 "master/static"] && \
1242 [string equal $zone(name) $name] && \
1243 [string equal $zone(mapped-view) $view]} {
1244 lappend matchview $iview
1245 if {![info exists matchinfo]} { set matchinfo [array get zone] }
1249 if {![llength $matchview]} {
1250 optparse-error "No match for zone `$name' in view `$view'"
1253 array set zone $matchinfo
1256 for {set i 0} {$i < 1000} {incr i} {
1257 set tmp [file join $ZONECFG(master-dir) "tmp" \
1258 "tmp.$pid.$i.$user.$name"]
1259 if {![catch { set chan [open $tmp {WRONLY CREAT EXCL}] } msg]} {
1261 } elseif {[string equal [lindex $errorCode 0] POSIX] && \
1262 ![string equal [lindex $errorCode 1] EEXIST]} {
1263 error $msg $errorInfo $errorCode
1266 if {![info exists chan]} { error "failed to create temporary file" }
1267 set cleanup [list file delete $tmp]
1271 set stuff [read stdin 4096]
1272 if {![string length $stuff]} { break }
1273 puts -nonewline $chan $stuff
1274 incr total [string bytelength $stuff]
1275 if {$total > $ZONECFG(max-zone-size)} {
1276 error "zone file size limit exceeded"
1282 foreach item $zone(checkzone-command) {
1283 lappend cmd [string map [list \
1290 set out [eval exec $cmd]
1292 if {$rc} { set out $msg }
1293 set out "| [string map [list "\n" "\n| "] $out]"
1295 puts stderr "$QUIS: zone check failed..."
1299 puts "$QUIS: zone check output..."
1303 file rename -force -- $tmp $zone(file-name)
1305 foreach view $matchview {
1307 foreach item $zone(reload-command) {
1308 lappend cmd [string map [list \
1320 ###--------------------------------------------------------------------------
1324 set USAGE() " \[-OPTIONS] SUBCOMMAND \[ARGUMENTS...]"
1326 define-options OPTS {
1328 short "h"; long "help"
1329 action { eval cmd/help [optparse-words]; exit }
1332 short "v"; long "version"
1333 action { puts "$QUIS, version $VERSION"; exit }
1336 short "c"; long "config"; arg required
1337 action { set CONFFILE [optparse-arg] }
1341 with-option-parser $OPTS $argv {
1343 set argv [optparse-words]
1346 if {![llength $argv]} { usage-error }
1347 dispatch [lindex $argv 0] [lrange $argv 1 end]
1349 ###----- That's all, folks --------------------------------------------------