io.lisp 8.63 KB
Newer Older
1
2
3
4
5
;; Copyright (c) 2002-2006, Edward Marco Baringer
;; All rights reserved.

(in-package :alexandria)

6
7
8
(defmacro with-open-file* ((stream filespec &key direction element-type
                                   if-exists if-does-not-exist external-format)
                           &body body)
9
10
  "Just like WITH-OPEN-FILE, but NIL values in the keyword arguments
mean to use the default value specified for OPEN."
11
12
13
14
15
16
  (once-only (direction element-type if-exists if-does-not-exist external-format)
    `(with-open-stream
         (,stream (apply #'open ,filespec
                         (append
                          (when ,direction
                            (list :direction ,direction))
17
18
                          (list :element-type (or ,element-type
                                                  (default-element-type)))
19
20
21
22
23
24
25
                          (when ,if-exists
                            (list :if-exists ,if-exists))
                          (when ,if-does-not-exist
                            (list :if-does-not-exist ,if-does-not-exist))
                          (when ,external-format
                            (list :external-format ,external-format)))))
       ,@body)))
26

27
28
29
30
31
32
33
34
35
36
(defun default-element-type ()
  ;; On Lispworks, ELEMENT-TYPE :DEFAULT selects the appropriate
  ;; subtype of CHARACTER for the given external format which can
  ;; represent all possible characters.
  #+lispworks :default
  ;; The spec says that OPEN's default ELEMENT-TYPE (when it is not
  ;; specified) is CHARACTER, but on AllegroCL it's (UNSIGNED-BYTE 8).
  ;; No harm done by specifying it on other implementations.
  #-lispworks 'character)

37
38
(defmacro with-input-from-file ((stream-name file-name &rest args
                                             &key (direction nil direction-p)
39
                                             &allow-other-keys)
40
                                &body body)
41
42
43
  "Evaluate BODY with STREAM-NAME to an input stream on the file
FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
which is only sent to WITH-OPEN-FILE when it's not NIL."
44
  (declare (ignore direction))
45
  (when direction-p
Steve Losh's avatar
Steve Losh committed
46
    (error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE."))
47
48
  `(with-open-file* (,stream-name ,file-name :direction :input ,@args)
     ,@body))
49

50
51
(defmacro with-output-to-file ((stream-name file-name &rest args
                                            &key (direction nil direction-p)
52
                                            &allow-other-keys)
53
54
			       &body body)
  "Evaluate BODY with STREAM-NAME to an output stream on the file
55
56
FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
which is only sent to WITH-OPEN-FILE when it's not NIL."
57
  (declare (ignore direction))
58
  (when direction-p
Steve Losh's avatar
Steve Losh committed
59
    (error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE."))
60
61
  `(with-open-file* (,stream-name ,file-name :direction :output ,@args)
     ,@body))
62

63
64
65
(defun read-stream-content-into-string (stream &key (buffer-size 4096))
  "Return the \"content\" of STREAM as a fresh string."
  (check-type buffer-size positive-integer)
66
67
68
69
  (let ((*print-pretty* nil)
        (element-type (stream-element-type stream)))
    (with-output-to-string (datum nil :element-type element-type)
      (let ((buffer (make-array buffer-size :element-type element-type)))
70
71
72
73
74
        (loop
          :for bytes-read = (read-sequence buffer stream)
          :do (write-sequence buffer datum :start 0 :end bytes-read)
          :while (= bytes-read buffer-size))))))

75
76
(defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
  "Return the contents of the file denoted by PATHNAME as a fresh string.
77

78
79
The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
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
87
  "Write STRING to PATHNAME.

88
89
The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
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
94
    (write-sequence string file-stream)))

95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
(defun read-stream-content-into-byte-vector (stream &key ((%length length))
                                                         (initial-size 4096))
  "Return \"content\" of STREAM as freshly allocated (unsigned-byte 8) vector."
  (check-type length (or null non-negative-integer))
  (check-type initial-size positive-integer)
  (do ((buffer (make-array (or length initial-size)
                           :element-type '(unsigned-byte 8)))
       (offset 0)
       (offset-wanted 0))
      ((or (/= offset-wanted offset)
           (and length (>= offset length)))
       (if (= offset (length buffer))
           buffer
           (subseq buffer 0 offset)))
    (unless (zerop offset)
      (let ((new-buffer (make-array (* 2 (length buffer))
                                    :element-type '(unsigned-byte 8))))
        (replace new-buffer buffer)
        (setf buffer new-buffer)))
    (setf offset-wanted (length buffer)
          offset (read-sequence buffer stream :start offset))))

117
118
119
(defun read-file-into-byte-vector (pathname)
  "Read PATHNAME into a freshly allocated (unsigned-byte 8) vector."
  (with-input-from-file (stream pathname :element-type '(unsigned-byte 8))
120
    (read-stream-content-into-byte-vector stream '%length (file-length stream))))
121
122
123
124
125
126
127
128
129
130

(defun write-byte-vector-into-file (bytes pathname &key (if-exists :error)
                                                       if-does-not-exist)
  "Write BYTES to PATHNAME."
  (check-type bytes (vector (unsigned-byte 8)))
  (with-output-to-file (stream pathname :if-exists if-exists
                               :if-does-not-exist if-does-not-exist
                               :element-type '(unsigned-byte 8))
    (write-sequence bytes stream)))

131
(defun copy-file (from to &key (if-to-exists :supersede)
132
			       (element-type '(unsigned-byte 8)) finish-output)
133
  (with-input-from-file (input from :element-type element-type)
134
135
    (with-output-to-file (output to :element-type element-type
				    :if-exists if-to-exists)
136
137
      (copy-stream input output
                   :element-type element-type
138
                   :finish-output finish-output))))
139

140
141
142
(defun copy-stream (input output &key (element-type (stream-element-type input))
                    (buffer-size 4096)
                    (buffer (make-array buffer-size :element-type element-type))
143
                    (start 0) end
144
                    finish-output)
145
146
147
  "Reads data from INPUT and writes it to OUTPUT. Both INPUT and OUTPUT must
be streams, they will be passed to READ-SEQUENCE and WRITE-SEQUENCE and must have
compatible element-types."
148
149
150
  (check-type start non-negative-integer)
  (check-type end (or null non-negative-integer))
  (check-type buffer-size positive-integer)
151
152
  (when (and end
             (< end start))
153
154
155
156
157
    (error "END is smaller than START in ~S" 'copy-stream))
  (let ((output-position 0)
        (input-position 0))
    (unless (zerop start)
      ;; FIXME add platform specific optimization to skip seekable streams
158
159
160
161
162
163
164
165
      (loop while (< input-position start)
            do (let ((n (read-sequence buffer input
                                       :end (min (length buffer)
                                                 (- start input-position)))))
                 (when (zerop n)
                   (error "~@<Could not read enough bytes from the input to fulfill ~
                           the :START ~S requirement in ~S.~:@>" 'copy-stream start))
                 (incf input-position n))))
166
    (assert (= input-position start))
167
168
169
170
171
172
173
174
175
176
177
178
179
    (loop while (or (null end) (< input-position end))
          do (let ((n (read-sequence buffer input
                                     :end (when end
                                            (min (length buffer)
                                                 (- end input-position))))))
               (when (zerop n)
                 (if end
                     (error "~@<Could not read enough bytes from the input to fulfill ~
                          the :END ~S requirement in ~S.~:@>" 'copy-stream end)
                     (return)))
               (incf input-position n)
               (write-sequence buffer output :end n)
               (incf output-position n)))
180
181
    (when finish-output
      (finish-output output))
182
    output-position))