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
 223 (defmacro with-utime-decoding ((utime &optional zone) &body body)
 224   "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"
 225   `(multiple-value-bind
 226        (second minute hour day-of-month month year day-of-week daylight-p zone)
 227        (decode-universal-time ,utime ,@(if zone (list zone)))
 228      (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone))
 229      ,@body))
 230
 231 (defvar +datetime-number-strings+
 232   (make-array 61 :adjustable nil :element-type 'string :fill-pointer nil
 233               :initial-contents
 234               '("00" "01" "02" "03" "04" "05" "06" "07" "08" "09" "10" "11"
 235                 "12" "13" "14" "15" "16" "17" "18" "19" "20" "21" "22" "23"
 236                 "24" "25" "26" "27" "28" "29" "30" "31" "32" "33" "34" "35"
 237                 "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" "46" "47"
 238                 "48" "49" "50" "51" "52" "53" "54" "55" "56" "57" "58" "59"
 239                 "60")))
 240
 241 (defun is-dst (utime)
 242   (with-utime-decoding (utime)
 243     daylight-p))
 244
 245
 246 (defmacro with-utime-decoding-utc-offset ((utime utc-offset) &body body)
 247   (with-gensyms (zone)
 248     `(let* ((,zone (cond
 249                     ((eq :utc ,utc-offset)
 250                      0)
 251                     ((null utc-offset)
 252                      nil)
 253                     (t
 254                      (if (is-dst ,utime)
 255                          (1- (- ,utc-offset))
 256                        (- ,utc-offset))))))
 257        (if ,zone
 258            (with-utime-decoding (,utime ,zone)
 259              ,@body)
 260          (with-utime-decoding (,utime)
 261            ,@body)))))
 262
 263
 264 (defun write-utime-hms (utime &key utc-offset stream)
 265   (if stream
 266       (write-utime-hms-stream utime stream utc-offset)
 267     (with-output-to-string (s)
 268       (write-utime-hms-stream utime s utc-offset))))
 269
 270 (defun write-utime-hms-stream (utime stream &optional utc-offset)
 271   (with-utime-decoding-utc-offset (utime utc-offset)
 272     (write-string (aref +datetime-number-strings+ hour) stream)
 273     (write-char #\: stream)
 274     (write-string (aref +datetime-number-strings+ minute) stream)
 275     (write-char #\: stream)
 276     (write-string (aref +datetime-number-strings+ second) stream)))
 277
 278 (defun write-utime-hm (utime &key utc-offset stream)
 279   (if stream
 280       (write-utime-hm-stream utime stream utc-offset)
 281     (with-output-to-string (s)
 282       (write-utime-hm-stream utime s utc-offset))))
 283
 284 (defun write-utime-hm-stream (utime stream &optional utc-offset)
 285   (with-utime-decoding-utc-offset (utime utc-offset)
 286     (write-string (aref +datetime-number-strings+ hour) stream)
 287     (write-char #\: stream)
 288     (write-string (aref +datetime-number-strings+ minute) stream)))
 289
 290
 291 (defun write-utime-ymdhms (utime &key stream utc-offset)
 292   (if stream
 293       (write-utime-ymdhms-stream utime stream utc-offset)
 294     (with-output-to-string (s)
 295       (write-utime-ymdhms-stream utime s utc-offset))))
 296
 297 (defun write-utime-ymdhms-stream (utime stream &optional utc-offset)
 298   (with-utime-decoding-utc-offset (utime utc-offset)
 299     (write-string (prefixed-fixnum-string year nil 4) stream)
 300     (write-char #\/ stream)
 301     (write-string (aref +datetime-number-strings+ month) stream)
 302     (write-char #\/ stream)
 303     (write-string (aref +datetime-number-strings+ day-of-month) stream)
 304     (write-char #\space stream)
 305     (write-string (aref +datetime-number-strings+ hour) stream)
 306     (write-char #\: stream)
 307     (write-string (aref +datetime-number-strings+ minute) stream)
 308     (write-char #\: stream)
 309     (write-string (aref +datetime-number-strings+ second) stream)))
 310
 311 (defun write-utime-ymdhm (utime &key stream utc-offset)
 312   (if stream
 313       (write-utime-ymdhm-stream utime stream utc-offset)
 314     (with-output-to-string (s)
 315       (write-utime-ymdhm-stream utime s utc-offset))))
 316
 317 (defun write-utime-ymdhm-stream (utime stream &optional utc-offset)
 318   (with-utime-decoding-utc-offset (utime utc-offset)
 319     (write-string (prefixed-fixnum-string year nil 4) stream)
 320     (write-char #\/ stream)
 321     (write-string (aref +datetime-number-strings+ month) stream)
 322     (write-char #\/ stream)
 323     (write-string (aref +datetime-number-strings+ day-of-month) stream)
 324     (write-char #\space stream)
 325     (write-string (aref +datetime-number-strings+ hour) stream)
 326     (write-char #\: stream)
 327     (write-string (aref +datetime-number-strings+ minute) stream)))
 328
 329