From 8e7c1366598806dff2b2e4fb2016efb5a78f42ec Mon Sep 17 00:00:00 2001 Message-Id: <8e7c1366598806dff2b2e4fb2016efb5a78f42ec.1714108640.git.mdw@distorted.org.uk> From: Mark Wooding Date: Mon, 31 Mar 2008 00:17:39 +0100 Subject: [PATCH] Upgrade everything for SBCL. Organization: Straylight/Edgeware From: Mark Wooding While we're at it, isolate the system-specific stuff to its own sin-bin for easier porting to other systems. --- .gitignore | 1 + frontend.lisp | 14 +++---- net.lisp | 25 +----------- sys.lisp | 105 ++++++++++++++++++++++++++++++++++++++++++++++++++ zone.asd | 5 ++- zone.lisp | 16 +------- 6 files changed, 119 insertions(+), 47 deletions(-) create mode 100644 sys.lisp diff --git a/.gitignore b/.gitignore index b94a63c..2335672 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ *.x86f *.fas *.lib +*.fasl diff --git a/frontend.lisp b/frontend.lisp index 46c5a36..1ff3e2f 100644 --- a/frontend.lisp +++ b/frontend.lisp @@ -1,7 +1,5 @@ ;;; -*-lisp-*- ;;; -;;; $Id$ -;;; ;;; Zone generator frontend ;;; ;;; (c) 2005 Straylight/Edgeware @@ -24,7 +22,9 @@ ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (defpackage #:zone.frontend - (:use #:common-lisp #:optparse #:net #:zone) + (:use #:common-lisp #:optparse #:net #:zone + #+cmu #:mop + #+sbcl #:sb-mop) (:export #:main)) (in-package #:zone.frontend) @@ -60,14 +60,14 @@ (define-program (keyword opt-format (delete-duplicates (loop for method in - (pcl:generic-function-methods + (generic-function-methods #'zone:zone-write) for specs = - (pcl:method-specializers method) + (method-specializers method) if (typep (car specs) - 'pcl:eql-specializer) + 'eql-specializer) collect - (pcl:eql-specializer-object + (eql-specializer-object (car specs))))) "Format to use for output.") (#\z "zone" (:arg "NAME") (list opt-zones) diff --git a/net.lisp b/net.lisp index 28f10ef..751ecfd 100644 --- a/net.lisp +++ b/net.lisp @@ -1,7 +1,5 @@ ;;; -*-lisp-*- ;;; -;;; $Id$ -;;; ;;; Network (numbering) tools ;;; ;;; (c) 2006 Straylight/Edgeware @@ -27,7 +25,7 @@ ;;; Packaging. (defpackage #:net - (:use #:common-lisp #:mdw.base #:mdw.str #:collect) + (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:net-sys) (:export #:ipaddr #:string-ipaddr #:ipaddr-byte #:ipaddr-string #:ipaddrp #:integer-netmask #:ipmask #:ipmask-cidl-slash #:make-ipnet #:string-ipnet #:ipnet #:ipnet-net #:ipnet-mask #:with-ipnet @@ -252,27 +250,6 @@ (defun ipnet-changeable-bytes (mask) (when (/= (ipaddr-byte mask i) 255) (return (- 4 i))))) -;;;-------------------------------------------------------------------------- -;;; Name resolution. - -(defun resolve-hostname (name) - "Resolve a hostname to an IP address using the DNS, or return nil." - #+cmu (let ((he (ext:lookup-host-entry name))) - (and he (ext:host-entry-addr he))) - #+clisp (let ((he (ext:resolve-host-ipaddr name))) - (and he (string-ipaddr (car (ext:hostent-addr-list he))))) - #+ecl (nth-value 2 (ext:lookup-host-entry name)) - #-(or cmu clisp ecl) nil) - -(defun canonify-hostname (name) - "Resolve a hostname to canonical form using the DNS, or return nil." - #+cmu (let ((he (ext:lookup-host-entry name))) - (and he (ext:host-entry-name he))) - #+clisp (let ((he (ext:resolve-host-ipaddr name))) - (and he (ext:hostent-name he))) - #+ecl (nth-value 0 (ext:lookup-host-entry name)) - #-(or cmu clisp ecl) name) - ;;;-------------------------------------------------------------------------- ;;; Host names and specifiers. diff --git a/sys.lisp b/sys.lisp new file mode 100644 index 0000000..fc7180e --- /dev/null +++ b/sys.lisp @@ -0,0 +1,105 @@ +;;; -*-lisp-*- +;;; +;;; System-specific functions +;;; +;;; (c) 2008 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; 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. + +(cl:defpackage #:net-sys + (:use #:common-lisp) + (:export #:gethostname #:resolve-hostname #:canonify-hostname)) +(cl:in-package #:net-sys) + +;;;-------------------------------------------------------------------------- +;;; Functions provided. + +#+ecl +(cffi:defcfun gethostname :int + (name :pointer) + (len :uint)) + +(defun gethostname () + "Return the hostname (not necessarily canonical) of the current host." + + #+cmu + (unix:unix-gethostname) + + #+sbcl + (sb-unix:unix-gethostname) + + #+clisp + (unix:get-host-name) + + #+ecl + (cffi:with-foreign-pointer-as-string (buffer 256 len) + (let ((rc (gethostname buffer len))) + (unless (zerop rc) + (error "gethostname(2) failed (rc = ~A)." rc)))) + + #-(or cmu sbcl clisp ecl) + "") + +(defun resolve-hostname (name) + "Resolve a hostname to an IP address using the DNS, or return nil." + + #+cmu + (let ((he (ext:lookup-host-entry name))) + (and he (ext:host-entry-addr he))) + + #+sbcl + (handler-case + (let* ((he (sb-bsd-sockets:get-host-by-name name)) + (addr (sb-bsd-sockets:host-ent-address he))) + (reduce (lambda (acc byte) (logior (ash acc 8) byte)) addr)) + (sb-bsd-sockets:name-service-error () nil)) + + #+clisp + (let ((he (ext:resolve-host-ipaddr name))) + (and he (string-ipaddr (car (ext:hostent-addr-list he))))) + + #+ecl + (nth-value 2 (ext:lookup-host-entry name)) + + #-(or cmu sbcl clisp ecl) + nil) + +(defun canonify-hostname (name) + "Resolve a hostname to canonical form using the DNS, or return nil." + + #+cmu + (let ((he (ext:lookup-host-entry name))) + (and he (ext:host-entry-name he))) + + #+sbcl + (handler-case + (let ((he (sb-bsd-sockets:get-host-by-name name))) + (sb-bsd-sockets:host-ent-name he)) + (sb-bsd-sockets:name-service-error () nil)) + + #+clisp + (let ((he (ext:resolve-host-ipaddr name))) + (and he (ext:hostent-name he))) + + #+ecl + (nth-value 0 (ext:lookup-host-entry name)) + + #-(or cmu sbcl clisp ecl) + name) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/zone.asd b/zone.asd index e16cef7..8d44774 100644 --- a/zone.asd +++ b/zone.asd @@ -4,8 +4,9 @@ :description "Generation of DNS zone files" :version "1.0.0" :author "Mark Wooding " - :depends-on ("mdw" #+ecl "cffi") - :components ((:file "net") + :depends-on ("mdw" #+ecl "cffi" #+sbcl "sb-bsd-sockets") + :components ((:file "sys") + (:file "net") (:file "serv") (:file "zone") (:file "frontend")) diff --git a/zone.lisp b/zone.lisp index ea9fda3..8dc3df0 100644 --- a/zone.lisp +++ b/zone.lisp @@ -1,7 +1,5 @@ ;;; -*-lisp-*- ;;; -;;; $Id$ -;;; ;;; DNS zone generation ;;; ;;; (c) 2005 Straylight/Edgeware @@ -29,7 +27,7 @@ (defpackage #:zone (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:safely - #:net #:services) + #:net #:net-sys #:services) (:export #:soa #:mx #:zone #:zone-record #:zone-subdomain #:*default-zone-source* #:*default-zone-refresh* #:*default-zone-retry* #:*default-zone-expire* @@ -151,18 +149,8 @@ (defstruct (zone (:predicate zonep)) ;;;-------------------------------------------------------------------------- ;;; Zone defaults. It is intended that scripts override these. -#+ecl -(cffi:defcfun gethostname :int - (name :pointer) - (len :uint)) - (defvar *default-zone-source* - (let ((hn #+cmu (unix:unix-gethostname) - #+clisp (unix:get-host-name) - #+ecl (cffi:with-foreign-pointer-as-string (buffer 256 len) - (let ((rc (gethostname buffer len))) - (unless (zerop rc) - (error "gethostname(2) failed (rc = ~A)." rc)))))) + (let ((hn (gethostname))) (and hn (concatenate 'string (canonify-hostname hn) "."))) "The default zone source: the current host's name.") -- [mdw]