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-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))
  54       usb8)))
  55
  56
  57 (defun read-stream-to-strings (in)
  58   (let ((lines '())
  59         (eof (gensym)))
  60     (do ((line (read-line in nil eof)
  61                (read-line in nil eof)))
  62         ((eq line eof))
  63       (push line lines))
  64     (nreverse lines)))
  65
  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)))
  70
  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))))
  76
  77 (defun print-n-chars (char n stream)
  78   (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
  79   (dotimes (i n)
  80     (declare (fixnum i))
  81     (write-char char stream)))
  82
  83 (defun print-n-strings (str n stream)
  84   (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
  85   (dotimes (i n)
  86     (declare (fixnum i))
  87     (write-string str stream)))
  88
  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))
  92
  93
  94 (defun indent-html-spaces (n &optional (stream *standard-output*))
  95   "Indent n*2 html spaces to output stream"
  96   (print-n-strings "&nbsp;" (+ n n) stream))
  97
  98
  99 (defun print-list (l &optional (output *standard-output*))
 100   "Print a list to a stream"
 101   (format output "~{~A~%~}" l))
 102
 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)))
 106
 107
 108 ;; Buffered stream substitute
 109
 110 (defstruct buf
 111   vec (start -1) (used -1) (new -1) (end -1))
 112
 113 (defun bref (buf n)
 114   (svref (buf-vec buf)
 115          (mod n (length (buf-vec buf)))))
 116
 117 (defun (setf bref) (val buf n)
 118   (setf (svref (buf-vec buf)
 119                (mod n (length (buf-vec buf))))
 120         val))
 121
 122 (defun new-buf (len)
 123   (make-buf :vec (make-array len)))
 124
 125 (defun buf-insert (x b)
 126   (setf (bref b (incf (buf-end b))) x))
 127
 128 (defun buf-pop (b)
 129   (prog1
 130     (bref b (incf (buf-start b)))
 131     (setf (buf-used b) (buf-start b)
 132           (buf-new  b) (buf-end   b))))
 133
 134 (defun buf-next (b)
 135   (when (< (buf-used b) (buf-new b))
 136     (bref b (incf (buf-used b)))))
 137
 138 (defun buf-reset (b)
 139   (setf (buf-used b) (buf-start b)
 140         (buf-new  b) (buf-end   b)))
 141
 142 (defun buf-clear (b)
 143   (setf (buf-start b) -1 (buf-used  b) -1
 144         (buf-new   b) -1 (buf-end   b) -1))
 145
 146 (defun buf-flush (b str)
 147   (do ((i (1+ (buf-used b)) (1+ i)))
 148       ((> i (buf-end b)))
 149     (princ (bref b i) str)))
 150
 151
 152 (defun stream-subst (old new in out)
 153   (declare (string old new))
 154   (let* ((pos 0)
 155          (len (length old))
 156          (buf (new-buf len))
 157          (from-buf nil))
 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))))
 162         ((eql c :eof))
 163       (declare (character c))
 164       (cond ((char= c (char old pos))
 165              (incf pos)
 166              (cond ((= pos len)            ; 3
 167                     (princ new out)
 168                     (setf pos 0)
 169                     (buf-clear buf))
 170                    ((not from-buf)         ; 2
 171                     (buf-insert c buf))))
 172             ((zerop pos)                   ; 1
 173              (princ c out)
 174              (when from-buf
 175                (buf-pop buf)
 176                (buf-reset buf)))
 177             (t                             ; 4
 178              (unless from-buf
 179                (buf-insert c buf))
 180              (princ (buf-pop buf) out)
 181              (buf-reset buf)
 182              (setf pos 0))))
 183     (buf-flush buf out)))
 184
 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))
 189
 190
 191
 192
 193 (defun null-output-stream ()
 194   (when (probe-file #p"/dev/null")
 195     (open #p"/dev/null" :direction :output :if-exists :overwrite))
 196   )
 197
 198
 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
 204                                                     :type :wild
 205                                                     :defaults root))
 206                         when (probe-directory path)
 207                         collect (canonicalize-directory-name path))))
 208     (when (find nil subdirs)
 209       (error "~A" subdirs))
 210     (when (null root)
 211       (error "~A" root))
 212     (if subdirs
 213         (cons root (mapcar #'directory-tree subdirs))
 214         (if (probe-directory root)
 215             (list root)
 216             (error "root not directory ~A" root)))))
 217
 218
 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))
 225      ,@body))
 226
 227 (defvar +datetime-number-strings+
 228   (make-array 61 :adjustable nil :element-type 'string :fill-pointer nil
 229               :initial-contents
 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"
 235                 "60")))
 236
 237 (defun is-dst (utime)
 238   (with-utime-decoding (utime)
 239     daylight-p))
 240
 241
 242 (defmacro with-utime-decoding-utc-offset ((utime utc-offset) &body body)
 243   (with-gensyms (zone)
 244     `(let* ((,zone (cond
 245                     ((eq :utc ,utc-offset)
 246                      0)
 247                     ((null utc-offset)
 248                      nil)
 249                     (t
 250                      (if (is-dst ,utime)
 251                          (1- (- ,utc-offset))
 252                        (- ,utc-offset))))))
 253        (if ,zone
 254            (with-utime-decoding (,utime ,zone)
 255              ,@body)
 256          (with-utime-decoding (,utime)
 257            ,@body)))))
 258
 259
 260 (defun write-utime-hms (utime &key utc-offset stream)
 261   (if 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))))
 265
 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)))
 273
 274 (defun write-utime-hm (utime &key utc-offset stream)
 275   (if 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))))
 279
 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)))
 285
 286
 287 (defun write-utime-ymdhms (utime &key stream utc-offset)
 288   (if stream
 289       (write-utime-ymdhms-stream utime stream utc-offset)
 290     (with-output-to-string (s)
 291       (write-utime-ymdhms-stream utime s utc-offset))))
 292
 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)))
 306
 307 (defun write-utime-ymdhm (utime &key stream utc-offset)
 308   (if stream
 309       (write-utime-ymdhm-stream utime stream utc-offset)
 310     (with-output-to-string (s)
 311       (write-utime-ymdhm-stream utime s utc-offset))))
 312
 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)))
 324
 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)))
 328       ((zerop pos))
 329     (write-sequence buf out :end pos)))
 330