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-open-file (in file :direction :input)
  43     (read-stream-to-string in)))
  44
  45 (defun read-file-to-usb8-array (file)
  46   "Opens a reads a file. Returns the contents as single unsigned-byte array"
  47   (with-open-file (in file :direction :input :element-type '(unsigned-byte 8))
  48     (let* ((file-len (file-length in))
  49            (usb8 (make-array file-len :element-type '(unsigned-byte 8)))
  50            (pos (read-sequence usb8 in)))
  51       (unless (= file-len pos)
  52         (error "Length read (~D) doesn't match file length (~D)~%" pos file-len))
  53       usb8)))
  54
  55
  56 (defun read-stream-to-strings (in)
  57   (let ((lines '())
  58         (eof (gensym)))
  59     (do ((line (read-line in nil eof)
  60                (read-line in nil eof)))
  61         ((eq line eof))
  62       (push line lines))
  63     (nreverse lines)))
  64
  65 (defun read-file-to-strings (file)
  66   "Opens a reads a file. Returns the contents as a list of strings"
  67   (with-open-file (in file :direction :input)
  68     (read-stream-to-strings in)))
  69
  70 (defun file-subst (old new file1 file2)
  71   (with-open-file (in file1 :direction :input)
  72     (with-open-file (out file2 :direction :output
  73                          :if-exists :supersede)
  74       (stream-subst old new in out))))
  75
  76 (defun print-n-chars (char n stream)
  77   (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
  78   (dotimes (i n)
  79     (declare (fixnum i))
  80     (write-char char stream)))
  81
  82 (defun print-n-strings (str n stream)
  83   (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
  84   (dotimes (i n)
  85     (declare (fixnum i))
  86     (write-string str stream)))
  87
  88 (defun indent-spaces (n &optional (stream *standard-output*))
  89   "Indent n*2 spaces to output stream"
  90   (print-n-chars #\space (+ n n) stream))
  91
  92
  93 (defun indent-html-spaces (n &optional (stream *standard-output*))
  94   "Indent n*2 html spaces to output stream"
  95   (print-n-strings "&nbsp;" (+ n n) stream))
  96
  97
  98 (defun print-list (l &optional (output *standard-output*))
  99   "Print a list to a stream"
 100   (format output "~{~A~%~}" l))
 101
 102 (defun print-rows (rows &optional (ostrm *standard-output*))
 103   "Print a list of list rows to a stream"
 104   (dolist (r rows) (format ostrm "~{~A~^ ~}~%" r)))
 105
 106
 107 ;; Buffered stream substitute
 108
 109 (defstruct buf
 110   vec (start -1) (used -1) (new -1) (end -1))
 111
 112 (defun bref (buf n)
 113   (svref (buf-vec buf)
 114          (mod n (length (buf-vec buf)))))
 115
 116 (defun (setf bref) (val buf n)
 117   (setf (svref (buf-vec buf)
 118                (mod n (length (buf-vec buf))))
 119         val))
 120
 121 (defun new-buf (len)
 122   (make-buf :vec (make-array len)))
 123
 124 (defun buf-insert (x b)
 125   (setf (bref b (incf (buf-end b))) x))
 126
 127 (defun buf-pop (b)
 128   (prog1
 129     (bref b (incf (buf-start b)))
 130     (setf (buf-used b) (buf-start b)
 131           (buf-new  b) (buf-end   b))))
 132
 133 (defun buf-next (b)
 134   (when (< (buf-used b) (buf-new b))
 135     (bref b (incf (buf-used b)))))
 136
 137 (defun buf-reset (b)
 138   (setf (buf-used b) (buf-start b)
 139         (buf-new  b) (buf-end   b)))
 140
 141 (defun buf-clear (b)
 142   (setf (buf-start b) -1 (buf-used  b) -1
 143         (buf-new   b) -1 (buf-end   b) -1))
 144
 145 (defun buf-flush (b str)
 146   (do ((i (1+ (buf-used b)) (1+ i)))
 147       ((> i (buf-end b)))
 148     (princ (bref b i) str)))
 149
 150
 151 (defun stream-subst (old new in out)
 152   (declare (string old new))
 153   (let* ((pos 0)
 154          (len (length old))
 155          (buf (new-buf len))
 156          (from-buf nil))
 157     (declare (fixnum pos len))
 158     (do ((c (read-char in nil :eof)
 159             (or (setf from-buf (buf-next buf))
 160                 (read-char in nil :eof))))
 161         ((eql c :eof))
 162       (declare (character c))
 163       (cond ((char= c (char old pos))
 164              (incf pos)
 165              (cond ((= pos len)            ; 3
 166                     (princ new out)
 167                     (setf pos 0)
 168                     (buf-clear buf))
 169                    ((not from-buf)         ; 2
 170                     (buf-insert c buf))))
 171             ((zerop pos)                   ; 1
 172              (princ c out)
 173              (when from-buf
 174                (buf-pop buf)
 175                (buf-reset buf)))
 176             (t                             ; 4
 177              (unless from-buf
 178                (buf-insert c buf))
 179              (princ (buf-pop buf) out)
 180              (buf-reset buf)
 181              (setf pos 0))))
 182     (buf-flush buf out)))
 183
 184 (declaim (inline write-fixnum))
 185 (defun write-fixnum (n s)
 186   #+allegro (excl::print-fixnum s 10 n)
 187   #-allegro (write-string (write-to-string n) s))
 188
 189
 190
 191
 192 (defun null-output-stream ()
 193   (when (probe-file #p"/dev/null")
 194     (open #p"/dev/null" :direction :output :if-exists :overwrite))
 195   )
 196
 197
 198 (defun directory-tree (filename)
 199   "Returns a tree of pathnames for sub-directories of a directory"
 200   (let* ((root (canonicalize-directory-name filename))
 201          (subdirs (loop for path in (directory
 202                                      (make-pathname :name :wild
 203                                                     :type :wild
 204                                                     :defaults root))
 205                         when (probe-directory path)
 206                         collect (canonicalize-directory-name path))))
 207     (when (find nil subdirs)
 208       (error "~A" subdirs))
 209     (when (null root)
 210       (error "~A" root))
 211     (if subdirs
 212         (cons root (mapcar #'directory-tree subdirs))
 213         (if (probe-directory root)
 214             (list root)
 215             (error "root not directory ~A" root)))))
 216
 217
 218 (defmacro with-utime-decoding ((utime &optional zone) &body body)
 219   "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"
 220   `(multiple-value-bind
 221        (second minute hour day-of-month month year day-of-week daylight-p zone)
 222        (decode-universal-time ,utime ,@(if zone (list zone)))
 223      (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone))
 224      ,@body))
 225
 226 (defvar +datetime-number-strings+
 227   (make-array 61 :adjustable nil :element-type 'string :fill-pointer nil
 228               :initial-contents
 229               '("00" "01" "02" "03" "04" "05" "06" "07" "08" "09" "10" "11"
 230                 "12" "13" "14" "15" "16" "17" "18" "19" "20" "21" "22" "23"
 231                 "24" "25" "26" "27" "28" "29" "30" "31" "32" "33" "34" "35"
 232                 "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" "46" "47"
 233                 "48" "49" "50" "51" "52" "53" "54" "55" "56" "57" "58" "59"
 234                 "60")))
 235
 236 (defun is-dst (utime)
 237   (with-utime-decoding (utime)
 238     daylight-p))
 239
 240
 241 (defmacro with-utime-decoding-utc-offset ((utime utc-offset) &body body)
 242   (with-gensyms (zone)
 243     `(let* ((,zone (cond
 244                     ((eq :utc ,utc-offset)
 245                      0)
 246                     ((null utc-offset)
 247                      nil)
 248                     (t
 249                      (if (is-dst ,utime)
 250                          (1- (- ,utc-offset))
 251                        (- ,utc-offset))))))
 252        (if ,zone
 253            (with-utime-decoding (,utime ,zone)
 254              ,@body)
 255          (with-utime-decoding (,utime)
 256            ,@body)))))
 257
 258
 259 (defun write-utime-hms (utime &key utc-offset stream)
 260   (if stream
 261       (write-utime-hms-stream utime stream utc-offset)
 262     (with-output-to-string (s)
 263       (write-utime-hms-stream utime s utc-offset))))
 264
 265 (defun write-utime-hms-stream (utime stream &optional utc-offset)
 266   (with-utime-decoding-utc-offset (utime utc-offset)
 267     (write-string (aref +datetime-number-strings+ hour) stream)
 268     (write-char #\: stream)
 269     (write-string (aref +datetime-number-strings+ minute) stream)
 270     (write-char #\: stream)
 271     (write-string (aref +datetime-number-strings+ second) stream)))
 272
 273 (defun write-utime-hm (utime &key utc-offset stream)
 274   (if stream
 275       (write-utime-hm-stream utime stream utc-offset)
 276     (with-output-to-string (s)
 277       (write-utime-hm-stream utime s utc-offset))))
 278
 279 (defun write-utime-hm-stream (utime stream &optional utc-offset)
 280   (with-utime-decoding-utc-offset (utime utc-offset)
 281     (write-string (aref +datetime-number-strings+ hour) stream)
 282     (write-char #\: stream)
 283     (write-string (aref +datetime-number-strings+ minute) stream)))
 284
 285
 286 (defun write-utime-ymdhms (utime &key stream utc-offset)
 287   (if stream
 288       (write-utime-ymdhms-stream utime stream utc-offset)
 289     (with-output-to-string (s)
 290       (write-utime-ymdhms-stream utime s utc-offset))))
 291
 292 (defun write-utime-ymdhms-stream (utime stream &optional utc-offset)
 293   (with-utime-decoding-utc-offset (utime utc-offset)
 294     (write-string (prefixed-fixnum-string year nil 4) stream)
 295     (write-char #\/ stream)
 296     (write-string (aref +datetime-number-strings+ month) stream)
 297     (write-char #\/ stream)
 298     (write-string (aref +datetime-number-strings+ day-of-month) stream)
 299     (write-char #\space stream)
 300     (write-string (aref +datetime-number-strings+ hour) stream)
 301     (write-char #\: stream)
 302     (write-string (aref +datetime-number-strings+ minute) stream)
 303     (write-char #\: stream)
 304     (write-string (aref +datetime-number-strings+ second) stream)))
 305
 306 (defun write-utime-ymdhm (utime &key stream utc-offset)
 307   (if stream
 308       (write-utime-ymdhm-stream utime stream utc-offset)
 309     (with-output-to-string (s)
 310       (write-utime-ymdhm-stream utime s utc-offset))))
 311
 312 (defun write-utime-ymdhm-stream (utime stream &optional utc-offset)
 313   (with-utime-decoding-utc-offset (utime utc-offset)
 314     (write-string (prefixed-fixnum-string year nil 4) stream)
 315     (write-char #\/ stream)
 316     (write-string (aref +datetime-number-strings+ month) stream)
 317     (write-char #\/ stream)
 318     (write-string (aref +datetime-number-strings+ day-of-month) stream)
 319     (write-char #\space stream)
 320     (write-string (aref +datetime-number-strings+ hour) stream)
 321     (write-char #\: stream)
 322     (write-string (aref +datetime-number-strings+ minute) stream)))
 323
 324 (defun copy-binary-stream (in out &key (chunk-size 16384))
 325   (do* ((buf (make-array chunk-size :element-type '(unsigned-byte 8)))
 326         (pos (read-sequence buf in) (read-sequence buf in)))
 327       ((zerop pos))
 328     (write-sequence buf out :end pos)))
 329