stream.lisp 35.8 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
Robert Goldman's avatar
Robert Goldman committed
166
 (with-upgradability ()
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
  (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))

188
  (defun call-with-output (output function &key (element-type 'character))
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 of given ELEMENT-TYPE as the stream, and
return the resulting string.
194
If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
195
196
If OUTPUT is a STRING with a fill-pointer, use it as a STRING-OUTPUT-STREAM of given ELEMENT-TYPE.
If OUTPUT is a PATHNAME, open the file and write to it, passing ELEMENT-TYPE to WITH-OUTPUT-FILE
197
-- this latter as an extension since ASDF 3.1.
Robert Goldman's avatar
Robert Goldman committed
198
\(Proper ELEMENT-TYPE treatment since ASDF 3.3.4 only.\)
199
Otherwise, signal an error."
200
201
    (etypecase output
      (null
202
       (with-output-to-string (stream nil :element-type element-type) (funcall function stream)))
203
204
205
206
207
208
      ((eql t)
       (funcall function *standard-output*))
      (stream
       (funcall function output))
      (string
       (assert (fill-pointer output))
209
       (with-output-to-string (stream output :element-type element-type) (funcall function stream)))
210
      (pathname
Robert Goldman's avatar
Robert Goldman committed
211
       (call-with-output-file output function :element-type element-type)))))
212

Robert Goldman's avatar
Robert Goldman committed
213
214
215
216
217
(with-upgradability ()
  (locally (declare #+sbcl (sb-ext:muffle-conditions style-warning))
    (handler-bind (#+sbcl (style-warning #'muffle-warning))
      (defmacro with-output ((output-var &optional (value output-var) &key element-type) &body body)
        "Bind OUTPUT-VAR to an output stream obtained from VALUE (default: previous binding
218
219
of OUTPUT-VAR) treated as a stream designator per CALL-WITH-OUTPUT. Evaluate BODY in
the scope of this binding."
Robert Goldman's avatar
Robert Goldman committed
220
221
222
223
224
225
226
227
        `(call-with-output ,value #'(lambda (,output-var) ,@body)
                           ,@(when element-type `(:element-type ,element-type)))))))

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

229
230

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

245
246
247
248
249
250
  (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))

251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
  (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."
272
273
274
275
276
277
278
279
    `(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)))))
280

281
282
283
;;; Null device
(with-upgradability ()
  (defun null-device-pathname ()
284
285
    "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
286
    (os-cond
287
288
289
      ((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"))))
290
291
292
  (defun call-with-null-input (fun &key element-type external-format if-does-not-exist)
    "Call FUN with an input stream that always returns end of file.
The keyword arguments are allowed for backward compatibility, but are ignored."
293
    (declare (ignore element-type external-format if-does-not-exist))
294
295
    (with-open-stream (input (make-concatenated-stream))
      (funcall fun input)))
296
297
298
299
  (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))
300
301
    "Evaluate BODY in a context when VAR is bound to an input stream that always returns end of file.
The keyword arguments are allowed for backward compatibility, but are ignored."
302
303
304
305
306
307
    `(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))
308
309
310
311
312
    (declare (ignore element-type external-format if-exists if-does-not-exist))
    "Call FUN with an output stream that discards all output.
The keyword arguments are allowed for backward compatibility, but are ignored."
    (with-open-stream (output (make-broadcast-stream))
      (funcall fun output)))
