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

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

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

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

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

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

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

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

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

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

79

80
81
;;; Encodings (mostly hooks only; full support requires asdf-encodings)
(with-upgradability ()
82
83
84
85
86
  (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)
87
    "Default encoding for source files.
88
89
The default value :utf-8 is the portable thing.
The legacy behavior was :default.
90
91
If you (asdf:load-system :asdf-encodings) then
you will have autodetection via *encoding-detection-hook* below,
92
93
94
95
reading emacs-style -*- coding: utf-8 -*- specifications,
and falling back to utf-8 or latin1 if nothing is specified.")

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

  (defun default-encoding-external-format (encoding)
122
123
124
    "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."
125
126
127
128
129
130
131
132
133
    (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
134
135
    "Hook for an extension (e.g. ASDF-ENCODINGS) to define a better mapping
from non-default encodings to and implementation-defined external-format's")
136
137

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


143
;;; Safe syntax
144
(with-upgradability ()
145
146
147
  (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.")
148

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

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

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

166
;;; Output helpers
167
(with-upgradability ()
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
  (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)
190
    "Calls FUNCTION with an actual stream argument,
191
behaving like FORMAT with respect to how stream designators are interpreted:
192
If OUTPUT is a STREAM, use it as the stream.
193
194
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.
195
196
197
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.
198
Otherwise, signal an error."
199
200
201
202
203
204
205
206
207
    (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))
208
209
210
       (with-output-to-string (stream output) (funcall function stream)))
      (pathname
       (apply 'call-with-output-file output function keys))))
211
212
213

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

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

223
224

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

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

245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
  (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."
266
267
268
269
270
271
272
273
    `(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)))))
274

275
276
277
;;; Null device
(with-upgradability ()
  (defun null-device-pathname ()
278
279
    "Pathname to a bit bucket device that discards any information written to it
and always returns EOF when read from"
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
280
    (os-cond
281
282
283
284
      ((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)
285
    "Call FUN with an input stream from the null device; pass keyword arguments to OPEN."
286
287
288
289
290
291
    (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))
292
293
    "Evaluate BODY in a context when VAR is bound to an input stream accessing the null device.
Pass keyword arguments to OPEN."
294
295
296
297
298
299
    `(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))
300
    "Call FUN with an output stream to the null device; pass keyword arguments to OPEN."
301
302
303
304
305
306
307
    (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)
308
309
    "Evaluate BODY in a context when VAR is bound to an output stream accessing the null device.
Pass keyword arguments to OPEN."
310
311
312
    (declare (ignore element-type external-format if-exists if-does-not-exist))
    `(call-with-null-output #'(lambda (,var) ,@body) ,@keys)))

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

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

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


;;; Simple Whole-Stream processing
340
341
342
(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.
343
344
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."
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
    (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)
            :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))))))

  (defun concatenate-files (inputs output)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
363
    "create a new OUTPUT file the contents of which a the concatenate of the INPUTS files."
364
365
366
367
368
369
370
    (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))))))

371
  (defun copy-file (input output)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
372
    "Copy contents of the INPUT file to the OUTPUT file"
373
374
375
    ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
    (concatenate-files (list input) output))

376
  (defun slurp-stream-string (input &key (element-type 'character) stripped)
377
    "Read the contents of the INPUT stream as a string"
378
379
380
381
382
    (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)))
383
384
385

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

387
388
389
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.

390
Read no more than COUNT lines."
391
392
393
394
395
    (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))
396
397
            ;; stripln: to remove CR when the OS sends CRLF and Lisp only remove LF
            :while l :collect (stripln l))))
398
399
400

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

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

418
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
419
420
421
422
423
424
425
426
427
428
    (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,
429
430
431
432
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.
433
434
435
436
437
438

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

441
442
443
  (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))
444

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

450
451
452
453
454
455
456
457
  (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)))

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

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

474
475
476
477
478
479
480
  (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))))

481
482
  (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.
483
484
Extracts the form using READ-FILE-FORM,
within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
485
486
487
488
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)))
            :finally (return (apply 'values results)))))

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

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

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

526

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

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
539
  (defvar *temporary-directory* nil "User-configurable location for temporary files")
540
541

  (defun temporary-directory ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
542
    "Return a directory to use for temporary files"
543
544
545
    (or *temporary-directory* (default-temporary-directory)))

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

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

The temporary file's pathname will be based on concatenating
559
PREFIX (defaults to \"uiop\"), a random alphanumeric string,
560
561
and optional SUFFIX (defaults to \"-tmp\" if a type was provided)
and TYPE (defaults to \"tmp\", using a dot as separator if not NIL),
562
563
564
565
566
567
568
569
570
571
572
573
574
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),
and stream with be closed after the THUNK exits (either normally or abnormally).
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."
575
    #+xcl (declare (ignorable typep))
576
    (check-type direction (member :output :io))
577
    (assert (or want-stream-p want-pathname-p))
578
    (loop
579
580
581
582
583
      :with prefix = (native-namestring
                      (ensure-absolute-pathname
                       (or prefix "tmp")
                       (or (ensure-pathname directory :namestring :native :ensure-directory t)
                           #'temporary-directory)))
584
      :with results = ()
585
      :for counter :from (random (expt 36 #-gcl 8 #+gcl 5))
586
      :for pathname = (parse-native-namestring
587
588
                       (format nil "~A~36R~@[~A~]~@[.~A~]"
                               prefix counter suffix (unless (eq type :unspecific) type)))
589
      :for okp = nil :do
590
591
        ;; TODO: on Unix, do something about umask
        ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
592
593
594
        ;; 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?
595
        (unwind-protect
596
597
598
599
             (progn
               (with-open-file (stream pathname
                                       :direction direction
                                       :element-type element-type
600
                                       :external-format external-format
601
602
603
604
                                       :if-exists nil :if-does-not-exist :create)
                 (when stream
                   (setf okp pathname)
                   (when want-stream-p
605
606
607
608
609
610
611
612
613
614
615
                     ;; 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)))
                 (t (return (apply 'values results)))))
616
          (when (and okp (not (call-function keep)))
617
            (ignore-errors (delete-file-if-exists okp))))))
618
619
620

  (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
                                    (pathname (gensym "PATHNAME") pathnamep)
621
622
                                    directory prefix suffix type
                                    keep direction element-type external-format)
623
624
                                 &body body)
    "Evaluate BODY where the symbols specified by keyword arguments
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
625
626
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.
627
628
629
630
631
632
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."
633
634
    (check-type stream symbol)
    (check-type pathname symbol)
635
    (assert (or streamp pathnamep))
636
    (let* ((afterp (position :close-stream body))
637
           (before (if afterp (subseq body 0 afterp) body))
638
639
640
641
           (after (when afterp (subseq body (1+ afterp))))
           (beforef (gensym "BEFORE"))
           (afterf (gensym "AFTER")))
      `(flet (,@(when before
642
643
644
                  `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname)))
                       ,@(when after `((declare (ignorable ,pathname))))
                       ,@before)))
645
646
647
648
649
650
651
652
653
654
655
656
              ,@(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))
657
          ,@(when type `(:type ,type))
658
          ,@(when keep `(:keep ,keep))
659
          ,@(when after `(:after #',afterf))
660
661
662
663
664
665
          ,@(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)
666
667
      pn))

668
  ;; Temporary pathnames in simple cases where no contention is assumed
669
670
671
672
673
  (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))
674
675

  (defun tmpize-pathname (x)
676
677
678
679
680
681
682
    "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."
    (let* ((px (ensure-pathname x))
           (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp")))
      (get-temporary-file
       :directory (pathname-directory-pathname px) :prefix prefix :type (pathname-type px))))
683
684

  (defun call-with-staging-pathname (pathname fun)
685
686
687
688
    "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."
689
690
691
692
693
694
695
696
697
    (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)
698
    "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
699
    `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))