X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=io.lisp;h=851c3718eae62f98c828b812fefbc691c70db937;hp=75ee65087b1c3ccd78ed37749818e5de5c6c3556;hb=373a64e9369c2e96c465eb462a035884c7e08fa6;hpb=7808e314e1cc884ca3b86cc6936138f97b4f2a2e diff --git a/io.lisp b/io.lisp index 75ee650..851c371 100644 --- a/io.lisp +++ b/io.lisp @@ -23,7 +23,7 @@ (when (probe-file file) (let ((eof (cons 'eof nil))) (with-open-file (in file :direction :input) - (do ((line (read-line in nil eof) + (do ((line (read-line in nil eof) (read-line in nil eof))) ((eq line eof)) (write-string line strm) @@ -31,27 +31,37 @@ (defun read-stream-to-string (in) (with-output-to-string (out) - (let ((eof (gensym))) - (do ((line (read-line in nil eof) - (read-line in nil eof))) - ((eq line eof)) - (format out "~A~%" line))))) - + (let ((eof (gensym))) + (do ((line (read-line in nil eof) + (read-line in nil eof))) + ((eq line eof)) + (format out "~A~%" line))))) + (defun read-file-to-string (file) "Opens a reads a file. Returns the contents as a single string" - (with-output-to-string (out) - (with-open-file (in file :direction :input) - (read-stream-to-string in)))) + (with-open-file (in file :direction :input) + (read-stream-to-string in))) + +(defun read-file-to-usb8-array (file) + "Opens a reads a file. Returns the contents as single unsigned-byte array" + (with-open-file (in file :direction :input :element-type '(unsigned-byte 8)) + (let* ((file-len (file-length in)) + (usb8 (make-array file-len :element-type '(unsigned-byte 8))) + (pos (read-sequence usb8 in))) + (unless (= file-len pos) + (error "Length read (~D) doesn't match file length (~D)~%" pos file-len)) + usb8))) + (defun read-stream-to-strings (in) (let ((lines '()) - (eof (gensym))) - (do ((line (read-line in nil eof) - (read-line in nil eof))) - ((eq line eof)) + (eof (gensym))) + (do ((line (read-line in nil eof) + (read-line in nil eof))) + ((eq line eof)) (push line lines)) (nreverse lines))) - + (defun read-file-to-strings (file) "Opens a reads a file. Returns the contents as a list of strings" (with-open-file (in file :direction :input) @@ -60,7 +70,7 @@ (defun file-subst (old new file1 file2) (with-open-file (in file1 :direction :input) (with-open-file (out file2 :direction :output - :if-exists :supersede) + :if-exists :supersede) (stream-subst old new in out)))) (defun print-n-chars (char n stream) @@ -83,14 +93,14 @@ (defun indent-html-spaces (n &optional (stream *standard-output*)) "Indent n*2 html spaces to output stream" (print-n-strings " " (+ n n) stream)) - + (defun print-list (l &optional (output *standard-output*)) "Print a list to a stream" (format output "~{~A~%~}" l)) (defun print-rows (rows &optional (ostrm *standard-output*)) - "Print a list of list rows to a stream" + "Print a list of list rows to a stream" (dolist (r rows) (format ostrm "~{~A~^ ~}~%" r))) @@ -115,7 +125,7 @@ (setf (bref b (incf (buf-end b))) x)) (defun buf-pop (b) - (prog1 + (prog1 (bref b (incf (buf-start b))) (setf (buf-used b) (buf-start b) (buf-new b) (buf-end b)))) @@ -181,28 +191,28 @@ (defun null-output-stream () (when (probe-file #p"/dev/null") - (open #p"/dev/null" :direction :output :if-exists :overwrite)) + (open #p"/dev/null" :direction :output :if-exists :overwrite)) ) (defun directory-tree (filename) "Returns a tree of pathnames for sub-directories of a directory" (let* ((root (canonicalize-directory-name filename)) - (subdirs (loop for path in (directory - (make-pathname :name :wild - :type :wild - :defaults root)) - when (probe-directory path) - collect (canonicalize-directory-name path)))) + (subdirs (loop for path in (directory + (make-pathname :name :wild + :type :wild + :defaults root)) + when (probe-directory path) + collect (canonicalize-directory-name path)))) (when (find nil subdirs) (error "~A" subdirs)) (when (null root) (error "~A" root)) (if subdirs - (cons root (mapcar #'directory-tree subdirs)) - (if (probe-directory root) - (list root) - (error "root not directory ~A" root))))) + (cons root (mapcar #'directory-tree subdirs)) + (if (probe-directory root) + (list root) + (error "root not directory ~A" root))))) (defmacro with-utime-decoding ((utime &optional zone) &body body) @@ -213,15 +223,15 @@ (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone)) ,@body)) -(defvar +datetime-number-strings+ +(defvar +datetime-number-strings+ (make-array 61 :adjustable nil :element-type 'string :fill-pointer nil - :initial-contents - '("00" "01" "02" "03" "04" "05" "06" "07" "08" "09" "10" "11" - "12" "13" "14" "15" "16" "17" "18" "19" "20" "21" "22" "23" - "24" "25" "26" "27" "28" "29" "30" "31" "32" "33" "34" "35" - "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" "46" "47" - "48" "49" "50" "51" "52" "53" "54" "55" "56" "57" "58" "59" - "60"))) + :initial-contents + '("00" "01" "02" "03" "04" "05" "06" "07" "08" "09" "10" "11" + "12" "13" "14" "15" "16" "17" "18" "19" "20" "21" "22" "23" + "24" "25" "26" "27" "28" "29" "30" "31" "32" "33" "34" "35" + "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" "46" "47" + "48" "49" "50" "51" "52" "53" "54" "55" "56" "57" "58" "59" + "60"))) (defun is-dst (utime) (with-utime-decoding (utime) @@ -231,19 +241,19 @@ (defmacro with-utime-decoding-utc-offset ((utime utc-offset) &body body) (with-gensyms (zone) `(let* ((,zone (cond - ((eq :utc ,utc-offset) - 0) - ((null utc-offset) - nil) - (t - (if (is-dst ,utime) - (1- (- ,utc-offset)) - (- ,utc-offset)))))) + ((eq :utc ,utc-offset) + 0) + ((null utc-offset) + nil) + (t + (if (is-dst ,utime) + (1- (- ,utc-offset)) + (- ,utc-offset)))))) (if ,zone - (with-utime-decoding (,utime ,zone) - ,@body) - (with-utime-decoding (,utime) - ,@body))))) + (with-utime-decoding (,utime ,zone) + ,@body) + (with-utime-decoding (,utime) + ,@body))))) (defun write-utime-hms (utime &key utc-offset stream) @@ -311,4 +321,9 @@ (write-char #\: stream) (write-string (aref +datetime-number-strings+ minute) stream))) +(defun copy-binary-stream (in out &key (chunk-size 16384)) + (do* ((buf (make-array chunk-size :element-type '(unsigned-byte 8))) + (pos (read-sequence buf in) (read-sequence buf in))) + ((zerop pos)) + (write-sequence buf out :end pos)))