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 ###--------------------------------------------------------------------------
202 ### Configuration spaces.
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.
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.
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.
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 {}
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
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.
245 global CONFSPC_CMD CONFSPC_VAR
246 pushnew CONFSPC_CMD($space) $name
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]
254 ## Now arrange for this command to exist properly in the configuration
256 namespace eval ::confspc::$space \
257 [list namespace import ${ns}::conf/$space/$name]
259 namespace eval ::confspc::$space [list rename $name {}]
261 namespace eval ::confspc::$space \
262 [list rename conf/$space/$name $name]
265 proc confspc-include {space includes} {
266 ## Arrange for SPACE to include the directives from the INCLUDES spaces.
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}]
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.
280 global CONFSPC_CPL CONFSPC_CHANGE CONFSPC_INCL
281 global CONFSPC_CHANGESEQ CONFSPC_LASTCHANGESEQ
282 set CONFSPC_LASTCHANGESEQ $CONFSPC_CHANGESEQ
284 ## If the space is already up-to-date, do nothing.
285 if {$CONFSPC_CHANGE($space) == $CONFSPC_CHANGESEQ} { return }
287 ## Arrange for the included spaces to be up-to-date, and gather the CPLs
288 ## together so we can merge them.
290 lappend merge [concat $space $CONFSPC_INCL($space)]
291 foreach included $CONFSPC_INCL($space) {
292 confspc-update $included
293 lappend merge $CONFSPC_CPL($included)
296 ## Do the merge and update the change indicator.
297 set CONFSPC_CPL($space) [merge-lists $merge]
298 set CONFSPC_CHANGE($space) $CONFSPC_CHANGESEQ
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.
308 ## Add the new namespaces to the front.
309 foreach spc $cpl { lappend path ::confspc::$spc }
311 ## Now add the existing path items, with any existing confspc hacking
313 foreach item [namespace eval $ns { namespace path }] {
314 if {![string match "::confspc::*" $item]} { lappend npath $item }
317 ## Commit the result.
318 namespace eval $ns [list namespace path $path]
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).
326 confspc-update $space
327 confspc-path $ns $CONFSPC_CPL($space)
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.
335 set ns [uplevel 1 { namespace current }]
336 set path [namespace eval $ns { namespace path }]
338 confspc-set $ns $space
341 namespace eval $ns [list namespace path $path]
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.
349 upvar #0 $confvar CONFIG
350 set old [array get CONFIG]
355 array set CONFIG $old
359 confspc-create confspc CONFSPC_CONFIG
361 confspc-command confspc include {args} {
362 ## Include the named configuration spaces in the current one.
364 confspc-include $CONFSPC_CONFIG(space) $args
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.
371 confspc-command $CONFSPC_CONFIG(space) $name $bvl $body
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.
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
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
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
401 confspc-command confspc prefix {prefix} {
402 set CONFSPC_CONFIG(prefix) $prefix
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'.
409 global CONFSPC_CONFIG
410 set ns [uplevel 1 { namespace current }]
411 set oldpath [namespace eval $ns { namespace path }]
412 confspc-create $space $confvar
414 preserving-config CONFSPC_CONFIG {
415 array set CONFSPC_CONFIG [list space $space \
417 confspc-set $ns confspc
421 namespace eval $ns [list namespace path $oldpath]
425 ###--------------------------------------------------------------------------
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.
434 proc optparse-more-p {} {
435 ## Answer whether there are more argument words available.
437 upvar #0 OPTPARSE_STATE state
438 if {[llength $state(words)]} { return true } else { return false }
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.
445 upvar #0 OPTPARSE_STATE state
446 set word [lindex $state(words) 0]
447 set state(words) [lrange $state(words) 1 end]
451 proc optparse-error {message} {
452 ## Report an error message and exit.
455 puts stderr "$QUIS: $message"
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'.
464 ## See the description of `optparse-option/free' for the interface
465 ## implemented by this procedure.
467 ## Get hold of my state and the caller's array.
468 upvar #0 OPTPARSE_STATE state
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.
478 switch [string length $state(rest)] {
480 error "empty cluster"
485 set name $state(rest)
489 set name [string index $state(rest) 0]
490 set state(rest) [string range $state(rest) 1 end]
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'"
498 array set opt [dict get $state(short-map) $name]
499 set state(name) $name
501 ## Collect an argument if one is required.
502 catch { unset state(arg) }
503 switch -glob -- "$opt(arg),$argp" {
505 if {![optparse-more-p]} {
506 optparse-error "Option `$state(prefix)$name' requires an argument"
508 set state(arg) [optparse-next-word]
510 "required,true" - "optional,true" {
511 set state(arg) $state(rest)
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.
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.
531 ## prefix The prefix character(s) to write before the option name in
532 ## messages, e.g., `--' for long options.
534 ## name The option name without any prefix attached.
536 ## arg The option's argument, if there is one; otherwise unset.
538 upvar #0 OPTPARSE_STATE state
543 catch { unset state(arg) }
544 if {![optparse-more-p]} { return 0 }
545 set word [optparse-next-word]
547 ## Work out what to do based on the word. The order of these tests is
548 ## critically important.
549 switch -glob -- $word {
552 ## End-of-options marker.
560 set state(prefix) "--"
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]
566 set name [string range $word 2 [expr {$eq - 1}]]
567 set state(arg) [string range $word [expr {$eq + 1}] end]
570 set name [string range $word 2 end]
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]
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'" }
584 optparse-error "Ambiaguous option `--$name' \
585 (matches: --[join $matches {, --}])"
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" {
594 optparse-error "Option `$name' doesn't accept an argument"
597 if {![optparse-more-p]} {
598 optparse-error "Option `$name' requires an argument"
600 set state(arg) [optparse-next-word]
604 ## Done. We consumed either one or two entire argument words, so we
605 ## should remain in the `free' state.
610 ## Short option. Set state, initialize the cluster, and go.
612 set state(rest) [string range $word 1 end]
613 set state(mode) short
614 set state(prefix) "-"
615 return [optparse-option/short opt]
619 ## Some non-option thing. Under POSIX rules, this ends the parse. (We
620 ## could do something more adventurous later.)
622 set state(words) [concat [list $word] $state(words)]
628 proc optparse-arg-p {} {
629 ## Return the whether the most recently processed option had an argument.
631 upvar #0 OPTPARSE_STATE state
632 return [info exists state(arg)]
635 proc optparse-arg {} {
636 ## Return the argument from the most recently processed option. It is an
637 ## error if no argument was supplied.
639 upvar #0 OPTPARSE_STATE state
643 proc optparse-words {} {
644 ## Return the remaining unparsed argument words as a list.
646 upvar #0 OPTPARSE_STATE state
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.
655 upvar #0 OPTPARSE_STATE state
657 if {![optparse-option/$state(mode) opt]} {
659 } elseif {[info exists opt(action)]} {
660 uplevel 1 $opt(action)
661 } elseif {[info exists opt(tag)]} {
664 error "Don't know what to do with option `$state(prefix)$state(name)'"
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
675 global OPTPARSE_STATE
676 set old [array get OPTPARSE_STATE]
679 array unset OPTPARSE_STATE
680 array set OPTPARSE_STATE $state
681 set OPTPARSE_STATE(mode) free
682 set OPTPARSE_STATE(words) $words
685 array set OPTPARSE_STATE $old
689 define-configuration-space optparse-option OPTCFG {
692 define action {act} { set OPTCFG(action) $act }
693 define tag {tag} { set OPTCFG(tag) $tag }
694 define-simple arg none
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'"
707 dict set state($kind-map) $name $opt
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.
717 global OPTPARSE_STATE
718 upvar 1 $statevar state
719 set old [array get OPTPARSE_STATE]
721 array unset OPTPARSE_STATE
722 if {[info exists state]} {
723 array set OPTPARSE_STATE $state
725 array set OPTPARSE_STATE {
730 uplevel 1 [list confspc-eval optparse $body]
731 set state [array get OPTPARSE_STATE]
733 array set OPTPARSE_STATE $old
737 ###--------------------------------------------------------------------------
738 ### Subcommand handling.
740 ## Determine the program name.
741 set QUIS [file tail $argv0]
743 ## This is fluid-bound to the name of the current command.
746 proc find-command {name} {
747 ## Given a command NAME as typed by the user, find the actual command and
751 set matches [info commands cmd/$name*]
754 foreach match $matches {
755 set cmd [string range $match 4 end]
757 if {[info exists HELP($cmd)]} { lappend doc $cmd }
759 switch -exact -- [llength $cmds] {
760 1 { return [lindex $cmds 0] }
761 0 { optparse-error "Unknown command `$name'" }
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" }
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.
778 ## By convention, the main program is denoted by an empty CMD name.
781 if {[info exists USAGE($cmd)]} {
782 set usage $USAGE($cmd)
785 foreach arg [info args cmd/$cmd] {
786 if {[string equal $arg "args"]} {
788 } elseif {[info default cmd/$cmd $arg hunoz]} {
789 append usage " \[[string toupper $arg]\]"
791 append usage " [string toupper $arg]"
798 proc usage-error {} {
799 ## Report a usage error in the current command. The message is obtained by
800 ## the `usage' procedure.
803 if {[string length $COMMAND]} { set cmd " $COMMAND" } else { set cmd "" }
804 puts stderr "Usage: $QUIS$cmd[usage $COMMAND]"
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.
815 let COMMAND [find-command $name] {
817 ## Decode the argument list of the handler and set min and max
819 set args [info args cmd/$COMMAND]
820 if {![llength $args]} {
823 if {[string equal [lindex $args end] "args"]} {
825 set args [lrange $args 0 end-1]
827 set max [llength $args]
831 if {[info default cmd/$COMMAND $arg hunoz]} { break }
836 ## Complain if the number of arguments is inappropriate.
837 set n [llength $argv]
838 if {$n < $min || ($max != inf && $n > $max)} { usage-error }
840 ## Invoke the handler.
841 eval cmd/$COMMAND $argv
845 define-configuration-space subcommand SUBCMD {
846 define-simple help-text -
847 define-simple usage-text -
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
855 global SUBCMD USAGE HELP
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)
865 proc cmd/$name $bvl $body
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.
871 ## USAGE(cmd) Contains the usage message for cmd -- including
872 ## leading space -- to use instead of the `usage'
873 ## procedure's automagic.
875 ## HELP(cmd) Contains descriptive text -- not including a final
876 ## trailing newline -- about the command.
878 ## VERSION The program's version number.
880 ## The `defcmd' procedure can be used to set these things up conveniently.
882 usage-text " \[SUBCOMMAND ...]"
883 help-text "Show help on the given SUBCOMMANDs, or on the overall program."
885 global QUIS VERSION USAGE HELP
886 if {[llength $args]} {
888 set cmd [find-command $name]
889 puts "Usage: $QUIS $cmd[usage $cmd]"
890 if {[info exists HELP($cmd)]} { puts "\n$HELP($cmd)" }
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]"
904 ###--------------------------------------------------------------------------
905 ### Build the configuration space for zone files.
907 proc host-addr {host} {
908 ## Given a HOST name, return a list of its addresses.
910 if {![string match $host {*[!0-9.]*}]} { return $host }
911 set adns [open [list | adnshost +Dc -s $host] r]
914 while {[gets $adns line] >= 0} {
915 set* {name type fam addr} $line
916 switch -glob -- $type:$fam {
917 A:INET { lappend addrs $addr }
920 return [lindex $addrs 0]
926 proc host-canonify {host} {
927 ## Given a HOST name, return a canonical version of it.
929 set adns [open [list | adnshost -Dc -s $host] r]
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] }
937 error "failed to canonify $host"
943 proc local-address-p {addr} {
944 ## Answer whether the ADDR is one of the host's addresses.
946 if {[catch { set sk [socket -server {} -myaddr $addr 0] }]} {
954 ## The list of zones configured by the user.
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]
963 define deny {identity nametype name args} {
964 lappend ZONECFG(ddns-policy) \
965 [concat deny [list $identity $nametype $name] $args]
969 ## Dynamic zone details.
970 define-configuration-space dynamic ZONECFG {
972 define-simple key "ddns"
973 define-simple auto-dnssec off
974 define-list types {A TXT PTR}
976 define policy {body} {
977 set ZONECFG(ddns-policy) {}
978 uplevel 1 [list confspc-eval policy $body]
981 set ZONECFG(ddns-policy) {}
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
996 define-list sign-views {}
997 define-list signzone-command \
998 [list "$BINDPROGS/dnssec-signzone" \
1003 "-s-3600" "-e+176400" "-i90000" \
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" \
1020 define setvar {name value} {
1021 dict set ZONECFG(var) $name $value
1024 define primary {map} {
1025 if {[llength $map] % 2} {
1026 error "master map must have an even number of items"
1028 set ZONECFG(master-map) $map
1031 define dynamic {{body {}}} {
1032 array set ZONECFG [list type dynamic]
1033 uplevel 1 [list confspc-eval dynamic $body]
1036 define view-map {map} {
1038 ## OK, this needs careful documentation.
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.
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'.
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.
1055 if {[llength $map] % 2} {
1056 error "view map must have an even number of items"
1058 set ZONECFG(view-map) $map
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 {
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}
1077 define scope {body} {
1078 preserving-config ZONECFG { uplevel 1 $body }
1081 define zone {name {body {}}} {
1083 preserving-config ZONECFG {
1087 uplevel 1 [list confspc-eval zone $body]
1088 lappend ZONES [array get ZONECFG]
1093 ###--------------------------------------------------------------------------
1094 ### Processing the results.
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
1102 array set zone $config
1103 return [string map [list \
1109 proc output-file-name {view} {
1110 ## Return the output file name for the given VIEW.
1113 return [string map [list %v $view] $ZONECFG(conf-file)]
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.
1120 array set zone $config
1122 ## See whether the zone matches the view.
1124 foreach wanted $zone(views) {
1125 if {[string match $wanted $view]} { set match 1; break }
1127 if {!$match} { return {config-type ignore} }
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 }
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
1156 ## Work out the file names.
1157 switch -glob -- $zone(config-type):$zone(type) {
1159 set dir $zone(static-dir)
1160 set nameview $zone(mapped-view)
1163 set dir $zone(dynamic-dir)
1167 set zone(file-name) [file join $dir \
1168 [zone-file-name $nameview $config]]
1170 ## Find out whether this zone wants signing.
1171 set zone(sign) false
1172 switch -glob -- $zone(config-type):$zone(type) {
1174 foreach sview $zone(sign-views) {
1175 if {[string match $zone(mapped-view) $sview]} { set zone(sign) true }
1180 set zone(server-file-name) "$zone(file-name).sig"
1182 set zone(server-file-name) $zone(file-name)
1186 return [array get zone]
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.
1193 array set zone $config
1194 puts $chan "${prefix}update-policy {"
1195 set policyskel "${prefix}\t%s %s %s \"%s\" %s;"
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 \
1208 puts $chan [format $policyskel \
1215 puts $chan "${prefix}};"
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.
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) \
1235 file delete -force $outfile
1238 file rename -force $outfile $zone(server-file-name)
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.
1246 array set zone [compute-zone-properties $view $config]
1247 if {[string equal $zone(config-type) "ignore"]} { return }
1249 ## Create the directory for the zone files.
1250 set dir [file dirname $zone(file-name)]
1251 if {![file isdirectory $dir]} {
1253 exec chmod $zone(dir-mode) $dir
1256 ## Write the configuration fragment.
1257 puts $chan "\nzone \"$zone(name)\" {"
1258 switch -glob -- $zone(config-type) {
1260 puts $chan "\ttype master;"
1261 puts $chan "\tfile \"$zone(server-file-name)\";"
1262 switch -exact -- $zone(type) {
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);"
1272 puts $chan "\ttype slave;"
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; };" }
1285 ###--------------------------------------------------------------------------
1286 ### Command-line interface.
1288 set CONFFILE "@pkgconfdir@/zones.in"
1291 help-text "List the output file names to stdout."
1293 global ZONECFG CONFFILE
1295 confspc-eval toplevel [list source $CONFFILE]
1296 foreach view $ZONECFG(all-views) { puts [output-file-name $view] }
1300 help-text "Generate BIND configuration files."
1302 global ZONECFG ZONES CONFFILE
1304 ## Read the configuration.
1305 confspc-eval toplevel [list source $CONFFILE]
1307 ## Safely update the files.
1311 ## Work through each server view.
1312 foreach view $ZONECFG(all-views) {
1314 ## Open an output file.
1315 set out($view) [output-file-name $view]
1316 set chan($view) [open "$out($view).new" w]
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"
1323 ## Now print a stanza for each zone in the view.
1324 foreach zone $ZONES {
1325 write-zone-stanza $view $chan($view) $zone
1329 ## Done: don't delete the output.
1333 ## Close the open files.
1334 foreach view $ZONECFG(all-views) {
1335 catch { close $chan($view) }
1338 ## If we succeeded, rename the output files into their proper places;
1339 ## otherwise, delete them.
1341 foreach view $ZONECFG(all-views) {
1342 file rename -force -- "$out($view).new" $out($view)
1344 eval exec $ZONECFG(reconfig-command)
1346 catch { file delete -force -- "$out($view).new" }
1351 defcmd install {user view name} {
1352 help-text "Install a new zone file.
1354 The file is for the given zone NAME and \(user-side) VIEW. The file is
1355 provided by the named USER."
1357 global QUIS ZONECFG ZONES CONFFILE errorInfo errorCode
1359 ## Read the configuration.
1360 confspc-eval toplevel [list source $CONFFILE]
1362 ## Make sure there's a temporary directory.
1363 file mkdir [file join $ZONECFG(home-dir) "tmp"]
1365 ## Keep track of cleanup jobs.
1369 ## Find out which server views are affected by this update.
1371 foreach iview $ZONECFG(all-views) {
1372 foreach info $ZONES {
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] }
1385 if {![llength $matchview]} {
1386 optparse-error "No match for zone `$name' in view `$view'"
1389 array set zone $matchinfo
1391 ## Make a new temporary file to read the zone into.
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]} {
1398 } elseif {[string equal [lindex $errorCode 0] POSIX] && \
1399 ![string equal [lindex $errorCode 1] EEXIST]} {
1400 error $msg $errorInfo $errorCode
1403 if {![info exists chan]} { error "failed to create temporary file" }
1404 set cleanup [list file delete $tmp]
1406 ## Read the zone data from standard input into the file.
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"
1419 ## Check the zone for sanity.
1420 if {![run "zone check" $zone(checkzone-command) \
1428 ## If the zone wants signing, better to do that now.
1429 if {$zone(sign) && ![sign-zone-file $matchinfo keep $tmp]} {
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)
1438 foreach view $matchview {
1439 if {![run "reload zone `$zone(name) in view `$view'" \
1440 $zone(reload-command) \
1442 "%z" $zone(name)]} {
1452 help-text "Sign DNSSEC zones."
1454 global QUIS ZONECFG ZONES CONFFILE
1458 ## Read the configuration.
1459 confspc-eval toplevel [list source $CONFFILE]
1461 ## Grind through all of the zones.
1463 foreach view $ZONECFG(all-views) {
1464 foreach info $ZONES {
1466 ## Fetch the zone information.
1468 set compinfo [compute-zone-properties $view $info]
1469 array set zone $compinfo
1470 if {![string equal $zone(config-type) master]} { continue }
1472 if {[string equal $zone(type) static] && $zone(sign)} {
1473 ## Static zone: re-sign it if we haven't seen this user view before,
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)]} {
1484 set seen($id) failed
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) \
1497 } elseif {[string equal $zone(type) dynamic] &&
1498 ![string equal $zone(ddns-auto-dnssec) off]} {
1499 ## Dynamic zone: get BIND to re-sign it.
1501 if {![run "re-sign zone `$zone(name) in server view `$view'" \
1502 $zone(autosign-command) \
1513 ###--------------------------------------------------------------------------
1516 set VERSION "@VERSION@"
1517 set USAGE() " \[-OPTIONS] SUBCOMMAND \[ARGUMENTS...]"
1519 define-options OPTS {
1521 short "h"; long "help"
1522 action { eval cmd/help [optparse-words]; exit }
1525 short "v"; long "version"
1526 action { puts "$QUIS, version $VERSION"; exit }
1529 short "c"; long "config"; arg required
1530 action { set CONFFILE [optparse-arg] }
1534 with-option-parser $OPTS $argv {
1536 set argv [optparse-words]
1539 if {![llength $argv]} { usage-error }
1540 dispatch [lindex $argv 0] [lrange $argv 1 end]
1542 ###----- That's all, folks --------------------------------------------------