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-stream-to-strings (in)
49 (do ((line (read-line in nil eof)
50 (read-line in nil eof)))
55 (defun read-file-to-strings (file)
56 "Opens a reads a file. Returns the contents as a list of strings"
57 (with-open-file (in file :direction :input)
58 (read-stream-to-strings in)))
60 (defun file-subst (old new file1 file2)
61 (with-open-file (in file1 :direction :input)
62 (with-open-file (out file2 :direction :output
63 :if-exists :supersede)
64 (stream-subst old new in out))))
66 (defun print-n-chars (char n stream)
67 (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
70 (write-char char stream)))
72 (defun print-n-strings (str n stream)
73 (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
76 (write-string str stream)))
78 (defun indent-spaces (n &optional (stream *standard-output*))
79 "Indent n*2 spaces to output stream"
80 (print-n-chars #\space (+ n n) stream))
83 (defun indent-html-spaces (n &optional (stream *standard-output*))
84 "Indent n*2 html spaces to output stream"
85 (print-n-strings " " (+ n n) stream))
88 (defun print-list (l &optional (output *standard-output*))
89 "Print a list to a stream"
90 (format output "~{~A~%~}" l))
92 (defun print-rows (rows &optional (ostrm *standard-output*))
93 "Print a list of list rows to a stream"
94 (dolist (r rows) (format ostrm "~{~A~^ ~}~%" r)))
97 ;; Buffered stream substitute
100 vec (start -1) (used -1) (new -1) (end -1))
104 (mod n (length (buf-vec buf)))))
106 (defun (setf bref) (val buf n)
107 (setf (svref (buf-vec buf)
108 (mod n (length (buf-vec buf))))
112 (make-buf :vec (make-array len)))
114 (defun buf-insert (x b)
115 (setf (bref b (incf (buf-end b))) x))
119 (bref b (incf (buf-start b)))
120 (setf (buf-used b) (buf-start b)
121 (buf-new b) (buf-end b))))
124 (when (< (buf-used b) (buf-new b))
125 (bref b (incf (buf-used b)))))
128 (setf (buf-used b) (buf-start b)
129 (buf-new b) (buf-end b)))
132 (setf (buf-start b) -1 (buf-used b) -1
133 (buf-new b) -1 (buf-end b) -1))
135 (defun buf-flush (b str)
136 (do ((i (1+ (buf-used b)) (1+ i)))
138 (princ (bref b i) str)))
141 (defun stream-subst (old new in out)
142 (declare (string old new))
147 (declare (fixnum pos len))
148 (do ((c (read-char in nil :eof)
149 (or (setf from-buf (buf-next buf))
150 (read-char in nil :eof))))
152 (declare (character c))
153 (cond ((char= c (char old pos))
155 (cond ((= pos len) ; 3
160 (buf-insert c buf))))
169 (princ (buf-pop buf) out)
172 (buf-flush buf out)))
174 (declaim (inline write-fixnum))
175 (defun write-fixnum (n s)
176 #+allegro (excl::print-fixnum s 10 n)
177 #-allegro (write-string (write-to-string n) s))
182 (defun open-device-stream (path direction)
183 (let* ((mode (ecase direction
184 (:input #.(read-from-string "#$O_RDONLY"))
185 (:output #.(read-from-string "#$O_WRONLY"))
186 (:io #.(read-from-string "#$O_RDWR"))))
187 (fd (ccl::fd-open (ccl::native-translated-namestring path) mode)))
189 (ccl::signal-file-error fd path)
190 (ccl::make-fd-stream fd :direction direction))))
193 (defun null-output-stream ()
195 (when (probe-file #p"/dev/null")
196 (open #p"/dev/null" :direction :output :if-exists :overwrite))
198 (when (probe-file #p"/dev/null")
199 (open-device-stream #p"/dev/null" :output))
203 (defun directory-tree (filename)
204 "Returns a tree of pathnames for sub-directories of a directory"
205 (let* ((root (canonicalize-directory-name filename))
206 (subdirs (loop for path in (directory
207 (make-pathname :name :wild
210 when (probe-directory path)
211 collect (canonicalize-directory-name path))))
212 (when (find nil subdirs)
213 (error "~A" subdirs))
217 (cons root (mapcar #'directory-tree subdirs))
218 (if (probe-directory root)
220 (error "root not directory ~A" root)))))