stream.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
stream.lisp (34828B)
---
1 ;;;; ---------------------------------------------------------------------------
2 ;;;; Utilities related to streams
3
4 (uiop/package:define-package :uiop/stream
5 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem)
6 (:export
7 #:*default-stream-element-type*
8 #:*stdin* #:setup-stdin #:*stdout* #:setup-stdout #:*stderr* #:setup-stderr
9 #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
10 #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
11 #:*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 #:null-device-pathname #:call-with-null-input #:with-null-input
16 #:call-with-null-output #:with-null-output
17 #:finish-outputs #:format! #:safe-format!
18 #:copy-stream-to-stream #:concatenate-files #:copy-file
19 #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
20 #:slurp-stream-forms #:slurp-stream-form
21 #:read-file-string #:read-file-line #:read-file-lines #:safe-read-file-line
22 #:read-file-forms #:read-file-form #:safe-read-file-form
23 #:eval-input #:eval-thunk #:standard-eval-thunk
24 #:println #:writeln
25 #:file-stream-p #:file-or-synonym-stream-p
26 ;; Temporary files
27 #:*temporary-directory* #:temporary-directory #:default-temporary-directory
28 #:setup-temporary-directory
29 #:call-with-temporary-file #:with-temporary-file
30 #:add-pathname-suffix #:tmpize-pathname
31 #: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 #+lispworks 'lw:simple-char
38 :default)
39 "default element-type for open (depends on the current CL implementation)")
40
41 (defvar *stdin* *standard-input*
42 "the original standard input stream at startup")
43
44 (defun setup-stdin ()
45 (setf *stdin*
46 #.(or #+clozure 'ccl::*stdin*
47 #+(or cmucl scl) 'system:*stdin*
48 #+(or clasp ecl) 'ext::+process-standard-input+
49 #+sbcl 'sb-sys:*stdin*
50 '*standard-input*)))
51
52 (defvar *stdout* *standard-output*
53 "the original standard output stream at startup")
54
55 (defun setup-stdout ()
56 (setf *stdout*
57 #.(or #+clozure 'ccl::*stdout*
58 #+(or cmucl scl) 'system:*stdout*
59 #+(or clasp ecl) 'ext::+process-standard-output+
60 #+sbcl 'sb-sys:*stdout*
61 '*standard-output*)))
62
63 (defvar *stderr* *error-output*
64 "the original error output stream at startup")
65
66 (defun setup-stderr ()
67 (setf *stderr*
68 #.(or #+allegro 'excl::*stderr*
69 #+clozure 'ccl::*stderr*
70 #+(or cmucl scl) 'system:*stderr*
71 #+(or clasp ecl) 'ext::+process-error-output+
72 #+sbcl 'sb-sys:*stderr*
73 '*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 ;;; Encodings (mostly hooks only; full support requires asdf-encodings)
80 (with-upgradability ()
81 (defparameter *default-encoding*
82 ;; preserve explicit user changes to something other than the legacy default :default
83 (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*)))
84 (unless (eq previous :default) previous))
85 :utf-8)
86 "Default encoding for source files.
87 The default value :utf-8 is the portable thing.
88 The legacy behavior was :default.
89 If you (asdf:load-system :asdf-encodings) then
90 you will have autodetection via *encoding-detection-hook* below,
91 reading emacs-style -*- coding: utf-8 -*- specifications,
92 and falling back to utf-8 or latin1 if nothing is specified.")
93
94 (defparameter *utf-8-external-format*
95 (if (featurep :asdf-unicode)
96 (or #+clisp charset:utf-8 :utf-8)
97 :default)
98 "Default :external-format argument to pass to CL:OPEN and also
99 CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
100 On modern implementations, this will decode UTF-8 code points as CL characters.
101 On legacy implementations, it may fall back on some 8-bit encoding,
102 with non-ASCII code points being read as several CL characters;
103 hopefully, if done consistently, that won't affect program behavior too much.")
104
105 (defun always-default-encoding (pathname)
106 "Trivial function to use as *encoding-detection-hook*,
107 always 'detects' the *default-encoding*"
108 (declare (ignore pathname))
109 *default-encoding*)
110
111 (defvar *encoding-detection-hook* #'always-default-encoding
112 "Hook for an extension to define a function to automatically detect a file's encoding")
113
114 (defun detect-encoding (pathname)
115 "Detects the encoding of a specified file, going through user-configurable hooks"
116 (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname))
117 (funcall *encoding-detection-hook* pathname)
118 *default-encoding*))
119
120 (defun default-encoding-external-format (encoding)
121 "Default, ignorant, function to transform a character ENCODING as a
122 portable keyword to an implementation-dependent EXTERNAL-FORMAT specification.
123 Load system ASDF-ENCODINGS to hook in a better one."
124 (case encoding
125 (:default :default) ;; for backward-compatibility only. Explicit usage discouraged.
126 (:utf-8 *utf-8-external-format*)
127 (otherwise
128 (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)
129 :default)))
130
131 (defvar *encoding-external-format-hook*
132 #'default-encoding-external-format
133 "Hook for an extension (e.g. ASDF-ENCODINGS) to define a better mapping
134 from non-default encodings to and implementation-defined external-format's")
135
136 (defun encoding-external-format (encoding)
137 "Transform a portable ENCODING keyword to an implementation-dependent EXTERNAL-FORMAT,
138 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 (defvar *standard-readtable* (with-standard-io-syntax *readtable*)
145 "The standard readtable, implementing the syntax specified by the CLHS.
146 It must never be modified, though only good implementations will even enforce that.")
147
148 (defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
149 "Establish safe CL reader options around the evaluation of BODY"
150 `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body))))
151
152 (defun call-with-safe-io-syntax (thunk &key (package :cl))
153 (with-standard-io-syntax
154 (let ((*package* (find-package package))
155 (*read-default-float-format* 'double-float)
156 (*print-readably* nil)
157 (*read-eval* nil))
158 (funcall thunk))))
159
160 (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 (with-safe-io-syntax (:package package)
163 (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 (defun call-with-output-file (pathname thunk
168 &key
169 (element-type *default-stream-element-type*)
170 (external-format *utf-8-external-format*)
171 (if-exists :error)
172 (if-does-not-exist :create))
173 "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
174 Other keys are accepted but discarded."
175 (with-open-file (s pathname :direction :output
176 :element-type element-type
177 :external-format external-format
178 :if-exists if-exists
179 :if-does-not-exist if-does-not-exist)
180 (funcall thunk s)))
181
182 (defmacro with-output-file ((var pathname &rest keys
183 &key element-type external-format if-exists if-does-not-exist)
184 &body body)
185 (declare (ignore element-type external-format if-exists if-does-not-exist))
186 `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys))
187
188 (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 If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
193 If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
194 If OUTPUT is a STRING with a fill-pointer, use it as a string-output-stream.
195 If OUTPUT is a PATHNAME, open the file and write to it, passing KEYS to WITH-OUTPUT-FILE
196 -- this latter as an extension since ASDF 3.1.
197 Otherwise, signal an error."
198 (etypecase output
199 (null
200 (with-output-to-string (stream) (funcall function stream)))
201 ((eql t)
202 (funcall function *standard-output*))
203 (stream
204 (funcall function output))
205 (string
206 (assert (fill-pointer output))
207 (with-output-to-string (stream output) (funcall function stream)))
208 (pathname
209 (apply 'call-with-output-file output function keys))))
210
211 (defmacro with-output ((output-var &optional (value output-var)) &body body)
212 "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 (defun output-string (string &optional output)
217 "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
218 (if output
219 (with-output (output) (princ string output))
220 string)))
221
222
223 ;;; Input helpers
224 (with-upgradability ()
225 (defun call-with-input-file (pathname thunk
226 &key
227 (element-type *default-stream-element-type*)
228 (external-format *utf-8-external-format*)
229 (if-does-not-exist :error))
230 "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
231 Other keys are accepted but discarded."
232 (with-open-file (s pathname :direction :input
233 :element-type element-type
234 :external-format external-format
235 :if-does-not-exist if-does-not-exist)
236 (funcall thunk s)))
237
238 (defmacro with-input-file ((var pathname &rest keys
239 &key element-type external-format if-does-not-exist)
240 &body body)
241 (declare (ignore element-type external-format if-does-not-exist))
242 `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))
243
244 (defun call-with-input (input function &key keys)
245 "Calls FUNCTION with an actual stream argument, interpreting
246 stream designators like READ, but also coercing strings to STRING-INPUT-STREAM,
247 and PATHNAME to FILE-STREAM.
248 If INPUT is a STREAM, use it as the stream.
249 If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
250 If INPUT is T, use *TERMINAL-IO* as the stream.
251 If INPUT is a STRING, use it as a string-input-stream.
252 If INPUT is a PATHNAME, open it, passing KEYS to WITH-INPUT-FILE
253 -- the latter is an extension since ASDF 3.1.
254 Otherwise, signal an error."
255 (etypecase input
256 (null (funcall function *standard-input*))
257 ((eql t) (funcall function *terminal-io*))
258 (stream (funcall function input))
259 (string (with-input-from-string (stream input) (funcall function stream)))
260 (pathname (apply 'call-with-input-file input function keys))))
261
262 (defmacro with-input ((input-var &optional (value input-var)) &body body)
263 "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
264 as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
265 `(call-with-input ,value #'(lambda (,input-var) ,@body)))
266
267 (defun input-string (&optional input)
268 "If the desired INPUT is a string, return that string; otherwise slurp the INPUT into a string
269 and return that"
270 (if (stringp input)
271 input
272 (with-input (input) (funcall 'slurp-stream-string input)))))
273
274 ;;; Null device
275 (with-upgradability ()
276 (defun null-device-pathname ()
277 "Pathname to a bit bucket device that discards any information written to it
278 and always returns EOF when read from"
279 (os-cond
280 ((os-unix-p) #p"/dev/null")
281 ((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax?
282 (t (error "No /dev/null on your OS"))))
283 (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 (declare (ignore element-type external-format if-does-not-exist))
286 (apply 'call-with-input-file (null-device-pathname) fun keys))
287 (defmacro with-null-input ((var &rest keys
288 &key element-type external-format if-does-not-exist)
289 &body body)
290 (declare (ignore element-type external-format if-does-not-exist))
291 "Evaluate BODY in a context when VAR is bound to an input stream accessing the null device.
292 Pass keyword arguments to OPEN."
293 `(call-with-null-input #'(lambda (,var) ,@body) ,@keys))
294 (defun call-with-null-output (fun
295 &key (element-type *default-stream-element-type*)
296 (external-format *utf-8-external-format*)
297 (if-exists :overwrite)
298 (if-does-not-exist :error))
299 "Call FUN with an output stream to the null device; pass keyword arguments to OPEN."
300 (call-with-output-file
301 (null-device-pathname) fun
302 :element-type element-type :external-format external-format
303 :if-exists if-exists :if-does-not-exist if-does-not-exist))
304 (defmacro with-null-output ((var &rest keys
305 &key element-type external-format if-does-not-exist if-exists)
306 &body body)
307 "Evaluate BODY in a context when VAR is bound to an output stream accessing the null device.
308 Pass keyword arguments to OPEN."
309 (declare (ignore element-type external-format if-exists if-does-not-exist))
310 `(call-with-null-output #'(lambda (,var) ,@body) ,@keys)))
311
312 ;;; Ensure output buffers are flushed
313 (with-upgradability ()
314 (defun finish-outputs (&rest streams)
315 "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 ;; CCL notably buffers its stream output by default.
318 (dolist (s (append streams
319 (list *stdout* *stderr* *error-output* *standard-output* *trace-output*
320 *debug-io* *terminal-io* *query-io*)))
321 (ignore-errors (finish-output s)))
322 (values))
323
324 (defun format! (stream format &rest args)
325 "Just like format, but call finish-outputs before and after the output."
326 (finish-outputs stream)
327 (apply 'format stream format args)
328 (finish-outputs stream))
329
330 (defun safe-format! (stream format &rest args)
331 "Variant of FORMAT that is safe against both
332 dangerous syntax configuration and errors while printing."
333 (with-safe-io-syntax ()
334 (ignore-errors (apply 'format! stream format args))
335 (finish-outputs stream)))) ; just in case format failed
336
337
338 ;;; Simple Whole-Stream processing
339 (with-upgradability ()
340 (defun copy-stream-to-stream (input output &key element-type buffer-size linewise prefix)
341 "Copy the contents of the INPUT stream into the OUTPUT stream.
342 If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX.
343 Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
344 (with-open-stream (input input)
345 (if linewise
346 (loop* :for (line eof) = (multiple-value-list (read-line input nil nil))
347 :while line :do
348 (when prefix (princ prefix output))
349 (princ line output)
350 (unless eof (terpri output))
351 (finish-output output)
352 (when eof (return)))
353 (loop
354 :with buffer-size = (or buffer-size 8192)
355 :with buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
356 :for end = (read-sequence buffer input)
357 :until (zerop end)
358 :do (write-sequence buffer output :end end)
359 (when (< end buffer-size) (return))))))
360
361 (defun concatenate-files (inputs output)
362 "create a new OUTPUT file the contents of which a the concatenate of the INPUTS files."
363 (with-open-file (o output :element-type '(unsigned-byte 8)
364 :direction :output :if-exists :rename-and-delete)
365 (dolist (input inputs)
366 (with-open-file (i input :element-type '(unsigned-byte 8)
367 :direction :input :if-does-not-exist :error)
368 (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
369
370 (defun copy-file (input output)
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 #+allegro
374 (excl.osi:copy-file input output)
375 #+ecl
376 (ext:copy-file input output)
377 #-(or allegro ecl)
378 (concatenate-files (list input) output))
379
380 (defun slurp-stream-string (input &key (element-type 'character) stripped)
381 "Read the contents of the INPUT stream as a string"
382 (let ((string
383 (with-open-stream (input input)
384 (with-output-to-string (output)
385 (copy-stream-to-stream input output :element-type element-type)))))
386 (if stripped (stripln string) string)))
387
388 (defun slurp-stream-lines (input &key count)
389 "Read the contents of the INPUT stream as a list of lines, return those lines.
390
391 Note: relies on the Lisp's READ-LINE, but additionally removes any remaining CR
392 from the line-ending if the file or stream had CR+LF but Lisp only removed LF.
393
394 Read no more than COUNT lines."
395 (check-type count (or null integer))
396 (with-open-stream (input input)
397 (loop :for n :from 0
398 :for l = (and (or (not count) (< n count))
399 (read-line input nil nil))
400 ;; stripln: to remove CR when the OS sends CRLF and Lisp only remove LF
401 :while l :collect (stripln l))))
402
403 (defun slurp-stream-line (input &key (at 0))
404 "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 PATH defaults to 0, i.e. return the first line.
407 PATH is typically an integer, or a list of an integer and a function.
408 If PATH is NIL, it will return all the lines in the file.
409
410 The stream will not be read beyond the Nth lines,
411 where N is the index specified by path
412 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 (defun slurp-stream-forms (input &key count)
416 "Read the contents of the INPUT stream as a list of forms,
417 and return those forms.
418
419 If COUNT is null, read to the end of the stream;
420 if COUNT is an integer, stop after COUNT forms were read.
421
422 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
423 (check-type count (or null integer))
424 (loop :with eof = '#:eof
425 :for n :from 0
426 :for form = (if (and count (>= n count))
427 eof
428 (read-preserving-whitespace input nil eof))
429 :until (eq form eof) :collect form))
430
431 (defun slurp-stream-form (input &key (at 0))
432 "Read the contents of the INPUT stream as a list of forms,
433 then return the ACCESS-AT of these forms following the AT.
434 AT defaults to 0, i.e. return the first form.
435 AT is typically a list of integers.
436 If AT is NIL, it will return all the forms in the file.
437
438 The stream will not be read beyond the Nth form,
439 where N is the index specified by path,
440 if path is either an integer or a list that starts with an integer.
441
442 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 (defun read-file-string (file &rest keys)
446 "Open FILE with option KEYS, read its contents as a string"
447 (apply 'call-with-input-file file 'slurp-stream-string keys))
448
449 (defun read-file-lines (file &rest keys)
450 "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 (defun read-file-line (file &rest keys &key (at 0) &allow-other-keys)
455 "Open input FILE with option KEYS (except AT),
456 and read its contents as per SLURP-STREAM-LINE with given AT specifier.
457 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
458 (apply 'call-with-input-file file
459 #'(lambda (input) (slurp-stream-line input :at at))
460 (remove-plist-key :at keys)))
461
462 (defun read-file-forms (file &rest keys &key count &allow-other-keys)
463 "Open input FILE with option KEYS (except COUNT),
464 and read its contents as per SLURP-STREAM-FORMS with given COUNT.
465 If COUNT is null, read to the end of the stream;
466 if COUNT is an integer, stop after COUNT forms were read.
467 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
468 (apply 'call-with-input-file file
469 #'(lambda (input) (slurp-stream-forms input :count count))
470 (remove-plist-key :count keys)))
471
472 (defun read-file-form (file &rest keys &key (at 0) &allow-other-keys)
473 "Open input FILE with option KEYS (except AT),
474 and read its contents as per SLURP-STREAM-FORM with given AT specifier.
475 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
476 (apply 'call-with-input-file file
477 #'(lambda (input) (slurp-stream-form input :at at))
478 (remove-plist-key :at keys)))
479
480 (defun safe-read-file-line (pathname &rest keys &key (package :cl) &allow-other-keys)
481 "Reads the specified line from the top of a file using a safe standardized syntax.
482 Extracts the line using READ-FILE-LINE,
483 within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
484 (with-safe-io-syntax (:package package)
485 (apply 'read-file-line pathname (remove-plist-key :package keys))))
486
487 (defun safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
488 "Reads the specified form from the top of a file using a safe standardized syntax.
489 Extracts the form using READ-FILE-FORM,
490 within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
491 (with-safe-io-syntax (:package package)
492 (apply 'read-file-form pathname (remove-plist-key :package keys))))
493
494 (defun eval-input (input)
495 "Portably read and evaluate forms from INPUT, return the last values."
496 (with-input (input)
497 (loop :with results :with eof ='#:eof
498 :for form = (read input nil eof)
499 :until (eq form eof)
500 :do (setf results (multiple-value-list (eval form)))
501 :finally (return (values-list results)))))
502
503 (defun eval-thunk (thunk)
504 "Evaluate a THUNK of code:
505 If a function, FUNCALL it without arguments.
506 If a constant literal and not a sequence, return it.
507 If a cons or a symbol, EVAL it.
508 If a string, repeatedly read and evaluate from it, returning the last values."
509 (etypecase thunk
510 ((or boolean keyword number character pathname) thunk)
511 ((or cons symbol) (eval thunk))
512 (function (funcall thunk))
513 (string (eval-input thunk))))
514
515 (defun standard-eval-thunk (thunk &key (package :cl))
516 "Like EVAL-THUNK, but in a more standardized evaluation context."
517 ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
518 (when thunk
519 (with-safe-io-syntax (:package package)
520 (let ((*read-eval* t))
521 (eval-thunk thunk))))))
522
523 (with-upgradability ()
524 (defun println (x &optional (stream *standard-output*))
525 "Variant of PRINC that also calls TERPRI afterwards"
526 (princ x stream) (terpri stream) (finish-output stream) (values))
527
528 (defun writeln (x &rest keys &key (stream *standard-output*) &allow-other-keys)
529 "Variant of WRITE that also calls TERPRI afterwards"
530 (apply 'write x keys) (terpri stream) (finish-output stream) (values)))
531
532
533 ;;; Using temporary files
534 (with-upgradability ()
535 (defun default-temporary-directory ()
536 "Return a default directory to use for temporary files"
537 (os-cond
538 ((os-unix-p)
539 (or (getenv-pathname "TMPDIR" :ensure-directory t)
540 (parse-native-namestring "/tmp/")))
541 ((os-windows-p)
542 (getenv-pathname "TEMP" :ensure-directory t))
543 (t (subpathname (user-homedir-pathname) "tmp/"))))
544
545 (defvar *temporary-directory* nil "User-configurable location for temporary files")
546
547 (defun temporary-directory ()
548 "Return a directory to use for temporary files"
549 (or *temporary-directory* (default-temporary-directory)))
550
551 (defun setup-temporary-directory ()
552 "Configure a default temporary directory to use."
553 (setf *temporary-directory* (default-temporary-directory))
554 #+gcl (setf system::*tmp-dir* *temporary-directory*))
555
556 (defun call-with-temporary-file
557 (thunk &key
558 (want-stream-p t) (want-pathname-p t) (direction :io) keep after
559 directory (type "tmp" typep) prefix (suffix (when typep "-tmp"))
560 (element-type *default-stream-element-type*)
561 (external-format *utf-8-external-format*))
562 "Call a THUNK with stream and/or pathname arguments identifying a temporary file.
563
564 The temporary file's pathname will be based on concatenating
565 PREFIX (or \"tmp\" if it's NIL), a random alphanumeric string,
566 and optional SUFFIX (defaults to \"-tmp\" if a type was provided)
567 and TYPE (defaults to \"tmp\", using a dot as separator if not NIL),
568 within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute.
569
570 The file will be open with specified DIRECTION (defaults to :IO),
571 ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and
572 EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*).
573 If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed
574 with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T),
575 and stream will be closed after the THUNK exits (either normally or abnormally).
576 If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then
577 THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument.
578 Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument.
579 If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned.
580 Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true."
581 #+xcl (declare (ignorable typep))
582 (check-type direction (member :output :io))
583 (assert (or want-stream-p want-pathname-p))
584 (loop
585 :with prefix-pn = (ensure-absolute-pathname
586 (or prefix "tmp")
587 (or (ensure-pathname
588 directory
589 :namestring :native
590 :ensure-directory t
591 :ensure-physical t)
592 #'temporary-directory))
593 :with prefix-nns = (native-namestring prefix-pn)
594 :with results = (progn (ensure-directories-exist prefix-pn)
595 ())
596 :for counter :from (random (expt 36 #-gcl 8 #+gcl 5))
597 :for pathname = (parse-native-namestring
598 (format nil "~A~36R~@[~A~]~@[.~A~]"
599 prefix-nns counter suffix (unless (eq type :unspecific) type)))
600 :for okp = nil :do
601 ;; TODO: on Unix, do something about umask
602 ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
603 ;; TODO: on Unix, use CFFI and mkstemp --
604 ;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr.
605 ;; Can we at least design some hook?
606 (unwind-protect
607 (progn
608 (ensure-directories-exist pathname)
609 (with-open-file (stream pathname
610 :direction direction
611 :element-type element-type
612 :external-format external-format
613 :if-exists nil :if-does-not-exist :create)
614 (when stream
615 (setf okp pathname)
616 (when want-stream-p
617 ;; Note: can't return directly from within with-open-file
618 ;; or the non-local return causes the file creation to be undone.
619 (setf results (multiple-value-list
620 (if want-pathname-p
621 (funcall thunk stream pathname)
622 (funcall thunk stream)))))))
623 (cond
624 ((not okp) nil)
625 (after (return (call-function after okp)))
626 ((and want-pathname-p (not want-stream-p)) (return (call-function thunk okp)))
627 (t (return (values-list results)))))
628 (when (and okp (not (call-function keep)))
629 (ignore-errors (delete-file-if-exists okp))))))
630
631 (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
632 (pathname (gensym "PATHNAME") pathnamep)
633 directory prefix suffix type
634 keep direction element-type external-format)
635 &body body)
636 "Evaluate BODY where the symbols specified by keyword arguments
637 STREAM and PATHNAME (if respectively specified) are bound corresponding
638 to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE.
639 At least one of STREAM or PATHNAME must be specified.
640 If the STREAM is not specified, it will be closed before the BODY is evaluated.
641 If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY,
642 separates forms run before and after the stream is closed.
643 The values of the last form of the BODY (not counting the separating :CLOSE-STREAM) are returned.
644 Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE."
645 (check-type stream symbol)
646 (check-type pathname symbol)
647 (assert (or streamp pathnamep))
648 (let* ((afterp (position :close-stream body))
649 (before (if afterp (subseq body 0 afterp) body))
650 (after (when afterp (subseq body (1+ afterp))))
651 (beforef (gensym "BEFORE"))
652 (afterf (gensym "AFTER")))
653 `(flet (,@(when before
654 `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname)))
655 ,@(when after `((declare (ignorable ,pathname))))
656 ,@before)))
657 ,@(when after
658 (assert pathnamep)
659 `((,afterf (,pathname) ,@after))))
660 #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@(when after `(#',afterf))))
661 (call-with-temporary-file
662 ,(when before `#',beforef)
663 :want-stream-p ,streamp
664 :want-pathname-p ,pathnamep
665 ,@(when direction `(:direction ,direction))
666 ,@(when directory `(:directory ,directory))
667 ,@(when prefix `(:prefix ,prefix))
668 ,@(when suffix `(:suffix ,suffix))
669 ,@(when type `(:type ,type))
670 ,@(when keep `(:keep ,keep))
671 ,@(when after `(:after #',afterf))
672 ,@(when element-type `(:element-type ,element-type))
673 ,@(when external-format `(:external-format ,external-format))))))
674
675 (defun get-temporary-file (&key directory prefix suffix type)
676 (with-temporary-file (:pathname pn :keep t
677 :directory directory :prefix prefix :suffix suffix :type type)
678 pn))
679
680 ;; Temporary pathnames in simple cases where no contention is assumed
681 (defun add-pathname-suffix (pathname suffix &rest keys)
682 "Add a SUFFIX to the name of a PATHNAME, return a new pathname.
683 Further KEYS can be passed to MAKE-PATHNAME."
684 (apply 'make-pathname :name (strcat (pathname-name pathname) suffix)
685 :defaults pathname keys))
686
687 (defun tmpize-pathname (x)
688 "Return a new pathname modified from X by adding a trivial random suffix.
689 A new empty file with said temporary pathname is created, to ensure there is no
690 clash with any concurrent process attempting the same thing."
691 (let* ((px (ensure-pathname x :ensure-physical t))
692 (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp"))
693 (directory (pathname-directory-pathname px)))
694 (get-temporary-file :directory directory :prefix prefix :type (pathname-type px))))
695
696 (defun call-with-staging-pathname (pathname fun)
697 "Calls FUN with a staging pathname, and atomically
698 renames the staging pathname to the PATHNAME in the end.
699 NB: this protects only against failure of the program, not against concurrent attempts.
700 For the latter case, we ought pick a random suffix and atomically open it."
701 (let* ((pathname (pathname pathname))
702 (staging (tmpize-pathname pathname)))
703 (unwind-protect
704 (multiple-value-prog1
705 (funcall fun staging)
706 (rename-file-overwriting-target staging pathname))
707 (delete-file-if-exists staging))))
708
709 (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
710 "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
711 `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
712
713 (with-upgradability ()
714 (defun file-stream-p (stream)
715 (typep stream 'file-stream))
716 (defun file-or-synonym-stream-p (stream)
717 (or (file-stream-p stream)
718 (and (typep stream 'synonym-stream)
719 (file-or-synonym-stream-p
720 (symbol-value (synonym-stream-symbol stream)))))))