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 are not first in some other list.
67 if {[lsearch -exact $list $cand] <= 0} { lappend ncand $cand }
72 ## If there's nothing left, report an error.
73 if {![llength $cand]} {
74 error "Inconsistent lists in `merge-lists'."
77 ## Otherwise take the first item.
78 set chosen [lindex $cand 0]
79 lappend output $chosen
81 ## Remove the chosen item from the input lists.
84 if {[string equal $chosen [lindex $list 0]]} {
85 set list [lrange $list 1 end]
86 if {![llength $list]} { continue }
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.
101 switch -glob -- $spec {
103 default { return [expr {$spec + $offset}] }
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.
114 catch { uplevel 1 $body } bodyval bodyopts
115 if {[catch { uplevel 1 $cleanup } cleanval cleanopts]} {
116 return -options $cleanopts $cleanval
118 return -options $bodyopts $bodyval
123 ## Syntax: let VAR VALUE ... BODY
125 ## Evaluate BODY with the VARs bound to the VALUEs. Reestore the previous
126 ## values when the BODY returns.
128 ## Parse the argument syntax.
129 if {[llength $args] % 2 == 0} {
130 error "bad number of arguments to `let'"
132 set body [lindex $args end]
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.
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"
144 append cleanup "unset fluid-$i\n"
150 ## Now evaluate the body.
151 unwind-protect { uplevel 1 $body } $cleanup
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.
158 if {[llength $names] != [llength $values]} {
159 error "length mismatch"
161 foreach name $names value $values {
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.
175 ## Substitute tokens in the command.
177 set subst [concat [list "%%" "%"] $args]
178 foreach item $command { lappend cmd [string map $subst $item] }
182 set out [eval exec -ignorestderr $cmd 2>@1]
185 ## Sort out the report.
186 if {$rc} { set out $msg }
187 set out "| [string map [list "\n" "\n| "] $out]"
189 ## Announce the result.
191 puts stderr "$QUIS: $what failed..."
195 puts "$QUIS: $what output..."
201 proc isolate {body} {
202 ## Evaluate BODY without changing the caller's variables. Return its
208 ###--------------------------------------------------------------------------
209 ### Configuration spaces.
211 ### A configuration space is essentially a collection of Tcl commands and a
212 ### global array which the commands act on. The commands live in their own
213 ### namespace and their availability can be altered by modifying the
214 ### namespace path. The basic idea is to support a structured configuration
215 ### language with short directive names and where the available directives
216 ### varies in a context-sensitive manner.
218 ### A configuration space can include other spaces, and they can include
219 ### further spaces. The graph of inclusions must be acyclic; further, since
220 ### the available commands are determined using the C3 linearization
221 ### algorithm, the relation in which a space precedes the spaces it includes,
222 ### and a space A precedes another space B if a third space includes A before
223 ### B, must be a partial order, and the linearizations of all of the spaces
224 ### must be monotonic. Don't worry about that if you don't know what it
225 ### means. If you don't do anything weird, it'll probably be all right.
227 proc confspc-create {space confvar} {
228 ## Define a new configuration space called SPACE. You must do this before
229 ## defining directives or including other spaces.
231 global CONFSPC_CMD CONFSPC_INCL CONFSPC_CPL CONFSPC_CHANGE CONFSPC_VAR
232 if {![info exists CONFSPC_CMD($space)]} {
233 set CONFSPC_CMD($space) {}
234 set CONFSPC_INCL($space) {}
235 set CONFSPC_CPL($space) [list $space]
236 set CONFSPC_CHANGE($space) 0
237 set CONFSPC_VAR($space) $confvar
238 namespace eval ::confspc::$space {}
242 ## Change sequence numbers are used to decide whether the linearized
243 ## inclusion caches are up to date.
244 set CONFSPC_LASTCHANGESEQ 0
245 set CONFSPC_CHANGESEQ 0
247 proc confspc-command {space name bvl body} {
248 ## Define a configuration directive NAME in SPACE, accepting the arguments
249 ## specified by the BVL, and executing BODY when invoked. The SPACE's
250 ## configuration array is available within the BODY.
252 global CONFSPC_CMD CONFSPC_VAR
253 pushnew CONFSPC_CMD($space) $name
255 ## Define the configuration command in the caller's namespace.
256 set ns [uplevel 1 { namespace current }]
257 eval [list proc ${ns}::conf/$space/$name $bvl \
258 "global $CONFSPC_VAR($space)\n$body"]
259 namespace eval $ns [list namespace export conf/$space/$name]
261 ## Now arrange for this command to exist properly in the configuration
263 namespace eval ::confspc::$space \
264 [list namespace import ${ns}::conf/$space/$name]
266 namespace eval ::confspc::$space [list rename $name {}]
268 namespace eval ::confspc::$space \
269 [list rename conf/$space/$name $name]
272 proc confspc-include {space includes} {
273 ## Arrange for SPACE to include the directives from the INCLUDES spaces.
275 global CONFSPC_INCL CONFSPC_LASTCHANGESEQ CONFSPC_CHANGESEQ
276 pushnew CONFSPC_INCL($space) $includes
277 if {$CONFSPC_CHANGESEQ <= $CONFSPC_LASTCHANGESEQ} {
278 set CONFSPC_CHANGESEQ [expr {$CONFSPC_LASTCHANGESEQ + 1}]
282 proc confspc-update {space} {
283 ## Update cached data for SPACE and its included spaces. We recompute the
284 ## space's class-precedence list, for which we use the C3 linearization
285 ## algorithm, which has known good properties.
287 global CONFSPC_CPL CONFSPC_CHANGE CONFSPC_INCL
288 global CONFSPC_CHANGESEQ CONFSPC_LASTCHANGESEQ
289 set CONFSPC_LASTCHANGESEQ $CONFSPC_CHANGESEQ
291 ## If the space is already up-to-date, do nothing.
292 if {$CONFSPC_CHANGE($space) == $CONFSPC_CHANGESEQ} { return }
294 ## Arrange for the included spaces to be up-to-date, and gather the CPLs
295 ## together so we can merge them.
297 lappend merge [concat $space $CONFSPC_INCL($space)]
298 foreach included $CONFSPC_INCL($space) {
299 confspc-update $included
300 lappend merge $CONFSPC_CPL($included)
303 ## Do the merge and update the change indicator.
304 set CONFSPC_CPL($space) [merge-lists $merge]
305 set CONFSPC_CHANGE($space) $CONFSPC_CHANGESEQ
308 proc confspc-path {ns cpl} {
309 ## Update namespace NS's command path so that it has (only) the
310 ## directives of the given CPL. Pass an empty CPL to clear the
311 ## configuration space hacking.
315 ## Add the new namespaces to the front.
316 foreach spc $cpl { lappend path ::confspc::$spc }
318 ## Now add the existing path items, with any existing confspc hacking
320 foreach item [namespace eval $ns { namespace path }] {
321 if {![string match "::confspc::*" $item]} { lappend npath $item }
324 ## Commit the result.
325 namespace eval $ns [list namespace path $path]
328 proc confspc-set {ns space} {
329 ## Set the command path for namespace NS to include the configuration
330 ## directives of SPACE (and its included spaces).
333 confspc-update $space
334 confspc-path $ns $CONFSPC_CPL($space)
337 proc confspc-eval {space body} {
338 ## Evaluate BODY in the current namespace, but augmented with the
339 ## directives from the named SPACE. The command path of the current
340 ## namespace is restored afterwards.
342 set ns [uplevel 1 { namespace current }]
343 set path [namespace eval $ns { namespace path }]
345 confspc-set $ns $space
348 namespace eval $ns [list namespace path $path]
352 proc preserving-config {confvar body} {
353 ## Evaluate BODY, but on exit restore the CONFVAR array so that the BODY
354 ## has no lasting effect on it.
356 upvar #0 $confvar CONFIG
357 set old [array get CONFIG]
362 array set CONFIG $old
366 confspc-create confspc CONFSPC_CONFIG
368 confspc-command confspc include {args} {
369 ## Include the named configuration spaces in the current one.
371 confspc-include $CONFSPC_CONFIG(space) $args
374 confspc-command confspc define {name bvl body} {
375 ## Define a directive NAME in the current space, taking arguments BVL, and
376 ## having the given BODY.
378 confspc-command $CONFSPC_CONFIG(space) $name $bvl $body
381 confspc-command confspc define-simple {setting default} {
382 ## Define a directive SETTING which sets the appropriately prefixed entry
383 ## in the CONFIG array to its single arguments, and immediately set the
384 ## CONFIG entry to DEFAULT.
387 set space $CONFSPC_CONFIG(space)
388 upvar #0 $CONFSPC_VAR($space) config
389 confspc-command $space $setting arg \
390 "set $CONFSPC_VAR($space)($CONFSPC_CONFIG(prefix)$setting) \$arg"
391 set config($CONFSPC_CONFIG(prefix)$setting) $default
394 confspc-command confspc define-list {setting default} {
395 ## Define a directive SETTING which sets the appropriately prefixed entry
396 ## in the CONFIG array to its entire argument list, and immediately set the
397 ## CONFIG entry to DEFAULT (which should be a Tcl list, not a collection of
401 set space $CONFSPC_CONFIG(space)
402 upvar #0 $CONFSPC_VAR($space) config
403 confspc-command $space $setting args \
404 "set $CONFSPC_VAR($space)($CONFSPC_CONFIG(prefix)$setting) \$args"
405 set config($CONFSPC_CONFIG(prefix)$setting) $default
408 confspc-command confspc prefix {prefix} {
409 set CONFSPC_CONFIG(prefix) $prefix
412 proc define-configuration-space {space confvar body} {
413 ## Define a new configuration space named SPACE. The BODY is Tcl code,
414 ## though it may make use of `include' and `define'.
416 global CONFSPC_CONFIG
417 set ns [uplevel 1 { namespace current }]
418 set oldpath [namespace eval $ns { namespace path }]
419 confspc-create $space $confvar
421 preserving-config CONFSPC_CONFIG {
422 array set CONFSPC_CONFIG [list space $space \
424 confspc-set $ns confspc
428 namespace eval $ns [list namespace path $oldpath]
432 ###--------------------------------------------------------------------------
435 ### The option parsing machinery makes extensive use of a state array
436 ### OPTPARSE_STATE in order to maintain its context. The procedure
437 ### `with-option-parser' establishes this array correctly, and preserves any
438 ### existing state, so there should be no trouble with multiple parsers in
439 ### the same program.
441 proc optparse-more-p {} {
442 ## Answer whether there are more argument words available.
444 upvar #0 OPTPARSE_STATE state
445 if {[llength $state(words)]} { return true } else { return false }
448 proc optparse-next-word {} {
449 ## Return the next word in the argument list. It is an error if there are
450 ## no more words left.
452 upvar #0 OPTPARSE_STATE state
453 set word [lindex $state(words) 0]
454 set state(words) [lrange $state(words) 1 end]
458 proc optparse-error {message} {
459 ## Report an error message and exit.
462 puts stderr "$QUIS: $message"
466 proc optparse-option/short {var} {
467 ## Parse the next short option from the current cluster. If there are no
468 ## more short options, set the mode back to `free' and call back into
469 ## `optparse-option/free'.
471 ## See the description of `optparse-option/free' for the interface
472 ## implemented by this procedure.
474 ## Get hold of my state and the caller's array.
475 upvar #0 OPTPARSE_STATE state
478 ## Work out what to do based on the remaining length of the cluster. (The
479 ## cluster shouldn't be empty because the mode should only be set to
480 ## `short' if there is an initial nonempty cluster to parse, and we set it
481 ## back to `free' when we consume the final character from the cluster.)
482 ## Specifically, set `argp' according to whether we have a potential
483 ## argument in the cluster, and `name' to the option character extracted.
485 switch [string length $state(rest)] {
487 error "empty cluster"
492 set name $state(rest)
496 set name [string index $state(rest) 0]
497 set state(rest) [string range $state(rest) 1 end]
501 ## Try to look up the option in the map.
502 if {![dict exists $state(short-map) $name]} {
503 optparse-error "Unknown option `$state(prefix)$name'"
505 array set opt [dict get $state(short-map) $name]
506 set state(name) $name
508 ## Collect an argument if one is required.
509 catch { unset state(arg) }
510 switch -glob -- "$opt(arg),$argp" {
512 if {![optparse-more-p]} {
513 optparse-error "Option `$state(prefix)$name' requires an argument"
515 set state(arg) [optparse-next-word]
517 "required,true" - "optional,true" {
518 set state(arg) $state(rest)
527 proc optparse-option/free {var} {
528 ## Parse the next option from the argument list. This procedure is called
529 ## to process a new argument word, i.e., we are in `free' mode. It
530 ## analyses the next argument word and either processes it internally or
531 ## sets the mode appropriately and calls a specialized handler
532 ## `optparse-option/MODE' for that mode.
534 ## The interface works as follows. If an option was found, then the array
535 ## VAR is set according to the option's settings dictionary; and state
536 ## variables are set as follows.
538 ## prefix The prefix character(s) to write before the option name in
539 ## messages, e.g., `--' for long options.
541 ## name The option name without any prefix attached.
543 ## arg The option's argument, if there is one; otherwise unset.
545 upvar #0 OPTPARSE_STATE state
550 catch { unset state(arg) }
551 if {![optparse-more-p]} { return 0 }
552 set word [optparse-next-word]
554 ## Work out what to do based on the word. The order of these tests is
555 ## critically important.
556 switch -glob -- $word {
559 ## End-of-options marker.
567 set state(prefix) "--"
569 ## If there's an equals sign, the name is the bit to the left; keep the
570 ## remainder as an argument.
571 set eq [string first "=" $word 2]
573 set name [string range $word 2 [expr {$eq - 1}]]
574 set state(arg) [string range $word [expr {$eq + 1}] end]
577 set name [string range $word 2 end]
582 ## Look the name up in the map.
583 if {[dict exists $state(long-map) $name]} {
584 array set opt [dict get $state(long-map) $name]
586 set matches [dict keys $state(long-map) "$name*"]
587 switch -exact -- [llength $matches] {
588 1 { array set opt [dict get $state(long-map) [lindex $matches 0]] }
589 0 { optparse-error "Unknown option `--$name'" }
591 optparse-error "Ambiaguous option `--$name' \
592 (matches: --[join $matches {, --}])"
597 ## Now check whether we want an argument. The missing cases are
598 ## because we are already in the correct state.
599 switch -glob -- "$opt(arg),$argp" {
601 optparse-error "Option `$name' doesn't accept an argument"
604 if {![optparse-more-p]} {
605 optparse-error "Option `$name' requires an argument"
607 set state(arg) [optparse-next-word]
611 ## Done. We consumed either one or two entire argument words, so we
612 ## should remain in the `free' state.
617 ## Short option. Set state, initialize the cluster, and go.
619 set state(rest) [string range $word 1 end]
620 set state(mode) short
621 set state(prefix) "-"
622 return [optparse-option/short opt]
626 ## Some non-option thing. Under POSIX rules, this ends the parse. (We
627 ## could do something more adventurous later.)
629 set state(words) [concat [list $word] $state(words)]
635 proc optparse-arg-p {} {
636 ## Return the whether the most recently processed option had an argument.
638 upvar #0 OPTPARSE_STATE state
639 return [info exists state(arg)]
642 proc optparse-arg {} {
643 ## Return the argument from the most recently processed option. It is an
644 ## error if no argument was supplied.
646 upvar #0 OPTPARSE_STATE state
650 proc optparse-words {} {
651 ## Return the remaining unparsed argument words as a list.
653 upvar #0 OPTPARSE_STATE state
657 proc optparse-option {} {
658 ## Parse the next option(s). The action taken depends on the option
659 ## dictionary: if an `action' is provided then it is evaluated in the
660 ## caller's context; otherwise the option's `tag' is returned.
662 upvar #0 OPTPARSE_STATE state
664 if {![optparse-option/$state(mode) opt]} {
666 } elseif {[info exists opt(action)]} {
667 uplevel 1 $opt(action)
668 } elseif {[info exists opt(tag)]} {
671 error "Don't know what to do with option `$state(prefix)$state(name)'"
676 proc with-option-parser {state words body} {
677 ## Establish an option parsing context, initialized with the STATE
678 ## (constructed using `define-options') and the lits of argument WORDS.
679 ## The BODY may use `optparse-option', `optparse-arg', etc. to parse the
682 global OPTPARSE_STATE
683 set old [array get OPTPARSE_STATE]
686 array unset OPTPARSE_STATE
687 array set OPTPARSE_STATE $state
688 set OPTPARSE_STATE(mode) free
689 set OPTPARSE_STATE(words) $words
692 array set OPTPARSE_STATE $old
696 define-configuration-space optparse-option OPTCFG {
699 define action {act} { set OPTCFG(action) $act }
700 define tag {tag} { set OPTCFG(tag) $tag }
701 define-simple arg none
704 define-configuration-space optparse OPTCFG {
705 define option {body} {
706 upvar #0 OPTPARSE_STATE state
707 uplevel 1 [list confspc-eval optparse-option $body]
708 set opt [array get OPTCFG]
709 foreach kind {long short} {
710 foreach name $OPTCFG($kind) {
711 if {[dict exists $state($kind-map) $name]} {
712 error "Already have an option with $kind name `$name'"
714 dict set state($kind-map) $name $opt
720 proc define-options {statevar body} {
721 ## Define an option state, and write it to STATEVAR. The BODY may contain
722 ## `optparse' configuration directives to define the available options.
724 global OPTPARSE_STATE
725 upvar 1 $statevar state
726 set old [array get OPTPARSE_STATE]
728 array unset OPTPARSE_STATE
729 if {[info exists state]} {
730 array set OPTPARSE_STATE $state
732 array set OPTPARSE_STATE {
737 uplevel 1 [list confspc-eval optparse $body]
738 set state [array get OPTPARSE_STATE]
740 array set OPTPARSE_STATE $old
744 ###--------------------------------------------------------------------------
745 ### Subcommand handling.
747 ## Determine the program name.
748 set QUIS [file tail $argv0]
750 ## This is fluid-bound to the name of the current command.
753 proc find-command {name} {
754 ## Given a command NAME as typed by the user, find the actual command and
758 set matches [info commands cmd/$name*]
761 foreach match $matches {
762 set cmd [string range $match 4 end]
764 if {[info exists HELP($cmd)]} { lappend doc $cmd }
766 switch -exact -- [llength $cmds] {
767 1 { return [lindex $cmds 0] }
768 0 { optparse-error "Unknown command `$name'" }
770 if {[llength $doc]} { set cmds $doc }
771 switch -exact -- [llength $cmds] {
772 1 { return [lindex $cmds 0] }
773 0 { optparse-error "Unknown command `$name'" }
774 default { optparse-error "Ambiguous command `$name' -- matches: $cmds" }
779 ## Return a usage message for CMD. The message is taken from the `USAGE'
780 ## array if that contains an entry for CMD (it should not include the
781 ## command name, and should begin with a leading space); otherwise a
782 ## message is constructed by examining the argument names and defaulting
783 ## arrangements of the Tcl command cmd/CMD.
785 ## By convention, the main program is denoted by an empty CMD name.
788 if {[info exists USAGE($cmd)]} {
789 set usage $USAGE($cmd)
792 foreach arg [info args cmd/$cmd] {
793 if {[string equal $arg "args"]} {
795 } elseif {[info default cmd/$cmd $arg hunoz]} {
796 append usage " \[[string toupper $arg]\]"
798 append usage " [string toupper $arg]"
805 proc usage-error {} {
806 ## Report a usage error in the current command. The message is obtained by
807 ## the `usage' procedure.
810 if {[string length $COMMAND]} { set cmd " $COMMAND" } else { set cmd "" }
811 puts stderr "Usage: $QUIS$cmd[usage $COMMAND]"
815 proc dispatch {name argv} {
816 ## Invokes the handler for CMD, passing it the argument list ARGV. This
817 ## does some minimal syntax checking by examining the argument list to the
818 ## command handler procedure cmd/COMMAND and issuing a usage error if
819 ## there's a mismatch.
822 let COMMAND [find-command $name] {
824 ## Decode the argument list of the handler and set min and max
826 set args [info args cmd/$COMMAND]
827 if {![llength $args]} {
830 if {[string equal [lindex $args end] "args"]} {
832 set args [lrange $args 0 end-1]
834 set max [llength $args]
838 if {[info default cmd/$COMMAND $arg hunoz]} { break }
843 ## Complain if the number of arguments is inappropriate.
844 set n [llength $argv]
845 if {$n < $min || ($max != inf && $n > $max)} { usage-error }
847 ## Invoke the handler.
848 eval cmd/$COMMAND $argv
852 define-configuration-space subcommand SUBCMD {
853 define-simple help-text -
854 define-simple usage-text -
857 proc defcmd {name bvl defs body} {
858 ## Define a command NAME with arguments BVL. The `usage-text' and
859 ## `help-text' commands can be used in DEFS to set messages for the new
862 global SUBCMD USAGE HELP
864 preserving-config SUBCMD {
865 confspc-eval subcommand { uplevel 1 $defs }
866 foreach tag {usage-text help-text} array {USAGE HELP} {
867 if {![string equal $SUBCMD($tag) -]} {
868 set ${array}($name) $SUBCMD($tag)
872 proc cmd/$name $bvl $body
875 ## Standard subcommand handler to show information about the program or its
876 ## subcommands. To use this, you need to set a bunch of variables.
878 ## USAGE(cmd) Contains the usage message for cmd -- including
879 ## leading space -- to use instead of the `usage'
880 ## procedure's automagic.
882 ## HELP(cmd) Contains descriptive text -- not including a final
883 ## trailing newline -- about the command.
885 ## VERSION The program's version number.
887 ## The `defcmd' procedure can be used to set these things up conveniently.
889 usage-text " \[SUBCOMMAND ...]"
890 help-text "Show help on the given SUBCOMMANDs, or on the overall program."
892 global QUIS VERSION USAGE HELP
893 if {[llength $args]} {
895 set cmd [find-command $name]
896 puts "Usage: $QUIS $cmd[usage $cmd]"
897 if {[info exists HELP($cmd)]} { puts "\n$HELP($cmd)" }
900 puts "$QUIS, version $VERSION\n"
901 puts "Usage: $QUIS$USAGE()\n"
902 if {[info exists HELP()]} { puts "$HELP()\n" }
903 puts "Subcommands available:"
904 foreach name [info commands cmd/*] {
905 set cmd [string range $name 4 end]
906 puts "\t$cmd[usage $cmd]"
911 ###--------------------------------------------------------------------------
912 ### Build the configuration space for zone files.
914 proc host-addr {host} {
915 ## Given a HOST name, return a list of its addresses.
917 if {![string match $host {*[!0-9.]*}]} { return $host }
918 set adns [open [list | adnshost +Dc -s $host] r]
921 while {[gets $adns line] >= 0} {
922 set* {name type fam addr} $line
923 switch -glob -- $type:$fam {
924 A:INET { lappend addrs $addr }
927 return [lindex $addrs 0]
933 proc host-canonify {host} {
934 ## Given a HOST name, return a canonical version of it.
936 set adns [open [list | adnshost -Dc -s $host] r]
938 while {[gets $adns line] >= 0} {
939 switch -exact -- [lindex $line 1] {
940 CNAME { return [lindex $line 2] }
941 A - AAAA { return [lindex $line 0] }
944 error "failed to canonify $host"
950 proc local-address-p {addr} {
951 ## Answer whether the ADDR is one of the host's addresses.
954 if {[info exists env(ZONECONF_LOCAL_ADDRESSES)]} {
955 if {[string match "*:$addr:*" ":$env(ZONECONF_LOCAL_ADDRESSES):"]} {
961 if {[catch { set sk [socket -server {} -myaddr $addr 0] }]} {
970 ## The list of zones configured by the user.
973 ## Dynamic zone update policy specifications.
974 define-configuration-space policy ZONECFG {
975 define allow {identity nametype name args} {
976 lappend ZONECFG(ddns-policy) \
977 [concat grant [list $identity $nametype $name] $args]
979 define deny {identity nametype name args} {
980 lappend ZONECFG(ddns-policy) \
981 [concat deny [list $identity $nametype $name] $args]
985 ## Dynamic zone details.
986 define-configuration-space dynamic ZONECFG {
988 define-simple key "ddns"
989 define-simple auto-dnssec off
990 define-list types {A TXT PTR}
992 define policy {body} {
993 set ZONECFG(ddns-policy) {}
994 uplevel 1 [list confspc-eval policy $body]
997 set ZONECFG(ddns-policy) {}
1000 ## Everything about a zone.
1001 set HOME "@pkgstatedir@"
1002 set BINDPROGS "@bindprogsdir@"
1003 define-configuration-space zone ZONECFG {
1004 define-simple user root
1005 define-simple home-dir $HOME
1006 define-simple static-dir "$HOME/static"
1007 define-simple dynamic-dir "$HOME/dynamic"
1008 define-simple dir-mode 2775
1009 define-simple zone-file "%v/%z.zone"
1010 define-simple soa-format increment
1011 define-simple allow-query nil
1013 define-list sign-views {}
1014 define-list signzone-command \
1015 [list "$BINDPROGS/dnssec-signzone" \
1019 "-s-3600" "-e+176400" "-i90000" \
1024 define-list reload-command [list "$BINDPROGS/rndc" "reload" "%z" "IN" "%v"]
1025 define-list autosign-command [list "$BINDPROGS/rndc" "sign" "%z" "IN" "%v"]
1026 define-list checkzone-command \
1027 [list "$BINDPROGS/named-checkzone" \
1035 define-list also-notify nil
1037 define setvar {name value} {
1038 dict set ZONECFG(var) $name $value
1041 define primary {map} {
1042 ## There's a grim hack here: a primary-address entry may have the form
1043 ## REAL!FAKE. If the REAL address is not a local address then this
1044 ## is used as the master address; otherwise the FAKE address is used.
1045 ## This is useful for inter-view updates of dynamic zones on the same
1046 ## host. I suggest abusing 127.0.0.0/8 addresses for this kind of
1048 if {[llength $map] % 2} {
1049 error "master map must have an even number of items"
1051 set ZONECFG(master-map) $map
1054 define dynamic {{body {}}} {
1055 array set ZONECFG [list type dynamic]
1056 uplevel 1 [list confspc-eval dynamic $body]
1059 define view-map {map} {
1061 ## OK, this needs careful documentation.
1063 ## The local nameserver presents a number of views according to its
1064 ## configuration. It is our purpose here to generate a configuration
1065 ## snippet for such a view.
1067 ## A user might have several different views of a zone which are meant to
1068 ## be presented to different clients. These map on to the server views
1069 ## in a one-to-many fashion. The `view-map' option defines this mapping.
1070 ## The argument is a list of alternating SERVER-VIEW USER-VIEW pairs; the
1071 ## SERVER-VIEW may be a glob pattern; the USER-VIEW may be the special
1072 ## token `=' to mean `same as the SERVER-VIEW'.
1074 ## We only keep one copy of the zone file for each user view: if the user
1075 ## view is used by many server views, then the zone stanza for each of
1076 ## those views refers to the same zone file.
1078 if {[llength $map] % 2} {
1079 error "view map must have an even number of items"
1081 set ZONECFG(view-map) $map
1090 ## Top-level configuration. Allow most zone options to be set here, so that
1091 ## one can set defaults for multiple zones conveniently.
1092 define-configuration-space toplevel ZONECFG {
1095 define-list all-views {}
1096 define-simple conf-file "$HOME/config/%v.conf"
1097 define-simple max-zone-size [expr {512*1024}]
1098 define-list reconfig-command {/usr/sbin/rndc reconfig}
1100 define scope {body} {
1101 preserving-config ZONECFG { uplevel 1 $body }
1104 define zone {name {body {}}} {
1106 preserving-config ZONECFG {
1110 uplevel 1 [list confspc-eval zone $body]
1111 lappend ZONES [array get ZONECFG]
1116 ###--------------------------------------------------------------------------
1117 ### Processing the results.
1119 proc zone-file-name {view config} {
1120 ## Return the relative file name for the zone described by CONFIG, relative
1121 ## to the given VIEW. An absolute filename may be derived later, depending
1122 ## on whether the zone data is static and the calling host is the master
1125 array set zone $config
1126 return [string map [list \
1132 proc output-file-name {view} {
1133 ## Return the output file name for the given VIEW.
1136 return [string map [list %v $view] $ZONECFG(conf-file)]
1139 proc temporary-directory {} {
1140 ## Create a temporary directory and set as the working directory.
1143 set tmp [file join $ZONECFG(home-dir) "tmp"]
1149 proc compute-zone-properties {view config} {
1150 ## Derive interesting information from the zone configuration plist CONFIG,
1151 ## relative to the stated server VIEW. Return a new plist.
1153 array set zone $config
1155 ## See whether the zone matches the view.
1157 foreach wanted $zone(views) {
1158 if {[string match $wanted $view]} { set match 1; break }
1160 if {!$match} { return {config-type ignore} }
1162 ## Transform the view name according to the view map.
1163 foreach {inview outview} $zone(view-map) {
1164 if {![string match $inview $view]} { continue }
1165 switch -exact -- $outview {
1166 = { set zone(mapped-view) $view }
1167 default { set zone(mapped-view) $outview }
1172 ## Find out where the master is supposed to be.
1173 set zone(config-type) ignore
1174 if {[info exists zone(mapped-view)]} {
1175 foreach {outview hosts} $zone(master-map) {
1176 if {[string match $outview $zone(mapped-view)]} {
1178 set zone(config-type) slave
1179 foreach host $hosts {
1180 set bang [string first "!" $host]
1182 set after [string range $host [expr {$bang + 1}] end]
1184 set before [string range $host 0 [expr {$bang - 1}]]
1188 if {[local-address-p $before]} {
1193 } elseif {[local-address-p $host]} {
1194 set zone(config-type) master
1196 lappend masters $host
1198 set zone(masters) $masters
1204 ## Work out the file names.
1205 switch -glob -- $zone(config-type):$zone(type) {
1207 set dir $zone(static-dir)
1208 set nameview $zone(mapped-view)
1211 set dir $zone(dynamic-dir)
1215 set zone(file-name) [file join $dir \
1216 [zone-file-name $nameview $config]]
1218 ## Find out whether this zone wants signing.
1219 set zone(sign) false
1220 switch -glob -- $zone(config-type):$zone(type) {
1222 foreach sview $zone(sign-views) {
1223 if {[string match $zone(mapped-view) $sview]} { set zone(sign) true }
1228 set zone(server-file-name) "$zone(file-name).sig"
1230 set zone(server-file-name) $zone(file-name)
1234 return [array get zone]
1237 proc write-ddns-update-policy {prefix chan config} {
1238 ## Write an `update-policy' stanza to CHAN for the zone described by the
1239 ## CONFIG plist. The PREFIX is written to the start of each line.
1241 array set zone $config
1242 puts $chan "${prefix}update-policy {"
1243 set policyskel "${prefix}\t%s %s %s \"%s\" %s;"
1245 foreach item $zone(ddns-policy) {
1246 set* {verb ident type name} [lrange $item 0 3]
1247 set rrtypes [lrange $item 4 end]
1248 puts $chan [format $policyskel \
1256 puts $chan [format $policyskel \
1263 puts $chan "${prefix}};"
1266 proc sign-zone-file {info soafmt infile} {
1267 ## Sign the zone described by INFO. The input zone file is INPUT; the SOA
1268 ## should be updated according to SOAFMT.
1272 array set zone $info
1273 set outfile "$zone(server-file-name).new"
1274 if {![run "sign zone `$zone(name)' in view `$zone(mapped-view)'" \
1275 $zone(signzone-command) \
1276 "%h" $zone(home-dir) \
1277 "%m" $zone(static-dir) \
1278 "%s" $zone(dynamic-dir) \
1283 file delete -force $outfile
1286 file rename -force $outfile $zone(server-file-name)
1290 proc write-zone-stanza {view chan config} {
1291 ## Write a `zone' stanza to CHAN for the zone described by the CONFIG
1292 ## plist in the given VIEW.
1294 array set zone [compute-zone-properties $view $config]
1295 if {[string equal $zone(config-type) "ignore"]} { return }
1297 ## Create the directory for the zone files.
1298 set dir [file dirname $zone(file-name)]
1299 if {![file isdirectory $dir]} {
1301 exec chmod $zone(dir-mode) $dir
1304 ## Write the configuration fragment.
1305 puts $chan "\nzone \"$zone(name)\" {"
1306 switch -glob -- $zone(config-type) {
1308 puts $chan "\ttype master;"
1309 puts $chan "\tfile \"$zone(server-file-name)\";"
1310 if {![string equal $zone(also-notify) "nil"]} {
1311 puts $chan "\talso-notify { [join $zone(also-notify) {; }]; };"
1313 switch -exact -- $zone(type) {
1315 write-ddns-update-policy "\t" $chan $config
1316 if {![string equal $zone(ddns-auto-dnssec) off]} {
1317 puts $chan "\tauto-dnssec $zone(ddns-auto-dnssec);"
1323 puts $chan "\ttype slave;"
1325 foreach host $zone(masters) { lappend masters [host-addr $host] }
1326 puts $chan "\tmasters { [join $masters {; }]; };"
1327 puts $chan "\tfile \"$zone(file-name)\";"
1328 switch -exact -- $zone(type) {
1329 dynamic { puts $chan "\tallow-update-forwarding { any; };" }
1333 if {![string equal $zone(allow-query) nil]} {
1334 puts $chan "\tallow-query {$zone(allow-query)};"
1339 ###--------------------------------------------------------------------------
1340 ### Command-line interface.
1342 set CONFFILE "@pkgconfdir@/zones.in"
1345 help-text "List the output file names to stdout."
1347 global ZONECFG CONFFILE
1349 isolate [list confspc-eval toplevel [list source $CONFFILE]]
1350 foreach view $ZONECFG(all-views) { puts [output-file-name $view] }
1354 help-text "Generate BIND configuration files."
1356 global ZONECFG ZONES CONFFILE
1358 ## Read the configuration.
1359 isolate [list confspc-eval toplevel [list source $CONFFILE]]
1361 ## Safely update the files.
1365 ## Work through each server view.
1366 foreach view $ZONECFG(all-views) {
1368 ## Open an output file.
1369 set out($view) [output-file-name $view]
1370 set chan($view) [open "$out($view).new" w]
1373 set now [clock format [clock seconds] -format "%Y-%m-%d %H:%M:%S"]
1374 puts $chan($view) "### -*-conf-javaprop-*-"
1375 puts $chan($view) "### Generated at $now: do not edit"
1377 ## Now print a stanza for each zone in the view.
1378 foreach zone $ZONES {
1379 write-zone-stanza $view $chan($view) $zone
1383 ## Done: don't delete the output.
1387 ## Close the open files.
1388 foreach view $ZONECFG(all-views) {
1389 catch { close $chan($view) }
1392 ## If we succeeded, rename the output files into their proper places;
1393 ## otherwise, delete them.
1395 foreach view $ZONECFG(all-views) {
1396 file rename -force -- "$out($view).new" $out($view)
1398 eval exec $ZONECFG(reconfig-command)
1400 catch { file delete -force -- "$out($view).new" }
1405 defcmd install {user view name} {
1406 help-text "Install a new zone file.
1408 The file is for the given zone NAME and \(user-side) VIEW. The file is
1409 provided by the named USER."
1411 global QUIS ZONECFG ZONES CONFFILE errorInfo errorCode
1413 ## Read the configuration.
1414 isolate [list confspc-eval toplevel [list source $CONFFILE]]
1416 ## Make sure there's a temporary directory.
1417 set tmpdir [temporary-directory]
1419 ## Keep track of cleanup jobs.
1423 ## Find out which server views are affected by this update.
1425 foreach iview $ZONECFG(all-views) {
1426 foreach info $ZONES {
1428 array set zone [compute-zone-properties $iview $info]
1429 if {[string equal $user $zone(user)] && \
1430 [string equal "$zone(config-type)/$zone(type)" \
1431 "master/static"] && \
1432 [string equal $zone(name) $name] && \
1433 [string equal $zone(mapped-view) $view]} {
1434 lappend matchview $iview
1435 if {![info exists matchinfo]} { set matchinfo [array get zone] }
1439 if {![llength $matchview]} {
1440 optparse-error "No match for zone `$name' in view `$view'"
1443 array set zone $matchinfo
1445 ## Make a new temporary file to read the zone into.
1447 for {set i 0} {$i < 1000} {incr i} {
1448 set tmp [file join $tmpdir "tmp.$pid.$i.$user.$name"]
1449 if {![catch { set chan [open $tmp {WRONLY CREAT EXCL}] } msg]} {
1451 } elseif {[string equal [lindex $errorCode 0] POSIX] && \
1452 ![string equal [lindex $errorCode 1] EEXIST]} {
1453 error $msg $errorInfo $errorCode
1456 if {![info exists chan]} { error "failed to create temporary file" }
1457 set cleanup [list file delete $tmp]
1459 ## Read the zone data from standard input into the file.
1462 set stuff [read stdin 4096]
1463 if {![string length $stuff]} { break }
1464 puts -nonewline $chan $stuff
1465 incr total [string bytelength $stuff]
1466 if {$total > $ZONECFG(max-zone-size)} {
1467 error "zone file size limit exceeded"
1472 ## Check the zone for sanity.
1473 if {![run "zone check" $zone(checkzone-command) \
1481 ## If the zone wants signing, better to do that now.
1482 if {$zone(sign) && ![sign-zone-file $matchinfo keep $tmp]} {
1487 ## All seems good: stash the file in the proper place and reload the
1488 ## necessary server views.
1489 file rename -force -- $tmp $zone(file-name)
1491 foreach view $matchview {
1492 if {![run "reload zone `$zone(name) in view `$view'" \
1493 $zone(reload-command) \
1495 "%z" $zone(name)]} {
1505 help-text "Sign DNSSEC zones."
1507 global QUIS ZONECFG ZONES CONFFILE
1511 ## Read the configuration.
1512 isolate [list confspc-eval toplevel [list source $CONFFILE]]
1514 ## Sometimes `dnssec-signzone' tries to write temporary files to the
1515 ## current directory. Make sure this is sensible.
1518 ## Grind through all of the zones.
1520 foreach view $ZONECFG(all-views) {
1521 foreach info $ZONES {
1523 ## Fetch the zone information.
1525 set compinfo [compute-zone-properties $view $info]
1526 array set zone $compinfo
1527 if {![string equal $zone(config-type) master]} { continue }
1529 if {[string equal $zone(type) static] && $zone(sign)} {
1530 ## Static zone: re-sign it if we haven't seen this user view before,
1533 ## Sign the zone file if we haven't tried before.
1534 set id [list $zone(name) $zone(mapped-view)]
1535 if {![info exists seen($id)]} {
1536 if {[sign-zone-file $compinfo $zone(soa-format) \
1537 $zone(server-file-name)]} {
1541 set seen($id) failed
1545 ## If we succeeded, reload the zone in this server view.
1546 if {[string equal $seen($id) true]} {
1547 if {![run "reload zone `$zone(name) in server view `$view'" \
1548 $zone(reload-command) \
1554 } elseif {[string equal $zone(type) dynamic] &&
1555 ![string equal $zone(ddns-auto-dnssec) off]} {
1556 ## Dynamic zone: get BIND to re-sign it.
1558 if {![run "re-sign zone `$zone(name) in server view `$view'" \
1559 $zone(autosign-command) \
1570 ###--------------------------------------------------------------------------
1573 set VERSION "@VERSION@"
1574 set USAGE() " \[-OPTIONS] SUBCOMMAND \[ARGUMENTS...]"
1576 define-options OPTS {
1578 short "h"; long "help"
1579 action { eval cmd/help [optparse-words]; exit }
1582 short "v"; long "version"
1583 action { puts "$QUIS, version $VERSION"; exit }
1586 short "c"; long "config"; arg required
1587 action { set CONFFILE [optparse-arg] }
1591 with-option-parser $OPTS $argv {
1593 set argv [optparse-words]
1596 if {![llength $argv]} { usage-error }
1597 dispatch [lindex $argv 0] [lrange $argv 1 end]
1599 ###----- That's all, folks --------------------------------------------------