X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/9c44003b8aa3a1a03d6f92c16ec782b13e61249a..HEAD:/frontend.lisp diff --git a/frontend.lisp b/frontend.lisp index cafa95a..1c1a442 100644 --- a/frontend.lisp +++ b/frontend.lisp @@ -1,7 +1,5 @@ ;;; -*-lisp-*- ;;; -;;; $Id$ -;;; ;;; Zone generator frontend ;;; ;;; (c) 2005 Straylight/Edgeware @@ -13,48 +11,173 @@ ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. -;;; +;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. -;;; +;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software Foundation, ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (defpackage #:zone.frontend - (:use #:common-lisp #:optparse #:net #:zone) + (:use #:common-lisp #:mdw.base #:mdw.sys-base #:optparse #:net #:zone + #+(or cmu clisp) #:mop + #+sbcl #:sb-mop) (:export #:main)) (in-package #:zone.frontend) (defvar opt-zones nil "Which zones to be emitted.") +(defvar opt-format :bind + "Which format to use on output.") +(defvar opt-debug nil + "Whether to emit stack backtraces on error.") + +(defun directory-exists-p (name) + + ;; Make a pathname for NAME which has the right form for a directory. + (let ((dirpath + (let ((path (pathname name))) + (if (null (pathname-name path)) + path + (make-pathname :directory + (append (or (pathname-directory path) + (list :relative)) + (list (pathname-name path))) + :name nil + :type nil + :defaults path))))) + + ;; Now check that it exists. + #+clisp (and (ext:probe-directory dirpath) (truename dirpath)) + #-clisp (probe-file dirpath))) + +(eval-when (:compile-toplevel :load-toplevel) + (defopthandler dir (var arg) () + (let ((path (directory-exists-p arg))) + (if (and path + (not (pathname-name path))) + (setf var path) + (option-parse-error "path `~A' doesn't name a directory." arg)))) + (let ((duration-units (make-hash-table :test #'equal))) + (dolist (item '((("Gs") #.(* 1000 1000 1000)) + (("Ms") #.(* 1000 1000)) + (("ks") 1000) + (("hs") 100) + (("das") 10) + (("yr" "year" "years" "y") #.(* 365 24 60 60)) + (("wk" "week" "weeks" "w") #.(* 7 24 60 60)) + (("day" "days" "dy" "d") #.(* 24 60 60)) + (("hr" "hour" "hours" "h") #.(* 60 60)) + (("min" "minute" "minutes" "m") 60) + (("s" "second" "seconds" "sec" "") 1))) + (dolist (name (car item)) + (setf (gethash name duration-units) (cadr item)))) + (defopthandler dur (var arg) () + (let ((len (length arg))) + (multiple-value-bind (n i) (parse-integer arg :junk-allowed t) + (unless n + (option-parse-error "invalid duration `~A': ~ + integer expected" arg)) + (loop (cond ((or (>= i len) + (not (whitespace-char-p (char arg i)))) + (return)) + (t + (incf i)))) + (let ((u0 i)) + (loop (cond ((or (>= i len) + (whitespace-char-p (char arg i))) + (return)) + (t + (incf i)))) + (let* ((u1 i) + (unit (subseq arg u0 u1)) + (scale (gethash unit duration-units))) + (unless scale + (option-parse-error "invalid duration `~A': ~ + unknown unit `~A'" + arg unit)) + (setf var (* n scale))))))))) (define-program :version "1.0.0" :usage "ZONEDEF..." :help "Generates BIND zone files from Lisp descriptions." - :options (options help-opts + :options (options help-options + "Parsing options" + (#\f "feature" (:arg "KEYWORD") + (list *features* 'keyword) + "Insert KEYWORD in *features* list.") + (#\s "subnet" (:arg "NET") + (list zone:*preferred-subnets*) + "Designate NET as a preferred subnet.") + (#\D "debug" (set opt-debug) + "Produce stack backtrace on error.") + "Timeout options" + (#\E "expire" (:arg "DURATION") + (dur *default-zone-expire*) + "Set default zone expiry period.") + (#\N "min-ttl" (:arg "DURATION") + (dur *default-zone-min-ttl*) + "Set default zone minimum/negative time-to-live.") + (#\R "refresh" (:arg "DURATION") + (dur *default-zone-refresh*) + "Set default zone refresh period.") + (#\T "ttl" (:arg "DURATION") + (dur *default-zone-ttl*) + "Set default zone time-to-live.") + (#\Y "retry" (:arg "DURATION") + (dur *default-zone-retry*) + "Set default zone retry period.") "Output options" + (#\d "directory" (:arg "DIRECTORY") + (dir *zone-output-path*) + "Write zone and serial files to DIRECTORY.") + (#\F "format" (:arg "FORMAT") + (keyword opt-format + (delete-duplicates + (loop for method in + (append + (generic-function-methods + #'zone:zone-write) + (generic-function-methods + #'zone:zone-write-header)) + for specs = + (method-specializers method) + if (typep (car specs) + 'eql-specializer) + collect + (eql-specializer-object + (car specs))))) + "Format to use for output.") (#\z "zone" (:arg "NAME") (list opt-zones) "Write information about zone NAME."))) (defun main () - (with-unix-error-reporting () - (let ((seq 54) - (files nil)) - (unless (option-parse-try - (do-options () - (nil (rest) - (when (zerop (length rest)) - (option-parse-error "no files to read")) - (setf files rest)))) - (die-usage)) - (dolist (f files) - (let ((*package* (make-package (format nil "zone.scratch-~A" - (incf seq)) - :use '(#:common-lisp #:net #:zone)))) - (load f :verbose nil :print nil :if-does-not-exist :error))) - (zone-save opt-zones)))) + (set-command-line-arguments) + (let ((files nil)) + (flet ((run () + (dolist (f files) + (let ((*package* (make-package "ZONE.SCRATCH" + :use '(#:common-lisp + #:net #:zone)))) + (progv *zone-config* (mapcar #'symbol-value *zone-config*) + (load f :verbose nil :print nil :if-does-not-exist :error) + (delete-package *package*)))) + (zone-save opt-zones :format opt-format) + t)) + (with-unix-error-reporting () + (unless (option-parse-try + (do-options () + (nil (rest) + (when (zerop (length rest)) + (option-parse-error "no files to read")) + (setf files rest)))) + (die-usage))) + (if opt-debug + (run) + (with-unix-error-reporting () (run))) + t))) ;;;----- That's all, folks --------------------------------------------------