Coverage report: /home/ellis/.stash/quicklisp/dists/quicklisp/software/alexandria-20241012-git/alexandria-1/io.lisp

KindCoveredAll%
expression0233 0.0
branch022 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;; Copyright (c) 2002-2006, Edward Marco Baringer
2
 ;; All rights reserved.
3
 
4
 (in-package :alexandria)
5
 
6
 (defmacro with-open-file* ((stream filespec &key direction element-type
7
                                    if-exists if-does-not-exist external-format)
8
                            &body body)
9
   "Just like WITH-OPEN-FILE, but NIL values in the keyword arguments
10
 mean to use the default value specified for OPEN."
11
   (once-only (direction element-type if-exists if-does-not-exist external-format)
12
     `(with-open-stream
13
          (,stream (apply #'open ,filespec
14
                          (append
15
                           (when ,direction
16
                             (list :direction ,direction))
17
                           (list :element-type (or ,element-type
18
                                                   (default-element-type)))
19
                           (when ,if-exists
20
                             (list :if-exists ,if-exists))
21
                           (when ,if-does-not-exist
22
                             (list :if-does-not-exist ,if-does-not-exist))
23
                           (when ,external-format
24
                             (list :external-format ,external-format)))))
25
        ,@body)))
26
 
27
 (defun default-element-type ()
28
   ;; On Lispworks, ELEMENT-TYPE :DEFAULT selects the appropriate
29
   ;; subtype of CHARACTER for the given external format which can
30
   ;; represent all possible characters.
31
   #+lispworks :default
32
   ;; The spec says that OPEN's default ELEMENT-TYPE (when it is not
33
   ;; specified) is CHARACTER, but on AllegroCL it's (UNSIGNED-BYTE 8).
34
   ;; No harm done by specifying it on other implementations.
35
   #-lispworks 'character)
36
 
37
 (defmacro with-input-from-file ((stream-name file-name &rest args
38
                                              &key (direction nil direction-p)
39
                                              &allow-other-keys)
40
                                 &body body)
41
   "Evaluate BODY with STREAM-NAME to an input stream on the file
42
 FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
43
 which is only sent to WITH-OPEN-FILE when it's not NIL."
44
   (declare (ignore direction))
45
   (when direction-p
46
     (error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE."))
47
   `(with-open-file* (,stream-name ,file-name :direction :input ,@args)
48
      ,@body))
49
 
50
 (defmacro with-output-to-file ((stream-name file-name &rest args
51
                                             &key (direction nil direction-p)
52
                                             &allow-other-keys)
53
                                &body body)
54
   "Evaluate BODY with STREAM-NAME to an output stream on the file
55
 FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
56
 which is only sent to WITH-OPEN-FILE when it's not NIL."
57
   (declare (ignore direction))
58
   (when direction-p
59
     (error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE."))
60
   `(with-open-file* (,stream-name ,file-name :direction :output ,@args)
61
      ,@body))
62
 
63
 (defun read-stream-content-into-string (stream &key (buffer-size 4096))
64
   "Return the \"content\" of STREAM as a fresh string."
65
   (check-type buffer-size positive-integer)
66
   (let ((*print-pretty* nil)
67
         (element-type (stream-element-type stream)))
68
     (with-output-to-string (datum nil :element-type element-type)
69
       (let ((buffer (make-array buffer-size :element-type element-type)))
70
         (loop
71
           :for bytes-read = (read-sequence buffer stream)
72
           :do (write-sequence buffer datum :start 0 :end bytes-read)
73
           :while (= bytes-read buffer-size))))))
74
 
75
 (defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
76
   "Return the contents of the file denoted by PATHNAME as a fresh string.
77
 
78
 The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
79
 unless it's NIL, which means the system default."
80
   (with-input-from-file (file-stream pathname :external-format external-format)
81
     (read-stream-content-into-string file-stream :buffer-size buffer-size)))
82
 
83
 (defun write-string-into-file (string pathname &key (if-exists :error)
84
                                                     if-does-not-exist
85
                                                     external-format)
86
   "Write STRING to PATHNAME.
87
 
88
 The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
89
 unless it's NIL, which means the system default."
90
   (with-output-to-file (file-stream pathname :if-exists if-exists
91
                                     :if-does-not-exist if-does-not-exist
92
                                     :external-format external-format)
93
     (write-sequence string file-stream)))
94
 
95
 (defun read-stream-content-into-byte-vector (stream &key ((%length length))
96
                                                          (initial-size 4096))
97
   "Return \"content\" of STREAM as freshly allocated (unsigned-byte 8) vector."
98
   (check-type length (or null non-negative-integer)) ; for compatibility
99
   (check-type initial-size non-negative-integer)
100
   (setf initial-size (or length initial-size))
101
   (let ((result (make-array initial-size :element-type '(unsigned-byte 8)))
102
         (bytes-read 0))
103
     (loop
104
       (setf bytes-read (read-sequence result stream :start bytes-read))
105
       (when (and length (>= bytes-read length))
106
         (return))
107
       ;; There is no PEEK-BYTE, so we just try to read a byte.
108
       (let ((next-byte (read-byte stream nil nil)))
109
         (when (null next-byte)
110
           (return))
111
         (let ((new-result (make-array (if (zerop (length result))
112
                                           4096
113
                                           (* 2 (length result)))
114
                                       :element-type '(unsigned-byte 8))))
115
           (replace new-result result :end1 bytes-read :end2 bytes-read)
116
           (setf (aref new-result bytes-read) next-byte
117
                 result new-result)
118
           (incf bytes-read))))
119
     (if (= bytes-read (length result))
120
         result
121
         (subseq result 0 bytes-read))))
122
 
123
 (defun read-file-into-byte-vector (pathname)
124
   "Read PATHNAME into a freshly allocated (unsigned-byte 8) vector."
125
   (with-input-from-file (stream pathname :element-type '(unsigned-byte 8))
126
     (read-stream-content-into-byte-vector stream :initial-size (file-length stream))))
127
 
128
 (defun write-byte-vector-into-file (bytes pathname &key (if-exists :error)
129
                                                        if-does-not-exist)
130
   "Write BYTES to PATHNAME."
131
   (check-type bytes (vector (unsigned-byte 8)))
132
   (with-output-to-file (stream pathname :if-exists if-exists
133
                                :if-does-not-exist if-does-not-exist
134
                                :element-type '(unsigned-byte 8))
135
     (write-sequence bytes stream)))
136
 
137
 (defun copy-file (from to &key (if-to-exists :supersede)
138
                                (element-type '(unsigned-byte 8)) finish-output)
139
   (with-input-from-file (input from :element-type element-type)
140
     (with-output-to-file (output to :element-type element-type
141
                                     :if-exists if-to-exists)
142
       (copy-stream input output
143
                    :element-type element-type
144
                    :finish-output finish-output))))
145
 
146
 (defun copy-stream (input output &key (element-type (stream-element-type input))
147
                     (buffer-size 4096)
148
                     (buffer (make-array buffer-size :element-type element-type))
149
                     (start 0) end
150
                     finish-output)
151
   "Reads data from INPUT and writes it to OUTPUT. Both INPUT and OUTPUT must
152
 be streams, they will be passed to READ-SEQUENCE and WRITE-SEQUENCE and must have
153
 compatible element-types."
154
   (check-type start non-negative-integer)
155
   (check-type end (or null non-negative-integer))
156
   (check-type buffer-size positive-integer)
157
   (when (and end
158
              (< end start))
159
     (error "END is smaller than START in ~S" 'copy-stream))
160
   (let ((output-position 0)
161
         (input-position 0))
162
     (unless (zerop start)
163
       ;; FIXME add platform specific optimization to skip seekable streams
164
       (loop while (< input-position start)
165
             do (let ((n (read-sequence buffer input
166
                                        :end (min (length buffer)
167
                                                  (- start input-position)))))
168
                  (when (zerop n)
169
                    (error "~@<Could not read enough bytes from the input to fulfill ~
170
                            the :START ~S requirement in ~S.~:@>" 'copy-stream start))
171
                  (incf input-position n))))
172
     (assert (= input-position start))
173
     (loop while (or (null end) (< input-position end))
174
           do (let ((n (read-sequence buffer input
175
                                      :end (when end
176
                                             (min (length buffer)
177
                                                  (- end input-position))))))
178
                (when (zerop n)
179
                  (if end
180
                      (error "~@<Could not read enough bytes from the input to fulfill ~
181
                           the :END ~S requirement in ~S.~:@>" 'copy-stream end)
182
                      (return)))
183
                (incf input-position n)
184
                (write-sequence buffer output :end n)
185
                (incf output-position n)))
186
     (when finish-output
187
       (finish-output output))
188
     output-position))