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
 182 (defun null-output-stream ()
 183   (when (probe-file #p"/dev/null")
 184     (open #p"/dev/null" :direction :output :if-exists :overwrite))
 185   )
 186
 187
 188 (defun directory-tree (filename)
 189   "Returns a tree of pathnames for sub-directories of a directory"
 190   (let* ((root (canonicalize-directory-name filename))
 191          (subdirs (loop for path in (directory
 192                                      (make-pathname :name :wild
 193                                                     :type :wild
 194                                                     :defaults root))
 195                         when (probe-directory path)
 196                         collect (canonicalize-directory-name path))))
 197     (when (find nil subdirs)
 198       (error "~A" subdirs))
 199     (when (null root)
 200       (error "~A" root))
 201     (if subdirs
 202         (cons root (mapcar #'directory-tree subdirs))
 203         (if (probe-directory root)
 204             (list root)
 205             (error "root not directory ~A" root)))))
 206
 207
 208 (defmacro with-utime-decoding ((utime &optional zone) &body body)
 209   "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"
 210   `(multiple-value-bind
 211        (second minute hour day-of-month month year day-of-week daylight-p zone)
 212        (decode-universal-time ,utime ,@(if zone (list zone)))
 213      (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone))
 214      ,@body))
 215
 216 (defvar +datetime-number-strings+
 217   (make-array 61 :adjustable nil :element-type 'string :fill-pointer nil
 218               :initial-contents
 219               '("00" "01" "02" "03" "04" "05" "06" "07" "08" "09" "10" "11"
 220                 "12" "13" "14" "15" "16" "17" "18" "19" "20" "21" "22" "23"
 221                 "24" "25" "26" "27" "28" "29" "30" "31" "32" "33" "34" "35"
 222                 "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" "46" "47"
 223                 "48" "49" "50" "51" "52" "53" "54" "55" "56" "57" "58" "59"
 224                 "60")))
 225
 226 (defun is-dst (utime)
 227   (with-utime-decoding (utime)
 228     daylight-p))
 229
 230
 231 (defmacro with-utime-decoding-utc-offset ((utime utc-offset) &body body)
 232   (with-gensyms (zone)
 233     `(let* ((,zone (cond
 234                     ((eq :utc ,utc-offset)
 235                      0)
 236                     ((null utc-offset)
 237                      nil)
 238                     (t
 239                      (if (is-dst ,utime)
 240                          (1- (- ,utc-offset))
 241                        (- ,utc-offset))))))
 242        (if ,zone
 243            (with-utime-decoding (,utime ,zone)
 244              ,@body)
 245          (with-utime-decoding (,utime)
 246            ,@body)))))
 247
 248
 249 (defun write-utime-hms (utime &key utc-offset stream)
 250   (if stream
 251       (write-utime-hms-stream utime stream utc-offset)
 252     (with-output-to-string (s)
 253       (write-utime-hms-stream utime s utc-offset))))
 254
 255 (defun write-utime-hms-stream (utime stream &optional utc-offset)
 256   (with-utime-decoding-utc-offset (utime utc-offset)
 257     (write-string (aref +datetime-number-strings+ hour) stream)
 258     (write-char #\: stream)
 259     (write-string (aref +datetime-number-strings+ minute) stream)
 260     (write-char #\: stream)
 261     (write-string (aref +datetime-number-strings+ second) stream)))
 262
 263 (defun write-utime-hm (utime &key utc-offset stream)
 264   (if stream
 265       (write-utime-hm-stream utime stream utc-offset)
 266     (with-output-to-string (s)
 267       (write-utime-hm-stream utime s utc-offset))))
 268
 269 (defun write-utime-hm-stream (utime stream &optional utc-offset)
 270   (with-utime-decoding-utc-offset (utime utc-offset)
 271     (write-string (aref +datetime-number-strings+ hour) stream)
 272     (write-char #\: stream)
 273     (write-string (aref +datetime-number-strings+ minute) stream)))
 274
 275
 276 (defun write-utime-ymdhms (utime &key stream utc-offset)
 277   (if stream
 278       (write-utime-ymdhms-stream utime stream utc-offset)
 279     (with-output-to-string (s)
 280       (write-utime-ymdhms-stream utime s utc-offset))))
 281
 282 (defun write-utime-ymdhms-stream (utime stream &optional utc-offset)
 283   (with-utime-decoding-utc-offset (utime utc-offset)
 284     (write-string (prefixed-fixnum-string year nil 4) stream)
 285     (write-char #\/ stream)
 286     (write-string (aref +datetime-number-strings+ month) stream)
 287     (write-char #\/ stream)
 288     (write-string (aref +datetime-number-strings+ day-of-month) stream)
 289     (write-char #\space stream)
 290     (write-string (aref +datetime-number-strings+ hour) stream)
 291     (write-char #\: stream)
 292     (write-string (aref +datetime-number-strings+ minute) stream)
 293     (write-char #\: stream)
 294     (write-string (aref +datetime-number-strings+ second) stream)))
 295
 296 (defun write-utime-ymdhm (utime &key stream utc-offset)
 297   (if stream
 298       (write-utime-ymdhm-stream utime stream utc-offset)
 299     (with-output-to-string (s)
 300       (write-utime-ymdhm-stream utime s utc-offset))))
 301
 302 (defun write-utime-ymdhm-stream (utime stream &optional utc-offset)
 303   (with-utime-decoding-utc-offset (utime utc-offset)
 304     (write-string (prefixed-fixnum-string year nil 4) stream)
 305     (write-char #\/ stream)
 306     (write-string (aref +datetime-number-strings+ month) stream)
 307     (write-char #\/ stream)
 308     (write-string (aref +datetime-number-strings+ day-of-month) stream)
 309     (write-char #\space stream)
 310     (write-string (aref +datetime-number-strings+ hour) stream)
 311     (write-char #\: stream)
 312     (write-string (aref +datetime-number-strings+ minute) stream)))
 313
 314 (defun copy-binary-stream (in out)
 315   (do* ((buf (make-array 4096 :element-type '(unsigned-byte 8)))
 316         (pos (read-sequence buf in) (read-sequence buf in)))
 317       ((zerop pos))
 318     (write-sequence buf out :end pos)))
 319