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 ;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
  11 ;;;;
  12 ;;;; KMRCL users are granted the rights to distribute and use this software
  13 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  14 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  15 ;;;; *************************************************************************
  16
  17 (in-package #:kmrcl)
  18
  19 (defun print-file-contents (file &optional (strm *standard-output*))
  20   "Opens a reads a file. Returns the contents as a single string"
  21   (when (probe-file file)
  22     (let ((eof (cons 'eof nil)))
  23       (with-open-file (in file :direction :input)
  24         (do ((line (read-line in nil eof)
  25                    (read-line in nil eof)))
  26             ((eq line eof))
  27           (write-string line strm)
  28           (write-char #\newline strm))))))
  29
  30 (defun read-stream-to-string (in)
  31   (with-output-to-string (out)
  32     (let ((eof (gensym)))
  33       (do ((line (read-line in nil eof)
  34                  (read-line in nil eof)))
  35           ((eq line eof))
  36         (format out "~A~%" line)))))
  37
  38 (defun read-file-to-string (file)
  39   "Opens a reads a file. Returns the contents as a single string"
  40   (with-open-file (in file :direction :input)
  41     (read-stream-to-string in)))
  42
  43 (defun read-file-to-usb8-array (file)
  44   "Opens a reads a file. Returns the contents as single unsigned-byte array"
  45   (with-open-file (in file :direction :input :element-type '(unsigned-byte 8))
  46     (let* ((file-len (file-length in))
  47            (usb8 (make-array file-len :element-type '(unsigned-byte 8)))
  48            (pos (read-sequence usb8 in)))
  49       (unless (= file-len pos)
  50         (error "Length read (~D) doesn't match file length (~D)~%" pos file-len))
  51       usb8)))
  52
  53
  54 (defun read-stream-to-strings (in)
  55   (let ((lines '())
  56         (eof (gensym)))
  57     (do ((line (read-line in nil eof)
  58                (read-line in nil eof)))
  59         ((eq line eof))
  60       (push line lines))
  61     (nreverse lines)))
  62
  63 (defun read-file-to-strings (file)
  64   "Opens a reads a file. Returns the contents as a list of strings"
  65   (with-open-file (in file :direction :input)
  66     (read-stream-to-strings in)))
  67
  68 (defun file-subst (old new file1 file2)
  69   (with-open-file (in file1 :direction :input)
  70     (with-open-file (out file2 :direction :output
  71                          :if-exists :supersede)
  72       (stream-subst old new in out))))
  73
  74 (defun print-n-chars (char n stream)
  75   (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
  76   (dotimes (i n)
  77     (declare (fixnum i))
  78     (write-char char stream)))
  79
  80 (defun print-n-strings (str n stream)
  81   (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
  82   (dotimes (i n)
  83     (declare (fixnum i))
  84     (write-string str stream)))
  85
  86 (defun indent-spaces (n &optional (stream *standard-output*))
  87   "Indent n*2 spaces to output stream"
  88   (print-n-chars #\space (+ n n) stream))
  89
  90
  91 (defun indent-html-spaces (n &optional (stream *standard-output*))
  92   "Indent n*2 html spaces to output stream"
  93   (print-n-strings "&nbsp;" (+ n n) stream))
  94
  95
  96 (defun print-list (l &optional (output *standard-output*))
  97   "Print a list to a stream"
  98   (format output "~{~A~%~}" l))
  99
 100 (defun print-rows (rows &optional (ostrm *standard-output*))
 101   "Print a list of list rows to a stream"
 102   (dolist (r rows) (format ostrm "~{~A~^ ~}~%" r)))
 103
 104
 105 ;; Buffered stream substitute
 106
 107 (defstruct buf
 108   vec (start -1) (used -1) (new -1) (end -1))
 109
 110 (defun bref (buf n)
 111   (svref (buf-vec buf)
 112          (mod n (length (buf-vec buf)))))
 113
 114 (defun (setf bref) (val buf n)
 115   (setf (svref (buf-vec buf)
 116                (mod n (length (buf-vec buf))))
 117         val))
 118
 119 (defun new-buf (len)
 120   (make-buf :vec (make-array len)))
 121
 122 (defun buf-insert (x b)
 123   (setf (bref b (incf (buf-end b))) x))
 124
 125 (defun buf-pop (b)
 126   (prog1
 127     (bref b (incf (buf-start b)))
 128     (setf (buf-used b) (buf-start b)
 129           (buf-new  b) (buf-end   b))))
 130
 131 (defun buf-next (b)
 132   (when (< (buf-used b) (buf-new b))
 133     (bref b (incf (buf-used b)))))
 134
 135 (defun buf-reset (b)
 136   (setf (buf-used b) (buf-start b)
 137         (buf-new  b) (buf-end   b)))
 138
 139 (defun buf-clear (b)
 140   (setf (buf-start b) -1 (buf-used  b) -1
 141         (buf-new   b) -1 (buf-end   b) -1))
 142
 143 (defun buf-flush (b str)
 144   (do ((i (1+ (buf-used b)) (1+ i)))
 145       ((> i (buf-end b)))
 146     (princ (bref b i) str)))
 147
 148
 149 (defun stream-subst (old new in out)
 150   (declare (string old new))
 151   (let* ((pos 0)
 152          (len (length old))
 153          (buf (new-buf len))
 154          (from-buf nil))
 155     (declare (fixnum pos len))
 156     (do ((c (read-char in nil :eof)
 157             (or (setf from-buf (buf-next buf))
 158                 (read-char in nil :eof))))
 159         ((eql c :eof))
 160       (declare (character c))
 161       (cond ((char= c (char old pos))
 162              (incf pos)
 163              (cond ((= pos len)            ; 3
 164                     (princ new out)
 165                     (setf pos 0)
 166                     (buf-clear buf))
 167                    ((not from-buf)         ; 2
 168                     (buf-insert c buf))))
 169             ((zerop pos)                   ; 1
 170              (princ c out)
 171              (when from-buf
 172                (buf-pop buf)
 173                (buf-reset buf)))
 174             (t                             ; 4
 175              (unless from-buf
 176                (buf-insert c buf))
 177              (princ (buf-pop buf) out)
 178              (buf-reset buf)
 179              (setf pos 0))))
 180     (buf-flush buf out)))
 181
 182 (declaim (inline write-fixnum))
 183 (defun write-fixnum (n s)
 184   #+allegro (excl::print-fixnum s 10 n)
 185   #-allegro (write-string (write-to-string n) s))
 186
 187
 188
 189
 190 (defun null-output-stream ()
 191   (when (probe-file #p"/dev/null")
 192     (open #p"/dev/null" :direction :output :if-exists :overwrite))
 193   )
 194
 195
 196 (defun directory-tree (filename)
 197   "Returns a tree of pathnames for sub-directories of a directory"
 198   (let* ((root (canonicalize-directory-name filename))
 199          (subdirs (loop for path in (directory
 200                                      (make-pathname :name :wild
 201                                                     :type :wild
 202                                                     :defaults root))
 203                         when (probe-directory path)
 204                         collect (canonicalize-directory-name path))))
 205     (when (find nil subdirs)
 206       (error "~A" subdirs))
 207     (when (null root)
 208       (error "~A" root))
 209     (if subdirs
 210         (cons root (mapcar #'directory-tree subdirs))
 211         (if (probe-directory root)
 212             (list root)
 213             (error "root not directory ~A" root)))))
 214
 215
 216 (defmacro with-utime-decoding ((utime &optional zone) &body body)
 217   "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"
 218   `(multiple-value-bind
 219        (second minute hour day-of-month month year day-of-week daylight-p zone)
 220        (decode-universal-time ,utime ,@(if zone (list zone)))
 221      (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone))
 222      ,@body))
 223
 224 (defvar +datetime-number-strings+
 225   (make-array 61 :adjustable nil :element-type 'string :fill-pointer nil
 226               :initial-contents
 227               '("00" "01" "02" "03" "04" "05" "06" "07" "08" "09" "10" "11"
 228                 "12" "13" "14" "15" "16" "17" "18" "19" "20" "21" "22" "23"
 229                 "24" "25" "26" "27" "28" "29" "30" "31" "32" "33" "34" "35"
 230                 "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" "46" "47"
 231                 "48" "49" "50" "51" "52" "53" "54" "55" "56" "57" "58" "59"
 232                 "60")))
 233
 234 (defun is-dst (utime)
 235   (with-utime-decoding (utime)
 236     daylight-p))
 237
 238
 239 (defmacro with-utime-decoding-utc-offset ((utime utc-offset) &body body)
 240   (with-gensyms (zone)
 241     `(let* ((,zone (cond
 242                     ((eq :utc ,utc-offset)
 243                      0)
 244                     ((null utc-offset)
 245                      nil)
 246                     (t
 247                      (if (is-dst ,utime)
 248                          (1- (- ,utc-offset))
 249                        (- ,utc-offset))))))
 250        (if ,zone
 251            (with-utime-decoding (,utime ,zone)
 252              ,@body)
 253          (with-utime-decoding (,utime)
 254            ,@body)))))
 255
 256
 257 (defun write-utime-hms (utime &key utc-offset stream)
 258   (if stream
 259       (write-utime-hms-stream utime stream utc-offset)
 260     (with-output-to-string (s)
 261       (write-utime-hms-stream utime s utc-offset))))
 262
 263 (defun write-utime-hms-stream (utime stream &optional utc-offset)
 264   (with-utime-decoding-utc-offset (utime utc-offset)
 265     (write-string (aref +datetime-number-strings+ hour) stream)
 266     (write-char #\: stream)
 267     (write-string (aref +datetime-number-strings+ minute) stream)
 268     (write-char #\: stream)
 269     (write-string (aref +datetime-number-strings+ second) stream)))
 270
 271 (defun write-utime-hm (utime &key utc-offset stream)
 272   (if stream
 273       (write-utime-hm-stream utime stream utc-offset)
 274     (with-output-to-string (s)
 275       (write-utime-hm-stream utime s utc-offset))))
 276
 277 (defun write-utime-hm-stream (utime stream &optional utc-offset)
 278   (with-utime-decoding-utc-offset (utime utc-offset)
 279     (write-string (aref +datetime-number-strings+ hour) stream)
 280     (write-char #\: stream)
 281     (write-string (aref +datetime-number-strings+ minute) stream)))
 282
 283
 284 (defun write-utime-ymdhms (utime &key stream utc-offset)
 285   (if stream
 286       (write-utime-ymdhms-stream utime stream utc-offset)
 287     (with-output-to-string (s)
 288       (write-utime-ymdhms-stream utime s utc-offset))))
 289
 290 (defun write-utime-ymdhms-stream (utime stream &optional utc-offset)
 291   (with-utime-decoding-utc-offset (utime utc-offset)
 292     (write-string (prefixed-fixnum-string year nil 4) stream)
 293     (write-char #\/ stream)
 294     (write-string (aref +datetime-number-strings+ month) stream)
 295     (write-char #\/ stream)
 296     (write-string (aref +datetime-number-strings+ day-of-month) stream)
 297     (write-char #\space stream)
 298     (write-string (aref +datetime-number-strings+ hour) stream)
 299     (write-char #\: stream)
 300     (write-string (aref +datetime-number-strings+ minute) stream)
 301     (write-char #\: stream)
 302     (write-string (aref +datetime-number-strings+ second) stream)))
 303
 304 (defun write-utime-ymdhm (utime &key stream utc-offset)
 305   (if stream
 306       (write-utime-ymdhm-stream utime stream utc-offset)
 307     (with-output-to-string (s)
 308       (write-utime-ymdhm-stream utime s utc-offset))))
 309
 310 (defun write-utime-ymdhm-stream (utime stream &optional utc-offset)
 311   (with-utime-decoding-utc-offset (utime utc-offset)
 312     (write-string (prefixed-fixnum-string year nil 4) stream)
 313     (write-char #\/ stream)
 314     (write-string (aref +datetime-number-strings+ month) stream)
 315     (write-char #\/ stream)
 316     (write-string (aref +datetime-number-strings+ day-of-month) stream)
 317     (write-char #\space stream)
 318     (write-string (aref +datetime-number-strings+ hour) stream)
 319     (write-char #\: stream)
 320     (write-string (aref +datetime-number-strings+ minute) stream)))
 321
 322 (defun copy-binary-stream (in out &key (chunk-size 16384))
 323   (do* ((buf (make-array chunk-size :element-type '(unsigned-byte 8)))
 324         (pos (read-sequence buf in) (read-sequence buf in)))
 325       ((zerop pos))
 326     (write-sequence buf out :end pos)))
 327
 328
 329 (defmacro def-unsigned-int-io (len r-name w-name &key (big-endian nil))
 330   "Defines read and write functions for an unsigned integer with LEN bytes from STREAM."
 331   (when (< len 1)
 332     (error "Number of bytes must be greater than 0.~%"))
 333   (let ((endian-string (if big-endian "big" "little")))
 334     `(eval-when (:compile-toplevel :load-toplevel :execute)
 335        (defun ,r-name (stream)
 336          ,(format nil "Reads an ~A byte unsigned integer (~A-endian)."
 337                   len endian-string)
 338          (declare (optimize (speed 3) (compilation-speed 0) (safety 0)
 339                             (space 0) (debug 0))
 340                   (type stream stream))
 341          (let ((val 0))
 342            (declare (type
 343                      ,(if (< (expt 256 len) most-positive-fixnum)
 344                           'fixnum
 345                           `(integer 0 ,(1- (expt 256 len))))
 346                      val))
 347            ,@(loop for i from 1 upto len
 348                 collect
 349                   `(setf (ldb (byte 8 ,(* (if big-endian (1- i) (- len i))
 350                                           8)) val) (read-byte stream)))
 351            val))
 352        (defun ,w-name (val stream &key (bounds-check t))
 353          ,(format nil "Writes an ~A byte unsigned integer as binary to STREAM (~A-endian)."
 354                   len endian-string)
 355          (declare (optimize (speed 3) (compilation-speed 0) (safety 0)
 356                             (space 0) (debug 0))
 357                   (type stream stream)
 358                   ,(if (< (expt 256 len) most-positive-fixnum)
 359                        '(type fixnum val)
 360                        '(type integer val)))
 361          (when bounds-check
 362            (when (>= val ,(expt 256 len))
 363              (error "Number ~D is too large to fit in ~D bytes.~%" val ,len))
 364            (when (minusp val)
 365              (error "Number ~D can't be written as unsigned integer." val)))
 366          (locally (declare (type (integer 0 ,(1- (expt 256 len))) val))
 367            ,@(loop for i from 1 upto len
 368                 collect
 369                   `(write-byte (ldb (byte 8 ,(* (if big-endian (1- i) (- len i))
 370                                                 8)) val) stream)))
 371          val)
 372        nil)))
 373
 374 (defmacro make-unsigned-int-io-fn (len)
 375   "Makes reader and writer functions for unsigned byte input/output of
 376 LEN bytes with both little and big endian order. Function names are in the
 377 form of {READ,WRITE}-UINT<LEN>-{be,le}."
 378   `(progn
 379      (def-unsigned-int-io
 380          ,len
 381          ,(intern (format nil "~A~D-~A" (symbol-name '#:read-uint) len (symbol-name '#:le)))
 382        ,(intern (format nil "~A~D-~A" (symbol-name '#:write-uint) len (symbol-name '#:le)))
 383        :big-endian nil)
 384      (def-unsigned-int-io
 385          ,len
 386          ,(intern (format nil "~A~D-~A" (symbol-name '#:read-uint) len (symbol-name '#:be)))
 387        ,(intern (format nil "~A~D-~A" (symbol-name '#:write-uint) len (symbol-name '#:be)))
 388        :big-endian t)))
 389
 390 (make-unsigned-int-io-fn 2)
 391 (make-unsigned-int-io-fn 3)
 392 (make-unsigned-int-io-fn 4)
 393 (make-unsigned-int-io-fn 5)
 394 (make-unsigned-int-io-fn 6)
 395 (make-unsigned-int-io-fn 7)
 396 (make-unsigned-int-io-fn 8)