Commit | Line | Data |
---|---|---|
8e7c1366 MW |
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 | ||
e1528fd6 | 24 | (cl:in-package #:net) |
8e7c1366 MW |
25 | |
26 | ;;;-------------------------------------------------------------------------- | |
27 | ;;; Functions provided. | |
28 | ||
29 | #+ecl | |
30 | (cffi:defcfun gethostname :int | |
31 | (name :pointer) | |
32 | (len :uint)) | |
33 | ||
e1528fd6 | 34 | (export 'gethostname) |
8e7c1366 MW |
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 | |
9b01dd96 | 45 | (os:uname-nodename (os:uname)) |
8e7c1366 MW |
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 | ||
e1528fd6 | 56 | (export 'resolve-hostname) |
8e7c1366 MW |
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 | ||
e1528fd6 | 81 | (export 'canonify-hostname) |
8e7c1366 MW |
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 | ||
aaacbd24 MW |
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 | ||
5020fdad MW |
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 | ||
8e7c1366 | 209 | ;;;----- That's all, folks -------------------------------------------------- |