| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; System-specific functions |
| 4 | ;;; |
| 5 | ;;; (c) 2008 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This program is free software; you can redistribute it and/or modify |
| 11 | ;;; it under the terms of the GNU General Public License as published by |
| 12 | ;;; the Free Software Foundation; either version 2 of the License, or |
| 13 | ;;; (at your option) any later version. |
| 14 | ;;; |
| 15 | ;;; This program is distributed in the hope that it will be useful, |
| 16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 18 | ;;; GNU General Public License for more details. |
| 19 | ;;; |
| 20 | ;;; You should have received a copy of the GNU General Public License |
| 21 | ;;; along with this program; if not, write to the Free Software Foundation, |
| 22 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
| 23 | |
| 24 | (cl:defpackage #:net-sys |
| 25 | (:use #:common-lisp) |
| 26 | (:export #:gethostname #:resolve-hostname #:canonify-hostname)) |
| 27 | (cl:in-package #:net-sys) |
| 28 | |
| 29 | ;;;-------------------------------------------------------------------------- |
| 30 | ;;; Functions provided. |
| 31 | |
| 32 | #+ecl |
| 33 | (cffi:defcfun gethostname :int |
| 34 | (name :pointer) |
| 35 | (len :uint)) |
| 36 | |
| 37 | (defun gethostname () |
| 38 | "Return the hostname (not necessarily canonical) of the current host." |
| 39 | |
| 40 | #+cmu |
| 41 | (unix:unix-gethostname) |
| 42 | |
| 43 | #+sbcl |
| 44 | (sb-unix:unix-gethostname) |
| 45 | |
| 46 | #+clisp |
| 47 | (unix:get-host-name) |
| 48 | |
| 49 | #+ecl |
| 50 | (cffi:with-foreign-pointer-as-string (buffer 256 len) |
| 51 | (let ((rc (gethostname buffer len))) |
| 52 | (unless (zerop rc) |
| 53 | (error "gethostname(2) failed (rc = ~A)." rc)))) |
| 54 | |
| 55 | #-(or cmu sbcl clisp ecl) |
| 56 | "<unknown-host>") |
| 57 | |
| 58 | (defun resolve-hostname (name) |
| 59 | "Resolve a hostname to an IP address using the DNS, or return nil." |
| 60 | |
| 61 | #+cmu |
| 62 | (let ((he (ext:lookup-host-entry name))) |
| 63 | (and he (ext:host-entry-addr he))) |
| 64 | |
| 65 | #+sbcl |
| 66 | (handler-case |
| 67 | (let* ((he (sb-bsd-sockets:get-host-by-name name)) |
| 68 | (addr (sb-bsd-sockets:host-ent-address he))) |
| 69 | (reduce (lambda (acc byte) (logior (ash acc 8) byte)) addr)) |
| 70 | (sb-bsd-sockets:name-service-error () nil)) |
| 71 | |
| 72 | #+clisp |
| 73 | (let ((he (ext:resolve-host-ipaddr name))) |
| 74 | (and he (string-ipaddr (car (ext:hostent-addr-list he))))) |
| 75 | |
| 76 | #+ecl |
| 77 | (nth-value 2 (ext:lookup-host-entry name)) |
| 78 | |
| 79 | #-(or cmu sbcl clisp ecl) |
| 80 | nil) |
| 81 | |
| 82 | (defun canonify-hostname (name) |
| 83 | "Resolve a hostname to canonical form using the DNS, or return nil." |
| 84 | |
| 85 | #+cmu |
| 86 | (let ((he (ext:lookup-host-entry name))) |
| 87 | (and he (ext:host-entry-name he))) |
| 88 | |
| 89 | #+sbcl |
| 90 | (handler-case |
| 91 | (let ((he (sb-bsd-sockets:get-host-by-name name))) |
| 92 | (sb-bsd-sockets:host-ent-name he)) |
| 93 | (sb-bsd-sockets:name-service-error () nil)) |
| 94 | |
| 95 | #+clisp |
| 96 | (let ((he (ext:resolve-host-ipaddr name))) |
| 97 | (and he (ext:hostent-name he))) |
| 98 | |
| 99 | #+ecl |
| 100 | (nth-value 0 (ext:lookup-host-entry name)) |
| 101 | |
| 102 | #-(or cmu sbcl clisp ecl) |
| 103 | name) |
| 104 | |
| 105 | ;;;----- That's all, folks -------------------------------------------------- |