313
314
315
  (defmacro with-null-output ((var &rest keys
                              &key element-type external-format if-does-not-exist if-exists)
                              &body body)
316
317
    "Evaluate BODY in a context when VAR is bound to an output stream that discards all output.
The keyword arguments are allowed for backward compatibility, but are ignored."
318
319
320
    (declare (ignore element-type external-format if-exists if-does-not-exist))
    `(call-with-null-output #'(lambda (,var) ,@body) ,@keys)))

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

333
334
335
336
  (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)
337
    (finish-outputs stream))
338

339
  (defun safe-format! (stream format &rest args)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
340
341
    "Variant of FORMAT that is safe against both
dangerous syntax configuration and errors while printing."
342
343
344
    (with-safe-io-syntax ()
      (ignore-errors (apply 'format! stream format args))
      (finish-outputs stream)))) ; just in case format failed
345
346
347


;;; Simple Whole-Stream processing
348
349
350
(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.
351
352
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."
353
354
    (with-open-stream (input input)
      (if linewise
355
356
357
358
359
360
361
          (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)))
362
363
          (loop
            :with buffer-size = (or buffer-size 8192)
364
            :with buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
365
366
367
368
369
370
            :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
371
    "create a new OUTPUT file the contents of which a the concatenate of the INPUTS files."
372
373
374
375
376
377
378
    (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))))))

379
  (defun copy-file (input output)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
380
    "Copy contents of the INPUT file to the OUTPUT file"
381
    ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
382
383
    #+allegro
    (excl.osi:copy-file input output)
384
385
386
    #+ecl
    (ext:copy-file input output)
    #-(or allegro ecl)
387
388
    (concatenate-files (list input) output))

389
  (defun slurp-stream-string (input &key (element-type 'character) stripped)
390
    "Read the contents of the INPUT stream as a string"
391
392
    (let ((string
            (with-open-stream (input input)
393
              (with-output-to-string (output nil :element-type element-type)
394
395
                (copy-stream-to-stream input output :element-type element-type)))))
      (if stripped (stripln string) string)))
396
397
398

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

400
401
402
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.

403
Read no more than COUNT lines."
404
405
406
407
408
    (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))
409
410
            ;; stripln: to remove CR when the OS sends CRLF and Lisp only remove LF
            :while l :collect (stripln l))))
411
412
413

  (defun slurp-stream-line (input &key (at 0))
    "Read the contents of the INPUT stream as a list of lines,
414
then return the ACCESS-AT of that list of lines using the AT specifier.
415
416
417
418
419
420
421
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."
422
    (access-at (slurp-stream-lines input :count (access-at-count at)) at))
423

424
425
  (defun slurp-stream-forms (input &key count)
    "Read the contents of the INPUT stream as a list of forms,
426
427
428
429
430
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.

431
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
432
433
434
435
436
437
438
439
440
441
    (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,
442
443
444
445
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.
446
447
448
449
450
451

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

454
455
456
  (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))
457

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

463
464
465
466
467
468
469
470
  (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)))

471
472
  (defun read-file-forms (file &rest keys &key count &allow-other-keys)
    "Open input FILE with option KEYS (except COUNT),
473
and read its contents as per SLURP-STREAM-FORMS with given COUNT.
Robert Goldman's avatar
Robert Goldman committed
474
475
If COUNT is null, read to the end of the stream;
if COUNT is an integer, stop after COUNT forms were read.
476
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
477
478
479
    (apply 'call-with-input-file file
           #'(lambda (input) (slurp-stream-forms input :count count))
           (remove-plist-key :count keys)))
480

481
482
  (defun read-file-form (file &rest keys &key (at 0) &allow-other-keys)
    "Open input FILE with option KEYS (except AT),
483
and read its contents as per SLURP-STREAM-FORM with given AT specifier.
484
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
485
486
487
    (apply 'call-with-input-file file
           #'(lambda (input) (slurp-stream-form input :at at))
           (remove-plist-key :at keys)))
488

489
490
491
492
493
494
495
  (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))))

496
497
  (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.
498
499
Extracts the form using READ-FILE-FORM,
within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
500
501
502
503
504
505
506
507
508
509
    (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)))
510
            :finally (return (values-list results)))))
511
512
513

  (defun eval-thunk (thunk)
    "Evaluate a THUNK of code:
514
515
516
517
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."
518
519
520
521
522
523
524
525
526
527
528
529
530
531
    (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))))))

532
533
(with-upgradability ()
  (defun println (x &optional (stream *standard-output*))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
534
    "Variant of PRINC that also calls TERPRI afterwards"
535
    (princ x stream) (terpri stream) (finish-output stream) (values))
536
537

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

541

542
;;; Using temporary files
543
544
(with-upgradability ()
  (defun default-temporary-directory ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
545
    "Return a default directory to use for temporary files"
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
546
547
    (os-cond
      ((os-unix-p)
548
549
       (or (getenv-pathname "TMPDIR" :ensure-directory t)
           (parse-native-namestring "/tmp/")))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
550
      ((os-windows-p)
551
       (getenv-pathname "TEMP" :ensure-directory t))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
552
      (t (subpathname (user-homedir-pathname) "tmp/"))))
553

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
554
  (defvar *temporary-directory* nil "User-configurable location for temporary files")
555
556

  (defun temporary-directory ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
557
    "Return a directory to use for temporary files"
558
559
560
    (or *temporary-directory* (default-temporary-directory)))

  (defun setup-temporary-directory ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
561
    "Configure a default temporary directory to use."
562
    (setf *temporary-directory* (default-temporary-directory))
563
    #+gcl (setf system::*tmp-dir* *temporary-directory*))
564
565
566

  (defun call-with-temporary-file
      (thunk &key
567
               (want-stream-p t) (want-pathname-p t) (direction :io) keep after
568
               directory (type "tmp" typep) prefix (suffix (when typep "-tmp"))
569
               (element-type *default-stream-element-type*)
570
               (external-format *utf-8-external-format*))
571
572
573
    "Call a THUNK with stream and/or pathname arguments identifying a temporary file.

The temporary file's pathname will be based on concatenating
574
PREFIX (or \"tmp\" if it's NIL), a random alphanumeric string,
575
576
and optional SUFFIX (defaults to \"-tmp\" if a type was provided)
and TYPE (defaults to \"tmp\", using a dot as separator if not NIL),
577
578
579
580
581
582
583
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),
584
and stream will be closed after the THUNK exits (either normally or abnormally).
585
586
587
588
589
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."
590
    #+xcl (declare (ignorable typep))
591
    (check-type direction (member :output :io))
592
    (assert (or want-stream-p want-pathname-p))
593
    (loop
594
595
      :with prefix-pn = (ensure-absolute-pathname
                         (or prefix "tmp")
596
597
598
599
600
                         (or (ensure-pathname
                              directory
                              :namestring :native
                              :ensure-directory t
                              :ensure-physical t)
601
602
603
604
                             #'temporary-directory))
      :with prefix-nns = (native-namestring prefix-pn)
      :with results = (progn (ensure-directories-exist prefix-pn)
                             ())
605
      :for counter :from (random (expt 36 #-gcl 8 #+gcl 5))
606
      :for pathname = (parse-native-namestring
607
                       (format nil "~A~36R~@[~A~]~@[.~A~]"
608
                               prefix-nns counter suffix (unless (eq type :unspecific) type)))
609
      :for okp = nil :do
610
611
        ;; TODO: on Unix, do something about umask
        ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
612
613
614
        ;; 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?
615
        (unwind-protect
616
             (progn
617
               (ensure-directories-exist pathname)
618
619
620
               (with-open-file (stream pathname
                                       :direction direction
                                       :element-type element-type
621
                                       :external-format external-format
622
623
624
625
                                       :if-exists nil :if-does-not-exist :create)
                 (when stream
                   (setf okp pathname)
                   (when want-stream-p
626
627
628
629
                     ;; 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
630
631
                                        (call-function thunk stream pathname)
                                        (call-function thunk stream)))))))
Robert Goldman's avatar
Robert Goldman committed
632
633
634
635
               ;; if we don't want a stream, then we must call the thunk *after*
               ;; the stream is closed, but only if it was successfully opened.
               (when okp
                 (when (and want-pathname-p (not want-stream-p))
636
                   (setf results (multiple-value-list (call-function thunk okp))))
Robert Goldman's avatar
Robert Goldman committed
637
638
639
640
641
                 ;; if the stream was successfully opened, then return a value,
                 ;; either one computed already, or one from AFTER, if that exists.
                 (if after
                     (return (call-function after pathname))
                     (return (values-list results)))))
642
          (when (and okp (not (call-function keep)))
643
            (ignore-errors (delete-file-if-exists okp))))))
644
645
646

  (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
                                    (pathname (gensym "PATHNAME") pathnamep)
647
648
                                    directory prefix suffix type
                                    keep direction element-type external-format)
649
650
                                 &body body)
    "Evaluate BODY where the symbols specified by keyword arguments
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
651
652
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.
653
654
655
656
657
658
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."
659
660
    (check-type stream symbol)
    (check-type pathname symbol)
661
    (assert (or streamp pathnamep))
662
    (let* ((afterp (position :close-stream body))
663
           (before (if afterp (subseq body 0 afterp) body))
664
665
666
           (after (when afterp (subseq body (1+ afterp))))
           (beforef (gensym "BEFORE"))
           (afterf (gensym "AFTER")))
667
668
      (when (eql afterp 0)
        (style-warn ":CLOSE-STREAM should not be the first form of BODY in WITH-TEMPORARY-FILE. Instead, do not provide a STREAM."))
669
      `(flet (,@(when before
670
671
672
                  `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname)))
                       ,@(when after `((declare (ignorable ,pathname))))
                       ,@before)))
