GopherProxy

	tstream.lisp - clic - Clic is an command line interactive client for gopher wri…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tstream.lisp (34721B)
	---
	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/pat…
	6 (:export
	7 #:default-stream-element-type
	8 #:stdin #:setup-stdin #:stdout #:setup-stdout #:stderr #:setup-…
	9 #:detect-encoding #:encoding-detection-hook #:always-default-encodi…
	10 #:encoding-external-format #:encoding-external-format-hook #:defaul…
	11 #:default-encoding #:utf-8-external-format
	12 #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-str…
	13 #:with-output #:output-string #:with-input #:input-string
	14 #:with-input-file #:call-with-input-file #:with-output-file #:call-wi…
	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-fil…
	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-dir…
	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 implementa…
	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…
	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…
	83 (or (if-let (previous (and (boundp 'default-encoding) (symbol-valu…
	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 char…
	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 …
	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 …
	113
	114 (defun detect-encoding (pathname)
	115 "Detects the encoding of a specified file, going through user-config…
	116 (if (and pathname (not (directory-pathname-p pathname)) (probe-file*…
	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 specific…
	123 Load system ASDF-ENCODINGS to hook in a better one."
	124 (case encoding
	125 (:default :default) ;; for backward-compatibility only. Explicit u…
	126 (:utf-8 utf-8-external-format)
	127 (otherwise
	128 (cerror "Continue using :external-format :default" (compatfmt "~@…
	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 mapp…
	134 from non-default encodings to and implementation-defined external-format…
	135
	136 (defun encoding-external-format (encoding)
	137 "Transform a portable ENCODING keyword to an implementation-dependen…
	138 going through all the proper hooks."
	139 (funcall encoding-external-format-hook (or encoding *default-encod…
	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 CL…
	146 It must never be modified, though only good implementations will even en…
	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-packa…
	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…
	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 e…
	164
	165 ;;; Output helpers
	166 (with-upgradability ()
	167 (defun call-with-output-file (pathname thunk
	168 &key
	169 (element-type *default-stream-element-…
	170 (external-format *utf-8-external-forma…
	171 (if-exists :error)
	172 (if-does-not-exist :create))
	173 "Open FILE for input with given recognizes options, call THUNK with …
	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-exis…
	184 &body body)
	185 (declare (ignore element-type external-format if-exists if-does-not-…
	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 interpre…
	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 t…
	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-str…
	195 If OUTPUT is a PATHNAME, open the file and write to it, passing KEYS to …
	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…
	212 "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previ…
	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; o…
	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-t…
	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 …
	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-…
	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-…
	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 s…
	260 (pathname (apply 'call-with-input-file input function keys))))
	261
	262 (defmacro with-input ((input-var &optional (value input-var)) &body bo…
	263 "Bind INPUT-VAR to an input stream, coercing VALUE (default: previou…
	264 as per CALL-WITH-INPUT, and evaluate BODY within the scope of this bindi…
	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 slu…
	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 writt…
	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:" …
	282 (t (error "No /dev/null on your OS"))))
	283 (defun call-with-null-input (fun &rest keys &key element-type external…
	284 "Call FUN with an input stream from the null device; pass keyword ar…
	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-…
	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 acc…
	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-eleme…
	296 (external-format *utf-8-external-forma…
	297 (if-exists :overwrite)
	298 (if-does-not-exist :error))
	299 "Call FUN with an output stream to the null device; pass keyword arg…
	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-…
	306 &body body)
	307 "Evaluate BODY in a context when VAR is bound to an output stream ac…
	308 Pass keyword arguments to OPEN."
	309 (declare (ignore element-type external-format if-exists if-does-not-…
	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 o…
	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-…
	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 outp…
	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-si…
	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…
	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…
	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 …
	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…
	363 (with-open-file (o output :element-type '(unsigned-byte 8)
	364 :direction :output :if-exists :rename-and-…
	365 (dolist (input inputs)
	366 (with-open-file (i input :element-type '(unsigned-byte 8)
	367 :direction :input :if-does-not-exist :e…
	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…
	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) strip…
	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 elemen…
	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 th…
	390
	391 Note: relies on the Lisp's READ-LINE, but additionally removes any remai…
	392 from the line-ending if the file or stream had CR+LF but Lisp only remov…
	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 onl…
	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 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
	466 (apply 'call-with-input-file file
	467 #'(lambda (input) (slurp-stream-forms input :count count))
	468 (remove-plist-key :count keys)))
	469
	470 (defun read-file-form (file &rest keys &key (at 0) &allow-other-keys)
	471 "Open input FILE with option KEYS (except AT),
	472 and read its contents as per SLURP-STREAM-FORM with given AT specifier.
	473 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
	474 (apply 'call-with-input-file file
	475 #'(lambda (input) (slurp-stream-form input :at at))
	476 (remove-plist-key :at keys)))
	477
	478 (defun safe-read-file-line (pathname &rest keys &key (package :cl) &al…
	479 "Reads the specified line from the top of a file using a safe standa…
	480 Extracts the line using READ-FILE-LINE,
	481 within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
	482 (with-safe-io-syntax (:package package)
	483 (apply 'read-file-line pathname (remove-plist-key :package keys))))
	484
	485 (defun safe-read-file-form (pathname &rest keys &key (package :cl) &al…
	486 "Reads the specified form from the top of a file using a safe standa…
	487 Extracts the form using READ-FILE-FORM,
	488 within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
	489 (with-safe-io-syntax (:package package)
	490 (apply 'read-file-form pathname (remove-plist-key :package keys))))
	491
	492 (defun eval-input (input)
	493 "Portably read and evaluate forms from INPUT, return the last values…
	494 (with-input (input)
	495 (loop :with results :with eof ='#:eof
	496 :for form = (read input nil eof)
	497 :until (eq form eof)
	498 :do (setf results (multiple-value-list (eval form)))
	499 :finally (return (values-list results)))))
	500
	501 (defun eval-thunk (thunk)
	502 "Evaluate a THUNK of code:
	503 If a function, FUNCALL it without arguments.
	504 If a constant literal and not a sequence, return it.
	505 If a cons or a symbol, EVAL it.
	506 If a string, repeatedly read and evaluate from it, returning the last va…
	507 (etypecase thunk
	508 ((or boolean keyword number character pathname) thunk)
	509 ((or cons symbol) (eval thunk))
	510 (function (funcall thunk))
	511 (string (eval-input thunk))))
	512
	513 (defun standard-eval-thunk (thunk &key (package :cl))
	514 "Like EVAL-THUNK, but in a more standardized evaluation context."
	515 ;; Note: it's "standard-" not "safe-", because evaluation is never s…
	516 (when thunk
	517 (with-safe-io-syntax (:package package)
	518 (let ((read-eval t))
	519 (eval-thunk thunk))))))
	520
	521 (with-upgradability ()
	522 (defun println (x &optional (stream standard-output))
	523 "Variant of PRINC that also calls TERPRI afterwards"
	524 (princ x stream) (terpri stream) (finish-output stream) (values))
	525
	526 (defun writeln (x &rest keys &key (stream standard-output) &allow-ot…
	527 "Variant of WRITE that also calls TERPRI afterwards"
	528 (apply 'write x keys) (terpri stream) (finish-output stream) (values…
	529
	530
	531 ;;; Using temporary files
	532 (with-upgradability ()
	533 (defun default-temporary-directory ()
	534 "Return a default directory to use for temporary files"
	535 (os-cond
	536 ((os-unix-p)
	537 (or (getenv-pathname "TMPDIR" :ensure-directory t)
	538 (parse-native-namestring "/tmp/")))
	539 ((os-windows-p)
	540 (getenv-pathname "TEMP" :ensure-directory t))
	541 (t (subpathname (user-homedir-pathname) "tmp/"))))
	542
	543 (defvar temporary-directory nil "User-configurable location for temp…
	544
	545 (defun temporary-directory ()
	546 "Return a directory to use for temporary files"
	547 (or temporary-directory (default-temporary-directory)))
	548
	549 (defun setup-temporary-directory ()
	550 "Configure a default temporary directory to use."
	551 (setf temporary-directory (default-temporary-directory))
	552 #+gcl (setf system::tmp-dir temporary-directory))
	553
	554 (defun call-with-temporary-file
	555 (thunk &key
	556 (want-stream-p t) (want-pathname-p t) (direction :io) kee…
	557 directory (type "tmp" typep) prefix (suffix (when typep "…
	558 (element-type default-stream-element-type)
	559 (external-format utf-8-external-format))
	560 "Call a THUNK with stream and/or pathname arguments identifying a te…
	561
	562 The temporary file's pathname will be based on concatenating
	563 PREFIX (or \"tmp\" if it's NIL), a random alphanumeric string,
	564 and optional SUFFIX (defaults to \"-tmp\" if a type was provided)
	565 and TYPE (defaults to \"tmp\", using a dot as separator if not NIL),
	566 within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX i…
	567
	568 The file will be open with specified DIRECTION (defaults to :IO),
	569 ELEMENT-TYPE (defaults to DEFAULT-STREAM-ELEMENT-TYPE) and
	570 EXTERNAL-FORMAT (defaults to UTF-8-EXTERNAL-FORMAT).
	571 If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CA…
	572 with the stream and the pathname (if WANT-PATHNAME-P is true, defaults t…
	573 and stream will be closed after the THUNK exits (either normally or abno…
	574 If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then
	575 THUNK is only CALL-FUNCTION'ed after the stream is closed, with the path…
	576 Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with …
	577 If AFTER is defined, its results are returned, otherwise, the results of…
	578 Finally, the file will be deleted, unless the KEEP argument when CALL-FU…
	579 #+xcl (declare (ignorable typep))
	580 (check-type direction (member :output :io))
	581 (assert (or want-stream-p want-pathname-p))
	582 (loop
	583 :with prefix-pn = (ensure-absolute-pathname
	584 (or prefix "tmp")
	585 (or (ensure-pathname
	586 directory
	587 :namestring :native
	588 :ensure-directory t
	589 :ensure-physical t)
	590 #'temporary-directory))
	591 :with prefix-nns = (native-namestring prefix-pn)
	592 :with results = (progn (ensure-directories-exist prefix-pn)
	593 ())
	594 :for counter :from (random (expt 36 #-gcl 8 #+gcl 5))
	595 :for pathname = (parse-native-namestring
	596 (format nil "~A~36R~@[~A~]~@[.~A~]"
	597 prefix-nns counter suffix (unless (eq typ…
	598 :for okp = nil :do
	599 ;; TODO: on Unix, do something about umask
	600 ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT…
	601 ;; TODO: on Unix, use CFFI and mkstemp --
	602 ;; except UIOP is precisely meant to not depend on CFFI or on an…
	603 ;; Can we at least design some hook?
	604 (unwind-protect
	605 (progn
	606 (ensure-directories-exist pathname)
	607 (with-open-file (stream pathname
	608 :direction direction
	609 :element-type element-type
	610 :external-format external-format
	611 :if-exists nil :if-does-not-exist…
	612 (when stream
	613 (setf okp pathname)
	614 (when want-stream-p
	615 ;; Note: can't return directly from within with-ope…
	616 ;; or the non-local return causes the file creation…
	617 (setf results (multiple-value-list
	618 (if want-pathname-p
	619 (funcall thunk stream pathname)
	620 (funcall thunk stream)))))))
	621 (cond
	622 ((not okp) nil)
	623 (after (return (call-function after okp)))
	624 ((and want-pathname-p (not want-stream-p)) (return (cal…
	625 (t (return (values-list results)))))
	626 (when (and okp (not (call-function keep)))
	627 (ignore-errors (delete-file-if-exists okp))))))
	628
	629 (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
	630 (pathname (gensym "PATHNAME") pathna…
	631 directory prefix suffix type
	632 keep direction element-type external…
	633 &body body)
	634 "Evaluate BODY where the symbols specified by keyword arguments
	635 STREAM and PATHNAME (if respectively specified) are bound corresponding
	636 to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPOR…
	637 At least one of STREAM or PATHNAME must be specified.
	638 If the STREAM is not specified, it will be closed before the BODY is eva…
	639 If STREAM is specified, then the :CLOSE-STREAM label if it appears in th…
	640 separates forms run before and after the stream is closed.
	641 The values of the last form of the BODY (not counting the separating :CL…
	642 Upon success, the KEEP form is evaluated and the file is is deleted unle…
	643 (check-type stream symbol)
	644 (check-type pathname symbol)
	645 (assert (or streamp pathnamep))
	646 (let* ((afterp (position :close-stream body))
	647 (before (if afterp (subseq body 0 afterp) body))
	648 (after (when afterp (subseq body (1+ afterp))))
	649 (beforef (gensym "BEFORE"))
	650 (afterf (gensym "AFTER")))
	651 `(flet (,@(when before
	652 `((,beforef (,@(when streamp `(,stream)) ,@(when pathn…
	653 ,@(when after `((declare (ignorable ,pathname))))
	654 ,@before)))
	655 ,@(when after
	656 (assert pathnamep)
	657 `((,afterf (,pathname) ,@after))))
	658 #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@…
	659 (call-with-temporary-file
	660 ,(when before `#',beforef)
	661 :want-stream-p ,streamp
	662 :want-pathname-p ,pathnamep
	663 ,@(when direction `(:direction ,direction))
	664 ,@(when directory `(:directory ,directory))
	665 ,@(when prefix `(:prefix ,prefix))
	666 ,@(when suffix `(:suffix ,suffix))
	667 ,@(when type `(:type ,type))
	668 ,@(when keep `(:keep ,keep))
	669 ,@(when after `(:after #',afterf))
	670 ,@(when element-type `(:element-type ,element-type))
	671 ,@(when external-format `(:external-format ,external-format)))…
	672
	673 (defun get-temporary-file (&key directory prefix suffix type)
	674 (with-temporary-file (:pathname pn :keep t
	675 :directory directory :prefix prefix :suffix su…
	676 pn))
	677
	678 ;; Temporary pathnames in simple cases where no contention is assumed
	679 (defun add-pathname-suffix (pathname suffix &rest keys)
	680 "Add a SUFFIX to the name of a PATHNAME, return a new pathname.
	681 Further KEYS can be passed to MAKE-PATHNAME."
	682 (apply 'make-pathname :name (strcat (pathname-name pathname) suffix)
	683 :defaults pathname keys))
	684
	685 (defun tmpize-pathname (x)
	686 "Return a new pathname modified from X by adding a trivial random su…
	687 A new empty file with said temporary pathname is created, to ensure ther…
	688 clash with any concurrent process attempting the same thing."
	689 (let* ((px (ensure-pathname x :ensure-physical t))
	690 (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp…
	691 (directory (pathname-directory-pathname px)))
	692 (get-temporary-file :directory directory :prefix prefix :type (pat…
	693
	694 (defun call-with-staging-pathname (pathname fun)
	695 "Calls FUN with a staging pathname, and atomically
	696 renames the staging pathname to the PATHNAME in the end.
	697 NB: this protects only against failure of the program, not against concu…
	698 For the latter case, we ought pick a random suffix and atomically open i…
	699 (let* ((pathname (pathname pathname))
	700 (staging (tmpize-pathname pathname)))
	701 (unwind-protect
	702 (multiple-value-prog1
	703 (funcall fun staging)
	704 (rename-file-overwriting-target staging pathname))
	705 (delete-file-if-exists staging))))
	706
	707 (defmacro with-staging-pathname ((pathname-var &optional (pathname-val…
	708 "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
	709 `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-va…
	710
	711 (with-upgradability ()
	712 (defun file-stream-p (stream)
	713 (typep stream 'file-stream))
	714 (defun file-or-synonym-stream-p (stream)
	715 (or (file-stream-p stream)
	716 (and (typep stream 'synonym-stream)
	717 (file-or-synonym-stream-p
	718 (symbol-value (synonym-stream-symbol stream)))))))