summaryrefslogtreecommitdiff
path: root/module/ice-9/lineio.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/lineio.scm')
-rw-r--r--module/ice-9/lineio.scm115
1 files changed, 115 insertions, 0 deletions
diff --git a/module/ice-9/lineio.scm b/module/ice-9/lineio.scm
new file mode 100644
index 000000000..68f290369
--- /dev/null
+++ b/module/ice-9/lineio.scm
@@ -0,0 +1,115 @@
+;;; installed-scm-file
+
+;;;; Copyright (C) 1996, 1998, 2001, 2003, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+
+
+(define-module (ice-9 lineio)
+ :use-module (ice-9 rdelim)
+ :export (unread-string read-string lineio-port?
+ make-line-buffering-input-port))
+
+
+;;; {Line Buffering Input Ports}
+;;;
+;;; [This is a work-around to get past certain deficiencies in the capabilities
+;;; of ports. Eventually, ports should be fixed and this module nuked.]
+;;;
+;;; A line buffering input port supports:
+;;;
+;;; read-string which returns the next line of input
+;;; unread-string which pushes a line back onto the stream
+;;;
+;;; The implementation of unread-string is kind of limited; it doesn't
+;;; interact properly with unread-char, or any of the other port
+;;; reading functions. Only read-string will get you back the things that
+;;; unread-string accepts.
+;;;
+;;; Normally a "line" is all characters up to and including a newline.
+;;; If lines are put back using unread-string, they can be broken arbitrarily
+;;; -- that is, read-string returns strings passed to unread-string (or
+;;; shared substrings of them).
+;;;
+
+;; read-string port
+;; unread-string port str
+;; Read (or buffer) a line from PORT.
+;;
+;; Not all ports support these functions -- only those with
+;; 'unread-string and 'read-string properties, bound to hooks
+;; implementing these functions.
+;;
+(define (unread-string str line-buffering-input-port)
+ ((object-property line-buffering-input-port 'unread-string) str))
+
+;;
+(define (read-string line-buffering-input-port)
+ ((object-property line-buffering-input-port 'read-string)))
+
+
+(define (lineio-port? port)
+ (not (not (object-property port 'read-string))))
+
+;; make-line-buffering-input-port port
+;; Return a wrapper for PORT. The wrapper handles read-string/unread-string.
+;;
+;; The port returned by this function reads newline terminated lines from PORT.
+;; It buffers these characters internally, and parsels them out via calls
+;; to read-char, read-string, and unread-string.
+;;
+
+(define (make-line-buffering-input-port underlying-port)
+ (let* (;; buffers - a list of strings put back by unread-string or cached
+ ;; using read-line.
+ ;;
+ (buffers '())
+
+ ;; getc - return the next character from a buffer or from the underlying
+ ;; port.
+ ;;
+ (getc (lambda ()
+ (if (not buffers)
+ (read-char underlying-port)
+ (let ((c (string-ref (car buffers) 0)))
+ (if (= 1 (string-length (car buffers)))
+ (set! buffers (cdr buffers))
+ (set-car! buffers (substring (car buffers) 1)))
+ c))))
+
+ (propogate-close (lambda () (close-port underlying-port)))
+
+ (self (make-soft-port (vector #f #f #f getc propogate-close) "r"))
+
+ (unread-string (lambda (str)
+ (and (< 0 (string-length str))
+ (set! buffers (cons str buffers)))))
+
+ (read-string (lambda ()
+ (cond
+ ((not (null? buffers))
+ (let ((answer (car buffers)))
+ (set! buffers (cdr buffers))
+ answer))
+ (else
+ (read-line underlying-port 'concat)))))) ;handle-newline->concat
+
+ (set-object-property! self 'unread-string unread-string)
+ (set-object-property! self 'read-string read-string)
+ self))
+
+