stream.lisp 12 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
  (:export
8
   #:*default-stream-element-type* #:*stderr* #:setup-stderr
9 10 11 12
   #: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!
13 14 15 16
   #: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
17 18
   #:slurp-stream-forms #:read-file-string
   #:read-file-lines #:read-file-forms
19
   #:safe-read-first-file-form #:eval-input #:eval-text
20 21 22
   #: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*))
23 24 25 26 27
(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)")

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

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

38

39
;;; Safe syntax
40

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

43 44 45
(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))))
46

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


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

59 60 61 62 63 64 65
(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.
66
Otherwise, signal an error."
67
  (etypecase output
68
    (null
69
     (with-output-to-string (stream) (funcall function stream)))
70
    ((eql t)
71
     (funcall function *standard-output*))
72
    (stream
73
     (funcall function output))
74
    (string
75 76
     (assert (fill-pointer output))
     (with-output-to-string (stream output) (funcall function stream)))))
77

78 79
(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)
80
as per FORMAT, and evaluate BODY within the scope of this binding."
81
  `(call-with-output ,value #'(lambda (,output-var) ,@body)))
82

83 84 85 86
(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))
87 88
      string))

89 90 91

;;; Input helpers

92 93 94 95 96 97 98
(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.
99
Otherwise, signal an error."
100 101 102 103 104
  (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)))))
105

106 107 108 109
(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)))
110 111

(defun* call-with-input-file (pathname thunk
112 113 114
                             &key (element-type *default-stream-element-type*)
                             (external-format :default))
  "Open FILE for input with given options, call THUNK with the resulting stream."
115
  #+gcl<2.7 (declare (ignore external-format))
116
  (with-open-file (s pathname :direction :input
117 118
                     :element-type element-type
                     #-gcl<2.7 :external-format #-gcl<2.7 external-format
119 120 121 122 123 124 125 126
                     :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))


127
;;; Ensure output buffers are flushed
128

129 130 131 132 133
(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
134 135
                     (list *stderr* *error-output* *standard-output* *trace-output*
                           *debug-io* *terminal-io* *debug-io* *query-io*)))
136 137
    (ignore-errors (finish-output s)))
  (values))
138

139 140 141 142 143
(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))
144

145 146 147 148
(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
149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171


;;; 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))))))

172
(defun* copy-stream-to-stream-line-by-line (input output &key prefix)
173 174 175 176 177 178 179 180 181 182 183
  "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)))))

184
(defun* slurp-stream-string (input &key (element-type 'character))
185 186 187 188 189
  "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))))

190
(defun* slurp-stream-lines (input)
191 192 193 194
  "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)))

195 196 197
(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"
198 199 200 201 202
  (with-open-stream (input input)
    (loop :with eof = '#:eof
      :for form = (read input nil eof)
      :until (eq form eof) :collect form)))

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

207 208 209
(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"
210 211
  (apply 'call-with-input-file file 'slurp-stream-lines keys))

212 213 214
(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"
215 216
  (apply 'call-with-input-file file 'slurp-stream-forms keys))

217 218 219 220
(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)
221
    (read-preserving-whitespace in eof-error-p eof-value)))
222

223 224 225
(defun* safe-read-first-file-form (pathname &key
                                            (package :cl)
                                            eof-error-p eof-value)
226 227 228 229 230 231 232 233 234 235 236 237 238
  "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)))))

239 240 241 242 243 244
(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))))

245 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

;;; 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))