173 lines
8.1 KiB
Common Lisp
173 lines
8.1 KiB
Common Lisp
|
;; Copyright (c) 2002-2006, Edward Marco Baringer
|
||
|
|
;; All rights reserved.
|
||
|
|
|
||
|
|
(in-package :alexandria)
|
||
|
|
|
||
|
|
(defmacro with-open-file* ((stream filespec &key direction element-type
|
||
|
|
if-exists if-does-not-exist external-format)
|
||
|
|
&body body)
|
||
|
|
"Just like WITH-OPEN-FILE, but NIL values in the keyword arguments mean to use
|
||
|
|
the default value specified for OPEN."
|
||
|
|
(once-only (direction element-type if-exists if-does-not-exist external-format)
|
||
|
|
`(with-open-stream
|
||
|
|
(,stream (apply #'open ,filespec
|
||
|
|
(append
|
||
|
|
(when ,direction
|
||
|
|
(list :direction ,direction))
|
||
|
|
(when ,element-type
|
||
|
|
(list :element-type ,element-type))
|
||
|
|
(when ,if-exists
|
||
|
|
(list :if-exists ,if-exists))
|
||
|
|
(when ,if-does-not-exist
|
||
|
|
(list :if-does-not-exist ,if-does-not-exist))
|
||
|
|
(when ,external-format
|
||
|
|
(list :external-format ,external-format)))))
|
||
|
|
,@body)))
|
||
|
|
|
||
|
|
(defmacro with-input-from-file ((stream-name file-name &rest args
|
||
|
|
&key (direction nil direction-p)
|
||
|
|
&allow-other-keys)
|
||
|
|
&body body)
|
||
|
|
"Evaluate BODY with STREAM-NAME to an input stream on the file
|
||
|
|
FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
|
||
|
|
which is only sent to WITH-OPEN-FILE when it's not NIL."
|
||
|
|
(declare (ignore direction))
|
||
|
|
(when direction-p
|
||
|
|
(error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE."))
|
||
|
|
`(with-open-file* (,stream-name ,file-name :direction :input ,@args)
|
||
|
|
,@body))
|
||
|
|
|
||
|
|
(defmacro with-output-to-file ((stream-name file-name &rest args
|
||
|
|
&key (direction nil direction-p)
|
||
|
|
&allow-other-keys)
|
||
|
|
&body body)
|
||
|
|
"Evaluate BODY with STREAM-NAME to an output stream on the file
|
||
|
|
FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
|
||
|
|
which is only sent to WITH-OPEN-FILE when it's not NIL."
|
||
|
|
(declare (ignore direction))
|
||
|
|
(when direction-p
|
||
|
|
(error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE."))
|
||
|
|
`(with-open-file* (,stream-name ,file-name :direction :output ,@args)
|
||
|
|
,@body))
|
||
|
|
|
||
|
|
(defun read-stream-content-into-string (stream &key (buffer-size 4096))
|
||
|
|
"Return the \"content\" of STREAM as a fresh string."
|
||
|
|
(check-type buffer-size positive-integer)
|
||
|
|
(let ((*print-pretty* nil))
|
||
|
|
(with-output-to-string (datum)
|
||
|
|
(let ((buffer (make-array buffer-size :element-type 'character)))
|
||
|
|
(loop
|
||
|
|
:for bytes-read = (read-sequence buffer stream)
|
||
|
|
:do (write-sequence buffer datum :start 0 :end bytes-read)
|
||
|
|
:while (= bytes-read buffer-size))))))
|
||
|
|
|
||
|
|
(defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
|
||
|
|
"Return the contents of the file denoted by PATHNAME as a fresh string.
|
||
|
|
|
||
|
|
The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
|
||
|
|
unless it's NIL, which means the system default."
|
||
|
|
(with-input-from-file
|
||
|
|
(file-stream pathname :external-format external-format)
|
||
|
|
(read-stream-content-into-string file-stream :buffer-size buffer-size)))
|
||
|
|
|
||
|
|
(defun write-string-into-file (string pathname &key (if-exists :error)
|
||
|
|
if-does-not-exist
|
||
|
|
external-format)
|
||
|
|
"Write STRING to PATHNAME.
|
||
|
|
|
||
|
|
The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
|
||
|
|
unless it's NIL, which means the system default."
|
||
|
|
(with-output-to-file (file-stream pathname :if-exists if-exists
|
||
|
|
:if-does-not-exist if-does-not-exist
|
||
|
|
:external-format external-format)
|
||
|
|
(write-sequence string file-stream)))
|
||
|
|
|
||
|
|
(defun read-stream-content-into-byte-vector (stream &key ((%length length))
|
||
|
|
(initial-size 4096))
|
||
|
|
"Return \"content\" of STREAM as freshly allocated (unsigned-byte 8) vector."
|
||
|
|
(check-type length (or null non-negative-integer))
|
||
|
|
(check-type initial-size positive-integer)
|
||
|
|
(do ((buffer (make-array (or length initial-size)
|
||
|
|
:element-type '(unsigned-byte 8)))
|
||
|
|
(offset 0)
|
||
|
|
(offset-wanted 0))
|
||
|
|
((or (/= offset-wanted offset)
|
||
|
|
(and length (>= offset length)))
|
||
|
|
(if (= offset (length buffer))
|
||
|
|
buffer
|
||
|
|
(subseq buffer 0 offset)))
|
||
|
|
(unless (zerop offset)
|
||
|
|
(let ((new-buffer (make-array (* 2 (length buffer))
|
||
|
|
:element-type '(unsigned-byte 8))))
|
||
|
|
(replace new-buffer buffer)
|
||
|
|
(setf buffer new-buffer)))
|
||
|
|
(setf offset-wanted (length buffer)
|
||
|
|
offset (read-sequence buffer stream :start offset))))
|
||
|
|
|
||
|
|
(defun read-file-into-byte-vector (pathname)
|
||
|
|
"Read PATHNAME into a freshly allocated (unsigned-byte 8) vector."
|
||
|
|
(with-input-from-file (stream pathname :element-type '(unsigned-byte 8))
|
||
|
|
(read-stream-content-into-byte-vector stream '%length (file-length stream))))
|
||
|
|
|
||
|
|
(defun write-byte-vector-into-file (bytes pathname &key (if-exists :error)
|
||
|
|
if-does-not-exist)
|
||
|
|
"Write BYTES to PATHNAME."
|
||
|
|
(check-type bytes (vector (unsigned-byte 8)))
|
||
|
|
(with-output-to-file (stream pathname :if-exists if-exists
|
||
|
|
:if-does-not-exist if-does-not-exist
|
||
|
|
:element-type '(unsigned-byte 8))
|
||
|
|
(write-sequence bytes stream)))
|
||
|
|
|
||
|
|
(defun copy-file (from to &key (if-to-exists :supersede)
|
||
|
|
(element-type '(unsigned-byte 8)) finish-output)
|
||
|
|
(with-input-from-file (input from :element-type element-type)
|
||
|
|
(with-output-to-file (output to :element-type element-type
|
||
|
|
:if-exists if-to-exists)
|
||
|
|
(copy-stream input output
|
||
|
|
:element-type element-type
|
||
|
|
:finish-output finish-output))))
|
||
|
|
|
||
|
|
(defun copy-stream (input output &key (element-type (stream-element-type input))
|
||
|
|
(buffer-size 4096)
|
||
|
|
(buffer (make-array buffer-size :element-type element-type))
|
||
|
|
(start 0) end
|
||
|
|
finish-output)
|
||
|
|
"Reads data from INPUT and writes it to OUTPUT. Both INPUT and OUTPUT must
|
||
|
|
be streams, they will be passed to READ-SEQUENCE and WRITE-SEQUENCE and must have
|
||
|
|
compatible element-types."
|
||
|
|
(check-type start non-negative-integer)
|
||
|
|
(check-type end (or null non-negative-integer))
|
||
|
|
(check-type buffer-size positive-integer)
|
||
|
|
(when (and end
|
||
|
|
(< end start))
|
||
|
|
(error "END is smaller than START in ~S" 'copy-stream))
|
||
|
|
(let ((output-position 0)
|
||
|
|
(input-position 0))
|
||
|
|
(unless (zerop start)
|
||
|
|
;; FIXME add platform specific optimization to skip seekable streams
|
||
|
|
(loop while (< input-position start)
|
||
|
|
do (let ((n (read-sequence buffer input
|
||
|
|
:end (min (length buffer)
|
||
|
|
(- start input-position)))))
|
||
|
|
(when (zerop n)
|
||
|
|
(error "~@<Could not read enough bytes from the input to fulfill ~
|
||
|
|
the :START ~S requirement in ~S.~:@>" 'copy-stream start))
|
||
|
|
(incf input-position n))))
|
||
|
|
(assert (= input-position start))
|
||
|
|
(loop while (or (null end) (< input-position end))
|
||
|
|
do (let ((n (read-sequence buffer input
|
||
|
|
:end (when end
|
||
|
|
(min (length buffer)
|
||
|
|
(- end input-position))))))
|
||
|
|
(when (zerop n)
|
||
|
|
(if end
|
||
|
|
(error "~@<Could not read enough bytes from the input to fulfill ~
|
||
|
|
the :END ~S requirement in ~S.~:@>" 'copy-stream end)
|
||
|
|
(return)))
|
||
|
|
(incf input-position n)
|
||
|
|
(write-sequence buffer output :end n)
|
||
|
|
(incf output-position n)))
|
||
|
|
(when finish-output
|
||
|
|
(finish-output output))
|
||
|
|
output-position))
|