;;; -*- Mode: Lisp -*-
;;;
;;; $Header: /home/gene/library/website/docsrc/sfpc/RCS/slurp-file.lisp,v 395.1 2008/04/20 17:25:50 gene Exp $
;;;
;;; Copyright (C) 2004, 2005  Gene Michael Stover.  All rights reserved.
;;; 
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of version 2.1 of the GNU
;;; Lesser General Public License as published by the Free
;;; Software Foundation.
;;; 
;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;; PURPOSE.  See the GNU Lesser General Public License for more
;;; details.
;;; 
;;; You should have received a copy of the GNU Lesser General
;;; Public License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;; Boston, MA 02111-1307 USA
;;;

(defun next-char (strm)
  (read-char strm nil strm))

(defconstant newline-string (format nil "~%"))

(defun xread-line (strm)
  "Returns a string containing the next line in the file
with the end-of-line character(s).  On end-of-file,
returns STRM."
  (read-line strm nil strm))

(defun slurp-stream-cons (strm)
  (do ((x (next-char strm) (next-char strm))
       (lst () (cons x lst)))
      ((eq x strm) (coerce (nreverse lst) 'string))))

(defun slurp-stream-vector-push (strm)
  "Return a string containing the entire
contents of the stream."
  (let ((str (make-array 1024
                         :element-type 'character
                         :adjustable t
                         :fill-pointer 0)))
    (do ((ch (next-char strm) (next-char strm)))
        ((eq ch strm) str)
        (vector-push-extend ch str))))

(defun slurp-stream-vector-push2 (strm)
  "Return a string containing the entire
contents of the stream."
  (let ((str (make-array 1024
                         :element-type 'character
                         :adjustable t
                         :fill-pointer 0)))
    (do ((ch (next-char strm) (next-char strm)))
        ((eq ch strm) str)
        (vector-push-extend ch str 1024))))

(defun slurp-stream-line (strm)
  "Slurp the contents of the stream.  Return them in a
string.  This turned out to be slower than the 'simple'
version."
  (do ((str "" (concatenate 'string
			    (concatenate 'string str line)
			    newline-string))
       (line (xread-line strm) (xread-line strm)))
      ((eq line strm) str)))

;;; Suggested by Shawn Betts.
(defun slurp-stream-string-stream (stream)
  "Return the contents of file as a string."
  (with-output-to-string (out)
    (do ((line (xread-line stream) (xread-line stream)))
        ((eq line stream))
      (write-line line out))))

(defun slurp-stream-string-stream2 (stream)
  "Return the contents of file as a string."
  (with-output-to-string (out)
    (do ((x (next-char stream) (next-char stream)))
        ((eq x stream))
      (write-char x out))))

(defun slurp-file (pathname fn)
  (declare (type function fn))
  (with-open-file (strm pathname)
    (funcall fn strm)))

(defun timetest (slurper pathname)
  (declare (type symbol slurper) (type (or pathname string) pathname))
  (format t "~&~A" slurper)
  (force-output)
  (let* ((start-time (get-universal-time))
         (stop-time (get-universal-time))
	 (fn (symbol-function slurper))
         (count 0))
    (declare (type function fn))
    ;; Side-effect of this loop is to bind values to
    ;; COUNT & STOP-TIME.
    (do ()
        ((>= (- stop-time start-time) 10))
	(incf count (length (slurp-file pathname fn)))
        (setq stop-time (get-universal-time)))
    (format t " & ~A & ~A & ~,2E \\\\ \\hline" count
            (- stop-time start-time)
            (/ count (- stop-time start-time)))
    (force-output))
  slurper)

(defun testall (pathname)
  (declare (type (or pathname string) pathname))
  (mapc #'(lambda (symbol)
	    (timetest symbol pathname))
	(list 'slurp-stream-cons
	      'slurp-stream-vector-push
	      'slurp-stream-vector-push2
	      'slurp-stream-line
	      'slurp-stream-string-stream
	      'slurp-stream-string-stream2))
  'testall)

(defvar *chars* "0123456789abcdefghijklmnopqrstuvwxyz")
(defun random-char ()
  (char *chars* (random (length *chars*))))

(defun make-big-file ()
  (with-open-file (strm "big.tmp" :direction :output
			:if-exists :rename-and-delete
			:if-does-not-exist :create)
    (dotimes (line 800)
      (format strm "~&")
      (dotimes (char 1024)
	(format strm "~C" (random-char)))))
  'make-big-file)

;;; --- end of file ---