Commit | Line | Data |
---|---|---|
a37c695a | 1 | #! @TCLSH@ |
2a65b7cf MW |
2 | ### -*-tcl-*- |
3 | ### | |
4 | ### Generate `named.conf' stanze for multiple views. | |
5 | ### | |
6 | ### (c) 2011 Mark Wooding | |
7 | ### | |
8 | ||
9 | ###----- Licensing notice --------------------------------------------------- | |
10 | ### | |
11 | ### This program is free software; you can redistribute it and/or modify | |
12 | ### it under the terms of the GNU General Public License as published by | |
13 | ### the Free Software Foundation; either version 2 of the License, or | |
14 | ### (at your option) any later version. | |
15 | ### | |
16 | ### This program is distributed in the hope that it will be useful, | |
17 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | ### GNU General Public License for more details. | |
20 | ### | |
21 | ### You should have received a copy of the GNU General Public License | |
22 | ### along with this program; if not, write to the Free Software Foundation, | |
23 | ### Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
24 | ||
25 | ###-------------------------------------------------------------------------- | |
26 | ### Utility functions. | |
27 | ||
28 | proc pushnew {var args} { | |
29 | ## Append each of the ARGS onto the list VAR if they're not there already. | |
30 | ||
31 | upvar 1 $var list | |
32 | foreach item $list { set found($item) t } | |
33 | foreach item $args { | |
34 | if {![info exists found($item)]} { | |
35 | lappend list $item | |
36 | set found($item) t | |
37 | } | |
38 | } | |
39 | } | |
40 | ||
41 | proc merge-lists {lists} { | |
42 | ## Merge the given LISTS into a single list, respecting the order of the | |
43 | ## items in the original list. If that's not possible, signal an error. | |
44 | ## Any ambiguity is resolved by choosing the item from the earlier list. | |
45 | ||
46 | ## Strip out any empty lists in the input. | |
47 | set nlists {} | |
48 | foreach list $lists { | |
49 | if {[llength $list]} { lappend nlists $list } | |
50 | } | |
51 | set lists $nlists | |
52 | ||
53 | ## Clear the output list. | |
54 | set output {} | |
55 | ||
56 | ## Now pick out items one by one. | |
57 | while {[llength $lists]} { | |
58 | ||
59 | ## Find the candidate items | |
60 | set cand {} | |
61 | foreach list $lists { pushnew cand [lindex $list 0] } | |
62 | ||
2042733d | 63 | ## Remove candidate items which are not first in some other list. |
2a65b7cf MW |
64 | set ncand {} |
65 | foreach cand $cand { | |
66 | foreach list $lists { | |
2042733d | 67 | if {[lsearch -exact $list $cand] <= 0} { lappend ncand $cand } |
2a65b7cf MW |
68 | } |
69 | } | |
2042733d | 70 | set cand $ncand |
2a65b7cf MW |
71 | |
72 | ## If there's nothing left, report an error. | |
73 | if {![llength $cand]} { | |
74 | error "Inconsistent lists in `merge-lists'." | |
75 | } | |
76 | ||
77 | ## Otherwise take the first item. | |
78 | set chosen [lindex $cand 0] | |
79 | lappend output $chosen | |
80 | ||
81 | ## Remove the chosen item from the input lists. | |
82 | set nlists {} | |
83 | foreach list $lists { | |
84 | if {[string equal $chosen [lindex $list 0]]} { | |
85 | set list [lrange $list 1 end] | |
86 | if {![llength $list]} { continue } | |
87 | } | |
88 | lappend nlists $list | |
89 | } | |
90 | set lists $nlists | |
91 | } | |
92 | ||
93 | return $output | |
94 | } | |
95 | ||
96 | proc adjust-uplevel {spec offset} { | |
97 | ## Adjust an `uplevel' SPEC by OFFSET to take account of intervening call | |
98 | ## frames. If SPEC begins with `#' then it is left alone; otherwise it is | |
99 | ## incremented by OFFSET. | |
100 | ||
101 | switch -glob -- $spec { | |
102 | \#* { return $spec } | |
103 | default { return [expr {$spec + $offset}] } | |
104 | } | |
105 | } | |
106 | ||
107 | proc unwind-protect {body cleanup} { | |
108 | ## Evaluate BODY; then evaluate CLEANUP, regardless of whether BODY | |
109 | ## returned normally or did something complicated. If CLEANUP completes | |
110 | ## normally then the final result is that of BODY (including any errors or | |
111 | ## abnormal returns it made); otherwise the result of CLEANUP takes | |
112 | ## precedence and the results of BODY are discarded. | |
113 | ||
114 | catch { uplevel 1 $body } bodyval bodyopts | |
115 | if {[catch { uplevel 1 $cleanup } cleanval cleanopts]} { | |
116 | return -options $cleanopts $cleanval | |
117 | } else { | |
118 | return -options $bodyopts $bodyval | |
119 | } | |
120 | } | |
121 | ||
122 | proc let {args} { | |
123 | ## Syntax: let VAR VALUE ... BODY | |
124 | ## | |
125 | ## Evaluate BODY with the VARs bound to the VALUEs. Reestore the previous | |
126 | ## values when the BODY returns. | |
127 | ||
128 | ## Parse the argument syntax. | |
129 | if {[llength $args] % 2 == 0} { | |
130 | error "bad number of arguments to `let'" | |
131 | } | |
132 | set body [lindex $args end] | |
133 | ||
134 | ## Now work through the bindings, setting the variables to their new | |
135 | ## values. As we go, also build up code in `cleanup' to restore everything | |
136 | ## the way it's meant to be. | |
137 | set cleanup {} | |
138 | set i 0 | |
139 | foreach {var value} [lrange $args 0 end-1] { | |
140 | upvar 1 $var fluid-$i | |
141 | if {[info exists fluid-$i]} { | |
142 | append cleanup "set fluid-$i [list [set fluid-$i]]\n" | |
143 | } else { | |
144 | append cleanup "unset fluid-$i\n" | |
145 | } | |
146 | set fluid-$i $value | |
147 | incr i | |
148 | } | |
149 | ||
150 | ## Now evaluate the body. | |
151 | unwind-protect { uplevel 1 $body } $cleanup | |
152 | } | |
153 | ||
154 | proc set* {names values} { | |
155 | ## Set each of the variables listed in NAMES to the corresponding element | |
156 | ## of VALUES. The two lists must have the same length. | |
157 | ||
158 | if {[llength $names] != [llength $values]} { | |
159 | error "length mismatch" | |
160 | } | |
161 | foreach name $names value $values { | |
162 | upvar 1 $name var | |
163 | set var $value | |
164 | } | |
165 | } | |
166 | ||
400655ac MW |
167 | proc run {what command args} { |
168 | ## Run a command, reporting the result. WHAT is shown in the output; | |
169 | ## COMMAND are the command and arguments as a list; these are substituted | |
170 | ## according to the string map ARGS. Return true if the command succeeded, | |
171 | ## false if it failed. | |
172 | ||
173 | global QUIS | |
174 | ||
175 | ## Substitute tokens in the command. | |
176 | set cmd {} | |
177 | set subst [concat [list "%%" "%"] $args] | |
178 | foreach item $command { lappend cmd [string map $subst $item] } | |
179 | ||
180 | ## Run the command. | |
181 | set rc [catch { | |
182 | set out [eval exec -ignorestderr $cmd 2>@1] | |
183 | } msg] | |
184 | ||
185 | ## Sort out the report. | |
186 | if {$rc} { set out $msg } | |
187 | set out "| [string map [list "\n" "\n| "] $out]" | |
188 | ||
189 | ## Announce the result. | |
190 | if {$rc} { | |
191 | puts stderr "$QUIS: $what failed..." | |
192 | puts stderr $out | |
193 | return false | |
194 | } else { | |
195 | puts "$QUIS: $what output..." | |
196 | puts $out | |
197 | return true | |
198 | } | |
199 | } | |
200 | ||
4b9857df MW |
201 | proc isolate {body} { |
202 | ## Evaluate BODY without changing the caller's variables. Return its | |
203 | ## result. | |
204 | ||
205 | eval $body | |
206 | } | |
207 | ||
2a65b7cf MW |
208 | ###-------------------------------------------------------------------------- |
209 | ### Configuration spaces. | |
210 | ### | |
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. | |
217 | ### | |
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. | |
226 | ||
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. | |
230 | ||
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 {} | |
239 | } | |
240 | } | |
241 | ||
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 | |
246 | ||
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. | |
251 | ||
252 | global CONFSPC_CMD CONFSPC_VAR | |
253 | pushnew CONFSPC_CMD($space) $name | |
254 | ||
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] | |
260 | ||
261 | ## Now arrange for this command to exist properly in the configuration | |
262 | ## space. | |
263 | namespace eval ::confspc::$space \ | |
264 | [list namespace import ${ns}::conf/$space/$name] | |
265 | catch { | |
266 | namespace eval ::confspc::$space [list rename $name {}] | |
267 | } | |
268 | namespace eval ::confspc::$space \ | |
269 | [list rename conf/$space/$name $name] | |
270 | } | |
271 | ||
272 | proc confspc-include {space includes} { | |
273 | ## Arrange for SPACE to include the directives from the INCLUDES spaces. | |
274 | ||
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}] | |
279 | } | |
280 | } | |
281 | ||
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. | |
286 | ||
287 | global CONFSPC_CPL CONFSPC_CHANGE CONFSPC_INCL | |
288 | global CONFSPC_CHANGESEQ CONFSPC_LASTCHANGESEQ | |
289 | set CONFSPC_LASTCHANGESEQ $CONFSPC_CHANGESEQ | |
290 | ||
291 | ## If the space is already up-to-date, do nothing. | |
292 | if {$CONFSPC_CHANGE($space) == $CONFSPC_CHANGESEQ} { return } | |
293 | ||
294 | ## Arrange for the included spaces to be up-to-date, and gather the CPLs | |
295 | ## together so we can merge them. | |
296 | set merge {} | |
297 | lappend merge [concat $space $CONFSPC_INCL($space)] | |
298 | foreach included $CONFSPC_INCL($space) { | |
299 | confspc-update $included | |
300 | lappend merge $CONFSPC_CPL($included) | |
301 | } | |
302 | ||
303 | ## Do the merge and update the change indicator. | |
304 | set CONFSPC_CPL($space) [merge-lists $merge] | |
305 | set CONFSPC_CHANGE($space) $CONFSPC_CHANGESEQ | |
306 | } | |
307 | ||
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. | |
312 | ||
313 | set path {} | |
314 | ||
315 | ## Add the new namespaces to the front. | |
316 | foreach spc $cpl { lappend path ::confspc::$spc } | |
317 | ||
318 | ## Now add the existing path items, with any existing confspc hacking | |
319 | ## stripped out. | |
320 | foreach item [namespace eval $ns { namespace path }] { | |
321 | if {![string match "::confspc::*" $item]} { lappend npath $item } | |
322 | } | |
323 | ||
324 | ## Commit the result. | |
325 | namespace eval $ns [list namespace path $path] | |
326 | } | |
327 | ||
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). | |
331 | ||
332 | global CONFSPC_CPL | |
333 | confspc-update $space | |
334 | confspc-path $ns $CONFSPC_CPL($space) | |
335 | } | |
336 | ||
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. | |
341 | ||
342 | set ns [uplevel 1 { namespace current }] | |
343 | set path [namespace eval $ns { namespace path }] | |
344 | unwind-protect { | |
345 | confspc-set $ns $space | |
346 | uplevel 1 $body | |
347 | } { | |
348 | namespace eval $ns [list namespace path $path] | |
349 | } | |
350 | } | |
351 | ||
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. | |
355 | ||
63ba7a29 | 356 | upvar #0 $confvar CONFIG |
2a65b7cf MW |
357 | set old [array get CONFIG] |
358 | unwind-protect { | |
359 | uplevel 1 $body | |
360 | } { | |
361 | array unset CONFIG | |
362 | array set CONFIG $old | |
363 | } | |
364 | } | |
365 | ||
366 | confspc-create confspc CONFSPC_CONFIG | |
367 | ||
368 | confspc-command confspc include {args} { | |
369 | ## Include the named configuration spaces in the current one. | |
370 | ||
371 | confspc-include $CONFSPC_CONFIG(space) $args | |
372 | } | |
373 | ||
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. | |
377 | ||
378 | confspc-command $CONFSPC_CONFIG(space) $name $bvl $body | |
379 | } | |
380 | ||
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. | |
385 | ||
386 | global CONFSPC_VAR | |
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 | |
392 | } | |
393 | ||
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 | |
398 | ## arguments). | |
399 | ||
400 | global CONFSPC_VAR | |
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 | |
406 | } | |
407 | ||
408 | confspc-command confspc prefix {prefix} { | |
409 | set CONFSPC_CONFIG(prefix) $prefix | |
410 | } | |
411 | ||
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'. | |
415 | ||
416 | global CONFSPC_CONFIG | |
417 | set ns [uplevel 1 { namespace current }] | |
418 | set oldpath [namespace eval $ns { namespace path }] | |
419 | confspc-create $space $confvar | |
420 | unwind-protect { | |
421 | preserving-config CONFSPC_CONFIG { | |
422 | array set CONFSPC_CONFIG [list space $space \ | |
423 | prefix ""] | |
424 | confspc-set $ns confspc | |
425 | uplevel 1 $body | |
426 | } | |
427 | } { | |
428 | namespace eval $ns [list namespace path $oldpath] | |
429 | } | |
430 | } | |
431 | ||
432 | ###-------------------------------------------------------------------------- | |
433 | ### Option parsing. | |
434 | ### | |
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. | |
440 | ||
441 | proc optparse-more-p {} { | |
442 | ## Answer whether there are more argument words available. | |
443 | ||
444 | upvar #0 OPTPARSE_STATE state | |
445 | if {[llength $state(words)]} { return true } else { return false } | |
446 | } | |
447 | ||
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. | |
451 | ||
452 | upvar #0 OPTPARSE_STATE state | |
453 | set word [lindex $state(words) 0] | |
454 | set state(words) [lrange $state(words) 1 end] | |
455 | return $word | |
456 | } | |
457 | ||
458 | proc optparse-error {message} { | |
459 | ## Report an error message and exit. | |
460 | ||
461 | global QUIS | |
462 | puts stderr "$QUIS: $message" | |
463 | exit 1 | |
464 | } | |
465 | ||
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'. | |
470 | ## | |
471 | ## See the description of `optparse-option/free' for the interface | |
472 | ## implemented by this procedure. | |
473 | ||
474 | ## Get hold of my state and the caller's array. | |
475 | upvar #0 OPTPARSE_STATE state | |
476 | upvar 1 $var opt | |
477 | ||
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. | |
484 | array unset opt | |
485 | switch [string length $state(rest)] { | |
486 | 0 { | |
487 | error "empty cluster" | |
488 | } | |
489 | 1 { | |
490 | set argp false | |
491 | set state(mode) free | |
492 | set name $state(rest) | |
493 | } | |
494 | default { | |
495 | set argp true | |
496 | set name [string index $state(rest) 0] | |
497 | set state(rest) [string range $state(rest) 1 end] | |
498 | } | |
499 | } | |
500 | ||
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'" | |
504 | } | |
505 | array set opt [dict get $state(short-map) $name] | |
506 | set state(name) $name | |
507 | ||
508 | ## Collect an argument if one is required. | |
509 | catch { unset state(arg) } | |
510 | switch -glob -- "$opt(arg),$argp" { | |
511 | "required,false" { | |
512 | if {![optparse-more-p]} { | |
513 | optparse-error "Option `$state(prefix)$name' requires an argument" | |
514 | } | |
515 | set state(arg) [optparse-next-word] | |
516 | } | |
517 | "required,true" - "optional,true" { | |
518 | set state(arg) $state(rest) | |
519 | set state(mode) free | |
520 | } | |
521 | } | |
522 | ||
523 | ## Report success. | |
524 | return 1 | |
525 | } | |
526 | ||
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. | |
533 | ## | |
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. | |
537 | ## | |
538 | ## prefix The prefix character(s) to write before the option name in | |
539 | ## messages, e.g., `--' for long options. | |
540 | ## | |
541 | ## name The option name without any prefix attached. | |
542 | ## | |
543 | ## arg The option's argument, if there is one; otherwise unset. | |
544 | ||
545 | upvar #0 OPTPARSE_STATE state | |
546 | upvar 1 $var opt | |
547 | ||
548 | ## Set stuff up. | |
549 | array unset opt | |
550 | catch { unset state(arg) } | |
551 | if {![optparse-more-p]} { return 0 } | |
552 | set word [optparse-next-word] | |
553 | ||
554 | ## Work out what to do based on the word. The order of these tests is | |
555 | ## critically important. | |
556 | switch -glob -- $word { | |
557 | ||
558 | "--" { | |
559 | ## End-of-options marker. | |
560 | ||
561 | return 0 | |
562 | } | |
563 | ||
564 | "--*" { | |
565 | ## Long option. | |
566 | ||
567 | set state(prefix) "--" | |
568 | ||
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] | |
572 | if {$eq >= 0} { | |
573 | set name [string range $word 2 [expr {$eq - 1}]] | |
574 | set state(arg) [string range $word [expr {$eq + 1}] end] | |
575 | set argp true | |
576 | } else { | |
577 | set name [string range $word 2 end] | |
578 | set argp false | |
579 | } | |
580 | set state(name) name | |
581 | ||
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] | |
585 | } else { | |
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'" } | |
590 | default { | |
591 | optparse-error "Ambiaguous option `--$name' \ | |
592 | (matches: --[join $matches {, --}])" | |
593 | } | |
594 | } | |
595 | } | |
596 | ||
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" { | |
600 | "none,true" { | |
601 | optparse-error "Option `$name' doesn't accept an argument" | |
602 | } | |
603 | "required,false" { | |
604 | if {![optparse-more-p]} { | |
605 | optparse-error "Option `$name' requires an argument" | |
606 | } | |
607 | set state(arg) [optparse-next-word] | |
608 | } | |
609 | } | |
610 | ||
611 | ## Done. We consumed either one or two entire argument words, so we | |
612 | ## should remain in the `free' state. | |
613 | return 1 | |
614 | } | |
615 | ||
616 | "-?*" { | |
617 | ## Short option. Set state, initialize the cluster, and go. | |
618 | ||
619 | set state(rest) [string range $word 1 end] | |
620 | set state(mode) short | |
621 | set state(prefix) "-" | |
622 | return [optparse-option/short opt] | |
623 | } | |
624 | ||
625 | default { | |
626 | ## Some non-option thing. Under POSIX rules, this ends the parse. (We | |
627 | ## could do something more adventurous later.) | |
628 | ||
629 | set state(words) [concat [list $word] $state(words)] | |
630 | return 0 | |
631 | } | |
632 | } | |
633 | } | |
634 | ||
635 | proc optparse-arg-p {} { | |
636 | ## Return the whether the most recently processed option had an argument. | |
637 | ||
638 | upvar #0 OPTPARSE_STATE state | |
639 | return [info exists state(arg)] | |
640 | } | |
641 | ||
642 | proc optparse-arg {} { | |
643 | ## Return the argument from the most recently processed option. It is an | |
644 | ## error if no argument was supplied. | |
645 | ||
646 | upvar #0 OPTPARSE_STATE state | |
647 | return $state(arg) | |
648 | } | |
649 | ||
650 | proc optparse-words {} { | |
651 | ## Return the remaining unparsed argument words as a list. | |
652 | ||
653 | upvar #0 OPTPARSE_STATE state | |
654 | return $state(words) | |
655 | } | |
656 | ||
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. | |
661 | ||
662 | upvar #0 OPTPARSE_STATE state | |
663 | while 1 { | |
664 | if {![optparse-option/$state(mode) opt]} { | |
665 | return done | |
666 | } elseif {[info exists opt(action)]} { | |
667 | uplevel 1 $opt(action) | |
668 | } elseif {[info exists opt(tag)]} { | |
669 | return $opt(tag) | |
670 | } else { | |
671 | error "Don't know what to do with option `$state(prefix)$state(name)'" | |
672 | } | |
673 | } | |
674 | } | |
675 | ||
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 | |
680 | ## options. | |
681 | ||
682 | global OPTPARSE_STATE | |
683 | set old [array get OPTPARSE_STATE] | |
684 | ||
685 | unwind-protect { | |
686 | array unset OPTPARSE_STATE | |
687 | array set OPTPARSE_STATE $state | |
688 | set OPTPARSE_STATE(mode) free | |
689 | set OPTPARSE_STATE(words) $words | |
690 | uplevel 1 $body | |
691 | } { | |
692 | array set OPTPARSE_STATE $old | |
693 | } | |
694 | } | |
695 | ||
696 | define-configuration-space optparse-option OPTCFG { | |
697 | define-list short {} | |
698 | define-list long {} | |
699 | define action {act} { set OPTCFG(action) $act } | |
700 | define tag {tag} { set OPTCFG(tag) $tag } | |
701 | define-simple arg none | |
702 | } | |
703 | ||
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'" | |
713 | } | |
714 | dict set state($kind-map) $name $opt | |
715 | } | |
716 | } | |
717 | } | |
718 | } | |
719 | ||
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. | |
723 | ||
724 | global OPTPARSE_STATE | |
725 | upvar 1 $statevar state | |
726 | set old [array get OPTPARSE_STATE] | |
727 | unwind-protect { | |
728 | array unset OPTPARSE_STATE | |
729 | if {[info exists state]} { | |
730 | array set OPTPARSE_STATE $state | |
731 | } else { | |
732 | array set OPTPARSE_STATE { | |
733 | long-map {} | |
734 | short-map {} | |
735 | } | |
736 | } | |
737 | uplevel 1 [list confspc-eval optparse $body] | |
738 | set state [array get OPTPARSE_STATE] | |
739 | } { | |
740 | array set OPTPARSE_STATE $old | |
741 | } | |
742 | } | |
743 | ||
744 | ###-------------------------------------------------------------------------- | |
745 | ### Subcommand handling. | |
746 | ||
747 | ## Determine the program name. | |
748 | set QUIS [file tail $argv0] | |
749 | ||
750 | ## This is fluid-bound to the name of the current command. | |
751 | set COMMAND {} | |
752 | ||
753 | proc find-command {name} { | |
754 | ## Given a command NAME as typed by the user, find the actual command and | |
755 | ## return it. | |
756 | ||
757 | global HELP | |
758 | set matches [info commands cmd/$name*] | |
759 | set cmds {} | |
760 | set doc {} | |
761 | foreach match $matches { | |
762 | set cmd [string range $match 4 end] | |
763 | lappend cmds $cmd | |
764 | if {[info exists HELP($cmd)]} { lappend doc $cmd } | |
765 | } | |
766 | switch -exact -- [llength $cmds] { | |
767 | 1 { return [lindex $cmds 0] } | |
768 | 0 { optparse-error "Unknown command `$name'" } | |
769 | } | |
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" } | |
775 | } | |
776 | } | |
777 | ||
778 | proc usage {cmd} { | |
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. | |
784 | ## | |
785 | ## By convention, the main program is denoted by an empty CMD name. | |
786 | ||
787 | global USAGE | |
788 | if {[info exists USAGE($cmd)]} { | |
789 | set usage $USAGE($cmd) | |
790 | } else { | |
791 | set usage "" | |
792 | foreach arg [info args cmd/$cmd] { | |
793 | if {[string equal $arg "args"]} { | |
794 | append usage " ..." | |
795 | } elseif {[info default cmd/$cmd $arg hunoz]} { | |
796 | append usage " \[[string toupper $arg]\]" | |
797 | } else { | |
798 | append usage " [string toupper $arg]" | |
799 | } | |
800 | } | |
801 | } | |
802 | return $usage | |
803 | } | |
804 | ||
805 | proc usage-error {} { | |
806 | ## Report a usage error in the current command. The message is obtained by | |
807 | ## the `usage' procedure. | |
808 | ||
809 | global QUIS COMMAND | |
810 | if {[string length $COMMAND]} { set cmd " $COMMAND" } else { set cmd "" } | |
811 | puts stderr "Usage: $QUIS$cmd[usage $COMMAND]" | |
812 | exit 1 | |
813 | } | |
814 | ||
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. | |
820 | ||
821 | global COMMAND | |
822 | let COMMAND [find-command $name] { | |
823 | ||
824 | ## Decode the argument list of the handler and set min and max | |
825 | ## appropriately. | |
826 | set args [info args cmd/$COMMAND] | |
827 | if {![llength $args]} { | |
828 | set* {min max} {0 0} | |
829 | } else { | |
830 | if {[string equal [lindex $args end] "args"]} { | |
831 | set max inf | |
832 | set args [lrange $args 0 end-1] | |
833 | } else { | |
834 | set max [llength $args] | |
835 | } | |
836 | set min 0 | |
837 | foreach arg $args { | |
838 | if {[info default cmd/$COMMAND $arg hunoz]} { break } | |
839 | incr min | |
840 | } | |
841 | } | |
842 | ||
843 | ## Complain if the number of arguments is inappropriate. | |
844 | set n [llength $argv] | |
845 | if {$n < $min || ($max != inf && $n > $max)} { usage-error } | |
846 | ||
847 | ## Invoke the handler. | |
848 | eval cmd/$COMMAND $argv | |
849 | } | |
850 | } | |
851 | ||
852 | define-configuration-space subcommand SUBCMD { | |
853 | define-simple help-text - | |
854 | define-simple usage-text - | |
855 | } | |
856 | ||
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 | |
860 | ## command. | |
861 | ||
862 | global SUBCMD USAGE HELP | |
863 | ||
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) | |
869 | } | |
870 | } | |
871 | } | |
872 | proc cmd/$name $bvl $body | |
873 | } | |
874 | ||
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. | |
877 | ## | |
878 | ## USAGE(cmd) Contains the usage message for cmd -- including | |
879 | ## leading space -- to use instead of the `usage' | |
880 | ## procedure's automagic. | |
881 | ## | |
882 | ## HELP(cmd) Contains descriptive text -- not including a final | |
883 | ## trailing newline -- about the command. | |
884 | ## | |
885 | ## VERSION The program's version number. | |
886 | ## | |
887 | ## The `defcmd' procedure can be used to set these things up conveniently. | |
888 | defcmd help {args} { | |
889 | usage-text " \[SUBCOMMAND ...]" | |
890 | help-text "Show help on the given SUBCOMMANDs, or on the overall program." | |
891 | } { | |
892 | global QUIS VERSION USAGE HELP | |
893 | if {[llength $args]} { | |
894 | foreach name $args { | |
895 | set cmd [find-command $name] | |
896 | puts "Usage: $QUIS $cmd[usage $cmd]" | |
897 | if {[info exists HELP($cmd)]} { puts "\n$HELP($cmd)" } | |
898 | } | |
899 | } else { | |
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]" | |
907 | } | |
908 | } | |
909 | } | |
910 | ||
911 | ###-------------------------------------------------------------------------- | |
912 | ### Build the configuration space for zone files. | |
913 | ||
914 | proc host-addr {host} { | |
915 | ## Given a HOST name, return a list of its addresses. | |
916 | ||
917 | if {![string match $host {*[!0-9.]*}]} { return $host } | |
918 | set adns [open [list | adnshost +Dc -s $host] r] | |
919 | unwind-protect { | |
920 | set addrs {} | |
921 | while {[gets $adns line] >= 0} { | |
922 | set* {name type fam addr} $line | |
923 | switch -glob -- $type:$fam { | |
924 | A:INET { lappend addrs $addr } | |
925 | } | |
926 | } | |
927 | return [lindex $addrs 0] | |
928 | } { | |
929 | close $adns | |
930 | } | |
931 | } | |
932 | ||
933 | proc host-canonify {host} { | |
934 | ## Given a HOST name, return a canonical version of it. | |
935 | ||
936 | set adns [open [list | adnshost -Dc -s $host] r] | |
937 | unwind-protect { | |
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] } | |
942 | } | |
943 | } | |
944 | error "failed to canonify $host" | |
945 | } { | |
946 | close $adns | |
947 | } | |
948 | } | |
949 | ||
950 | proc local-address-p {addr} { | |
951 | ## Answer whether the ADDR is one of the host's addresses. | |
66b7fe74 | 952 | global env |
2a65b7cf | 953 | |
66b7fe74 MW |
954 | if {[info exists env(ZONECONF_LOCAL_ADDRESSES)]} { |
955 | if {[string match "*:$addr:*" ":$env(ZONECONF_LOCAL_ADDRESSES):"]} { | |
956 | return true | |
957 | } else { | |
958 | return false | |
959 | } | |
2a65b7cf | 960 | } else { |
66b7fe74 MW |
961 | if {[catch { set sk [socket -server {} -myaddr $addr 0] }]} { |
962 | return false | |
963 | } else { | |
964 | close $sk | |
965 | return true | |
966 | } | |
2a65b7cf MW |
967 | } |
968 | } | |
969 | ||
970 | ## The list of zones configured by the user. | |
971 | set ZONES {} | |
972 | ||
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] | |
978 | } | |
979 | define deny {identity nametype name args} { | |
980 | lappend ZONECFG(ddns-policy) \ | |
981 | [concat deny [list $identity $nametype $name] $args] | |
982 | } | |
983 | } | |
984 | ||
985 | ## Dynamic zone details. | |
986 | define-configuration-space dynamic ZONECFG { | |
987 | prefix "ddns-" | |
988 | define-simple key "ddns" | |
db6576c8 | 989 | define-simple auto-dnssec off |
2a65b7cf MW |
990 | define-list types {A TXT PTR} |
991 | ||
992 | define policy {body} { | |
993 | set ZONECFG(ddns-policy) {} | |
994 | uplevel 1 [list confspc-eval policy $body] | |
995 | } | |
996 | ||
997 | set ZONECFG(ddns-policy) {} | |
998 | } | |
999 | ||
1000 | ## Everything about a zone. | |
a37c695a MW |
1001 | set HOME "@pkgstatedir@" |
1002 | set BINDPROGS "@bindprogsdir@" | |
2a65b7cf MW |
1003 | define-configuration-space zone ZONECFG { |
1004 | define-simple user root | |
a37c695a MW |
1005 | define-simple home-dir $HOME |
1006 | define-simple static-dir "$HOME/static" | |
1007 | define-simple dynamic-dir "$HOME/dynamic" | |
2a65b7cf MW |
1008 | define-simple dir-mode 2775 |
1009 | define-simple zone-file "%v/%z.zone" | |
0af96368 | 1010 | define-simple soa-format increment |
6e1af3c0 | 1011 | define-simple allow-query nil |
2a65b7cf | 1012 | define-list views * |
0af96368 | 1013 | define-list sign-views {} |
a37c695a MW |
1014 | define-list signzone-command \ |
1015 | [list "$BINDPROGS/dnssec-signzone" \ | |
a37c695a MW |
1016 | "-S" \ |
1017 | "-K%h/key" \ | |
1018 | "-d%h/ds" \ | |
5860c677 | 1019 | "-s-3600" "-e+176400" "-i90000" \ |
a37c695a MW |
1020 | "-N%q" \ |
1021 | "-o%z" \ | |
1022 | "-f%o" \ | |
1023 | "%f"] | |
a37c695a MW |
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" \ | |
1028 | "-ifull" \ | |
1029 | "-kfail" \ | |
1030 | "-Mfail" \ | |
1031 | "-nfail" \ | |
1032 | "-Sfail" \ | |
1033 | "-Wfail" \ | |
1034 | "%z" "%f"] | |
9a61c5c9 | 1035 | define-list also-notify nil |
a37c695a MW |
1036 | |
1037 | define setvar {name value} { | |
1038 | dict set ZONECFG(var) $name $value | |
2a65b7cf MW |
1039 | } |
1040 | ||
1041 | define primary {map} { | |
e4ce9d1e MW |
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 | |
1047 | ## chicanery. | |
2a65b7cf MW |
1048 | if {[llength $map] % 2} { |
1049 | error "master map must have an even number of items" | |
1050 | } | |
1051 | set ZONECFG(master-map) $map | |
1052 | } | |
1053 | ||
1054 | define dynamic {{body {}}} { | |
1055 | array set ZONECFG [list type dynamic] | |
1056 | uplevel 1 [list confspc-eval dynamic $body] | |
1057 | } | |
1058 | ||
1059 | define view-map {map} { | |
e83cb954 MW |
1060 | |
1061 | ## OK, this needs careful documentation. | |
1062 | ## | |
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. | |
1066 | ## | |
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'. | |
1073 | ## | |
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. | |
1077 | ||
2a65b7cf MW |
1078 | if {[llength $map] % 2} { |
1079 | error "view map must have an even number of items" | |
1080 | } | |
1081 | set ZONECFG(view-map) $map | |
1082 | } | |
1083 | ||
1084 | array set ZONECFG { | |
1085 | type static | |
1086 | view-map {* =} | |
1087 | } | |
1088 | } | |
1089 | ||
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 { | |
1093 | include zone | |
1094 | ||
1095 | define-list all-views {} | |
a37c695a | 1096 | define-simple conf-file "$HOME/config/%v.conf" |
2a65b7cf MW |
1097 | define-simple max-zone-size [expr {512*1024}] |
1098 | define-list reconfig-command {/usr/sbin/rndc reconfig} | |
1099 | ||
0af96368 MW |
1100 | define scope {body} { |
1101 | preserving-config ZONECFG { uplevel 1 $body } | |
1102 | } | |
2a65b7cf MW |
1103 | |
1104 | define zone {name {body {}}} { | |
1105 | global ZONES | |
1106 | preserving-config ZONECFG { | |
1107 | array set ZONECFG \ | |
1108 | [list name $name \ | |
1109 | type static] | |
1110 | uplevel 1 [list confspc-eval zone $body] | |
1111 | lappend ZONES [array get ZONECFG] | |
1112 | } | |
1113 | } | |
1114 | } | |
1115 | ||
1116 | ###-------------------------------------------------------------------------- | |
1117 | ### Processing the results. | |
1118 | ||
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 | |
1123 | ## for the zone. | |
1124 | ||
1125 | array set zone $config | |
1126 | return [string map [list \ | |
1127 | "%v" $view \ | |
1128 | "%z" $zone(name)] \ | |
1129 | $zone(zone-file)] | |
1130 | } | |
1131 | ||
1132 | proc output-file-name {view} { | |
1133 | ## Return the output file name for the given VIEW. | |
1134 | ||
1135 | global ZONECFG | |
1136 | return [string map [list %v $view] $ZONECFG(conf-file)] | |
1137 | } | |
1138 | ||
07da6299 MW |
1139 | proc temporary-directory {} { |
1140 | ## Create a temporary directory and set as the working directory. | |
1141 | ||
1142 | global ZONECFG | |
1143 | set tmp [file join $ZONECFG(home-dir) "tmp"] | |
1144 | file mkdir $tmp | |
1145 | cd $tmp | |
1146 | return $tmp | |
1147 | } | |
1148 | ||
2a65b7cf MW |
1149 | proc compute-zone-properties {view config} { |
1150 | ## Derive interesting information from the zone configuration plist CONFIG, | |
e83cb954 | 1151 | ## relative to the stated server VIEW. Return a new plist. |
2a65b7cf MW |
1152 | |
1153 | array set zone $config | |
1154 | ||
1155 | ## See whether the zone matches the view. | |
1156 | set match 0 | |
1157 | foreach wanted $zone(views) { | |
1158 | if {[string match $wanted $view]} { set match 1; break } | |
1159 | } | |
1160 | if {!$match} { return {config-type ignore} } | |
1161 | ||
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 } | |
1168 | } | |
1169 | break | |
1170 | } | |
1171 | ||
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)]} { | |
e4ce9d1e | 1177 | set masters {} |
2a65b7cf MW |
1178 | set zone(config-type) slave |
1179 | foreach host $hosts { | |
e4ce9d1e MW |
1180 | set bang [string first "!" $host] |
1181 | if {$bang >= 0} { | |
e4ce9d1e | 1182 | set after [string range $host [expr {$bang + 1}] end] |
7de7888a MW |
1183 | if {$bang} { |
1184 | set before [string range $host 0 [expr {$bang - 1}]] | |
1185 | } else { | |
1186 | set before $after | |
1187 | } | |
e4ce9d1e MW |
1188 | if {[local-address-p $before]} { |
1189 | set host $after | |
1190 | } else { | |
1191 | set host $before | |
1192 | } | |
1193 | } elseif {[local-address-p $host]} { | |
2a65b7cf MW |
1194 | set zone(config-type) master |
1195 | } | |
e4ce9d1e | 1196 | lappend masters $host |
2a65b7cf | 1197 | } |
e4ce9d1e | 1198 | set zone(masters) $masters |
2a65b7cf MW |
1199 | break |
1200 | } | |
1201 | } | |
1202 | } | |
1203 | ||
0af96368 MW |
1204 | ## Work out the file names. |
1205 | switch -glob -- $zone(config-type):$zone(type) { | |
1206 | master:static { | |
a37c695a | 1207 | set dir $zone(static-dir) |
0af96368 | 1208 | set nameview $zone(mapped-view) |
2a65b7cf | 1209 | } |
0af96368 | 1210 | default { |
a37c695a | 1211 | set dir $zone(dynamic-dir) |
0af96368 MW |
1212 | set nameview $view |
1213 | } | |
1214 | } | |
1215 | set zone(file-name) [file join $dir \ | |
1216 | [zone-file-name $nameview $config]] | |
1217 | ||
1218 | ## Find out whether this zone wants signing. | |
1219 | set zone(sign) false | |
1220 | switch -glob -- $zone(config-type):$zone(type) { | |
1221 | master:static { | |
1222 | foreach sview $zone(sign-views) { | |
1223 | if {[string match $zone(mapped-view) $sview]} { set zone(sign) true } | |
1224 | } | |
2a65b7cf MW |
1225 | } |
1226 | } | |
0af96368 MW |
1227 | if {$zone(sign)} { |
1228 | set zone(server-file-name) "$zone(file-name).sig" | |
1229 | } else { | |
1230 | set zone(server-file-name) $zone(file-name) | |
1231 | } | |
2a65b7cf MW |
1232 | |
1233 | ## Done. | |
1234 | return [array get zone] | |
1235 | } | |
1236 | ||
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. | |
1240 | ||
1241 | array set zone $config | |
1242 | puts $chan "${prefix}update-policy {" | |
1243 | set policyskel "${prefix}\t%s %s %s \"%s\" %s;" | |
1244 | ||
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 \ | |
1249 | $verb \ | |
a37c695a MW |
1250 | $ident \ |
1251 | $type \ | |
1252 | $name \ | |
1253 | $rrtypes] | |
2a65b7cf MW |
1254 | } |
1255 | ||
1256 | puts $chan [format $policyskel \ | |
1257 | grant \ | |
1258 | $zone(ddns-key) \ | |
1259 | subdomain \ | |
1260 | $zone(name) \ | |
1261 | $zone(ddns-types)] | |
1262 | ||
1263 | puts $chan "${prefix}};" | |
1264 | } | |
1265 | ||
a37c695a | 1266 | proc sign-zone-file {info soafmt infile} { |
0af96368 MW |
1267 | ## Sign the zone described by INFO. The input zone file is INPUT; the SOA |
1268 | ## should be updated according to SOAFMT. | |
1269 | ||
1270 | global QUIS | |
1271 | ||
1272 | array set zone $info | |
a37c695a | 1273 | set outfile "$zone(server-file-name).new" |
9fe4d067 | 1274 | if {![run "sign zone `$zone(name)' in view `$zone(mapped-view)'" \ |
a37c695a MW |
1275 | $zone(signzone-command) \ |
1276 | "%h" $zone(home-dir) \ | |
1277 | "%m" $zone(static-dir) \ | |
1278 | "%s" $zone(dynamic-dir) \ | |
1279 | "%z" $zone(name) \ | |
1280 | "%f" $infile \ | |
1281 | "%o" $outfile \ | |
1282 | "%q" $soafmt]} { | |
1283 | file delete -force $outfile | |
1284 | return false | |
1285 | } | |
1286 | file rename -force $outfile $zone(server-file-name) | |
1287 | return true | |
0af96368 MW |
1288 | } |
1289 | ||
2a65b7cf MW |
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. | |
1293 | ||
1294 | array set zone [compute-zone-properties $view $config] | |
1295 | if {[string equal $zone(config-type) "ignore"]} { return } | |
1296 | ||
1297 | ## Create the directory for the zone files. | |
1298 | set dir [file dirname $zone(file-name)] | |
1299 | if {![file isdirectory $dir]} { | |
1300 | file mkdir $dir | |
1301 | exec chmod $zone(dir-mode) $dir | |
1302 | } | |
1303 | ||
1304 | ## Write the configuration fragment. | |
1305 | puts $chan "\nzone \"$zone(name)\" {" | |
1306 | switch -glob -- $zone(config-type) { | |
1307 | master { | |
1308 | puts $chan "\ttype master;" | |
0af96368 | 1309 | puts $chan "\tfile \"$zone(server-file-name)\";" |
9a61c5c9 MW |
1310 | if {![string equal $zone(also-notify) "nil"]} { |
1311 | puts $chan "\talso-notify { [join $zone(also-notify) {; }]; };" | |
1312 | } | |
2a65b7cf | 1313 | switch -exact -- $zone(type) { |
db6576c8 MW |
1314 | dynamic { |
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);" | |
1318 | } | |
1319 | } | |
2a65b7cf MW |
1320 | } |
1321 | } | |
1322 | slave { | |
1323 | puts $chan "\ttype slave;" | |
1324 | set masters {} | |
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; };" } | |
1330 | } | |
1331 | } | |
1332 | } | |
6e1af3c0 MW |
1333 | if {![string equal $zone(allow-query) nil]} { |
1334 | puts $chan "\tallow-query {$zone(allow-query)};" | |
1335 | } | |
2a65b7cf MW |
1336 | puts $chan "};"; |
1337 | } | |
1338 | ||
1339 | ###-------------------------------------------------------------------------- | |
1340 | ### Command-line interface. | |
1341 | ||
a37c695a | 1342 | set CONFFILE "@pkgconfdir@/zones.in" |
2a65b7cf MW |
1343 | |
1344 | defcmd outputs {} { | |
1345 | help-text "List the output file names to stdout." | |
1346 | } { | |
1347 | global ZONECFG CONFFILE | |
1348 | ||
4b9857df | 1349 | isolate [list confspc-eval toplevel [list source $CONFFILE]] |
2a65b7cf MW |
1350 | foreach view $ZONECFG(all-views) { puts [output-file-name $view] } |
1351 | } | |
1352 | ||
1353 | defcmd update {} { | |
1354 | help-text "Generate BIND configuration files." | |
1355 | } { | |
1356 | global ZONECFG ZONES CONFFILE | |
1357 | ||
0af96368 | 1358 | ## Read the configuration. |
4b9857df | 1359 | isolate [list confspc-eval toplevel [list source $CONFFILE]] |
0af96368 MW |
1360 | |
1361 | ## Safely update the files. | |
2a65b7cf MW |
1362 | set win false |
1363 | unwind-protect { | |
0af96368 MW |
1364 | |
1365 | ## Work through each server view. | |
2a65b7cf | 1366 | foreach view $ZONECFG(all-views) { |
0af96368 MW |
1367 | |
1368 | ## Open an output file. | |
2a65b7cf MW |
1369 | set out($view) [output-file-name $view] |
1370 | set chan($view) [open "$out($view).new" w] | |
0af96368 MW |
1371 | |
1372 | ## Write a header. | |
2a65b7cf MW |
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" | |
0af96368 MW |
1376 | |
1377 | ## Now print a stanza for each zone in the view. | |
2a65b7cf MW |
1378 | foreach zone $ZONES { |
1379 | write-zone-stanza $view $chan($view) $zone | |
1380 | } | |
1381 | } | |
0af96368 MW |
1382 | |
1383 | ## Done: don't delete the output. | |
2a65b7cf MW |
1384 | set win true |
1385 | } { | |
0af96368 MW |
1386 | |
1387 | ## Close the open files. | |
a37c695a MW |
1388 | foreach view $ZONECFG(all-views) { |
1389 | catch { close $chan($view) } | |
1390 | } | |
0af96368 MW |
1391 | |
1392 | ## If we succeeded, rename the output files into their proper places; | |
1393 | ## otherwise, delete them. | |
2a65b7cf MW |
1394 | if {$win} { |
1395 | foreach view $ZONECFG(all-views) { | |
1396 | file rename -force -- "$out($view).new" $out($view) | |
1397 | } | |
1398 | eval exec $ZONECFG(reconfig-command) | |
1399 | } else { | |
a37c695a | 1400 | catch { file delete -force -- "$out($view).new" } |
2a65b7cf MW |
1401 | } |
1402 | } | |
1403 | } | |
1404 | ||
1405 | defcmd install {user view name} { | |
1406 | help-text "Install a new zone file. | |
1407 | ||
9fe4d067 MW |
1408 | The file is for the given zone NAME and \(user-side) VIEW. The file is |
1409 | provided by the named USER." | |
2a65b7cf MW |
1410 | } { |
1411 | global QUIS ZONECFG ZONES CONFFILE errorInfo errorCode | |
1412 | ||
0af96368 | 1413 | ## Read the configuration. |
4b9857df | 1414 | isolate [list confspc-eval toplevel [list source $CONFFILE]] |
2a65b7cf | 1415 | |
0af96368 | 1416 | ## Make sure there's a temporary directory. |
07da6299 | 1417 | set tmpdir [temporary-directory] |
2a65b7cf | 1418 | |
0af96368 | 1419 | ## Keep track of cleanup jobs. |
2a65b7cf MW |
1420 | set cleanup {} |
1421 | unwind-protect { | |
1422 | ||
0af96368 | 1423 | ## Find out which server views are affected by this update. |
2a65b7cf MW |
1424 | set matchview {} |
1425 | foreach iview $ZONECFG(all-views) { | |
1426 | foreach info $ZONES { | |
1427 | array unset zone | |
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] } | |
1436 | } | |
1437 | } | |
1438 | } | |
1439 | if {![llength $matchview]} { | |
1440 | optparse-error "No match for zone `$name' in view `$view'" | |
1441 | } | |
1442 | array unset zone | |
1443 | array set zone $matchinfo | |
1444 | ||
0af96368 | 1445 | ## Make a new temporary file to read the zone into. |
2a65b7cf MW |
1446 | set pid [pid] |
1447 | for {set i 0} {$i < 1000} {incr i} { | |
07da6299 | 1448 | set tmp [file join $tmpdir "tmp.$pid.$i.$user.$name"] |
2a65b7cf MW |
1449 | if {![catch { set chan [open $tmp {WRONLY CREAT EXCL}] } msg]} { |
1450 | break | |
1451 | } elseif {[string equal [lindex $errorCode 0] POSIX] && \ | |
1452 | ![string equal [lindex $errorCode 1] EEXIST]} { | |
1453 | error $msg $errorInfo $errorCode | |
1454 | } | |
1455 | } | |
1456 | if {![info exists chan]} { error "failed to create temporary file" } | |
1457 | set cleanup [list file delete $tmp] | |
1458 | ||
0af96368 | 1459 | ## Read the zone data from standard input into the file. |
2a65b7cf MW |
1460 | set total 0 |
1461 | while {true} { | |
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" | |
1468 | } | |
1469 | } | |
1470 | close $chan | |
1471 | ||
a97a6929 | 1472 | ## Check the zone for sanity. |
400655ac | 1473 | if {![run "zone check" $zone(checkzone-command) \ |
a37c695a MW |
1474 | "%z" $name \ |
1475 | "%v" $view \ | |
1476 | "%f" $tmp]} { | |
0af96368 | 1477 | eval $cleanup |
2a65b7cf | 1478 | exit 1 |
2a65b7cf MW |
1479 | } |
1480 | ||
0af96368 | 1481 | ## If the zone wants signing, better to do that now. |
39bfd16a | 1482 | if {$zone(sign) && ![sign-zone-file $matchinfo keep $tmp]} { |
0af96368 MW |
1483 | eval $cleanup |
1484 | exit 2 | |
1485 | } | |
1486 | ||
1487 | ## All seems good: stash the file in the proper place and reload the | |
1488 | ## necessary server views. | |
2a65b7cf MW |
1489 | file rename -force -- $tmp $zone(file-name) |
1490 | set cleanup {} | |
1491 | foreach view $matchview { | |
400655ac MW |
1492 | if {![run "reload zone `$zone(name) in view `$view'" \ |
1493 | $zone(reload-command) \ | |
1494 | "%v" $view \ | |
1495 | "%z" $zone(name)]} { | |
1496 | exit 3 | |
1497 | } | |
2a65b7cf MW |
1498 | } |
1499 | } { | |
1500 | eval $cleanup | |
1501 | } | |
1502 | } | |
1503 | ||
0af96368 MW |
1504 | defcmd sign {} { |
1505 | help-text "Sign DNSSEC zones." | |
1506 | } { | |
1507 | global QUIS ZONECFG ZONES CONFFILE | |
1508 | ||
1509 | set rc 0 | |
1510 | ||
1511 | ## Read the configuration. | |
4b9857df | 1512 | isolate [list confspc-eval toplevel [list source $CONFFILE]] |
0af96368 | 1513 | |
bb07f2ba MW |
1514 | ## Sometimes `dnssec-signzone' tries to write temporary files to the |
1515 | ## current directory. Make sure this is sensible. | |
1516 | temporary-directory | |
1517 | ||
0af96368 | 1518 | ## Grind through all of the zones. |
400655ac MW |
1519 | array unset seen |
1520 | foreach view $ZONECFG(all-views) { | |
0af96368 | 1521 | foreach info $ZONES { |
400655ac MW |
1522 | |
1523 | ## Fetch the zone information. | |
0af96368 | 1524 | array unset zone |
400655ac | 1525 | set compinfo [compute-zone-properties $view $info] |
0af96368 MW |
1526 | array set zone $compinfo |
1527 | if {![string equal $zone(config-type) master]} { continue } | |
400655ac | 1528 | |
0af96368 | 1529 | if {[string equal $zone(type) static] && $zone(sign)} { |
400655ac MW |
1530 | ## Static zone: re-sign it if we haven't seen this user view before, |
1531 | ## and then reload. | |
1532 | ||
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)]} { | |
a37c695a MW |
1536 | if {[sign-zone-file $compinfo $zone(soa-format) \ |
1537 | $zone(server-file-name)]} { | |
400655ac MW |
1538 | set seen($id) true |
1539 | } else { | |
1540 | set rc 2 | |
1541 | set seen($id) failed | |
1542 | } | |
1543 | } | |
1544 | ||
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) \ | |
1549 | "%z" $zone(name) \ | |
1550 | "%v" $view]} { | |
1551 | set rc 2 | |
1552 | } | |
0af96368 MW |
1553 | } |
1554 | } elseif {[string equal $zone(type) dynamic] && | |
db6576c8 | 1555 | ![string equal $zone(ddns-auto-dnssec) off]} { |
400655ac MW |
1556 | ## Dynamic zone: get BIND to re-sign it. |
1557 | ||
1558 | if {![run "re-sign zone `$zone(name) in server view `$view'" \ | |
1559 | $zone(autosign-command) \ | |
1560 | "%z" $zone(name) \ | |
1561 | "%v" $view]} { | |
0af96368 MW |
1562 | set rc 2 |
1563 | } | |
1564 | } | |
1565 | } | |
1566 | } | |
1567 | exit $rc | |
1568 | } | |
1569 | ||
2a65b7cf MW |
1570 | ###-------------------------------------------------------------------------- |
1571 | ### Main program. | |
1572 | ||
a37c695a | 1573 | set VERSION "@VERSION@" |
2a65b7cf MW |
1574 | set USAGE() " \[-OPTIONS] SUBCOMMAND \[ARGUMENTS...]" |
1575 | ||
1576 | define-options OPTS { | |
1577 | option { | |
1578 | short "h"; long "help" | |
1579 | action { eval cmd/help [optparse-words]; exit } | |
1580 | } | |
1581 | option { | |
1582 | short "v"; long "version" | |
1583 | action { puts "$QUIS, version $VERSION"; exit } | |
1584 | } | |
1585 | option { | |
1586 | short "c"; long "config"; arg required | |
1587 | action { set CONFFILE [optparse-arg] } | |
1588 | } | |
1589 | } | |
1590 | ||
1591 | with-option-parser $OPTS $argv { | |
1592 | optparse-option | |
1593 | set argv [optparse-words] | |
1594 | } | |
1595 | ||
1596 | if {![llength $argv]} { usage-error } | |
1597 | dispatch [lindex $argv 0] [lrange $argv 1 end] | |
1598 | ||
1599 | ###----- That's all, folks -------------------------------------------------- |