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   :use-module (ice-9 readline))
  25
  26 \f
  27 ;;; {Line Buffering Input Ports}
  28 ;;;
  29 ;;; [This is a work-around to get past certain deficiencies in the capabilities
  30 ;;;  of ports.  Eventually, ports should be fixed and this module nuked.]
  31 ;;;
  32 ;;; A line buffering input port supports:
  33 ;;;
  34 ;;;     read-string     which returns the next line of input
  35 ;;;     unread-string   which pushes a line back onto the stream
  36 ;;;
  37 ;;; The implementation of unread-string is kind of limited; it doesn't
  38 ;;; interact properly with unread-char, or any of the other port
  39 ;;; reading functions.  Only read-string will get you back the things that
  40 ;;; unread-string accepts.
  41 ;;;
  42 ;;; Normally a "line" is all characters up to and including a newline.
  43 ;;; If lines are put back using unread-string, they can be broken arbitrarily
  44 ;;; -- that is, read-string returns strings passed to unread-string (or
  45 ;;; shared substrings of them).
  46 ;;;
  47
  48 ;; read-string port
  49 ;; unread-string port str
  50 ;;   Read (or buffer) a line from PORT.
  51 ;;
  52 ;; Not all ports support these functions -- only those with
  53 ;; 'unread-string and 'read-string properties, bound to hooks
  54 ;; implementing these functions.
  55 ;;
  56 (define-public (unread-string str line-buffering-input-port)
  57   ((object-property line-buffering-input-port 'unread-string) str))
  58
  59 ;;
  60 (define-public (read-string line-buffering-input-port)
  61   ((object-property line-buffering-input-port 'read-string)))
  62
  63
  64 (define-public (lineio-port? port)
  65   (not (not (object-property port 'read-string))))
  66
  67 ;; make-line-buffering-input-port port
  68 ;;   Return a wrapper for PORT.  The wrapper handles read-string/unread-string.
  69 ;;
  70 ;; The port returned by this function reads newline terminated lines from PORT.
  71 ;; It buffers these characters internally, and parsels them out via calls
  72 ;; to read-char, read-string, and unread-string.
  73 ;;
  74
  75 (define-public (make-line-buffering-input-port underlying-port)
  76   (let* (;; buffers - a list of strings put back by unread-string or cached
  77          ;; using read-line.
  78          ;;
  79          (buffers '())
  80
  81          ;; getc - return the next character from a buffer or from the underlying
  82          ;; port.
  83          ;;
  84          (getc (lambda ()
  85                  (if (not buffers)
  86                      (read-char underlying-port)
  87                      (let ((c (string-ref (car buffers))))
  88                        (if (= 1 (string-length (car buffers)))
  89                            (set! buffers (cdr buffers))
  90                            (set-car! buffers (substring (car buffers) 1)))
  91                        c))))
  92
  93          (propogate-close (lambda () (close-port underlying-port)))
  94
  95          (self (make-soft-port (vector #f #f #f getc propogate-close) "r"))
  96
  97          (unread-string (lambda (str)
  98                           (and (< 0 (string-length str))
  99                                    (set! buffers (cons str buffers)))))
 100
 101          (read-string (lambda ()
 102                        (cond
 103                         ((not (null? buffers))
 104                          (let ((answer (car buffers)))
 105                            (set! buffers (cdr buffers))
 106                            answer))
 107                         (else
 108                          (read-line underlying-port 'concat)))))) ;handle-newline->concat
 109
 110     (set-object-property! self 'unread-string unread-string)
 111     (set-object-property! self 'read-string read-string)
 112     self))
 113
 114