ice-9/lineio.scm

   1 ;;; installed-scm-file
   2
   3 ;;;;    Copyright (C) 1996, 1998 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This program is free software; you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation; either version 2, or (at your option)
   8 ;;;; any later version.
   9 ;;;;
  10 ;;;; This program is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with this software; see the file COPYING.  If not, write to
  17 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19 ;;;;
  20
  21 \f
  22
  23 (define-module (ice-9 lineio))
  24
  25 \f
  26 ;;; {Line Buffering Input Ports}
  27 ;;;
  28 ;;; [This is a work-around to get past certain deficiencies in the capabilities
  29 ;;;  of ports.  Eventually, ports should be fixed and this module nuked.]
  30 ;;;
  31 ;;; A line buffering input port supports:
  32 ;;;
  33 ;;;     read-string     which returns the next line of input
  34 ;;;     unread-string   which pushes a line back onto the stream
  35 ;;;
  36 ;;; The implementation of unread-string is kind of limited; it doesn't
  37 ;;; interact properly with unread-char, or any of the other port
  38 ;;; reading functions.  Only read-string will get you back the things that
  39 ;;; unread-string accepts.
  40 ;;;
  41 ;;; Normally a "line" is all characters up to and including a newline.
  42 ;;; If lines are put back using unread-string, they can be broken arbitrarily
  43 ;;; -- that is, read-string returns strings passed to unread-string (or
  44 ;;; shared substrings of them).
  45 ;;;
  46
  47 ;; read-string port
  48 ;; unread-string port str
  49 ;;   Read (or buffer) a line from PORT.
  50 ;;
  51 ;; Not all ports support these functions -- only those with
  52 ;; 'unread-string and 'read-string properties, bound to hooks
  53 ;; implementing these functions.
  54 ;;
  55 (define-public (unread-string str line-buffering-input-port)
  56   ((object-property line-buffering-input-port 'unread-string) str))
  57
  58 ;;
  59 (define-public (read-string line-buffering-input-port)
  60   ((object-property line-buffering-input-port 'read-string)))
  61
  62
  63 (define-public (lineio-port? port)
  64   (not (not (object-property port 'read-string))))
  65
  66 ;; make-line-buffering-input-port port
  67 ;;   Return a wrapper for PORT.  The wrapper handles read-string/unread-string.
  68 ;;
  69 ;; The port returned by this function reads newline terminated lines from PORT.
  70 ;; It buffers these characters internally, and parsels them out via calls
  71 ;; to read-char, read-string, and unread-string.
  72 ;;
  73
  74 (define-public (make-line-buffering-input-port underlying-port)
  75   (let* (;; buffers - a list of strings put back by unread-string or cached
  76          ;; using read-line.
  77          ;;
  78          (buffers '())
  79
  80          ;; getc - return the next character from a buffer or from the underlying
  81          ;; port.
  82          ;;
  83          (getc (lambda ()
  84                  (if (not buffers)
  85                      (read-char underlying-port)
  86                      (let ((c (string-ref (car buffers))))
  87                        (if (= 1 (string-length (car buffers)))
  88                            (set! buffers (cdr buffers))
  89                            (set-car! buffers (make-shared-substring (car buffers) 1)))
  90                        c))))
  91
  92          (propogate-close (lambda () (close-port underlying-port)))
  93
  94          (self (make-soft-port (vector #f #f #f getc propogate-close) "r"))
  95
  96          (unread-string (lambda (str)
  97                           (and (< 0 (string-length str))
  98                                    (set! buffers (cons str buffers)))))
  99
 100          (read-string (lambda ()
 101                        (cond
 102                         ((not (null? buffers))
 103                          (let ((answer (car buffers)))
 104                            (set! buffers (cdr buffers))
 105                            answer))
 106                         (else
 107                          (read-line underlying-port 'concat)))))) ;handle-newline->concat
 108
 109     (set-object-property! self 'unread-string unread-string)
 110     (set-object-property! self 'read-string read-string)
 111     self))
 112
 113