| 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 | (export 'fresh-file-name) |
| 106 | (defun fresh-file-name (template) |
| 107 | "Return the pathname of a fresh (newly created) file. |
| 108 | |
| 109 | The TEMPLATE explains where to put the file; the name portion of the |
| 110 | TEMPLATE will have a suffix appended to it to ensure freshness." |
| 111 | (let* ((pathname (pathname template)) |
| 112 | (base (pathname-name pathname))) |
| 113 | (loop |
| 114 | (let ((try (make-pathname :name (format nil "~A-~6,'0D" |
| 115 | base (random 1000000)) |
| 116 | :defaults pathname))) |
| 117 | (with-open-file (stream try |
| 118 | :direction :output |
| 119 | :if-exists nil |
| 120 | :if-does-not-exist :create) |
| 121 | (when stream |
| 122 | (close stream) |
| 123 | (return try))))))) |
| 124 | |
| 125 | (export '(temporary-file-context-p |
| 126 | make-temporary-file-context |
| 127 | temporary-file-context-active-p)) |
| 128 | (defstruct (temporary-file-context |
| 129 | (:constructor make-temporary-file-context |
| 130 | (%base |
| 131 | &aux |
| 132 | (base (if %base |
| 133 | (merge-pathnames %base) |
| 134 | *default-pathname-defaults*))))) |
| 135 | "Keeps track of a collection of temporary files." |
| 136 | (active-p t :type boolean) |
| 137 | (base *default-pathname-defaults* :type pathname) |
| 138 | (temporaries nil :type list)) |
| 139 | |
| 140 | (export 'temporary-file) |
| 141 | (defun temporary-file (context template) |
| 142 | "Create a new temporary file, and return its name. |
| 143 | |
| 144 | The new file is associated with a CONTEXT (as created by |
| 145 | `make-temporary-file-context'), and will be removed when |
| 146 | `clear-temporary-files' is called on the context." |
| 147 | (unless (temporary-file-context-active-p context) |
| 148 | (error "Temporary function context has expired")) |
| 149 | (let ((temp (fresh-file-name |
| 150 | (merge-pathnames template |
| 151 | (temporary-file-context-base context))))) |
| 152 | (push temp (temporary-file-context-temporaries context)) |
| 153 | temp)) |
| 154 | |
| 155 | (export 'clear-temporary-files) |
| 156 | (defun clear-temporary-files (context) |
| 157 | "Removes the temporary files associated with CONTEXT. |
| 158 | |
| 159 | The context becomes inactive, and an error is signalled if an attempt is |
| 160 | made to associate more files with it." |
| 161 | (mapc #'delete-file (temporary-file-context-temporaries context)) |
| 162 | (setf (temporary-file-context-active-p context) nil)) |
| 163 | |
| 164 | (defun with-temporary-files* (thunk &optional base) |
| 165 | "The innards of `with-temporary-files'. |
| 166 | |
| 167 | Invoke THUNK with a temporary-files context as its argument, returning |
| 168 | whatever values it returns. When THUNK terminates, remove the files in |
| 169 | the context." |
| 170 | (let ((context (make-temporary-file-context base))) |
| 171 | (unwind-protect (funcall thunk context) |
| 172 | (clear-temporary-files context)))) |
| 173 | |
| 174 | (export 'with-temporary-files) |
| 175 | (defmacro with-temporary-files |
| 176 | ((context &key (base '*default-pathname-defaults*)) &body body) |
| 177 | "Evaluate BODY within a temporary-files context. |
| 178 | |
| 179 | Bind the new context to CONTEXT, and evaluate the BODY; when BODY |
| 180 | terminates (normally or otherwise), delete the files. See |
| 181 | `temporary-file'." |
| 182 | `(with-temporary-files* (lambda (,context) ,@body) ,base)) |
| 183 | |
| 184 | (export 'run-program) |
| 185 | (defun run-program (command &key input output) |
| 186 | "Run a COMMAND, specified as a list of arguments. |
| 187 | |
| 188 | The INPUT and OUTPUT may be `nil' (no input, discard output), or |
| 189 | pathnames or namestrings. Signals an error if the command fails." |
| 190 | |
| 191 | #+ sbcl |
| 192 | (let ((proc (sb-ext:run-program (car command) (cdr command) |
| 193 | :wait t :search t |
| 194 | :input input :output output :error t |
| 195 | :if-input-does-not-exist :error |
| 196 | :if-output-exists :supersede))) |
| 197 | (unless (and (eq (sb-ext:process-status proc) :exited) |
| 198 | (zerop (sb-ext:process-exit-code proc))) |
| 199 | (error "Failed to run command `~{~A~^ ~}': ~S ~S" command |
| 200 | (sb-ext:process-status proc) (sb-ext:process-exit-code proc)))) |
| 201 | |
| 202 | #+ clisp |
| 203 | (let ((rc (ext:run-program (car command) :arguments (cdr command) |
| 204 | :input input :output output |
| 205 | :if-output-exists :overwrite))) |
| 206 | (when rc |
| 207 | (error "Failed to run command `~{~A~^ ~}': status ~S" command rc)))) |
| 208 | |
| 209 | ;;;----- That's all, folks -------------------------------------------------- |