Commit | Line | Data |
---|---|---|
0f2d19dd JB |
1 | ;;; installed-scm-file |
2 | ||
e39bbe80 | 3 | ;;;; Copyright (C) 1996, 1998, 2001 Free Software Foundation, Inc. |
0f2d19dd JB |
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 | |
15328041 JB |
17 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
18 | ;;;; Boston, MA 02111-1307 USA | |
a482f2cc MV |
19 | ;;;; |
20 | ;;;; As a special exception, the Free Software Foundation gives permission | |
21 | ;;;; for additional uses of the text contained in its release of GUILE. | |
22 | ;;;; | |
23 | ;;;; The exception is that, if you link the GUILE library with other files | |
24 | ;;;; to produce an executable, this does not by itself cause the | |
25 | ;;;; resulting executable to be covered by the GNU General Public License. | |
26 | ;;;; Your use of that executable is in no way restricted on account of | |
27 | ;;;; linking the GUILE library code into it. | |
28 | ;;;; | |
29 | ;;;; This exception does not however invalidate any other reasons why | |
30 | ;;;; the executable file might be covered by the GNU General Public License. | |
31 | ;;;; | |
32 | ;;;; This exception applies only to the code released by the | |
33 | ;;;; Free Software Foundation under the name GUILE. If you copy | |
34 | ;;;; code from other Free Software Foundation releases into a copy of | |
35 | ;;;; GUILE, as the General Public License permits, the exception does | |
36 | ;;;; not apply to the code that you add in this way. To avoid misleading | |
37 | ;;;; anyone as to the status of such modified files, you must delete | |
38 | ;;;; this exception notice from them. | |
39 | ;;;; | |
40 | ;;;; If you write modifications of your own for GUILE, it is your choice | |
41 | ;;;; whether to permit this exception to apply to your modifications. | |
42 | ;;;; If you do not wish that, delete this exception notice. | |
0f2d19dd JB |
43 | ;;;; |
44 | ||
45 | \f | |
46 | ||
9d774814 | 47 | (define-module (ice-9 lineio) |
1a179b03 MD |
48 | :use-module (ice-9 readline) |
49 | :export (unread-string read-string lineio-port? | |
50 | make-line-buffering-input-port)) | |
0f2d19dd JB |
51 | |
52 | \f | |
53 | ;;; {Line Buffering Input Ports} | |
54 | ;;; | |
55 | ;;; [This is a work-around to get past certain deficiencies in the capabilities | |
56 | ;;; of ports. Eventually, ports should be fixed and this module nuked.] | |
57 | ;;; | |
58 | ;;; A line buffering input port supports: | |
59 | ;;; | |
60 | ;;; read-string which returns the next line of input | |
61 | ;;; unread-string which pushes a line back onto the stream | |
95bfa948 JB |
62 | ;;; |
63 | ;;; The implementation of unread-string is kind of limited; it doesn't | |
64 | ;;; interact properly with unread-char, or any of the other port | |
65 | ;;; reading functions. Only read-string will get you back the things that | |
66 | ;;; unread-string accepts. | |
0f2d19dd JB |
67 | ;;; |
68 | ;;; Normally a "line" is all characters up to and including a newline. | |
69 | ;;; If lines are put back using unread-string, they can be broken arbitrarily | |
70 | ;;; -- that is, read-string returns strings passed to unread-string (or | |
71 | ;;; shared substrings of them). | |
72 | ;;; | |
73 | ||
74 | ;; read-string port | |
75 | ;; unread-string port str | |
76 | ;; Read (or buffer) a line from PORT. | |
77 | ;; | |
78 | ;; Not all ports support these functions -- only those with | |
79 | ;; 'unread-string and 'read-string properties, bound to hooks | |
80 | ;; implementing these functions. | |
81 | ;; | |
1a179b03 | 82 | (define (unread-string str line-buffering-input-port) |
0f2d19dd JB |
83 | ((object-property line-buffering-input-port 'unread-string) str)) |
84 | ||
85 | ;; | |
1a179b03 | 86 | (define (read-string line-buffering-input-port) |
0f2d19dd JB |
87 | ((object-property line-buffering-input-port 'read-string))) |
88 | ||
89 | ||
1a179b03 | 90 | (define (lineio-port? port) |
0f2d19dd JB |
91 | (not (not (object-property port 'read-string)))) |
92 | ||
93 | ;; make-line-buffering-input-port port | |
94 | ;; Return a wrapper for PORT. The wrapper handles read-string/unread-string. | |
95 | ;; | |
96 | ;; The port returned by this function reads newline terminated lines from PORT. | |
97 | ;; It buffers these characters internally, and parsels them out via calls | |
98 | ;; to read-char, read-string, and unread-string. | |
99 | ;; | |
100 | ||
1a179b03 | 101 | (define (make-line-buffering-input-port underlying-port) |
0f2d19dd JB |
102 | (let* (;; buffers - a list of strings put back by unread-string or cached |
103 | ;; using read-line. | |
104 | ;; | |
105 | (buffers '()) | |
106 | ||
107 | ;; getc - return the next character from a buffer or from the underlying | |
108 | ;; port. | |
109 | ;; | |
110 | (getc (lambda () | |
111 | (if (not buffers) | |
112 | (read-char underlying-port) | |
113 | (let ((c (string-ref (car buffers)))) | |
114 | (if (= 1 (string-length (car buffers))) | |
115 | (set! buffers (cdr buffers)) | |
4e15fee8 | 116 | (set-car! buffers (substring (car buffers) 1))) |
0f2d19dd JB |
117 | c)))) |
118 | ||
119 | (propogate-close (lambda () (close-port underlying-port))) | |
120 | ||
121 | (self (make-soft-port (vector #f #f #f getc propogate-close) "r")) | |
122 | ||
123 | (unread-string (lambda (str) | |
124 | (and (< 0 (string-length str)) | |
95bfa948 | 125 | (set! buffers (cons str buffers))))) |
0f2d19dd JB |
126 | |
127 | (read-string (lambda () | |
128 | (cond | |
b1646914 JB |
129 | ((not (null? buffers)) |
130 | (let ((answer (car buffers))) | |
131 | (set! buffers (cdr buffers)) | |
132 | answer)) | |
b1646914 | 133 | (else |
95bfa948 | 134 | (read-line underlying-port 'concat)))))) ;handle-newline->concat |
0f2d19dd JB |
135 | |
136 | (set-object-property! self 'unread-string unread-string) | |
137 | (set-object-property! self 'read-string read-string) | |
138 | self)) | |
139 | ||
140 |