1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
6 (in-package :io.zeta-streams
)
8 ;;;-----------------------------------------------------------------------------
9 ;;; File Classes and Types
10 ;;;-----------------------------------------------------------------------------
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
)))
18 (defclass memory-mapped-file-device
(file-device direct-device
) ())
20 (deftype file-direction
()
21 '(member :input
:output
:io
))
23 (deftype file-if-exists
()
24 '(member :default
:error
:error-if-symlink
:unlink
:overwrite
))
26 (deftype file-if-does-not-exist
()
27 '(member :default
:error
:create
))
30 ;;;-----------------------------------------------------------------------------
32 ;;;-----------------------------------------------------------------------------
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)
39 (when (and (eql :error if-exists
)
40 (eql :error if-does-not-exist
))
41 (error 'program-error
))
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
)))
57 ;;;-----------------------------------------------------------------------------
59 ;;;-----------------------------------------------------------------------------
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"))
69 (nix:posix-error
(c) (handle-error c
))))
70 (try-open (&optional
(retry-on-unlink t
))
72 (nix:open filename flags mode
)
74 (cond ((and retry-on-unlink
(eql :unlink if-exists
))
75 (try-unlink) (try-open nil
))
76 (t (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
)))
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
))))
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
)))
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
)))
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
))))
109 (unless (eql :input direction
) (add-flags nix
:o-excl
)))
111 (add-flags nix
:o-nofollow
)))
112 (case if-does-not-exist
113 (:create
(add-flags nix
:o-creat
)))
116 (unless (eql :input direction
) (add-flags nix
:o-trunc
)))
118 (when (eql :output direction
) (add-flags nix
:o-append
)))
120 (add-flags nix
:o-nonblock
))
122 (add-flags extra-flags
))))
123 (values flags if-exists if-does-not-exist
))
126 ;;;-----------------------------------------------------------------------------
127 ;;; File DEVICE-CLOSE
128 ;;;-----------------------------------------------------------------------------
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
)
137 ;;;-----------------------------------------------------------------------------
138 ;;; File DEVICE-POSITION
139 ;;;-----------------------------------------------------------------------------
141 (defmethod device-position ((device file-device
))
142 (nix:lseek
(input-handle-of device
) 0 nix
:seek-cur
))
144 (defmethod (setf device-position
) (position (device file-device
) &key
(from :start
))
145 (nix:lseek
(input-handle-of device
) position
147 (:start nix
:seek-set
)
148 (:current nix
:seek-cur
)
149 (:end nix
:seek-end
))))
152 ;;;-----------------------------------------------------------------------------
153 ;;; File DEVICE-LENGTH
154 ;;;-----------------------------------------------------------------------------
156 (defmethod device-length ((device file-device
))
157 (nix:stat-size
(nix:fstat
(input-handle-of device
))))
160 ;;;-----------------------------------------------------------------------------
162 ;;;-----------------------------------------------------------------------------
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
))
171 (make-instance 'file-device
172 :filename
(namestring filename
)
175 :if-does-not-exist if-does-not-exist
178 :nonblocking nonblocking
179 :extra-flags extra-flags
181 (posix-file-error (error)
182 (case (posix-file-error-identifier error
)
184 (if (null if-does-not-exist
) nil
(error error
)))
186 (if (null if-exists
) nil
(error error
)))
188 (:no-error
(file) file
)))