X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=io.lisp;h=4f896ed7584219f32fd425f0fcab74b7cdf5a41b;hp=68a6bc23cd9a8ab956d6f19ebc3db815d0870f61;hb=ea921dd2ce51a46bb3ca92a07df095d5ace99dcf;hpb=e45bcc21473cb56f074ba85bcef89ebae5851ced

diff --git a/io.lisp b/io.lisp
index 68a6bc2..4f896ed 100644
--- a/io.lisp
+++ b/io.lisp
@@ -9,7 +9,7 @@
 ;;;;
 ;;;; $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
@@ -21,33 +21,52 @@
 (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))))))
-
+      (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)
@@ -170,61 +189,12 @@
 
 
 
-#+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))  
+    (open #p"/dev/null" :direction :output :if-exists :overwrite))  
   )
 
-(defun un-unspecific (value)
-  "Convert :UNSPECIFIC to NIL."
-  (if (eq value :unspecific) nil value))
-
-(defun canonicalize-directory-name (filename)
-  (flet ((un-unspecific (value)
-	   (if (eq value :unspecific) nil value)))
-    (let* ((path (pathname filename))
-	   (name (un-unspecific (pathname-name path)))
-	   (type (un-unspecific (pathname-type path)))
-	   (new-dir
-	    (cond ((and name type) (list (concatenate 'string name "." type)))
-		  (name (list name))
-		  (type (list type))
-		  (t nil))))
-      (if new-dir
-	  (make-pathname
-	   :directory (append (un-unspecific (pathname-directory path))
-			      new-dir)
-		    :name nil :type nil :version nil :defaults path)
-	  path))))
-  
-(defun probe-directory (filename)
-  (let ((path (canonicalize-directory-name filename)))
-    #+allegro (excl:probe-directory path)
-    #+clisp (values
-	     (ignore-errors
-	       (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory
-			  path)))
-    #+(or cmu scl) (eq :directory (unix:unix-file-kind (namestring path)))
-    #+lispworks (lw:file-directory-p path)
-    #+sbcl (eq :directory (sb-unix:unix-file-kind (namestring path)))
-    #-(or allegro clisp cmu lispworks sbcl scl)
-    (probe-file path)))
 
 (defun directory-tree (filename)
   "Returns a tree of pathnames for sub-directories of a directory"
@@ -245,4 +215,116 @@
 	    (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)))
+