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

(asdf/package:define-package :asdf/stream
  (:recycle :asdf/stream)
6
  (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname :asdf/filesystem)
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
   #:copy-stream-to-stream #:concatenate-files
   #:copy-stream-to-stream-line-by-line
15 16
   #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
   #:slurp-stream-forms #:slurp-stream-form
17 18
   #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form
   #:eval-input #:eval-thunk #:standard-eval-thunk
19 20
   #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
   #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
21
   #:*default-encoding* #:*utf-8-external-format*
22
   ;; Temporary files
23 24 25 26 27
   #:*temporary-directory* #:temporary-directory #:default-temporary-directory
   #:setup-temporary-directory
   #:call-with-temporary-file #:with-temporary-file
   #:add-pathname-suffix #:tmpize-pathname
   #:call-with-staging-pathname #:with-staging-pathname))
28 29 30 31 32
(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)")

33
(defvar *stderr* *error-output*
34 35
  "the original error output stream at startup")

36
(defun setup-stderr ()
37 38 39 40 41
  (setf *stderr*
        #+allegro excl::*stderr*
        #+clozure ccl::*stderr*
        #-(or allegro clozure) *error-output*))
(setup-stderr)
42

43

44
;;; Safe syntax
45

46 47
(defvar *standard-readtable* (copy-readtable nil))

48 49 50
(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))))
51

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


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

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

