3rdparties/software/alexandria-20200427-git/alexandria-1/io.lisp (8280 bytes)
1 ;; Copyright (c) 2002-2006, Edward Marco Baringer 2 ;; All rights reserved. 3 4 (in-package :alexandria) 5 6 (defmacro with-open-file* ((stream filespec &key direction element-type 7 if-exists if-does-not-exist external-format) 8 &body body) 9 "Just like WITH-OPEN-FILE, but NIL values in the keyword arguments mean to use 10 the default value specified for OPEN." 11 (once-only (direction element-type if-exists if-does-not-exist external-format) 12 `(with-open-stream 13 (,stream (apply #'open ,filespec 14 (append 15 (when ,direction 16 (list :direction ,direction)) 17 (when ,element-type 18 (list :element-type ,element-type)) 19 (when ,if-exists 20 (list :if-exists ,if-exists)) 21 (when ,if-does-not-exist 22 (list :if-does-not-exist ,if-does-not-exist)) 23 (when ,external-format 24 (list :external-format ,external-format))))) 25 ,@body))) 26 27 (defmacro with-input-from-file ((stream-name file-name &rest args 28 &key (direction nil direction-p) 29 &allow-other-keys) 30 &body body) 31 "Evaluate BODY with STREAM-NAME to an input stream on the file 32 FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT, 33 which is only sent to WITH-OPEN-FILE when it's not NIL." 34 (declare (ignore direction)) 35 (when direction-p 36 (error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE.")) 37 `(with-open-file* (,stream-name ,file-name :direction :input ,@args) 38 ,@body)) 39 40 (defmacro with-output-to-file ((stream-name file-name &rest args 41 &key (direction nil direction-p) 42 &allow-other-keys) 43 &body body) 44 "Evaluate BODY with STREAM-NAME to an output stream on the file 45 FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT, 46 which is only sent to WITH-OPEN-FILE when it's not NIL." 47 (declare (ignore direction)) 48 (when direction-p 49 (error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE.")) 50 `(with-open-file* (,stream-name ,file-name :direction :output ,@args) 51 ,@body)) 52 53 (defun read-stream-content-into-string (stream &key (buffer-size 4096)) 54 "Return the \"content\" of STREAM as a fresh string." 55 (check-type buffer-size positive-integer) 56 (let ((*print-pretty* nil)) 57 (with-output-to-string (datum) 58 (let ((buffer (make-array buffer-size :element-type 'character))) 59 (loop 60 :for bytes-read = (read-sequence buffer stream) 61 :do (write-sequence buffer datum :start 0 :end bytes-read) 62 :while (= bytes-read buffer-size)))))) 63 64 (defun read-file-into-string (pathname &key (buffer-size 4096) external-format) 65 "Return the contents of the file denoted by PATHNAME as a fresh string. 66 67 The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE 68 unless it's NIL, which means the system default." 69 (with-input-from-file 70 (file-stream pathname :external-format external-format) 71 (read-stream-content-into-string file-stream :buffer-size buffer-size))) 72 73 (defun write-string-into-file (string pathname &key (if-exists :error) 74 if-does-not-exist 75 external-format) 76 "Write STRING to PATHNAME. 77 78 The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE 79 unless it's NIL, which means the system default." 80 (with-output-to-file (file-stream pathname :if-exists if-exists 81 :if-does-not-exist if-does-not-exist 82 :external-format external-format) 83 (write-sequence string file-stream))) 84 85 (defun read-stream-content-into-byte-vector (stream &key ((%length length)) 86 (initial-size 4096)) 87 "Return \"content\" of STREAM as freshly allocated (unsigned-byte 8) vector." 88 (check-type length (or null non-negative-integer)) 89 (check-type initial-size positive-integer) 90 (do ((buffer (make-array (or length initial-size) 91 :element-type '(unsigned-byte 8))) 92 (offset 0) 93 (offset-wanted 0)) 94 ((or (/= offset-wanted offset) 95 (and length (>= offset length))) 96 (if (= offset (length buffer)) 97 buffer 98 (subseq buffer 0 offset))) 99 (unless (zerop offset) 100 (let ((new-buffer (make-array (* 2 (length buffer)) 101 :element-type '(unsigned-byte 8)))) 102 (replace new-buffer buffer) 103 (setf buffer new-buffer))) 104 (setf offset-wanted (length buffer) 105 offset (read-sequence buffer stream :start offset)))) 106 107 (defun read-file-into-byte-vector (pathname) 108 "Read PATHNAME into a freshly allocated (unsigned-byte 8) vector." 109 (with-input-from-file (stream pathname :element-type '(unsigned-byte 8)) 110 (read-stream-content-into-byte-vector stream '%length (file-length stream)))) 111 112 (defun write-byte-vector-into-file (bytes pathname &key (if-exists :error) 113 if-does-not-exist) 114 "Write BYTES to PATHNAME." 115 (check-type bytes (vector (unsigned-byte 8))) 116 (with-output-to-file (stream pathname :if-exists if-exists 117 :if-does-not-exist if-does-not-exist 118 :element-type '(unsigned-byte 8)) 119 (write-sequence bytes stream))) 120 121 (defun copy-file (from to &key (if-to-exists :supersede) 122 (element-type '(unsigned-byte 8)) finish-output) 123 (with-input-from-file (input from :element-type element-type) 124 (with-output-to-file (output to :element-type element-type 125 :if-exists if-to-exists) 126 (copy-stream input output 127 :element-type element-type 128 :finish-output finish-output)))) 129 130 (defun copy-stream (input output &key (element-type (stream-element-type input)) 131 (buffer-size 4096) 132 (buffer (make-array buffer-size :element-type element-type)) 133 (start 0) end 134 finish-output) 135 "Reads data from INPUT and writes it to OUTPUT. Both INPUT and OUTPUT must 136 be streams, they will be passed to READ-SEQUENCE and WRITE-SEQUENCE and must have 137 compatible element-types." 138 (check-type start non-negative-integer) 139 (check-type end (or null non-negative-integer)) 140 (check-type buffer-size positive-integer) 141 (when (and end 142 (< end start)) 143 (error "END is smaller than START in ~S" 'copy-stream)) 144 (let ((output-position 0) 145 (input-position 0)) 146 (unless (zerop start) 147 ;; FIXME add platform specific optimization to skip seekable streams 148 (loop while (< input-position start) 149 do (let ((n (read-sequence buffer input 150 :end (min (length buffer) 151 (- start input-position))))) 152 (when (zerop n) 153 (error "~@<Could not read enough bytes from the input to fulfill ~ 154 the :START ~S requirement in ~S.~:@>" 'copy-stream start)) 155 (incf input-position n)))) 156 (assert (= input-position start)) 157 (loop while (or (null end) (< input-position end)) 158 do (let ((n (read-sequence buffer input 159 :end (when end 160 (min (length buffer) 161 (- end input-position)))))) 162 (when (zerop n) 163 (if end 164 (error "~@<Could not read enough bytes from the input to fulfill ~ 165 the :END ~S requirement in ~S.~:@>" 'copy-stream end) 166 (return))) 167 (incf input-position n) 168 (write-sequence buffer output :end n) 169 (incf output-position n))) 170 (when finish-output 171 (finish-output output)) 172 output-position))