;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
(defun print-file-contents (file &optional (strm *standard-output*))
"Opens a reads a file. Returns the contents as a single string"
(when (probe-file file)
- (with-open-file (in file :direction :input)
- (let ((eof (gensym)))
- (do ((line (read-line in nil eof)
- (read-line in nil eof)))
- ((eq line eof))
- (format strm "~A~%" line))))))
+ (let ((eof (cons 'eof nil)))
+ (with-open-file (in file :direction :input)
+ (do ((line (read-line in nil eof)
+ (read-line in nil eof)))
+ ((eq line eof))
+ (write-string line strm)
+ (write-char #\newline strm))))))
+
+(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)))))
(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)
- (let ((eof (gensym)))
- (do ((line (read-line in nil eof)
- (read-line in nil eof)))
- ((eq line eof))
- (format out "~A~%" line))))))
+ (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))
+ (push line lines))
+ (nreverse lines)))
(defun read-file-to-strings (file)
"Opens a reads a file. Returns the contents as a list of strings"
- (let ((lines '()))
- (with-open-file (in file :direction :input)
- (let ((eof (gensym)))
- (do ((line (read-line in nil eof)
- (read-line in nil eof)))
- ((eq line eof))
- (push line lines)))
- (nreverse lines))))
+ (with-open-file (in file :direction :input)
+ (read-stream-to-strings in)))
(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)
(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)))
(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))))
-#+openmcl
-(defun open-device-stream (path direction)
- (let* ((mode (ecase direction
- (:input #.(read-from-string "#$O_RDONLY"))
- (:output #.(read-from-string "#$O_WRONLY"))
- (:io #.(read-from-string "#$O_RDWR"))))
- (fd (ccl::fd-open (ccl::native-translated-namestring path) mode)))
- (if (< fd 0)
- (ccl::signal-file-error fd path)
- (ccl::make-fd-stream fd :direction direction))))
-
(defun null-output-stream ()
- #-openmcl
(when (probe-file #p"/dev/null")
(open #p"/dev/null" :direction :output :if-exists :overwrite))
- #+openmcl
- (when (probe-file #p"/dev/null")
- (open-device-stream #p"/dev/null" :output))
)
(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)
+ "UTIME is a universal-time, ZONE is a number of hours offset from UTC, or NIL to use local time. Execute BODY in an environment where SECOND MINUTE HOUR DAY-OF-MONTH MONTH YEAR DAY-OF-WEEK DAYLIGHT-P ZONE are bound to the decoded components of the universal time"
+ `(multiple-value-bind
+ (second minute hour day-of-month month year day-of-week daylight-p zone)
+ (decode-universal-time ,utime ,@(if zone (list zone)))
+ (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone))
+ ,@body))
+
+(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")))
+
+(defun is-dst (utime)
+ (with-utime-decoding (utime)
+ daylight-p))
+
+
+(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))))))
+ (if ,zone
+ (with-utime-decoding (,utime ,zone)
+ ,@body)
+ (with-utime-decoding (,utime)
+ ,@body)))))
+
+
+(defun write-utime-hms (utime &key utc-offset stream)
+ (if stream
+ (write-utime-hms-stream utime stream utc-offset)
+ (with-output-to-string (s)
+ (write-utime-hms-stream utime s utc-offset))))
+
+(defun write-utime-hms-stream (utime stream &optional utc-offset)
+ (with-utime-decoding-utc-offset (utime utc-offset)
+ (write-string (aref +datetime-number-strings+ hour) stream)
+ (write-char #\: stream)
+ (write-string (aref +datetime-number-strings+ minute) stream)
+ (write-char #\: stream)
+ (write-string (aref +datetime-number-strings+ second) stream)))
+
+(defun write-utime-hm (utime &key utc-offset stream)
+ (if stream
+ (write-utime-hm-stream utime stream utc-offset)
+ (with-output-to-string (s)
+ (write-utime-hm-stream utime s utc-offset))))
+
+(defun write-utime-hm-stream (utime stream &optional utc-offset)
+ (with-utime-decoding-utc-offset (utime utc-offset)
+ (write-string (aref +datetime-number-strings+ hour) stream)
+ (write-char #\: stream)
+ (write-string (aref +datetime-number-strings+ minute) stream)))
+
+
+(defun write-utime-ymdhms (utime &key stream utc-offset)
+ (if stream
+ (write-utime-ymdhms-stream utime stream utc-offset)
+ (with-output-to-string (s)
+ (write-utime-ymdhms-stream utime s utc-offset))))
+
+(defun write-utime-ymdhms-stream (utime stream &optional utc-offset)
+ (with-utime-decoding-utc-offset (utime utc-offset)
+ (write-string (prefixed-fixnum-string year nil 4) stream)
+ (write-char #\/ stream)
+ (write-string (aref +datetime-number-strings+ month) stream)
+ (write-char #\/ stream)
+ (write-string (aref +datetime-number-strings+ day-of-month) stream)
+ (write-char #\space stream)
+ (write-string (aref +datetime-number-strings+ hour) stream)
+ (write-char #\: stream)
+ (write-string (aref +datetime-number-strings+ minute) stream)
+ (write-char #\: stream)
+ (write-string (aref +datetime-number-strings+ second) stream)))
+
+(defun write-utime-ymdhm (utime &key stream utc-offset)
+ (if stream
+ (write-utime-ymdhm-stream utime stream utc-offset)
+ (with-output-to-string (s)
+ (write-utime-ymdhm-stream utime s utc-offset))))
+
+(defun write-utime-ymdhm-stream (utime stream &optional utc-offset)
+ (with-utime-decoding-utc-offset (utime utc-offset)
+ (write-string (prefixed-fixnum-string year nil 4) stream)
+ (write-char #\/ stream)
+ (write-string (aref +datetime-number-strings+ month) stream)
+ (write-char #\/ stream)
+ (write-string (aref +datetime-number-strings+ day-of-month) stream)
+ (write-char #\space stream)
+ (write-string (aref +datetime-number-strings+ hour) stream)
+ (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)))
+
+
+(defmacro def-unsigned-int-io (len r-name w-name &key (big-endian nil))
+ "Defines read and write functions for an unsigned integer with LEN bytes from STREAM."
+ (when (< len 1)
+ (error "Number of bytes must be greater than 0.~%"))
+ (let ((endian-string (if big-endian "big" "little")))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun ,r-name (stream)
+ ,(format nil "Reads an ~A byte unsigned integer (~A-endian)."
+ len endian-string)
+ (declare (optimize (speed 3) (compilation-speed 0) (safety 0)
+ (space 0) (debug 0))
+ (type stream stream))
+ (let ((val 0))
+ (declare (type
+ ,(if (< (expt 256 len) most-positive-fixnum)
+ 'fixnum
+ `(integer 0 ,(1- (expt 256 len))))
+ val))
+ ,@(loop for i from 1 upto len
+ collect
+ `(setf (ldb (byte 8 ,(* (if big-endian (1- i) (- len i))
+ 8)) val) (read-byte stream)))
+ val))
+ (defun ,w-name (val stream &key (bounds-check t))
+ ,(format nil "Writes an ~A byte unsigned integer as binary to STREAM (~A-endian)."
+ len endian-string)
+ (declare (optimize (speed 3) (compilation-speed 0) (safety 0)
+ (space 0) (debug 0))
+ (type stream stream)
+ ,(if (< (expt 256 len) most-positive-fixnum)
+ '(type fixnum val)
+ '(type integer val)))
+ (when bounds-check
+ (when (>= val ,(expt 256 len))
+ (error "Number ~D is too large to fit in ~D bytes.~%" val ,len))
+ (when (minusp val)
+ (error "Number ~D can't be written as unsigned integer." val)))
+ (locally (declare (type (integer 0 ,(1- (expt 256 len))) val))
+ ,@(loop for i from 1 upto len
+ collect
+ `(write-byte (ldb (byte 8 ,(* (if big-endian (1- i) (- len i))
+ 8)) val) stream)))
+ val)
+ nil)))
+
+(defmacro make-unsigned-int-io-fn (len)
+ "Makes reader and writer functions for unsigned byte input/output of
+LEN bytes with both little and big endian order. Function names are in the
+form of {READ,WRITE}-UINT<LEN>-{be,le}."
+ `(progn
+ (def-unsigned-int-io
+ ,len
+ ,(intern (format nil "~A~D-~A" (symbol-name '#:read-uint) len (symbol-name '#:le)))
+ ,(intern (format nil "~A~D-~A" (symbol-name '#:write-uint) len (symbol-name '#:le)))
+ :big-endian nil)
+ (def-unsigned-int-io
+ ,len
+ ,(intern (format nil "~A~D-~A" (symbol-name '#:read-uint) len (symbol-name '#:be)))
+ ,(intern (format nil "~A~D-~A" (symbol-name '#:write-uint) len (symbol-name '#:be)))
+ :big-endian t)))
+
+(make-unsigned-int-io-fn 2)
+(make-unsigned-int-io-fn 3)
+(make-unsigned-int-io-fn 4)
+(make-unsigned-int-io-fn 5)
+(make-unsigned-int-io-fn 6)
+(make-unsigned-int-io-fn 7)
+(make-unsigned-int-io-fn 8)
projects / kmrcl.git / blobdiff