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 (deftype file-direction ()
   9   '(member :input :output :io))
  10
  11 (deftype file-if-exists ()
  12   '(member :default :error :error-if-symlink :unlink :overwrite))
  13
  14 (deftype file-if-does-not-exist ()
  15   '(member :default :error :create))
  16
  17 (defmethod initialize-instance :after ((device file-device)
  18                                        &key filename (direction :input)
  19                                        (if-exists :default) (if-does-not-exist :default)
  20                                        truncate append nonblocking (extra-flags 0)
  21                                        (mode #o666))
  22   (when (and (eql :error if-exists)
  23              (eql :error if-does-not-exist))
  24     (error 'program-error))
  25   (let ((flags 0))
  26     (setf (values flags if-exists if-does-not-exist)
  27           (process-file-direction direction flags if-exists if-does-not-exist))
  28     (setf (values flags if-exists if-does-not-exist)
  29           (process-file-flags direction flags if-exists if-does-not-exist
  30                               truncate append nonblocking extra-flags))
  31     (setf (filename-of device) (copy-seq filename)
  32           (direction-of device) direction
  33           (if-exists-of device) if-exists
  34           (if-does-not-exist-of device) if-does-not-exist)
  35     (prog1
  36         (device-open device :filename filename :flags flags
  37                      :mode mode :if-exists if-exists
  38                      :if-does-not-exist if-does-not-exist)
  39       (when append
  40         (setf (position-of device) (device-length device))))))
  41
  42 (defmethod device-open ((device file-device) &key filename flags mode
  43                         if-exists if-does-not-exist &allow-other-keys)
  44   (declare (ignore if-does-not-exist))
  45   (labels ((handle-error (error)
  46              (error 'posix-file-error
  47                     :code (osicat-sys:system-error-code error)
  48                     :identifier (osicat-sys:system-error-identifier error)
  49                     :pathname filename :action "opening"))
  50            (try-open (&optional (retry-on-unlink t))
  51              (handler-case
  52                  (nix:open filename flags mode)
  53                (nix:eexist (error)
  54                  (cond ((and retry-on-unlink (eql :unlink if-exists))
  55                         (handler-case
  56                             (nix:unlink filename)
  57                           (nix:posix-error (error) (handle-error error)))
  58                         (try-open nil))
  59                        (t (handle-error error))))
  60                (nix:posix-error (error)
  61                  (handle-error error))
  62                (:no-error (fd) fd))))
  63     (let ((fd (try-open)))
  64       (%set-fd-nonblock-mode fd t)
  65       (setf (input-handle-of device) fd
  66             (output-handle-of device) fd)))
  67   (values device))
  68
  69 (defun process-file-direction (direction flags if-exists if-does-not-exist)
  70   (macrolet ((add-flags (&rest %flags)
  71                `(setf flags (logior flags ,@%flags))))
  72     (ecase direction
  73       (:input
  74        (add-flags nix:o-rdonly)
  75        (check-type if-exists (member nil :error-if-symlink))
  76        (check-type if-does-not-exist (member nil :error))
  77        (when (eql :default if-does-not-exist) (setf if-does-not-exist :error)))
  78       (:output
  79        (add-flags nix:o-wronly)
  80        (check-type if-exists file-if-exists)
  81        (check-type if-does-not-exist file-if-does-not-exist)
  82        (when (eql :default if-exists) (setf if-exists :overwrite))
  83        (when (eql :default if-does-not-exist) (setf if-does-not-exist :create)))
  84       (:io
  85        (add-flags nix:o-rdwr)
  86        (check-type if-exists file-if-exists)
  87        (check-type if-does-not-exist file-if-does-not-exist)
  88        (when (eql :default if-exists) (setf if-exists :overwrite))
  89        (when (eql :default if-does-not-exist) (setf if-does-not-exist :create))))
  90     (values flags if-exists if-does-not-exist)))
  91
  92 (defun process-file-flags (direction flags if-exists if-does-not-exist
  93                            truncate append nonblocking extra-flags)
  94   (macrolet ((add-flags (&rest %flags)
  95                `(setf flags (logior flags ,@%flags))))
  96     (case if-exists
  97       (:error
  98        (unless (eql :input direction) (add-flags nix:o-excl)))
  99       (:error-if-symlink
 100        (add-flags nix:o-nofollow)
 101        (setf if-exists :overwrite)))
 102     (case if-does-not-exist
 103       (:create (add-flags nix:o-creat)))
 104     (cond
 105       (truncate
 106        (unless (eql :input direction) (add-flags nix:o-trunc)))
 107       (append
 108        (when (eql :output direction) (add-flags nix:o-append)))
 109       (nonblocking
 110        (add-flags nix:o-nonblock))
 111       (extra-flags
 112        (add-flags extra-flags))))
 113   (values flags if-exists if-does-not-exist))
 114
 115 (defmethod device-close ((device file-device))
 116   (ignore-errors (nix:close (input-handle-of device)))
 117   (setf (input-handle-of device) nil
 118         (output-handle-of device) nil)
 119   (values device))
 120
 121 (defmethod device-position ((device file-device))
 122   (position-of device))
 123
 124 (defmethod (setf device-position) (offset (device file-device) &key (from :start))
 125   (ecase from
 126     (:start
 127      (nix:lseek (input-handle-of device) offset nix:seek-set)
 128      (setf (position-of device) offset))
 129     (:current
 130      (nix:lseek (input-handle-of device) offset nix:seek-cur)
 131      (incf (position-of device) offset))
 132     (:end
 133      (nix:lseek (input-handle-of device) offset nix:seek-end)
 134      ;; WARNING: possible race condition here: if betweek lseek() and fstat()
 135      ;; the file size is modified, this calculation will be wrong
 136      ;; perhaps fcntl() or ioctl() can be used to find out the file offset
 137      (setf (position-of device) (+ (device-length device) offset))))
 138   (position-of device))
 139
 140 (defmethod device-length ((device file-device))
 141   (nix:stat-size (nix:fstat (input-handle-of device))))
 142
 143 (defun open-file (filename &key (direction :input)
 144                   (if-exists :default) (if-does-not-exist :default)
 145                   truncate append nonblocking (extra-flags 0) (mode #o666))
 146   (when (and (null if-exists)
 147              (null if-does-not-exist))
 148     (error 'program-error))
 149   (handler-case
 150       (make-instance 'file-device
 151                      :filename (namestring filename)
 152                      :direction direction
 153                      :if-exists if-exists
 154                      :if-does-not-exist if-does-not-exist
 155                      :truncate truncate
 156                      :append append
 157                      :nonblocking nonblocking
 158                      :extra-flags extra-flags
 159                      :mode mode)
 160     (posix-file-error (error)
 161       (case (posix-file-error-identifier error)
 162         (:enoent
 163          (if (null if-does-not-exist) nil (error error)))
 164         (:eexist
 165          (if (null if-exists) nil (error error)))
 166         (t (error error))))
 167     (:no-error (file) file)))