io.streams/zeta/file.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- File devices.
   4 ;;;
   5
   6 (in-package :io.zeta-streams)
   7
   8 ;;;-----------------------------------------------------------------------------
   9 ;;; File Classes and Types
  10 ;;;-----------------------------------------------------------------------------
  11
  12 (defclass file-device (single-channel-device)
  13   ((filename :initarg :filename :accessor filename-of)
  14    (direction :initarg :direction :accessor direction-of)
  15    (if-exists :initarg :if-exists :accessor if-exists-of)
  16    (if-does-not-exist :initarg :if-does-not-exist :accessor if-does-not-exist-of)))
  17
  18 (defclass memory-mapped-file-device (file-device direct-device) ())
  19
  20 (deftype file-direction ()
  21   '(member :input :output :io))
  22
  23 (deftype file-if-exists ()
  24   '(member :default :error :error-if-symlink :unlink :overwrite))
  25
  26 (deftype file-if-does-not-exist ()
  27   '(member :default :error :create))
  28 \f
  29
  30 ;;;-----------------------------------------------------------------------------
  31 ;;; File Constructors
  32 ;;;-----------------------------------------------------------------------------
  33
  34 (defmethod initialize-instance :after ((device file-device)
  35                                        &key filename (direction :input)
  36                                        (if-exists :default) (if-does-not-exist :default)
  37                                        truncate append (extra-flags 0)
  38                                        (mode #o666))
  39   (when (and (eql :error if-exists)
  40              (eql :error if-does-not-exist))
  41     (error 'program-error))
  42   (let ((flags 0))
  43     (setf (values flags if-exists if-does-not-exist)
  44           (process-file-direction direction flags if-exists if-does-not-exist))
  45     (setf (values flags if-exists if-does-not-exist)
  46           (process-file-flags direction flags if-exists if-does-not-exist
  47                               truncate append extra-flags))
  48     (setf (filename-of device) (copy-seq filename)
  49           (direction-of device) direction
  50           (if-exists-of device) if-exists
  51           (if-does-not-exist-of device) if-does-not-exist)
  52     (with-device (device)
  53       (device-open device :filename filename :flags flags
  54                    :mode mode :if-exists if-exists
  55                    :if-does-not-exist if-does-not-exist))))
  56 \f
  57
  58 ;;;-----------------------------------------------------------------------------
  59 ;;; File PRINT-OBJECT
  60 ;;;-----------------------------------------------------------------------------
  61
  62 (defmethod print-object ((file file-device) stream)
  63   (print-unreadable-object (file stream :identity t :type nil)
  64     (format stream "File device for ~S" (filename-of file))))
  65 \f
  66
  67 ;;;-----------------------------------------------------------------------------
  68 ;;; File DEVICE-OPEN
  69 ;;;-----------------------------------------------------------------------------
  70
  71 (defmethod device-open ((device file-device) &key filename flags mode
  72                         if-exists if-does-not-exist)
  73   (declare (ignore if-does-not-exist))
  74   (labels ((handle-error (c)
  75              (posix-file-error c filename "opening"))
  76            (try-unlink ()
  77              (handler-case
  78                  (nix:unlink filename)
  79                (nix:posix-error (c) (handle-error c))))
  80            (try-open (&optional (retry-on-unlink t))
  81              (handler-case
  82                  (nix:open filename flags mode)
  83                (nix:eexist (c)
  84                  (cond ((and retry-on-unlink (eql :unlink if-exists))
  85                         (try-unlink) (try-open nil))
  86                        (t (handle-error c))))
  87                (nix:posix-error (c)
  88                  (handle-error c))
  89                (:no-error (fd) fd))))
  90     (let ((fd (try-open)))
  91       (%set-fd-nonblock-mode fd t)
  92       (setf (input-handle-of device) fd
  93             (output-handle-of device) fd)))
  94   (values device))
  95
  96 (defun process-file-direction (direction flags if-exists if-does-not-exist)
  97   (macrolet ((add-flags (&rest %flags)
  98                `(setf flags (logior flags ,@%flags))))
  99     (when (eql :default if-exists) (setf if-exists :overwrite))
 100     (ecase direction
 101       (:input
 102        (add-flags nix:o-rdonly)
 103        (check-type if-exists (member :overwrite :error-if-symlink))
 104        (check-type if-does-not-exist (member :default :error))
 105        (when (eql :default if-does-not-exist) (setf if-does-not-exist :error)))
 106       ((:output :io)
 107        (add-flags (if (eql :io direction) nix:o-rdwr nix:o-wronly))
 108        (check-type if-exists file-if-exists)
 109        (check-type if-does-not-exist file-if-does-not-exist)
 110        (when (eql :default if-does-not-exist) (setf if-does-not-exist :create))))
 111     (values flags if-exists if-does-not-exist)))
 112
 113 (defun process-file-flags (direction flags if-exists if-does-not-exist
 114                            truncate append extra-flags)
 115   (macrolet ((add-flags (&rest %flags)
 116                `(setf flags (logior flags ,@%flags))))
 117     (case if-exists
 118       (:error
 119        (unless (eql :input direction) (add-flags nix:o-excl)))
 120       (:error-if-symlink
 121        (add-flags nix:o-nofollow)))
 122     (case if-does-not-exist
 123       (:create (add-flags nix:o-creat)))
 124     (cond
 125       (truncate
 126        (unless (eql :input direction) (add-flags nix:o-trunc)))
 127       (append
 128        (when (eql :output direction) (add-flags nix:o-append)))
 129       (extra-flags
 130        (add-flags extra-flags))))
 131   (values flags if-exists if-does-not-exist))
 132 \f
 133
 134 ;;;-----------------------------------------------------------------------------
 135 ;;; File DEVICE-CLOSE
 136 ;;;-----------------------------------------------------------------------------
 137
 138 (defmethod device-close ((device file-device) &optional abort)
 139   (declare (ignore abort))
 140   (ignore-errors (nix:close (input-handle-of device)))
 141   (setf (input-handle-of device) nil
 142         (output-handle-of device) nil)
 143   (values device))
 144 \f
 145
 146 ;;;-----------------------------------------------------------------------------
 147 ;;; File DEVICE-POSITION
 148 ;;;-----------------------------------------------------------------------------
 149
 150 (defmethod device-position ((device file-device))
 151   (handler-case
 152       (nix:lseek (input-handle-of device) 0 nix:seek-cur)
 153     (nix:posix-error (err)
 154       (posix-file-error err device "seeking on"))))
 155
 156 (defmethod (setf device-position) (position (device file-device) &key (from :start))
 157   (handler-case
 158       (nix:lseek (input-handle-of device) position
 159                  (ecase from
 160                    (:start nix:seek-set)
 161                    (:current nix:seek-cur)
 162                    (:end nix:seek-end)))
 163     (nix:posix-error (err)
 164       (posix-file-error err device "seeking on"))))
 165 \f
 166
 167 ;;;-----------------------------------------------------------------------------
 168 ;;; File DEVICE-LENGTH
 169 ;;;-----------------------------------------------------------------------------
 170
 171 (defmethod device-length ((device file-device))
 172   (handler-case
 173       (nix:stat-size (nix:fstat (input-handle-of device)))
 174     (nix:posix-error (err)
 175       (posix-file-error err device "getting status of"))))
 176 \f
 177
 178 ;;;-----------------------------------------------------------------------------
 179 ;;; OPEN-FILE
 180 ;;;-----------------------------------------------------------------------------
 181
 182 (defun open-file (filename &key (direction :input)
 183                   (if-exists :default) (if-does-not-exist :default)
 184                   truncate append (extra-flags 0) (mode #o666))
 185   (when (and (null if-exists)
 186              (null if-does-not-exist))
 187     (error 'program-error))
 188   (handler-case
 189       (make-instance 'file-device
 190                      :filename (namestring filename)
 191                      :direction direction
 192                      :if-exists if-exists
 193                      :if-does-not-exist if-does-not-exist
 194                      :truncate truncate
 195                      :append append
 196                      :extra-flags extra-flags
 197                      :mode mode)
 198     (posix-file-error (error)
 199       (case (posix-file-error-identifier error)
 200         (:enoent
 201          (if (null if-does-not-exist) nil (error error)))
 202         (:eexist
 203          (if (null if-exists) nil (error error)))
 204         (t (error error))))
 205     (:no-error (file) file)))