;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          io.lisp
;;;; Purpose:       Input/Output functions for KMRCL package
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Apr 2000
;;;;
;;;; $Id$
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************

(in-package #:kmrcl)

(defun print-file-contents (file &optional (strm *standard-output*))
  "Opens a reads a file. Returns the contents as a single string"
  (when (probe-file file)
    (with-open-file (in file :direction :input)
      (let ((eof (gensym)))		    
	(do ((line (read-line in nil eof) 
		   (read-line in nil eof)))
	    ((eq line eof))
	  (format strm "~A~%" line))))))

(defun read-file-to-string (file)
  "Opens a reads a file. Returns the contents as a single string"
  (with-output-to-string (out)
    (with-open-file (in file :direction :input)
      (let ((eof (gensym)))		    
	(do ((line (read-line in nil eof) 
		   (read-line in nil eof)))
	    ((eq line eof))
	  (format out "~A~%" line))))))

(defun read-file-to-strings (file)
  "Opens a reads a file. Returns the contents as a list of strings"
  (let ((lines '()))
    (with-open-file (in file :direction :input)
      (let ((eof (gensym)))		    
	(do ((line (read-line in nil eof) 
		   (read-line in nil eof)))
	    ((eq line eof))
	  (push line lines)))
      (nreverse lines))))

(defun file-subst (old new file1 file2)
  (with-open-file (in file1 :direction :input)
    (with-open-file (out file2 :direction :output
			 :if-exists :supersede)
      (stream-subst old new in out))))

(defun print-n-chars (char n stream)
  (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
  (dotimes (i n)
    (declare (fixnum i))
    (write-char char stream)))

(defun print-n-strings (str n stream)
  (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
  (dotimes (i n)
    (declare (fixnum i))
    (write-string str stream)))

(defun indent-spaces (n &optional (stream *standard-output*))
  "Indent n*2 spaces to output stream"
  (print-n-chars #\space (+ n n) stream))


(defun indent-html-spaces (n &optional (stream *standard-output*))
  "Indent n*2 html spaces to output stream"
  (print-n-strings " " (+ n n) stream))
     

(defun print-list (l &optional (output *standard-output*))
  "Print a list to a stream"
  (format output "~{~A~%~}" l))

(defun print-rows (rows &optional (ostrm *standard-output*))
  "Print a list of list rows to a stream"  
  (dolist (r rows) (format ostrm "~{~A~^ ~}~%" r)))


;; Buffered stream substitute

(defstruct buf
  vec (start -1) (used -1) (new -1) (end -1))

(defun bref (buf n)
  (svref (buf-vec buf)
         (mod n (length (buf-vec buf)))))

(defun (setf bref) (val buf n)
  (setf (svref (buf-vec buf)
               (mod n (length (buf-vec buf))))
        val))

(defun new-buf (len)
  (make-buf :vec (make-array len)))

(defun buf-insert (x b)
  (setf (bref b (incf (buf-end b))) x))

(defun buf-pop (b)
  (prog1 
    (bref b (incf (buf-start b)))
    (setf (buf-used b) (buf-start b)
          (buf-new  b) (buf-end   b))))

(defun buf-next (b)
  (when (< (buf-used b) (buf-new b))
    (bref b (incf (buf-used b)))))

(defun buf-reset (b)
  (setf (buf-used b) (buf-start b)
        (buf-new  b) (buf-end   b)))

(defun buf-clear (b)
  (setf (buf-start b) -1 (buf-used  b) -1
        (buf-new   b) -1 (buf-end   b) -1))

(defun buf-flush (b str)
  (do ((i (1+ (buf-used b)) (1+ i)))
      ((> i (buf-end b)))
    (princ (bref b i) str)))


(defun stream-subst (old new in out)
  (declare (string old new))
  (let* ((pos 0)
         (len (length old))
         (buf (new-buf len))
         (from-buf nil))
    (declare (fixnum pos len))
    (do ((c (read-char in nil :eof)
            (or (setf from-buf (buf-next buf))
                (read-char in nil :eof))))
        ((eql c :eof))
      (declare (character c))
      (cond ((char= c (char old pos))
             (incf pos)
             (cond ((= pos len)            ; 3
                    (princ new out)
                    (setf pos 0)
                    (buf-clear buf))
                   ((not from-buf)         ; 2
                    (buf-insert c buf))))
            ((zerop pos)                   ; 1
             (princ c out)
             (when from-buf
               (buf-pop buf)
               (buf-reset buf)))
            (t                             ; 4
             (unless from-buf
               (buf-insert c buf))
             (princ (buf-pop buf) out)
             (buf-reset buf)
             (setf pos 0))))
    (buf-flush buf out)))

(declaim (inline write-fixnum))
(defun write-fixnum (n s)
  #+allegro (excl::print-fixnum s 10 n)
  #-allegro (write-string (write-to-string n) s))



#+openmcl
(defun open-device-stream (path direction)
  (let* ((mode (ecase direction
		 (:input #.(read-from-string "#$O_RDONLY"))
		 (:output #.(read-from-string "#$O_WRONLY"))
		 (:io #.(read-from-string "#$O_RDWR"))))
	 (fd (ccl::fd-open (ccl::native-translated-namestring path) mode)))
    (if (< fd 0)
       (ccl::signal-file-error fd path)
       (ccl::make-fd-stream fd :direction direction))))


(defun null-output-stream ()
  #-openmcl
  (when (probe-file #p"/dev/null")
    (open #p"/dev/null" :direction :output :if-exists :overwrite))
  #+openmcl
  (when (probe-file #p"/dev/null")
    (open-device-stream #p"/dev/null" :output))  
  )


(defun directory-tree (filename)
  "Returns a tree of pathnames for sub-directories of a directory"
  (let* ((root (canonicalize-directory-name filename))
	 (subdirs (loop for path in (directory
				     (make-pathname :name :wild
						    :type :wild
						    :defaults root))
			when (probe-directory path)
			collect (canonicalize-directory-name path))))
    (when (find nil subdirs)
      (error "~A" subdirs))
    (when (null root)
      (error "~A" root))
    (if subdirs
	(cons root (mapcar #'directory-tree subdirs))
	(if (probe-directory root)
	    (list root)
	    (error "root not directory ~A" root)))))