Upgrade everything for SBCL.

[zone] / sys.lisp

diff --git a/sys.lisp b/sys.lisp
new file mode 100644 (file)
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)
+  "<unknown-host>")
+
+(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 --------------------------------------------------