stream.lisp 33.9 KB
Newer Older
1 2 3
;;;; ---------------------------------------------------------------------------
;;;; Utilities related to streams

4 5
(uiop/package:define-package :uiop/stream
  (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem)
6
  (:export
7 8
   #:*default-stream-element-type*
   #:*stdin* #:setup-stdin #:*stdout* #:setup-stdout #:*stderr* #:setup-stderr
9 10 11
   #: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*
12
   #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
13
   #:with-output #:output-string #:with-input #:input-string
14
   #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file
15 16
   #:null-device-pathname #:call-with-null-input #:with-null-input
   #:call-with-null-output #:with-null-output
17
   #:finish-outputs #:format! #:safe-format!
18
   #:copy-stream-to-stream #:concatenate-files #:copy-file
19 20
   #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
   #:slurp-stream-forms #:slurp-stream-form
21 22
   #:read-file-string #:read-file-line #:read-file-lines #:safe-read-file-line
   #:read-file-forms #:read-file-form #:safe-read-file-form
23
   #:eval-input #:eval-thunk #:standard-eval-thunk
24
   #:println #:writeln
Elias Pipping's avatar
Elias Pipping committed
25
   #:file-stream-p #:file-or-synonym-stream-p
26
   ;; Temporary files
27 28 29 30 31
   #:*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))
32
(in-package :uiop/stream)
33

34
(with-upgradability ()
35
  (defvar *default-stream-element-type*
36
    (or #+(or abcl cmucl cormanlisp scl xcl) 'character
37 38
        #+lispworks 'lw:simple-char
        :default)
39
    "default element-type for open (depends on the current CL implementation)")
40

41 42 43 44
  (defvar *stdin* *standard-input*
    "the original standard input stream at startup")

  (defun setup-stdin ()
45 46
    (setf *stdin*
          #.(or #+clozure 'ccl::*stdin*
47
                #+(or cmucl scl) 'system:*stdin*
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
48
                #+(or clasp ecl) 'ext::+process-standard-input+
49 50
                #+sbcl 'sb-sys:*stdin*
                '*standard-input*)))
51 52 53 54 55

  (defvar *stdout* *standard-output*
    "the original standard output stream at startup")

  (defun setup-stdout ()
56 57
    (setf *stdout*
          #.(or #+clozure 'ccl::*stdout*
58
                #+(or cmucl scl) 'system:*stdout*
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
59
                #+(or clasp ecl) 'ext::+process-standard-output+
60 61
                #+sbcl 'sb-sys:*stdout*
                '*standard-output*)))
62

63 64
  (defvar *stderr* *error-output*
    "the original error output stream at startup")
65

66 67
  (defun setup-stderr ()
    (setf *stderr*
68
          #.(or #+allegro 'excl::*stderr*
69
                #+clozure 'ccl::*stderr*
70
                #+(or cmucl scl) 'system:*stderr*
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
71
                #+(or clasp ecl) 'ext::+process-error-output+
72 73
                #+sbcl 'sb-sys:*stderr*
                '*error-output*)))
74

75
  ;; Run them now. In image.lisp, we'll register them to be run at image restart.
76
  (setup-stdin) (setup-stdout) (setup-stderr))
77

78

79 80
;;; Encodings (mostly hooks only; full support requires asdf-encodings)
(with-upgradability ()
81 82 83 84 85
  (defparameter *default-encoding*
    ;; preserve explicit user changes to something other than the legacy default :default
    (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*)))
          (unless (eq previous :default) previous))
        :utf-8)
86
    "Default encoding for source files.
87 88
The default value :utf-8 is the portable thing.
The legacy behavior was :default.
89 90
If you (asdf:load-system :asdf-encodings) then
you will have autodetection via *encoding-detection-hook* below,
91 92 93 94
reading emacs-style -*- coding: utf-8 -*- specifications,
and falling back to utf-8 or latin1 if nothing is specified.")

  (defparameter *utf-8-external-format*
95 96 97
    (if (featurep :asdf-unicode)
        (or #+clisp charset:utf-8 :utf-8)
        :default)
98 99 100 101 102 103 104 105
    "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)
106 107
    "Trivial function to use as *encoding-detection-hook*,
always 'detects' the *default-encoding*"
108 109 110 111 112 113 114
    (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)
115
    "Detects the encoding of a specified file, going through user-configurable hooks"
116 117 118 119 120
    (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname))
        (funcall *encoding-detection-hook* pathname)
        *default-encoding*))

  (defun default-encoding-external-format (encoding)
121 122 123
    "Default, ignorant, function to transform a character ENCODING as a
portable keyword to an implementation-dependent EXTERNAL-FORMAT specification.
Load system ASDF-ENCODINGS to hook in a better one."
124 125 126 127 128 129 130 131 132
    (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
133 134
    "Hook for an extension (e.g. ASDF-ENCODINGS) to define a better mapping
from non-default encodings to and implementation-defined external-format's")
135 136

  (defun encoding-external-format (encoding)
137 138
    "Transform a portable ENCODING keyword to an implementation-dependent EXTERNAL-FORMAT,
going through all the proper hooks."
139
    (funcall *encoding-external-format-hook* (or encoding *default-encoding*))))
140 141


142
;;; Safe syntax
143
(with-upgradability ()
144 145 146
  (defvar *standard-readtable* (with-standard-io-syntax *readtable*)
    "The standard readtable, implementing the syntax specified by the CLHS.
It must never be modified, though only good implementations will even enforce that.")
147

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

152 153 154 155 156 157
  (defun call-with-safe-io-syntax (thunk &key (package :cl))
    (with-standard-io-syntax
      (let ((*package* (find-package package))
            (*read-default-float-format* 'double-float)
            (*print-readably* nil)
            (*read-eval* nil))
158 159 160
        (funcall thunk))))

  (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace)
161
    "Read from STRING using a safe syntax, as per WITH-SAFE-IO-SYNTAX"
162 163
    (with-safe-io-syntax (:package package)
      (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace))))
164

165
;;; Output helpers
166
(with-upgradability ()
167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188
  (defun call-with-output-file (pathname thunk
                                &key
                                  (element-type *default-stream-element-type*)
                                  (external-format *utf-8-external-format*)
                                  (if-exists :error)
                                  (if-does-not-exist :create))
    "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
Other keys are accepted but discarded."
    (with-open-file (s pathname :direction :output
                                :element-type element-type
                                :external-format external-format
                                :if-exists if-exists
                                :if-does-not-exist if-does-not-exist)
      (funcall thunk s)))

  (defmacro with-output-file ((var pathname &rest keys
                               &key element-type external-format if-exists if-does-not-exist)
                              &body body)
    (declare (ignore element-type external-format if-exists if-does-not-exist))
    `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys))

  (defun call-with-output (output function &key keys)
189
    "Calls FUNCTION with an actual stream argument,
190
behaving like FORMAT with respect to how stream designators are interpreted:
191
If OUTPUT is a STREAM, use it as the stream.
192 193
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.
194 195 196
If OUTPUT is a STRING with a fill-pointer, use it as a string-output-stream.
If OUTPUT is a PATHNAME, open the file and write to it, passing KEYS to WITH-OUTPUT-FILE
-- this latter as an extension since ASDF 3.1.
197
Otherwise, signal an error."
198 199 200 201 202 203 204 205 206
    (etypecase output
      (null
       (with-output-to-string (stream) (funcall function stream)))
      ((eql t)
       (funcall function *standard-output*))
      (stream
       (funcall function output))
      (string
       (assert (fill-pointer output))
207 208 209
       (with-output-to-string (stream output) (funcall function stream)))
      (pathname
       (apply 'call-with-output-file output function keys))))
210 211 212

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

216 217 218 219 220
  (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))
        string)))
221

222 223

;;; Input helpers
224 225 226 227
(with-upgradability ()
  (defun call-with-input-file (pathname thunk
                               &key
                                 (element-type *default-stream-element-type*)
228
                                 (external-format *utf-8-external-format*)
229 230
                                 (if-does-not-exist :error))
    "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
231
Other keys are accepted but discarded."
232 233
    (with-open-file (s pathname :direction :input
                                :element-type element-type
234
                                :external-format external-format
235 236
                                :if-does-not-exist if-does-not-exist)
      (funcall thunk s)))
237

238 239 240 241 242 243
  (defmacro with-input-file ((var pathname &rest keys
                              &key element-type external-format if-does-not-exist)
                             &body body)
    (declare (ignore element-type external-format if-does-not-exist))
    `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))

244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264
  (defun call-with-input (input function &key keys)
    "Calls FUNCTION with an actual stream argument, interpreting
stream designators like READ, but also coercing strings to STRING-INPUT-STREAM,
and PATHNAME to FILE-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.
If INPUT is a STRING, use it as a string-input-stream.
If INPUT is a PATHNAME, open it, passing KEYS to WITH-INPUT-FILE
-- the latter is an extension since ASDF 3.1.
Otherwise, signal an error."
    (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)))
      (pathname (apply 'call-with-input-file input function keys))))

  (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."
265 266 267 268 269 270 271 272
    `(call-with-input ,value #'(lambda (,input-var) ,@body)))

  (defun input-string (&optional input)
    "If the desired INPUT is a string, return that string; otherwise slurp the INPUT into a string
and return that"
    (if (stringp input)
        input
        (with-input (input) (funcall 'slurp-stream-string input)))))
273

274 275 276
;;; Null device
(with-upgradability ()
  (defun null-device-pathname ()
277 278
    "Pathname to a bit bucket device that discards any information written to it
and always returns EOF when read from"
279
    (os-cond
280 281 282 283
      ((os-unix-p) #p"/dev/null")
      ((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax?
      (t (error "No /dev/null on your OS"))))
  (defun call-with-null-input (fun &rest keys &key element-type external-format if-does-not-exist)
284
    "Call FUN with an input stream from the null device; pass keyword arguments to OPEN."
285 286 287 288 289 290
    (declare (ignore element-type external-format if-does-not-exist))
    (apply 'call-with-input-file (null-device-pathname) fun keys))
  (defmacro with-null-input ((var &rest keys
                              &key element-type external-format if-does-not-exist)
                             &body body)
    (declare (ignore element-type external-format if-does-not-exist))
291 292
    "Evaluate BODY in a context when VAR is bound to an input stream accessing the null device.
Pass keyword arguments to OPEN."
293 294 295 296 297 298
    `(call-with-null-input #'(lambda (,var) ,@body) ,@keys))
  (defun call-with-null-output (fun
                                &key (element-type *default-stream-element-type*)
                                  (external-format *utf-8-external-format*)
                                  (if-exists :overwrite)
                                  (if-does-not-exist :error))
299
    "Call FUN with an output stream to the null device; pass keyword arguments to OPEN."
300 301 302 303 304 305 306
    (call-with-output-file
     (null-device-pathname) fun
     :element-type element-type :external-format external-format
     :if-exists if-exists :if-does-not-exist if-does-not-exist))
  (defmacro with-null-output ((var &rest keys
                              &key element-type external-format if-does-not-exist if-exists)
                              &body body)
307 308
    "Evaluate BODY in a context when VAR is bound to an output stream accessing the null device.
Pass keyword arguments to OPEN."
309 310 311
    (declare (ignore element-type external-format if-exists if-does-not-exist))
    `(call-with-null-output #'(lambda (,var) ,@body) ,@keys)))

312
;;; Ensure output buffers are flushed
313 314 315
(with-upgradability ()
  (defun finish-outputs (&rest streams)
    "Finish output on the main output streams as well as any specified one.
316
Useful for portably flushing I/O before user input or program exit."
317 318
    ;; CCL notably buffers its stream output by default.
    (dolist (s (append streams
319 320
                       (list *stdout* *stderr* *error-output* *standard-output* *trace-output*
                             *debug-io* *terminal-io* *query-io*)))
321 322
      (ignore-errors (finish-output s)))
    (values))
323

324 325 326 327
  (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)
328
    (finish-outputs stream))
329

330
  (defun safe-format! (stream format &rest args)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
331 332
    "Variant of FORMAT that is safe against both
dangerous syntax configuration and errors while printing."
333 334 335
    (with-safe-io-syntax ()
      (ignore-errors (apply 'format! stream format args))
      (finish-outputs stream)))) ; just in case format failed
336 337 338


;;; Simple Whole-Stream processing
339 340 341
(with-upgradability ()
  (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.
342 343
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."
344 345 346 347 348 349 350 351 352 353 354
    (with-open-stream (input input)
      (if linewise
          (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)))
          (loop
            :with buffer-size = (or buffer-size 8192)
355
            :with buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
356 357 358 359 360 361
            :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)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
362
    "create a new OUTPUT file the contents of which a the concatenate of the INPUTS files."
363 364 365 366 367 368 369
    (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))))))

370
  (defun copy-file (input output)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
371
    "Copy contents of the INPUT file to the OUTPUT file"
372
    ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
373 374
    #+allegro
    (excl.osi:copy-file input output)
375 376 377
    #+ecl
    (ext:copy-file input output)
    #-(or allegro ecl)
378 379
    (concatenate-files (list input) output))

380
  (defun slurp-stream-string (input &key (element-type 'character) stripped)
381
    "Read the contents of the INPUT stream as a string"
382 383 384 385 386
    (let ((string
            (with-open-stream (input input)
              (with-output-to-string (output)
                (copy-stream-to-stream input output :element-type element-type)))))
      (if stripped (stripln string) string)))
387 388 389

  (defun slurp-stream-lines (input &key count)
    "Read the contents of the INPUT stream as a list of lines, return those lines.
390

391 392 393
Note: relies on the Lisp's READ-LINE, but additionally removes any remaining CR
from the line-ending if the file or stream had CR+LF but Lisp only removed LF.

394
Read no more than COUNT lines."
395 396 397 398 399
    (check-type count (or null integer))
    (with-open-stream (input input)
      (loop :for n :from 0
            :for l = (and (or (not count) (< n count))
                          (read-line input nil nil))
400 401
            ;; stripln: to remove CR when the OS sends CRLF and Lisp only remove LF
            :while l :collect (stripln l))))
402 403 404

  (defun slurp-stream-line (input &key (at 0))
    "Read the contents of the INPUT stream as a list of lines,
405
then return the ACCESS-AT of that list of lines using the AT specifier.
406 407 408 409 410 411 412
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."
413
    (access-at (slurp-stream-lines input :count (access-at-count at)) at))
414

415 416
  (defun slurp-stream-forms (input &key count)
    "Read the contents of the INPUT stream as a list of forms,
417 418 419 420 421
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.

422
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
423 424 425 426 427 428 429 430 431 432
    (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))

  (defun slurp-stream-form (input &key (at 0))
    "Read the contents of the INPUT stream as a list of forms,
433 434 435 436
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.
437 438 439 440 441 442

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"
443
    (access-at (slurp-stream-forms input :count (access-at-count at)) at))
444

445 446 447
  (defun read-file-string (file &rest keys)
    "Open FILE with option KEYS, read its contents as a string"
    (apply 'call-with-input-file file 'slurp-stream-string keys))
448

449 450
  (defun read-file-lines (file &rest keys)
    "Open FILE with option KEYS, read its contents as a list of lines
451
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
452
    (apply 'call-with-input-file file 'slurp-stream-lines keys))
453

454 455 456 457 458 459 460 461
  (defun read-file-line (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-LINE with given AT specifier.
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
    (apply 'call-with-input-file file
           #'(lambda (input) (slurp-stream-line input :at at))
           (remove-plist-key :at keys)))

462 463
  (defun read-file-forms (file &rest keys &key count &allow-other-keys)
    "Open input FILE with option KEYS (except COUNT),
464
and read its contents as per SLURP-STREAM-FORMS with given COUNT.
465
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
466 467 468
    (apply 'call-with-input-file file
           #'(lambda (input) (slurp-stream-forms input :count count))
           (remove-plist-key :count keys)))
469

470 471
  (defun read-file-form (file &rest keys &key (at 0) &allow-other-keys)
    "Open input FILE with option KEYS (except AT),
472
and read its contents as per SLURP-STREAM-FORM with given AT specifier.
473
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
474 475 476
    (apply 'call-with-input-file file
           #'(lambda (input) (slurp-stream-form input :at at))
           (remove-plist-key :at keys)))
477

478 479 480 481 482 483 484
  (defun safe-read-file-line (pathname &rest keys &key (package :cl) &allow-other-keys)
    "Reads the specified line from the top of a file using a safe standardized syntax.
Extracts the line using READ-FILE-LINE,
within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
    (with-safe-io-syntax (:package package)
      (apply 'read-file-line pathname (remove-plist-key :package keys))))

485 486
  (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.
487 488
Extracts the form using READ-FILE-FORM,
within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
489 490 491 492 493 494 495 496 497 498
    (with-safe-io-syntax (:package package)
      (apply 'read-file-form pathname (remove-plist-key :package keys))))

  (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)))
499
            :finally (return (values-list results)))))
500 501 502

  (defun eval-thunk (thunk)
    "Evaluate a THUNK of code:
503 504 505 506
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."
507 508 509 510 511 512 513 514 515 516 517 518 519 520
    (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))))))

521 522
(with-upgradability ()
  (defun println (x &optional (stream *standard-output*))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
523
    "Variant of PRINC that also calls TERPRI afterwards"
524
    (princ x stream) (terpri stream) (finish-output stream) (values))
525 526

  (defun writeln (x &rest keys &key (stream *standard-output*) &allow-other-keys)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
527
    "Variant of WRITE that also calls TERPRI afterwards"
528
    (apply 'write x keys) (terpri stream) (finish-output stream) (values)))
529

530

531
;;; Using temporary files
532 533
(with-upgradability ()
  (defun default-temporary-directory ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
534
    "Return a default directory to use for temporary files"
535 536
    (os-cond
      ((os-unix-p)
537 538
       (or (getenv-pathname "TMPDIR" :ensure-directory t)
           (parse-native-namestring "/tmp/")))
539
      ((os-windows-p)
540
       (getenv-pathname "TEMP" :ensure-directory t))
541
      (t (subpathname (user-homedir-pathname) "tmp/"))))
542

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
543
  (defvar *temporary-directory* nil "User-configurable location for temporary files")
544 545

  (defun temporary-directory ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
546
    "Return a directory to use for temporary files"
547 548 549
    (or *temporary-directory* (default-temporary-directory)))

  (defun setup-temporary-directory ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
550
    "Configure a default temporary directory to use."
551
    (setf *temporary-directory* (default-temporary-directory))
552
    #+gcl (setf system::*tmp-dir* *temporary-directory*))
553 554 555

  (defun call-with-temporary-file
      (thunk &key
556
               (want-stream-p t) (want-pathname-p t) (direction :io) keep after
557
               directory (type "tmp" typep) prefix (suffix (when typep "-tmp"))
558
               (element-type *default-stream-element-type*)
559
               (external-format *utf-8-external-format*))
560 561 562
    "Call a THUNK with stream and/or pathname arguments identifying a temporary file.

The temporary file's pathname will be based on concatenating
563
PREFIX (or \"tmp\" if it's NIL), a random alphanumeric string,
564 565
and optional SUFFIX (defaults to \"-tmp\" if a type was provided)
and TYPE (defaults to \"tmp\", using a dot as separator if not NIL),
566 567 568 569 570 571 572
within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute.

The file will be open with specified DIRECTION (defaults to :IO),
ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and
EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*).
If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed
with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T),
573
and stream will be closed after the THUNK exits (either normally or abnormally).
574 575 576 577 578
If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then
THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument.
Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument.
If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned.
Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true."
579
    #+xcl (declare (ignorable typep))
580
    (check-type direction (member :output :io))
581
    (assert (or want-stream-p want-pathname-p))
582
    (loop
583 584
      :with prefix-pn = (ensure-absolute-pathname
                         (or prefix "tmp")
585 586 587 588 589
                         (or (ensure-pathname
                              directory
                              :namestring :native
                              :ensure-directory t
                              :ensure-physical t)
590 591 592 593
                             #'temporary-directory))
      :with prefix-nns = (native-namestring prefix-pn)
      :with results = (progn (ensure-directories-exist prefix-pn)
                             ())
594
      :for counter :from (random (expt 36 #-gcl 8 #+gcl 5))
595
      :for pathname = (parse-native-namestring
596
                       (format nil "~A~36R~@[~A~]~@[.~A~]"
597
                               prefix-nns counter suffix (unless (eq type :unspecific) type)))
598
      :for okp = nil :do
599 600
        ;; TODO: on Unix, do something about umask
        ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
601 602 603
        ;; TODO: on Unix, use CFFI and mkstemp --
        ;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr.
        ;; Can we at least design some hook?
604
        (unwind-protect
605
             (progn
606
               (ensure-directories-exist pathname)
607 608 609
               (with-open-file (stream pathname
                                       :direction direction
                                       :element-type element-type
610
                                       :external-format external-format
611 612 613 614
                                       :if-exists nil :if-does-not-exist :create)
                 (when stream
                   (setf okp pathname)
                   (when want-stream-p
615 616 617 618 619 620 621 622 623 624
                     ;; Note: can't return directly from within with-open-file
                     ;; or the non-local return causes the file creation to be undone.
                     (setf results (multiple-value-list
                                    (if want-pathname-p
                                        (funcall thunk stream pathname)
                                        (funcall thunk stream)))))))
               (cond
                 ((not okp) nil)
                 (after (return (call-function after okp)))
                 ((and want-pathname-p (not want-stream-p)) (return (call-function thunk okp)))
625
                 (t (return (values-list results)))))
626
          (when (and okp (not (call-function keep)))
627
            (ignore-errors (delete-file-if-exists okp))))))
628 629 630

  (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
                                    (pathname (gensym "PATHNAME") pathnamep)
631 632
                                    directory prefix suffix type
                                    keep direction element-type external-format)
633 634
                                 &body body)
    "Evaluate BODY where the symbols specified by keyword arguments
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
635 636
STREAM and PATHNAME (if respectively specified) are bound corresponding
to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE.
637 638 639 640 641 642
At least one of STREAM or PATHNAME must be specified.
If the STREAM is not specified, it will be closed before the BODY is evaluated.
If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY,
separates forms run before and after the stream is closed.
The values of the last form of the BODY (not counting the separating :CLOSE-STREAM) are returned.
Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE."
643 644
    (check-type stream symbol)
    (check-type pathname symbol)
645
    (assert (or streamp pathnamep))
646
    (let* ((afterp (position :close-stream body))
647
           (before (if afterp (subseq body 0 afterp) body))
648 649 650 651
           (after (when afterp (subseq body (1+ afterp))))
           (beforef (gensym "BEFORE"))
           (afterf (gensym "AFTER")))
      `(flet (,@(when before
652 653 654
                  `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname)))
                       ,@(when after `((declare (ignorable ,pathname))))
                       ,@before)))
655 656 657 658 659 660 661 662 663 664 665 666
              ,@(when after
                  (assert pathnamep)
                  `((,afterf (,pathname) ,@after))))
         #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@(when after `(#',afterf))))
         (call-with-temporary-file
          ,(when before `#',beforef)
          :want-stream-p ,streamp
          :want-pathname-p ,pathnamep
          ,@(when direction `(:direction ,direction))
          ,@(when directory `(:directory ,directory))
          ,@(when prefix `(:prefix ,prefix))
          ,@(when suffix `(:suffix ,suffix))
667
          ,@(when type `(:type ,type))
668
          ,@(when keep `(:keep ,keep))
669
          ,@(when after `(:after #',afterf))
670 671 672 673 674 675
          ,@(when element-type `(:element-type ,element-type))
          ,@(when external-format `(:external-format ,external-format))))))

  (defun get-temporary-file (&key directory prefix suffix type)
    (with-temporary-file (:pathname pn :keep t
                          :directory directory :prefix prefix :suffix suffix :type type)
676 677
      pn))

678
  ;; Temporary pathnames in simple cases where no contention is assumed
679 680 681 682 683
  (defun add-pathname-suffix (pathname suffix &rest keys)
    "Add a SUFFIX to the name of a PATHNAME, return a new pathname.
Further KEYS can be passed to MAKE-PATHNAME."
    (apply 'make-pathname :name (strcat (pathname-name pathname) suffix)
                          :defaults pathname keys))
684 685

  (defun tmpize-pathname (x)
686 687 688
    "Return a new pathname modified from X by adding a trivial random suffix.
A new empty file with said temporary pathname is created, to ensure there is no
clash with any concurrent process attempting the same thing."
689
    (let* ((px (ensure-pathname x :ensure-physical t))
690
           (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp"))
691
           (directory (pathname-directory-pathname px)))
692
      (get-temporary-file :directory directory :prefix prefix :type (pathname-type px))))
693 694

  (defun call-with-staging-pathname (pathname fun)
695 696 697 698
    "Calls FUN with a staging pathname, and atomically
renames the staging pathname to the PATHNAME in the end.
NB: this protects only against failure of the program, not against concurrent attempts.
For the latter case, we ought pick a random suffix and atomically open it."
699 700 701 702 703 704 705 706 707
    (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)
708
    "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
709
    `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
Elias Pipping's avatar
Elias Pipping committed
710 711 712 713 714 715 716 717 718

(with-upgradability ()
  (defun file-stream-p (stream)
    (typep stream 'file-stream))
  (defun file-or-synonym-stream-p (stream)
    (or (file-stream-p stream)
        (and (typep stream 'synonym-stream)
             (file-or-synonym-stream-p
              (symbol-value (synonym-stream-symbol stream)))))))