frontend.lisp: Hack around CLisp's bizarreness.

[zone] / sys.lisp

;;; -*-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 --------------------------------------------------