1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Input/Output functions for KMRCL package
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
12 ;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
14 ;;;; KMRCL users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
21 (defun print-file-contents (file &optional (strm *standard-output*))
22 "Opens a reads a file. Returns the contents as a single string"
23 (when (probe-file file)
24 (let ((eof (cons 'eof nil)))
25 (with-open-file (in file :direction :input)
26 (do ((line (read-line in nil eof)
27 (read-line in nil eof)))
29 (write-string line strm)
30 (write-char #\newline strm))))))
32 (defun read-stream-to-string (in)
33 (with-output-to-string (out)
35 (do ((line (read-line in nil eof)
36 (read-line in nil eof)))
38 (format out "~A~%" line)))))
40 (defun read-file-to-string (file)
41 "Opens a reads a file. Returns the contents as a single string"
42 (with-output-to-string (out)
43 (with-open-file (in file :direction :input)
44 (read-stream-to-string in))))
46 (defun read-file-to-usb8-array (file)
47 "Opens a reads a file. Returns the contents as single unsigned-byte array"
48 (with-open-file (in file :direction :input :element-type '(unsigned-byte 8))
49 (let* ((file-len (file-length in))
50 (usb8 (make-array file-len :element-type '(unsigned-byte 8)))
51 (pos (read-sequence usb8 in)))
52 (unless (= file-len pos)
53 (error "Length read (~D) doesn't match file length (~D)~%" pos file-len))
57 (defun read-stream-to-strings (in)
60 (do ((line (read-line in nil eof)
61 (read-line in nil eof)))
66 (defun read-file-to-strings (file)
67 "Opens a reads a file. Returns the contents as a list of strings"
68 (with-open-file (in file :direction :input)
69 (read-stream-to-strings in)))
71 (defun file-subst (old new file1 file2)
72 (with-open-file (in file1 :direction :input)
73 (with-open-file (out file2 :direction :output
74 :if-exists :supersede)
75 (stream-subst old new in out))))
77 (defun print-n-chars (char n stream)
78 (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
81 (write-char char stream)))
83 (defun print-n-strings (str n stream)
84 (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
87 (write-string str stream)))
89 (defun indent-spaces (n &optional (stream *standard-output*))
90 "Indent n*2 spaces to output stream"
91 (print-n-chars #\space (+ n n) stream))
94 (defun indent-html-spaces (n &optional (stream *standard-output*))
95 "Indent n*2 html spaces to output stream"
96 (print-n-strings " " (+ n n) stream))
99 (defun print-list (l &optional (output *standard-output*))
100 "Print a list to a stream"
101 (format output "~{~A~%~}" l))
103 (defun print-rows (rows &optional (ostrm *standard-output*))
104 "Print a list of list rows to a stream"
105 (dolist (r rows) (format ostrm "~{~A~^ ~}~%" r)))
108 ;; Buffered stream substitute
111 vec (start -1) (used -1) (new -1) (end -1))
115 (mod n (length (buf-vec buf)))))
117 (defun (setf bref) (val buf n)
118 (setf (svref (buf-vec buf)
119 (mod n (length (buf-vec buf))))
123 (make-buf :vec (make-array len)))
125 (defun buf-insert (x b)
126 (setf (bref b (incf (buf-end b))) x))
130 (bref b (incf (buf-start b)))
131 (setf (buf-used b) (buf-start b)
132 (buf-new b) (buf-end b))))
135 (when (< (buf-used b) (buf-new b))
136 (bref b (incf (buf-used b)))))
139 (setf (buf-used b) (buf-start b)
140 (buf-new b) (buf-end b)))
143 (setf (buf-start b) -1 (buf-used b) -1
144 (buf-new b) -1 (buf-end b) -1))
146 (defun buf-flush (b str)
147 (do ((i (1+ (buf-used b)) (1+ i)))
149 (princ (bref b i) str)))
152 (defun stream-subst (old new in out)
153 (declare (string old new))
158 (declare (fixnum pos len))
159 (do ((c (read-char in nil :eof)
160 (or (setf from-buf (buf-next buf))
161 (read-char in nil :eof))))
163 (declare (character c))
164 (cond ((char= c (char old pos))
166 (cond ((= pos len) ; 3
171 (buf-insert c buf))))
180 (princ (buf-pop buf) out)
183 (buf-flush buf out)))
185 (declaim (inline write-fixnum))
186 (defun write-fixnum (n s)
187 #+allegro (excl::print-fixnum s 10 n)
188 #-allegro (write-string (write-to-string n) s))
193 (defun null-output-stream ()
194 (when (probe-file #p"/dev/null")
195 (open #p"/dev/null" :direction :output :if-exists :overwrite))
199 (defun directory-tree (filename)
200 "Returns a tree of pathnames for sub-directories of a directory"
201 (let* ((root (canonicalize-directory-name filename))
202 (subdirs (loop for path in (directory
203 (make-pathname :name :wild
206 when (probe-directory path)
207 collect (canonicalize-directory-name path))))
208 (when (find nil subdirs)
209 (error "~A" subdirs))
213 (cons root (mapcar #'directory-tree subdirs))
214 (if (probe-directory root)
216 (error "root not directory ~A" root)))))
219 (defmacro with-utime-decoding ((utime &optional zone) &body body)
220 "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"
221 `(multiple-value-bind
222 (second minute hour day-of-month month year day-of-week daylight-p zone)
223 (decode-universal-time ,utime ,@(if zone (list zone)))
224 (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone))
227 (defvar +datetime-number-strings+
228 (make-array 61 :adjustable nil :element-type 'string :fill-pointer nil
230 '("00" "01" "02" "03" "04" "05" "06" "07" "08" "09" "10" "11"
231 "12" "13" "14" "15" "16" "17" "18" "19" "20" "21" "22" "23"
232 "24" "25" "26" "27" "28" "29" "30" "31" "32" "33" "34" "35"
233 "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" "46" "47"
234 "48" "49" "50" "51" "52" "53" "54" "55" "56" "57" "58" "59"
237 (defun is-dst (utime)
238 (with-utime-decoding (utime)
242 (defmacro with-utime-decoding-utc-offset ((utime utc-offset) &body body)
245 ((eq :utc ,utc-offset)
254 (with-utime-decoding (,utime ,zone)
256 (with-utime-decoding (,utime)
260 (defun write-utime-hms (utime &key utc-offset stream)
262 (write-utime-hms-stream utime stream utc-offset)
263 (with-output-to-string (s)
264 (write-utime-hms-stream utime s utc-offset))))
266 (defun write-utime-hms-stream (utime stream &optional utc-offset)
267 (with-utime-decoding-utc-offset (utime utc-offset)
268 (write-string (aref +datetime-number-strings+ hour) stream)
269 (write-char #\: stream)
270 (write-string (aref +datetime-number-strings+ minute) stream)
271 (write-char #\: stream)
272 (write-string (aref +datetime-number-strings+ second) stream)))
274 (defun write-utime-hm (utime &key utc-offset stream)
276 (write-utime-hm-stream utime stream utc-offset)
277 (with-output-to-string (s)
278 (write-utime-hm-stream utime s utc-offset))))
280 (defun write-utime-hm-stream (utime stream &optional utc-offset)
281 (with-utime-decoding-utc-offset (utime utc-offset)
282 (write-string (aref +datetime-number-strings+ hour) stream)
283 (write-char #\: stream)
284 (write-string (aref +datetime-number-strings+ minute) stream)))
287 (defun write-utime-ymdhms (utime &key stream utc-offset)
289 (write-utime-ymdhms-stream utime stream utc-offset)
290 (with-output-to-string (s)
291 (write-utime-ymdhms-stream utime s utc-offset))))
293 (defun write-utime-ymdhms-stream (utime stream &optional utc-offset)
294 (with-utime-decoding-utc-offset (utime utc-offset)
295 (write-string (prefixed-fixnum-string year nil 4) stream)
296 (write-char #\/ stream)
297 (write-string (aref +datetime-number-strings+ month) stream)
298 (write-char #\/ stream)
299 (write-string (aref +datetime-number-strings+ day-of-month) stream)
300 (write-char #\space stream)
301 (write-string (aref +datetime-number-strings+ hour) stream)
302 (write-char #\: stream)
303 (write-string (aref +datetime-number-strings+ minute) stream)
304 (write-char #\: stream)
305 (write-string (aref +datetime-number-strings+ second) stream)))
307 (defun write-utime-ymdhm (utime &key stream utc-offset)
309 (write-utime-ymdhm-stream utime stream utc-offset)
310 (with-output-to-string (s)
311 (write-utime-ymdhm-stream utime s utc-offset))))
313 (defun write-utime-ymdhm-stream (utime stream &optional utc-offset)
314 (with-utime-decoding-utc-offset (utime utc-offset)
315 (write-string (prefixed-fixnum-string year nil 4) stream)
316 (write-char #\/ stream)
317 (write-string (aref +datetime-number-strings+ month) stream)
318 (write-char #\/ stream)
319 (write-string (aref +datetime-number-strings+ day-of-month) stream)
320 (write-char #\space stream)
321 (write-string (aref +datetime-number-strings+ hour) stream)
322 (write-char #\: stream)
323 (write-string (aref +datetime-number-strings+ minute) stream)))
325 (defun copy-binary-stream (in out &key (chunk-size 16384))
326 (do* ((buf (make-array chunk-size :element-type '(unsigned-byte 8)))
327 (pos (read-sequence buf in) (read-sequence buf in)))
329 (write-sequence buf out :end pos)))