673
674
675
676
677
678
679
680
681
682
683
684
              ,@(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))
685
          ,@(when type `(:type ,type))
686
          ,@(when keep `(:keep ,keep))
687
          ,@(when after `(:after #',afterf))
688
689
690
          ,@(when element-type `(:element-type ,element-type))
          ,@(when external-format `(:external-format ,external-format))))))

691
692
  (defun get-temporary-file (&key directory prefix suffix type (keep t))
    (with-temporary-file (:pathname pn :keep keep
693
                          :directory directory :prefix prefix :suffix suffix :type type)
694
695
      pn))

696
  ;; Temporary pathnames in simple cases where no contention is assumed
697
698
699
700
701
  (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))
702
703

  (defun tmpize-pathname (x)
704
705
706
    "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."
707
    (let* ((px (ensure-pathname x :ensure-physical t))
708
           (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp"))
709
           (directory (pathname-directory-pathname px)))
710
711
712
713
714
715
716
717
      ;; Genera uses versioned pathnames -- If we leave the empty file in place,
      ;; the system will create a new version of the file when the caller opens
      ;; it for output. That empty file will remain after the operation is completed.
      ;; As Genera is a single core processor, the possibility of a name conflict is
      ;; minimal if not nil. (And, in the event of a collision, the two processes
      ;; would be writing to different versions of the file.)
      (get-temporary-file :directory directory :prefix prefix :type (pathname-type px)
                          #+genera :keep #+genera nil)))
718
719

  (defun call-with-staging-pathname (pathname fun)
720
721
722
723
    "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."
724
725
726
727
728
729
730
731
732
    (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)
733
    "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
734
    `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
Elias Pipping's avatar
Elias Pipping committed
735
736
737
738
739
740
741
742
743

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