83 84
(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)
85
as per FORMAT, and evaluate BODY within the scope of this binding."
86
  `(call-with-output ,value #'(lambda (,output-var) ,@body)))
87

88 89 90 91
(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))
92 93
      string))

94 95 96

;;; Input helpers

97 98 99 100 101 102 103
(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.
104
Otherwise, signal an error."
105 106 107 108 109
  (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)))))
110

111 112 113 114
(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)))
115 116

(defun* call-with-input-file (pathname thunk
117 118 119 120 121 122
                                       &key
                                       (element-type *default-stream-element-type*)
                                       (external-format :default)
                                       (if-does-not-exist :error))
  "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
Other keys are accepted but discarded."
123
  #+gcl2.6 (declare (ignore external-format))
124
  (with-open-file (s pathname :direction :input
125
                     :element-type element-type
126
                     #-gcl2.6 :external-format #-gcl2.6 external-format
127
                     :if-does-not-exist if-does-not-exist)
128 129 130 131 132 133 134
    (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))


135
;;; Ensure output buffers are flushed
136

137 138 139 140 141
(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
142 143
                     (list *stderr* *error-output* *standard-output* *trace-output*
                           *debug-io* *terminal-io* *debug-io* *query-io*)))
144 145
    (ignore-errors (finish-output s)))
  (values))
146

147 148 149 150 151
(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))
152

153 154 155 156
(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
157 158 159 160


;;; Simple Whole-Stream processing

161 162 163 164 165

(defun* copy-stream-to-stream (input output &key element-type buffer-size linewise prefix)
  "Copy the contents of the INPUT stream into the OUTPUT stream.
If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX.
Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
166
  (with-open-stream (input input)
167
    (if linewise
168 169 170 171 172 173 174
        (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)))
175 176 177 178 179 180 181
        (loop
          :with buffer-size = (or buffer-size 8192)
          :for buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
          :for end = (read-sequence buffer input)
          :until (zerop end)
          :do (write-sequence buffer output :end end)
              (when (< end buffer-size) (return))))))
182 183 184 185 186 187 188 189 190

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

191
(defun* slurp-stream-string (input &key (element-type 'character))
192 193 194 195 196
  "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))))

197 198 199 200 201
(defun* slurp-stream-lines (input &key count)
  "Read the contents of the INPUT stream as a list of lines, return those lines.

Read no more than COUNT lines."
  (check-type count (or null integer))
202
  (with-open-stream (input input)
203 204 205 206 207
    (loop :for n :from 0
          :for l = (and (or (not count) (< n count))
                        (read-line input nil nil))
          :while l :collect l)))

208
(defun* slurp-stream-line (input &key (at 0))
209
  "Read the contents of the INPUT stream as a list of lines,
210
then return the ACCESS-AT of that list of lines using the AT specifier.
211 212 213 214 215 216 217
PATH defaults to 0, i.e. return the first line.
PATH is typically an integer, or a list of an integer and a function.
If PATH is NIL, it will return all the lines in the file.

The stream will not be read beyond the Nth lines,
where N is the index specified by path
if path is either an integer or a list that starts with an integer."
218
  (access-at (slurp-stream-lines input :count (access-at-count at)) at))
219

220 221 222 223 224 225 226
(defun* slurp-stream-forms (input &key count)
"Read the contents of the INPUT stream as a list of forms,
and return those forms.

If COUNT is null, read to the end of the stream;
if COUNT is an integer, stop after COUNT forms were read.

227
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
228 229 230 231 232 233 234 235
  (check-type count (or null integer))
  (loop :with eof = '#:eof
        :for n :from 0
        :for form = (if (and count (>= n count))
                        eof
                        (read-preserving-whitespace input nil eof))
        :until (eq form eof) :collect form))

236
(defun* slurp-stream-form (input &key (at 0))
237
"Read the contents of the INPUT stream as a list of forms,
238 239 240 241
then return the ACCESS-AT of these forms following the AT.
AT defaults to 0, i.e. return the first form.
AT is typically a list of integers.
If AT is NIL, it will return all the forms in the file.
242 243 244 245 246 247

The stream will not be read beyond the Nth form,
where N is the index specified by path,
if path is either an integer or a list that starts with an integer.

BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
248
  (access-at (slurp-stream-forms input :count (access-at-count at)) at))
249

250
(defun* read-file-string (file &rest keys)
251 252 253
  "Open FILE with option KEYS, read its contents as a string"
  (apply 'call-with-input-file file 'slurp-stream-string keys))

254 255 256
(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"
257 258
  (apply 'call-with-input-file file 'slurp-stream-lines keys))

259 260 261
(defun* read-file-forms (file &rest keys &key count &allow-other-keys)
  "Open input FILE with option KEYS (except COUNT),
and read its contents as per SLURP-STREAM-FORMS with given COUNT.
262
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
263 264
  (apply 'call-with-input-file file
         #'(lambda (input) (slurp-stream-forms input :count count))
265
         (remove-plist-key :count keys)))
266

267 268 269
(defun* read-file-form (file &rest keys &key (at 0) &allow-other-keys)
  "Open input FILE with option KEYS (except AT),
and read its contents as per SLURP-STREAM-FORM with given AT specifier.
270
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
271
  (apply 'call-with-input-file file
272 273
         #'(lambda (input) (slurp-stream-form input :at at))
         (remove-plist-key :at keys)))
274 275 276 277 278

(defun* safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
  "Reads the specified form from the top of a file using a safe standardized syntax.
Extracts the form using READ-FILE-FORM,
within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
279
  (with-safe-io-syntax (:package package)
280
    (apply 'read-file-form pathname (remove-plist-key :package keys))))
281 282 283 284 285 286 287 288 289 290

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

291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309
(defun* eval-thunk (thunk)
  "Evaluate a THUNK of code:
If a function, FUNCALL it without arguments.
If a constant literal and not a sequence, return it.
If a cons or a symbol, EVAL it.
If a string, repeatedly read and evaluate from it, returning the last values."
  (etypecase thunk
    ((or boolean keyword number character pathname) thunk)
    ((or cons symbol) (eval thunk))
    (function (funcall thunk))
    (string (eval-input thunk))))

(defun* standard-eval-thunk (thunk &key (package :cl))
  "Like EVAL-THUNK, but in a more standardized evaluation context."
  ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
  (when thunk
    (with-safe-io-syntax (:package package)
      (let ((*read-eval* t))
        (eval-thunk thunk)))))
310

311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339

;;; 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)
340
  (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname))
341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359
      (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))

360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393

;;; Using temporary files
(defun* default-temporary-directory ()
  (or
   (when (os-unix-p)
     (or (getenv-pathname "TMPDIR" :ensure-directory t)
         (parse-native-namestring "/tmp/")))
   (when (os-windows-p)
     (getenv-pathname "TEMP" :ensure-directory t))
   (subpathname (user-homedir-pathname) "tmp/")))

(defvar *temporary-directory* nil)

(defun* temporary-directory ()
  (or *temporary-directory* (default-temporary-directory)))

(defun setup-temporary-directory ()
  (setf *temporary-directory* (default-temporary-directory))
  ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1
  #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*))

(defun* call-with-temporary-file
    (thunk &key
     prefix keep (direction :io)
     (element-type *default-stream-element-type*)
     (external-format :default))
  #+gcl2.6 (declare (ignorable external-format))
  (check-type direction (member :output :io))
  (loop
    :with prefix = (or prefix (format nil "~Atmp" (native-namestring (temporary-directory))))
    :for counter :from (random (ash 1 32))
    :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
     ;; TODO: on Unix, do something about umask
     ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
394
     ;; TODO: on Unix, use CFFI and mkstemp -- but asdf/driver is precisely meant to not depend on CFFI or on anything! Grrrr.
395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455
    (with-open-file (stream pathname
                            :direction direction
                            :element-type element-type
                            #-gcl2.6 :external-format #-gcl2.6 external-format
                            :if-exists nil :if-does-not-exist :create)
      (when stream
        (return
          (if keep
              (funcall thunk stream pathname)
              (unwind-protect
                   (funcall thunk stream pathname)
                (ignore-errors (delete-file pathname)))))))))

(defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
                                (pathname (gensym "PATHNAME") pathnamep)
                                prefix keep direction element-type external-format)
                               &body body)
  "Evaluate BODY where the symbols specified by keyword arguments
STREAM and PATHNAME are bound corresponding to a newly created temporary file
ready for I/O. Unless KEEP is specified, delete the file afterwards."
  (check-type stream symbol)
  (check-type pathname symbol)
  `(flet ((think (,stream ,pathname)
            ,@(unless pathnamep `((declare (ignore ,pathname))))
            ,@(unless streamp `((when ,stream (close ,stream))))
            ,@body))
     #-gcl (declare (dynamic-extent #'think))
     (call-with-temporary-file
      #'think
      ,@(when direction `(:direction ,direction))
      ,@(when prefix `(:prefix ,prefix))
      ,@(when keep `(:keep ,keep))
      ,@(when element-type `(:element-type ,element-type))
      ,@(when external-format `(:external-format external-format)))))

;;; Temporary pathnames
(defun* add-pathname-suffix (pathname suffix)
  (make-pathname :name (strcat (pathname-name pathname) suffix)
                 :defaults pathname))

(defun* tmpize-pathname (x)
  (add-pathname-suffix x "-ASDF-TMP"))

(defun* call-with-staging-pathname (pathname fun)
  "Calls fun with a staging pathname, and atomically
renames the staging pathname to the pathname in the end.
Note: this protects only against failure of the program,
not against concurrent attempts.
For the latter case, we ought pick random suffix and atomically open it."
  (let* ((pathname (pathname pathname))
         (staging (tmpize-pathname pathname)))
    (unwind-protect
         (multiple-value-prog1
             (funcall fun staging)
           (rename-file-overwriting-target staging pathname))
      (delete-file-if-exists staging))))

(defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
  `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))