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 nonblocking (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 nonblocking 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     (device-open device :filename filename :flags flags
  53                  :mode mode :if-exists if-exists
  54                  :if-does-not-exist if-does-not-exist)))
  55 \f
  56
  57 ;;;-----------------------------------------------------------------------------
  58 ;;; File DEVICE-OPEN
  59 ;;;-----------------------------------------------------------------------------
  60
  61 (defmethod device-open ((device file-device) &key filename flags mode
  62                         if-exists if-does-not-exist)
  63   (declare (ignore if-does-not-exist))
  64   (labels ((handle-error (c)
  65              (posix-file-error c filename "opening"))
  66            (try-unlink ()
  67              (handler-case
  68                  (nix:unlink filename)
  69                (nix:posix-error (c) (handle-error c))))
  70            (try-open (&optional (retry-on-unlink t))
  71              (handler-case
  72                  (nix:open filename flags mode)
  73                (nix:eexist (c)
  74                  (cond ((and retry-on-unlink (eql :unlink if-exists))
  75                         (try-unlink) (try-open nil))
  76                        (t (handle-error c))))
  77                (nix:posix-error (c)
  78                  (handle-error c))
  79                (:no-error (fd) fd))))
  80     (let ((fd (try-open)))
  81       (%set-fd-nonblock-mode fd t)
  82       (setf (input-handle-of device) fd
  83             (output-handle-of device) fd)))
  84   (values device))
  85
  86 (defun process-file-direction (direction flags if-exists if-does-not-exist)
  87   (macrolet ((add-flags (&rest %flags)
  88                `(setf flags (logior flags ,@%flags))))
  89     (ecase direction
  90       (:input
  91        (add-flags nix:o-rdonly)
  92        (check-type if-exists (member nil :error-if-symlink))
  93        (check-type if-does-not-exist (member nil :error))
  94        (when (eql :default if-does-not-exist) (setf if-does-not-exist :error)))
  95       ((:output :io)
  96        (add-flags (if (eql :io direction) nix:o-rdwr nix:o-wronly))
  97        (check-type if-exists file-if-exists)
  98        (check-type if-does-not-exist file-if-does-not-exist)
  99        (when (eql :default if-exists) (setf if-exists :overwrite))
 100        (when (eql :default if-does-not-exist) (setf if-does-not-exist :create))))
 101     (values flags if-exists if-does-not-exist)))
 102
 103 (defun process-file-flags (direction flags if-exists if-does-not-exist
 104                            truncate append nonblocking extra-flags)
 105   (macrolet ((add-flags (&rest %flags)
 106                `(setf flags (logior flags ,@%flags))))
 107     (case if-exists
 108       (:error
 109        (unless (eql :input direction) (add-flags nix:o-excl)))
 110       (:error-if-symlink
 111        (add-flags nix:o-nofollow)))
 112     (case if-does-not-exist
 113       (:create (add-flags nix:o-creat)))
 114     (cond
 115       (truncate
 116        (unless (eql :input direction) (add-flags nix:o-trunc)))
 117       (append
 118        (when (eql :output direction) (add-flags nix:o-append)))
 119       (nonblocking
 120        (add-flags nix:o-nonblock))
 121       (extra-flags
 122        (add-flags extra-flags))))
 123   (values flags if-exists if-does-not-exist))
 124 \f
 125
 126 ;;;-----------------------------------------------------------------------------
 127 ;;; File DEVICE-CLOSE
 128 ;;;-----------------------------------------------------------------------------
 129
 130 (defmethod device-close ((device file-device))
 131   (ignore-errors (nix:close (input-handle-of device)))
 132   (setf (input-handle-of device) nil
 133         (output-handle-of device) nil)
 134   (values device))
 135 \f
 136
 137 ;;;-----------------------------------------------------------------------------
 138 ;;; File DEVICE-POSITION
 139 ;;;-----------------------------------------------------------------------------
 140
 141 (defmethod device-position ((device file-device))
 142   (nix:lseek (input-handle-of device) 0 nix:seek-cur))
 143
 144 (defmethod (setf device-position) (position (device file-device) &key (from :start))
 145   (nix:lseek (input-handle-of device) position
 146              (ecase from
 147                (:start nix:seek-set)
 148                (:current nix:seek-cur)
 149                (:end nix:seek-end))))
 150 \f
 151
 152 ;;;-----------------------------------------------------------------------------
 153 ;;; File DEVICE-LENGTH
 154 ;;;-----------------------------------------------------------------------------
 155
 156 (defmethod device-length ((device file-device))
 157   (nix:stat-size (nix:fstat (input-handle-of device))))
 158 \f
 159
 160 ;;;-----------------------------------------------------------------------------
 161 ;;; OPEN-FILE
 162 ;;;-----------------------------------------------------------------------------
 163
 164 (defun open-file (filename &key (direction :input)
 165                   (if-exists :default) (if-does-not-exist :default)
 166                   truncate append nonblocking (extra-flags 0) (mode #o666))
 167   (when (and (null if-exists)
 168              (null if-does-not-exist))
 169     (error 'program-error))
 170   (handler-case
 171       (make-instance 'file-device
 172                      :filename (namestring filename)
 173                      :direction direction
 174                      :if-exists if-exists
 175                      :if-does-not-exist if-does-not-exist
 176                      :truncate truncate
 177                      :append append
 178                      :nonblocking nonblocking
 179                      :extra-flags extra-flags
 180                      :mode mode)
 181     (posix-file-error (error)
 182       (case (posix-file-error-identifier error)
 183         (:enoent
 184          (if (null if-does-not-exist) nil (error error)))
 185         (:eexist
 186          (if (null if-exists) nil (error error)))
 187         (t (error error))))
 188     (:no-error (file) file)))