| 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:in-package #:net) |
| 25 | |
| 26 | ;;;-------------------------------------------------------------------------- |
| 27 | ;;; Functions provided. |
| 28 | |
| 29 | #+ecl |
| 30 | (cffi:defcfun gethostname :int |
| 31 | (name :pointer) |
| 32 | (len :uint)) |
| 33 | |
| 34 | (export 'gethostname) |
| 35 | (defun gethostname () |
| 36 | "Return the hostname (not necessarily canonical) of the current host." |
| 37 | |
| 38 | #+cmu |
| 39 | (unix:unix-gethostname) |
| 40 | |
| 41 | #+sbcl |
| 42 | (sb-unix:unix-gethostname) |
| 43 | |
| 44 | #+clisp |
| 45 | (os:uname-nodename (os:uname)) |
| 46 | |
| 47 | #+ecl |
| 48 | (cffi:with-foreign-pointer-as-string (buffer 256 len) |
| 49 | (let ((rc (gethostname buffer len))) |
| 50 | (unless (zerop rc) |
| 51 | (error "gethostname(2) failed (rc = ~A)." rc)))) |
| 52 | |
| 53 | #-(or cmu sbcl clisp ecl) |
| 54 | "<unknown-host>") |
| 55 | |
| 56 | (export 'resolve-hostname) |
| 57 | (defun resolve-hostname (name) |
| 58 | "Resolve a hostname to an IP address using the DNS, or return nil." |
| 59 | |
| 60 | #+cmu |
| 61 | (let ((he (ext:lookup-host-entry name))) |
| 62 | (and he (ext:host-entry-addr he))) |
| 63 | |
| 64 | #+sbcl |
| 65 | (handler-case |
| 66 | (let* ((he (sb-bsd-sockets:get-host-by-name name)) |
| 67 | (addr (sb-bsd-sockets:host-ent-address he))) |
| 68 | (reduce (lambda (acc byte) (logior (ash acc 8) byte)) addr)) |
| 69 | (sb-bsd-sockets:name-service-error () nil)) |
| 70 | |
| 71 | #+clisp |
| 72 | (let ((he (ext:resolve-host-ipaddr name))) |
| 73 | (and he (string-ipaddr (car (ext:hostent-addr-list he))))) |
| 74 | |
| 75 | #+ecl |
| 76 | (nth-value 2 (ext:lookup-host-entry name)) |
| 77 | |
| 78 | #-(or cmu sbcl clisp ecl) |
| 79 | nil) |
| 80 | |
| 81 | (export 'canonify-hostname) |
| 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 -------------------------------------------------- |