sys.lisp: New tools for making temporary files.

[zone] / sys.lisp

;;; -*-lisp-*-
;;;
;;; System-specific functions
;;;
;;; (c) 2008 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:net)

;;;--------------------------------------------------------------------------
;;; Functions provided.

#+ecl
(cffi:defcfun gethostname :int
  (name :pointer)
  (len :uint))

(export 'gethostname)
(defun gethostname ()
  "Return the hostname (not necessarily canonical) of the current host."

  #+cmu
  (unix:unix-gethostname)

  #+sbcl
  (sb-unix:unix-gethostname)

  #+clisp
  (os:uname-nodename (os:uname))

  #+ecl
  (cffi:with-foreign-pointer-as-string (buffer 256 len)
    (let ((rc (gethostname buffer len)))
      (unless (zerop rc)
	(error "gethostname(2) failed (rc = ~A)." rc))))

  #-(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."

  #+cmu
  (let ((he (ext:lookup-host-entry name)))
    (and he (ext:host-entry-addr he)))

  #+sbcl
  (handler-case
      (let* ((he (sb-bsd-sockets:get-host-by-name name))
	     (addr (sb-bsd-sockets:host-ent-address he)))
	(reduce (lambda (acc byte) (logior (ash acc 8) byte)) addr))
    (sb-bsd-sockets:name-service-error () nil))

  #+clisp
  (let ((he (ext:resolve-host-ipaddr name)))
    (and he (string-ipaddr (car (ext:hostent-addr-list he)))))

  #+ecl
  (nth-value 2 (ext:lookup-host-entry name))

  #-(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."

  #+cmu
  (let ((he (ext:lookup-host-entry name)))
    (and he (ext:host-entry-name he)))

  #+sbcl
  (handler-case
      (let ((he (sb-bsd-sockets:get-host-by-name name)))
	(sb-bsd-sockets:host-ent-name he))
    (sb-bsd-sockets:name-service-error () nil))

  #+clisp
  (let ((he (ext:resolve-host-ipaddr name)))
    (and he (ext:hostent-name he)))

  #+ecl
  (nth-value 0 (ext:lookup-host-entry name))

  #-(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))

;;;----- That's all, folks --------------------------------------------------