base: compile-time-defun should define in the interpreter.

[lisp] / unix.lisp

;;; -*-lisp-*-
;;;
;;; $Id$
;;;
;;; Unix system call stuff
;;;
;;; (c) 2005 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.

(defpackage #:mdw.unix
  (:use #:common-lisp #:mdw.base #:collect)
  (:export #:unix-error #:errno-value #:with-errno-handlers
	   #:syscall #:syscall*
	   #:stat #:sys-stat
	   #:sys-open #:sys-close #:sys-read #:sys-write
	   #:sys-chown #:sys-fchown #:sys-chmod #:sys-fchmod
	   #:sys-utimes #:sys-unlink #:sys-rename
	   #:sys-gettimeofday #:sys-gethostname
	   #:with-unix-open #:copy-file))
(in-package #:mdw.unix)

(defmacro with-buffer ((var len) &body body)
  "Evaluate BODY with VAR bound to a pointer (a SAP, if you must know) to a
   buffer of LEN bytes."
  (with-gensyms lenvar
    `(let ((,lenvar ,len)
	   (,var nil))
       (unwind-protect
	   (progn 
	     (setf ,var (system:allocate-system-memory ,lenvar))
	     ,@body)
	 (when ,var (system:deallocate-system-memory ,var ,lenvar))))))

(define-condition unix-error (error)
  ((func :initform 'unknown :initarg :func :reader unix-error-func)
   (args :initform nil :initarg :args :reader unix-error-args)
   (errno :initform 0 :initarg :errno :reader unix-error-errno))
  (:report (lambda (c s)
	     (format s "Error from ~A: ~A (~D)"
		     (cons (unix-error-func c) (unix-error-args c))
		     (unix:get-unix-error-msg (unix-error-errno c))
		     (unix-error-errno c))))
  (:documentation "Reports an error from a Unix system call."))

(compile-time-defun errno-value (err)
    "Returns the numeric value corresponding to an errno name."
    (etypecase err
      (integer err)
      (symbol (symbol-value (intern (symbol-name err) :unix)))))

(defmacro with-errno-handlers ((&key cond
				     (errno (gensym))
				     errstring)
			       form &rest clauses)
  "Evaluate FORM but trap Unix errors according to CLAUSES.  Each clause has
   the form of a `case' clause, but may contain symbolic errno names as well
   as numbers."
  (flet ((fix (sw)
	   (cond ((eq sw t) 't)
		 ((atom sw) (list (errno-value sw)))
		 (t (mapcar #'errno-value sw)))))
    (with-gensyms (block condtmp formfunc)
      (let ((labels (mapcar (lambda (cl)
			      (declare (ignore cl))
			      (gensym))
			    clauses)))
	`(let (,@(when cond `(,cond))
	       ,@(when errstring `(,errstring))
	       ,errno
	       (,formfunc (lambda () ,form)))
	   (block ,block
	     (tagbody
	       (handler-bind
		   ((unix-error
		      (lambda (,condtmp)
			(setf ,errno (unix-error-errno ,condtmp))
			,@(when cond
			    `((setf ,cond ,condtmp)))
			,@(when errstring
			    `((setf ,errstring
				    (unix:get-unix-error-msg ,errno))))
			(case ,errno
			  ,@(mapcar (lambda (cl lab)
				      `(,(fix (car cl)) (go ,lab)))
				    clauses
				    labels)))))
		 (return-from ,block (funcall ,formfunc)))
	       ,@(collecting ()
		   (mapc (lambda (cl lab)
			   (collect lab)
			   (collect `(return-from ,block
				       (progn ,@(cdr cl)))))
			 clauses
			 labels)))))))))

(defun syscall* (name func &rest args)
  "Call Unix system call FUNC, passing it ARGS.  If it returns an error,
   signal the unix-error condition, with NAME and ARGS."
  (multiple-value-call (lambda (rc &rest stuff)
			 (unless rc
			   (error 'unix-error
				  :func name
				  :args args
				  :errno (car stuff)))
			 (apply #'values rc stuff))
		       (apply func args)))
(defmacro syscall (func &rest args)
  "Call Unix system call FUNC, passing it ARGS.  If it returns an error,
   signal the unix-error condition, with FUNC and ARGS."
  `(syscall* ',func
   #',func ,@args))

(macrolet ((doit (doc slots)
	     `(defstruct (stat (:predicate statp)
			       (:conc-name st-)
			       (:constructor %make-stat-boa ,slots))
	        ,doc
	        ,@slots)))
  (doit
   "Structure representing all the useful information `stat' returns about a
   file."
   (dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks)))
(defun sys-stat (file)
  "Return information about FILE in a structure rather than as inconvenient
   multiple values."
  (multiple-value-call
      (lambda (rc &rest results)
	(unless rc
	  (error 'unix-error
		 :func 'sys-stat :args (list file)
		 :error (car results)))
	(apply #'%make-stat-boa results))
    (unix:unix-stat file)))

(defmacro defsyscall (name)
  (let ((sysname (intern (format nil "SYS-~:@(~A~)" name)))
	(unixname (intern (format nil "UNIX-~:@(~A~)" name) :unix)))
    `(defun ,sysname (&rest args)
       (apply #'syscall* ',sysname #',unixname args))))

(macrolet ((defsys (&rest names)
	     `(progn ,@(mapcar (lambda (name) 
				 `(defsyscall ,name))
			       names))))
  (defsys open close read write
	  chown fchown chmod fchmod utimes
	  unlink rename
	  gethostname gettimeofday))

(defmacro with-unix-open ((fd file how &optional (mode #o666)) &body body)
  "Evaluate BODY with FD bound to a file descriptor obtained from a Unix
   `open' syscall with arguments FILE, HOW and MODE.  Close the file
   descriptor when BODY is done."
  `(let (,fd)
     (unwind-protect
	 (progn
	   (setf ,fd (sys-open ,file ,how ,mode))
	   ,@body)
       (when ,fd (sys-close ,fd)))))

(defun copy-file (from to &optional (how 0))
  "Make a copy of the file FROM called TO.  The copy has the same permissions
   and timestamps (except for ctime) and attempts to have the same owner and
   group as the original."
  (let ((st (sys-stat from)))
    (with-unix-open (in from unix:O_RDONLY)
      (with-unix-open (out
		       to
		       (logior unix:O_WRONLY unix:O_CREAT how)
		       (logand (st-mode st) #o777))
        (sys-fchmod out (st-mode st))
	(sys-utimes to (st-atime st) 0 (st-mtime st) 0)
	(with-errno-handlers ()
	  (sys-fchown out (st-uid st) (st-gid st))
	  (eperm nil))
	(with-buffer (buf 16384)
	  (loop
	    (let ((n (sys-read in buf 16384)))
	      (when (zerop n)
		(return))
	      (sys-write out buf 0 n))))))))

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