io.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          io.lisp
   6 ;;;; Purpose:       Input/Output functions for KMRCL package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
  13 ;;;;
  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 ;;;; *************************************************************************
  18
  19 (in-package #:kmrcl)
  20
  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)))
  28             ((eq line eof))
  29           (write-string line strm)
  30           (write-char #\newline strm))))))
  31
  32 (defun read-stream-to-string (in)
  33   (with-output-to-string (out)
  34     (let ((eof (gensym)))
  35       (do ((line (read-line in nil eof)
  36                  (read-line in nil eof)))
  37           ((eq line eof))
  38         (format out "~A~%" line)))))
  39
  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))))
  45
  46 (defun read-stream-to-strings (in)
  47   (let ((lines '())
  48         (eof (gensym)))
  49     (do ((line (read-line in nil eof)
  50                (read-line in nil eof)))
  51         ((eq line eof))
  52       (push line lines))
  53     (nreverse lines)))
  54
  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)))
  59
  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))))
  65
  66 (defun print-n-chars (char n stream)
  67   (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
  68   (dotimes (i n)
  69     (declare (fixnum i))
  70     (write-char char stream)))
  71
  72 (defun print-n-strings (str n stream)
  73   (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
  74   (dotimes (i n)
  75     (declare (fixnum i))
  76     (write-string str stream)))
  77
  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))
  81
  82
  83 (defun indent-html-spaces (n &optional (stream *standard-output*))
  84   "Indent n*2 html spaces to output stream"
  85   (print-n-strings "&nbsp;" (+ n n) stream))
  86
  87
  88 (defun print-list (l &optional (output *standard-output*))
  89   "Print a list to a stream"
  90   (format output "~{~A~%~}" l))
  91
  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)))
  95
  96
  97 ;; Buffered stream substitute
  98
  99 (defstruct buf
 100   vec (start -1) (used -1) (new -1) (end -1))
 101
 102 (defun bref (buf n)
 103   (svref (buf-vec buf)
 104          (mod n (length (buf-vec buf)))))
 105
 106 (defun (setf bref) (val buf n)
 107   (setf (svref (buf-vec buf)
 108                (mod n (length (buf-vec buf))))
 109         val))
 110
 111 (defun new-buf (len)
 112   (make-buf :vec (make-array len)))
 113
 114 (defun buf-insert (x b)
 115   (setf (bref b (incf (buf-end b))) x))
 116
 117 (defun buf-pop (b)
 118   (prog1
 119     (bref b (incf (buf-start b)))
 120     (setf (buf-used b) (buf-start b)
 121           (buf-new  b) (buf-end   b))))
 122
 123 (defun buf-next (b)
 124   (when (< (buf-used b) (buf-new b))
 125     (bref b (incf (buf-used b)))))
 126
 127 (defun buf-reset (b)
 128   (setf (buf-used b) (buf-start b)
 129         (buf-new  b) (buf-end   b)))
 130
 131 (defun buf-clear (b)
 132   (setf (buf-start b) -1 (buf-used  b) -1
 133         (buf-new   b) -1 (buf-end   b) -1))
 134
 135 (defun buf-flush (b str)
 136   (do ((i (1+ (buf-used b)) (1+ i)))
 137       ((> i (buf-end b)))
 138     (princ (bref b i) str)))
 139
 140
 141 (defun stream-subst (old new in out)
 142   (declare (string old new))
 143   (let* ((pos 0)
 144          (len (length old))
 145          (buf (new-buf len))
 146          (from-buf nil))
 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))))
 151         ((eql c :eof))
 152       (declare (character c))
 153       (cond ((char= c (char old pos))
 154              (incf pos)
 155              (cond ((= pos len)            ; 3
 156                     (princ new out)
 157                     (setf pos 0)
 158                     (buf-clear buf))
 159                    ((not from-buf)         ; 2
 160                     (buf-insert c buf))))
 161             ((zerop pos)                   ; 1
 162              (princ c out)
 163              (when from-buf
 164                (buf-pop buf)
 165                (buf-reset buf)))
 166             (t                             ; 4
 167              (unless from-buf
 168                (buf-insert c buf))
 169              (princ (buf-pop buf) out)
 170              (buf-reset buf)
 171              (setf pos 0))))
 172     (buf-flush buf out)))
 173
 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))
 178
 179
 180
 181 #+openmcl
 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)))
 188     (if (< fd 0)
 189        (ccl::signal-file-error fd path)
 190        (ccl::make-fd-stream fd :direction direction))))
 191
 192
 193 (defun null-output-stream ()
 194   #-openmcl
 195   (when (probe-file #p"/dev/null")
 196     (open #p"/dev/null" :direction :output :if-exists :overwrite))
 197   #+openmcl
 198   (when (probe-file #p"/dev/null")
 199     (open-device-stream #p"/dev/null" :output))
 200   )
 201
 202
 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
 208                                                     :type :wild
 209                                                     :defaults root))
 210                         when (probe-directory path)
 211                         collect (canonicalize-directory-name path))))
 212     (when (find nil subdirs)
 213       (error "~A" subdirs))
 214     (when (null root)
 215       (error "~A" root))
 216     (if subdirs
 217         (cons root (mapcar #'directory-tree subdirs))
 218         (if (probe-directory root)
 219             (list root)
 220             (error "root not directory ~A" root)))))
 221
 222