stream.lisp 12.1 KB
Newer Older
1
2
3
4
5
;;;; ---------------------------------------------------------------------------
;;;; Utilities related to streams

(asdf/package:define-package :asdf/stream
  (:recycle :asdf/stream)
6
  (:use :cl :asdf/package :asdf/compatibility :asdf/utility :asdf/pathname)
7
  #+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:with-standard-io-syntax)
8
  (:export
9
   #:*default-stream-element-type* #:*stderr* #:setup-stderr
10
11
12
13
   #:with-safe-io-syntax #:call-with-safe-io-syntax
   #:with-output #:output-string #:with-input
   #:with-input-file #:call-with-input-file
   #:finish-outputs #:format! #:safe-format!
14
15
16
17
   #:read-file-forms #:read-first-file-form
   #:copy-stream-to-stream #:concatenate-files
   #:copy-stream-to-stream-line-by-line
   #:slurp-stream-string #:slurp-stream-lines
18
19
   #:slurp-stream-forms #:read-file-string
   #:read-file-lines #:read-file-forms
20
   #:safe-read-first-file-form #:eval-input #:eval-text
21
22
23
   #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
   #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
   #:*default-encoding* #:*utf-8-external-format*))
24
25
26
27
28
(in-package :asdf/stream)

(defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default)
  "default element-type for open (depends on the current CL implementation)")

29
(defvar *stderr* *error-output*
30
31
  "the original error output stream at startup")

32
(defun setup-stderr ()
33
34
35
36
37
  (setf *stderr*
        #+allegro excl::*stderr*
        #+clozure ccl::*stderr*
        #-(or allegro clozure) *error-output*))
(setup-stderr)
38

39

40
;;; Safe syntax
41

42
43
(defvar *standard-readtable* (copy-readtable nil))

44
45
46
(defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
  "Establish safe CL reader options around the evaluation of BODY"
  `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body))))
47

48
49
50
(defun* call-with-safe-io-syntax (thunk &key (package :cl))
  (with-standard-io-syntax ()
    (let ((*package* (find-package package))
51
52
          (*readtable* *standard-readtable*)
          (*read-default-float-format* 'double-float)
53
54
55
          (*print-readably* nil)
	  (*read-eval* nil))
      (funcall thunk))))
56
57
58
59


;;; Output to a stream or string, FORMAT-style

60
61
62
63
64
65
66
(defun* call-with-output (output function)
  "Calls FUNCTION with an actual stream argument,
behaving like FORMAT with respect to how stream designators are interpreted:
If OUTPUT is a stream, use it as the stream.
If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
If OUTPUT is a string with a fill-pointer, use it as a string-output-stream.
67
Otherwise, signal an error."
68
  (etypecase output
69
    (null
70
     (with-output-to-string (stream) (funcall function stream)))
71
    ((eql t)
72
     (funcall function *standard-output*))
73
    (stream
74
     (funcall function output))
75
    (string
76
77
     (assert (fill-pointer output))
     (with-output-to-string (stream output) (funcall function stream)))))
78

79
80
(defmacro with-output ((output-var &optional (value output-var)) &body body)
  "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR)
81
as per FORMAT, and evaluate BODY within the scope of this binding."
82
  `(call-with-output ,value #'(lambda (,output-var) ,@body)))
83

84
85
86
87
(defun* output-string (string &optional output)
  "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
  (if output
      (with-output (output) (princ string output))
88
89
      string))

90
91
92

;;; Input helpers

93
94
95
96
97
98
99
(defun* call-with-input (input function)
  "Calls FUNCTION with an actual stream argument, interpreting
stream designators like READ, but also coercing strings to STRING-INPUT-STREAM.
If INPUT is a STREAM, use it as the stream.
If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
If INPUT is T, use *TERMINAL-IO* as the stream.
As an extension, if INPUT is a string, use it as a string-input-stream.
100
Otherwise, signal an error."
101
102
103
104
105
  (etypecase input
    (null (funcall function *standard-input*))
    ((eql t) (funcall function *terminal-io*))
    (stream (funcall function input))
    (string (with-input-from-string (stream input) (funcall function stream)))))
106

107
108
109
110
(defmacro with-input ((input-var &optional (value input-var)) &body body)
  "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
  `(call-with-input ,value #'(lambda (,input-var) ,@body)))
111
112

(defun* call-with-input-file (pathname thunk
113
114
115
                             &key (element-type *default-stream-element-type*)
                             (external-format :default))
  "Open FILE for input with given options, call THUNK with the resulting stream."
116
  #+gcl<2.7 (declare (ignore external-format))
117
  (with-open-file (s pathname :direction :input
118
119
                     :element-type element-type
                     #-gcl<2.7 :external-format #-gcl<2.7 external-format
120
121
122
123
124
125
126
127
                     :if-does-not-exist :error)
    (funcall thunk s)))

(defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body)
  (declare (ignore element-type external-format))
  `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))


128
;;; Ensure output buffers are flushed
129

130
131
132
133
134
(defun* finish-outputs (&rest streams)
  "Finish output on the main output streams as well as any specified one.
Useful for portably flushing I/O before user input or program exit."
  ;; CCL notably buffers its stream output by default.
  (dolist (s (append streams
135
136
                     (list *stderr* *error-output* *standard-output* *trace-output*
                           *debug-io* *terminal-io* *debug-io* *query-io*)))
137
138
    (ignore-errors (finish-output s)))
  (values))
139

140
141
142
143
144
(defun* format! (stream format &rest args)
  "Just like format, but call finish-outputs before and after the output."
  (finish-outputs stream)
  (apply 'format stream format args)
  (finish-output stream))
145

146
147
148
149
(defun* safe-format! (stream format &rest args)
  (with-safe-io-syntax ()
    (ignore-errors (apply 'format! stream format args))
    (finish-outputs stream))) ; just in case format failed
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172


;;; Simple Whole-Stream processing

(defun* copy-stream-to-stream (input output &key (element-type 'character) (buffer-size 8192))
  "Copy the contents of the INPUT stream into the OUTPUT stream,
using WRITE-SEQUENCE and a sensibly sized buffer."
  (with-open-stream (input input)
    (loop
      :for buffer = (make-array (list buffer-size) :element-type element-type)
      :for end = (read-sequence buffer input)
      :until (zerop end)
      :do (write-sequence buffer output :end end)
          (when (< end buffer-size) (return)))))

(defun* concatenate-files (inputs output)
  (with-open-file (o output :element-type '(unsigned-byte 8)
                            :direction :output :if-exists :rename-and-delete)
    (dolist (input inputs)
      (with-open-file (i input :element-type '(unsigned-byte 8)
                               :direction :input :if-does-not-exist :error)
        (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))

173
(defun* copy-stream-to-stream-line-by-line (input output &key prefix)
174
175
176
177
178
179
180
181
182
183
184
  "Copy the contents of the INPUT stream into the OUTPUT stream,
reading contents line by line."
  (with-open-stream (input input)
    (loop :for (line eof) = (multiple-value-list (read-line input nil nil))
      :while line :do
      (when prefix (princ prefix output))
      (princ line output)
      (unless eof (terpri output))
      (finish-output output)
      (when eof (return)))))

185
(defun* slurp-stream-string (input &key (element-type 'character))
186
187
188
189
190
  "Read the contents of the INPUT stream as a string"
  (with-open-stream (input input)
    (with-output-to-string (output)
      (copy-stream-to-stream input output :element-type element-type))))

191
(defun* slurp-stream-lines (input)
192
193
194
195
  "Read the contents of the INPUT stream as a list of lines"
  (with-open-stream (input input)
    (loop :for l = (read-line input nil nil) :while l :collect l)))

196
197
198
(defun* slurp-stream-forms (input)
  "Read the contents of the INPUT stream as a list of forms.
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
199
200
201
202
203
  (with-open-stream (input input)
    (loop :with eof = '#:eof
      :for form = (read input nil eof)
      :until (eq form eof) :collect form)))

204
(defun* read-file-string (file &rest keys)
205
206
207
  "Open FILE with option KEYS, read its contents as a string"
  (apply 'call-with-input-file file 'slurp-stream-string keys))

208
209
210
(defun* read-file-lines (file &rest keys)
  "Open FILE with option KEYS, read its contents as a list of lines
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
211
212
  (apply 'call-with-input-file file 'slurp-stream-lines keys))

213
214
215
(defun* read-file-forms (file &rest keys)
  "Open FILE with option KEYS, read its contents as a list of forms.
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
216
217
  (apply 'call-with-input-file file 'slurp-stream-forms keys))

218
219
220
221
(defun* read-first-file-form (pathname &key eof-error-p eof-value)
  "Reads the first form from the top of a file.
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
  (with-input-file (in pathname)
222
    (read-preserving-whitespace in eof-error-p eof-value)))
223

224
225
226
(defun* safe-read-first-file-form (pathname &key
                                            (package :cl)
                                            eof-error-p eof-value)
227
228
229
230
231
232
233
234
235
236
237
238
239
  "Reads the first form from the top of a file using a safe standardized syntax"
  (with-safe-io-syntax (:package package)
    (read-first-file-form pathname :eof-error-p eof-error-p :eof-value eof-value)))

(defun* eval-input (input)
  "Portably read and evaluate forms from INPUT, return the last values."
  (with-input (input)
    (loop :with results :with eof ='#:eof
          :for form = (read input nil eof)
          :until (eq form eof)
          :do (setf results (multiple-value-list (eval form)))
          :finally (return (apply 'values results)))))

240
241
242
243
244
245
(defun* eval-text (text)
  "Evaluate a form, or if a string, read and evaluate from the string."
  (etypecase text
    ((or cons symbol) (eval text))
    (string (eval-input text))))

246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294

;;; Encodings

(defvar *default-encoding* :default
  "Default encoding for source files.
The default value :default preserves the legacy behavior.
A future default might be :utf-8 or :autodetect
reading emacs-style -*- coding: utf-8 -*- specifications,
and falling back to utf-8 or latin1 if nothing is specified.")

(defparameter *utf-8-external-format*
  #+(and asdf-unicode (not clisp)) :utf-8
  #+(and asdf-unicode clisp) charset:utf-8
  #-asdf-unicode :default
  "Default :external-format argument to pass to CL:OPEN and also
CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
On modern implementations, this will decode UTF-8 code points as CL characters.
On legacy implementations, it may fall back on some 8-bit encoding,
with non-ASCII code points being read as several CL characters;
hopefully, if done consistently, that won't affect program behavior too much.")

(defun* always-default-encoding (pathname)
  (declare (ignore pathname))
  *default-encoding*)

(defvar *encoding-detection-hook* #'always-default-encoding
  "Hook for an extension to define a function to automatically detect a file's encoding")

(defun* detect-encoding (pathname)
  (if (and pathname (not (directory-pathname-p pathname)) (probe-file pathname))
      (funcall *encoding-detection-hook* pathname)
      *default-encoding*))

(defun* default-encoding-external-format (encoding)
  (case encoding
    (:default :default) ;; for backward-compatibility only. Explicit usage discouraged.
    (:utf-8 *utf-8-external-format*)
    (otherwise
     (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
     :default)))

(defvar *encoding-external-format-hook*
  #'default-encoding-external-format
  "Hook for an extension to define a mapping between non-default encodings
and implementation-defined external-format's")

(defun* encoding-external-format (encoding)
  (funcall *encoding-external-format-hook* encoding))