tstream.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP (HTM) git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/ (DIR) Log (DIR) Files (DIR) Refs (DIR) Tags (DIR) 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/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 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) &allow-other-keys) 479 "Reads the specified line from the top of a file using a safe standardized syntax. 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) &allow-other-keys) 486 "Reads the specified form from the top of a file using a safe standardized syntax. 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 values." 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 safe. 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-other-keys) 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 temporary files") 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) keep after 557 directory (type "tmp" typep) prefix (suffix (when typep "-tmp")) 558 (element-type *default-stream-element-type*) 559 (external-format *utf-8-external-format*)) 560 "Call a THUNK with stream and/or pathname arguments identifying a temporary file. 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 isn't absolute. 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 CALL-FUNCTION'ed 572 with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T), 573 and stream will be closed after the THUNK exits (either normally or abnormally). 574 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 pathname as argument. 576 Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument. 577 If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned. 578 Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true." 579 #+xcl (declare (ignorable typep)) 580 (check-type direction (member :output :io)) 581 (assert (or want-stream-p want-pathname-p)) 582 (loop 583 :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 type :unspecific) type))) 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|O_EXCL 601 ;; TODO: on Unix, use CFFI and mkstemp -- 602 ;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr. 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 :create) 612 (when stream 613 (setf okp pathname) 614 (when want-stream-p 615 ;; Note: can't return directly from within with-open-file 616 ;; or the non-local return causes the file creation to be undone. 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 (call-function thunk okp))) 625 (t (return (values-list results))))) 626 (when (and okp (not (call-function keep))) 627 (ignore-errors (delete-file-if-exists okp)))))) 628 629 (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp) 630 (pathname (gensym "PATHNAME") pathnamep) 631 directory prefix suffix type 632 keep direction element-type external-format) 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-TEMPORARY-FILE. 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 evaluated. 639 If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY, 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 :CLOSE-STREAM) are returned. 642 Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE." 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 pathnamep `(,pathname))) 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)) ,@(when after `(#',afterf)))) 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 suffix :type type) 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 suffix. 687 A new empty file with said temporary pathname is created, to ensure there is no 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 (pathname-type px)))) 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 concurrent attempts. 698 For the latter case, we ought pick a random suffix and atomically open it." 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-value pathname-var)) &body body) 708 "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME" 709 `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))) 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)))))))