X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=io.lisp;h=7f06bd9b51b2f97ef6e62f791a09260c28ecd139;hp=abb9d2f0140a8b74c5772f8d630c783e06f3c7d0;hb=54cd6cb1b9550ac2310e2c6dffc9cdecd2bdccd3;hpb=d9a31b85e6cc4cd8e2ab091b422b14097fd6b66b

diff --git a/io.lisp b/io.lisp
index abb9d2f..7f06bd9 100644
--- a/io.lisp
+++ b/io.lisp
@@ -7,64 +7,98 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: io.lisp,v 1.3 2003/05/09 05:13:49 kevin Exp $
-;;;;
-;;;; 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
 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
-(in-package :kmrcl)
+(in-package #:kmrcl)
 
 (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)
+  (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
+  (dotimes (i n)
+    (declare (fixnum i))
+    (write-char char stream)))
+
+(defun print-n-strings (str n stream)
+  (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
+  (dotimes (i n)
+    (declare (fixnum i))
+    (write-string str stream)))
+
 (defun indent-spaces (n &optional (stream *standard-output*))
   "Indent n*2 spaces to output stream"
-  (write-string (make-string (+ n n) :initial-element #\space) stream))
+  (print-n-chars #\space (+ n 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)))
 
 
@@ -89,7 +123,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))))
@@ -145,3 +179,218 @@
              (setf pos 0))))
     (buf-flush buf out)))
 
+(declaim (inline write-fixnum))
+(defun write-fixnum (n s)
+  #+allegro (excl::print-fixnum s 10 n)
+  #-allegro (write-string (write-to-string n) s))
+
+
+
+
+(defun null-output-stream ()
+  (when (probe-file #p"/dev/null")
+    (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))))
+    (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)))))
+
+
+(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)