;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-(cl:defpackage #:net-sys
- (:use #:common-lisp)
- (:export #:gethostname #:resolve-hostname #:canonify-hostname))
-(cl:in-package #:net-sys)
+(cl:in-package #:net)
;;;--------------------------------------------------------------------------
;;; Functions provided.
(name :pointer)
(len :uint))
+(export 'gethostname)
(defun gethostname ()
"Return the hostname (not necessarily canonical) of the current host."
(sb-unix:unix-gethostname)
#+clisp
- (unix:get-host-name)
+ (os:uname-nodename (os:uname))
#+ecl
(cffi:with-foreign-pointer-as-string (buffer 256 len)
#-(or cmu sbcl clisp ecl)
"<unknown-host>")
+(export 'resolve-hostname)
(defun resolve-hostname (name)
"Resolve a hostname to an IP address using the DNS, or return nil."
#-(or cmu sbcl clisp ecl)
nil)
+(export 'canonify-hostname)
(defun canonify-hostname (name)
"Resolve a hostname to canonical form using the DNS, or return nil."
#-(or cmu sbcl clisp ecl)
name)
+(export 'fresh-file-name)
+(defun fresh-file-name (template)
+ "Return the pathname of a fresh (newly created) file.
+
+ The TEMPLATE explains where to put the file; the name portion of the
+ TEMPLATE will have a suffix appended to it to ensure freshness."
+ (let* ((pathname (pathname template))
+ (base (pathname-name pathname)))
+ (loop
+ (let ((try (make-pathname :name (format nil "~A-~6,'0D"
+ base (random 1000000))
+ :defaults pathname)))
+ (with-open-file (stream try
+ :direction :output
+ :if-exists nil
+ :if-does-not-exist :create)
+ (when stream
+ (close stream)
+ (return try)))))))
+
+(export '(temporary-file-context-p
+ make-temporary-file-context
+ temporary-file-context-active-p))
+(defstruct (temporary-file-context
+ (:constructor make-temporary-file-context
+ (%base
+ &aux
+ (base (if %base
+ (merge-pathnames %base)
+ *default-pathname-defaults*)))))
+ "Keeps track of a collection of temporary files."
+ (active-p t :type boolean)
+ (base *default-pathname-defaults* :type pathname)
+ (temporaries nil :type list))
+
+(export 'temporary-file)
+(defun temporary-file (context template)
+ "Create a new temporary file, and return its name.
+
+ The new file is associated with a CONTEXT (as created by
+ `make-temporary-file-context'), and will be removed when
+ `clear-temporary-files' is called on the context."
+ (unless (temporary-file-context-active-p context)
+ (error "Temporary function context has expired"))
+ (let ((temp (fresh-file-name
+ (merge-pathnames template
+ (temporary-file-context-base context)))))
+ (push temp (temporary-file-context-temporaries context))
+ temp))
+
+(export 'clear-temporary-files)
+(defun clear-temporary-files (context)
+ "Removes the temporary files associated with CONTEXT.
+
+ The context becomes inactive, and an error is signalled if an attempt is
+ made to associate more files with it."
+ (mapc #'delete-file (temporary-file-context-temporaries context))
+ (setf (temporary-file-context-active-p context) nil))
+
+(defun with-temporary-files* (thunk &optional base)
+ "The innards of `with-temporary-files'.
+
+ Invoke THUNK with a temporary-files context as its argument, returning
+ whatever values it returns. When THUNK terminates, remove the files in
+ the context."
+ (let ((context (make-temporary-file-context base)))
+ (unwind-protect (funcall thunk context)
+ (clear-temporary-files context))))
+
+(export 'with-temporary-files)
+(defmacro with-temporary-files
+ ((context &key (base '*default-pathname-defaults*)) &body body)
+ "Evaluate BODY within a temporary-files context.
+
+ Bind the new context to CONTEXT, and evaluate the BODY; when BODY
+ terminates (normally or otherwise), delete the files. See
+ `temporary-file'."
+ `(with-temporary-files* (lambda (,context) ,@body) ,base))
+
+(export 'run-program)
+(defun run-program (command &key input output)
+ "Run a COMMAND, specified as a list of arguments.
+
+ The INPUT and OUTPUT may be `nil' (no input, discard output), or
+ pathnames or namestrings. Signals an error if the command fails."
+
+ #+ sbcl
+ (let ((proc (sb-ext:run-program (car command) (cdr command)
+ :wait t :search t
+ :input input :output output :error t
+ :if-input-does-not-exist :error
+ :if-output-exists :supersede)))
+ (unless (and (eq (sb-ext:process-status proc) :exited)
+ (zerop (sb-ext:process-exit-code proc)))
+ (error "Failed to run command `~{~A~^ ~}': ~S ~S" command
+ (sb-ext:process-status proc) (sb-ext:process-exit-code proc))))
+
+ #+ clisp
+ (let ((rc (ext:run-program (car command) :arguments (cdr command)
+ :input input :output output
+ :if-output-exists :overwrite)))
+ (when rc
+ (error "Failed to run command `~{~A~^ ~}': status ~S" command rc))))
+
;;;----- That's all, folks --------------------------------------------------
~mdw / zone / blobdiff