3 ;;; System-specific functions
5 ;;; (c) 2008 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
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.
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.
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.
26 ;;;--------------------------------------------------------------------------
27 ;;; Functions provided.
30 (cffi:defcfun gethostname :int
36 "Return the hostname (not necessarily canonical) of the current host."
39 (unix:unix-gethostname)
42 (sb-unix:unix-gethostname)
45 (os:uname-nodename (os:uname))
48 (cffi:with-foreign-pointer-as-string (buffer 256 len)
49 (let ((rc (gethostname buffer len)))
51 (error "gethostname(2) failed (rc = ~A)." rc))))
53 #-(or cmu sbcl clisp ecl)
56 (export 'resolve-hostname)
57 (defun resolve-hostname (name)
58 "Resolve a hostname to an IP address using the DNS, or return nil."
61 (let ((he (ext:lookup-host-entry name)))
62 (and he (ext:host-entry-addr he)))
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))
72 (let ((he (ext:resolve-host-ipaddr name)))
73 (and he (string-ipaddr (car (ext:hostent-addr-list he)))))
76 (nth-value 2 (ext:lookup-host-entry name))
78 #-(or cmu sbcl clisp ecl)
81 (export 'canonify-hostname)
82 (defun canonify-hostname (name)
83 "Resolve a hostname to canonical form using the DNS, or return nil."
86 (let ((he (ext:lookup-host-entry name)))
87 (and he (ext:host-entry-name he)))
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))
96 (let ((he (ext:resolve-host-ipaddr name)))
97 (and he (ext:hostent-name he)))
100 (nth-value 0 (ext:lookup-host-entry name))
102 #-(or cmu sbcl clisp ecl)
105 (export 'fresh-file-name)
106 (defun fresh-file-name (template)
107 "Return the pathname of a fresh (newly created) file.
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)))
114 (let ((try (make-pathname :name (format nil "~A-~6,'0D"
115 base (random 1000000))
116 :defaults pathname)))
117 (with-open-file (stream try
120 :if-does-not-exist :create)
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
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))
140 (export 'temporary-file)
141 (defun temporary-file (context template)
142 "Create a new temporary file, and return its name.
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))
155 (export 'clear-temporary-files)
156 (defun clear-temporary-files (context)
157 "Removes the temporary files associated with CONTEXT.
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))
164 (defun with-temporary-files* (thunk &optional base)
165 "The innards of `with-temporary-files'.
167 Invoke THUNK with a temporary-files context as its argument, returning
168 whatever values it returns. When THUNK terminates, remove the files in
170 (let ((context (make-temporary-file-context base)))
171 (unwind-protect (funcall thunk context)
172 (clear-temporary-files context))))
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.
179 Bind the new context to CONTEXT, and evaluate the BODY; when BODY
180 terminates (normally or otherwise), delete the files. See
182 `(with-temporary-files* (lambda (,context) ,@body) ,base))
184 ;;;----- That's all, folks --------------------------------------------------