module/ice-9/lineio.scm

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