chiark - git - mdw - zone/blob - sys.lisp

   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 --------------------------------------------------