Commit | Line | Data |
---|---|---|
9d774814 GH |
1 | ;;; installed-scm-file |
2 | ||
6d36532c | 3 | ;;;; Copyright (C) 1997, 1999, 2000, 2001 Free Software Foundation, Inc. |
9d774814 GH |
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 | |
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. | |
9d774814 GH |
43 | ;;;; |
44 | \f | |
45 | ||
6d36532c GH |
46 | ;;; This is the Scheme part of the module for delimited I/O. It's |
47 | ;;; similar to (scsh rdelim) but somewhat incompatible. | |
9d774814 | 48 | |
1a179b03 MD |
49 | (define-module (ice-9 rdelim) |
50 | :export (read-line read-line! read-delimited read-delimited! | |
51 | %read-delimited! %read-line write-line) ; C | |
52 | ) | |
9d774814 | 53 | |
43fd4402 MV |
54 | (%init-rdelim-builtins) |
55 | ||
9d774814 GH |
56 | (define (read-line! string . maybe-port) |
57 | ;; corresponds to SCM_LINE_INCREMENTORS in libguile. | |
58 | (define scm-line-incrementors "\n") | |
59 | ||
60 | (let* ((port (if (pair? maybe-port) | |
61 | (car maybe-port) | |
62 | (current-input-port)))) | |
63 | (let* ((rv (%read-delimited! scm-line-incrementors | |
64 | string | |
65 | #t | |
66 | port)) | |
67 | (terminator (car rv)) | |
68 | (nchars (cdr rv))) | |
69 | (cond ((and (= nchars 0) | |
70 | (eof-object? terminator)) | |
71 | terminator) | |
72 | ((not terminator) #f) | |
73 | (else nchars))))) | |
74 | ||
75 | (define (read-delimited! delims buf . args) | |
76 | (let* ((num-args (length args)) | |
77 | (port (if (> num-args 0) | |
78 | (car args) | |
79 | (current-input-port))) | |
80 | (handle-delim (if (> num-args 1) | |
81 | (cadr args) | |
82 | 'trim)) | |
83 | (start (if (> num-args 2) | |
84 | (caddr args) | |
85 | 0)) | |
86 | (end (if (> num-args 3) | |
87 | (cadddr args) | |
88 | (string-length buf)))) | |
89 | (let* ((rv (%read-delimited! delims | |
90 | buf | |
91 | (not (eq? handle-delim 'peek)) | |
92 | port | |
93 | start | |
94 | end)) | |
95 | (terminator (car rv)) | |
96 | (nchars (cdr rv))) | |
97 | (cond ((or (not terminator) ; buffer filled | |
98 | (eof-object? terminator)) | |
99 | (if (zero? nchars) | |
100 | (if (eq? handle-delim 'split) | |
101 | (cons terminator terminator) | |
102 | terminator) | |
103 | (if (eq? handle-delim 'split) | |
104 | (cons nchars terminator) | |
105 | nchars))) | |
106 | (else | |
107 | (case handle-delim | |
108 | ((trim peek) nchars) | |
109 | ((concat) (string-set! buf (+ nchars start) terminator) | |
110 | (+ nchars 1)) | |
111 | ((split) (cons nchars terminator)) | |
112 | (else (error "unexpected handle-delim value: " | |
113 | handle-delim)))))))) | |
114 | ||
115 | (define (read-delimited delims . args) | |
116 | (let* ((port (if (pair? args) | |
117 | (let ((pt (car args))) | |
118 | (set! args (cdr args)) | |
119 | pt) | |
120 | (current-input-port))) | |
121 | (handle-delim (if (pair? args) | |
122 | (car args) | |
123 | 'trim))) | |
bf4aaed2 | 124 | (let loop ((substrings '()) |
9d774814 GH |
125 | (total-chars 0) |
126 | (buf-size 100)) ; doubled each time through. | |
127 | (let* ((buf (make-string buf-size)) | |
128 | (rv (%read-delimited! delims | |
129 | buf | |
130 | (not (eq? handle-delim 'peek)) | |
131 | port)) | |
132 | (terminator (car rv)) | |
133 | (nchars (cdr rv)) | |
134 | (join-substrings | |
135 | (lambda () | |
136 | (apply string-append | |
137 | (reverse | |
138 | (cons (if (and (eq? handle-delim 'concat) | |
139 | (not (eof-object? terminator))) | |
140 | (string terminator) | |
141 | "") | |
142 | (cons (substring buf 0 nchars) | |
143 | substrings)))))) | |
144 | (new-total (+ total-chars nchars))) | |
145 | (cond ((not terminator) | |
146 | ;; buffer filled. | |
147 | (loop (cons (substring buf 0 nchars) substrings) | |
148 | new-total | |
149 | (* buf-size 2))) | |
150 | ((eof-object? terminator) | |
151 | (if (zero? new-total) | |
152 | (if (eq? handle-delim 'split) | |
153 | (cons terminator terminator) | |
154 | terminator) | |
155 | (if (eq? handle-delim 'split) | |
156 | (cons (join-substrings) terminator) | |
157 | (join-substrings)))) | |
158 | (else | |
159 | (case handle-delim | |
160 | ((trim peek concat) (join-substrings)) | |
161 | ((split) (cons (join-substrings) terminator)) | |
162 | ||
163 | ||
164 | (else (error "unexpected handle-delim value: " | |
165 | handle-delim))))))))) | |
166 | ||
167 | ;;; read-line [PORT [HANDLE-DELIM]] reads a newline-terminated string | |
168 | ;;; from PORT. The return value depends on the value of HANDLE-DELIM, | |
169 | ;;; which may be one of the symbols `trim', `concat', `peek' and | |
170 | ;;; `split'. If it is `trim' (the default), the trailing newline is | |
171 | ;;; removed and the string is returned. If `concat', the string is | |
172 | ;;; returned with the trailing newline intact. If `peek', the newline | |
173 | ;;; is left in the input port buffer and the string is returned. If | |
174 | ;;; `split', the newline is split from the string and read-line | |
175 | ;;; returns a pair consisting of the truncated string and the newline. | |
176 | ||
177 | (define (read-line . args) | |
178 | (let* ((port (if (null? args) | |
179 | (current-input-port) | |
180 | (car args))) | |
181 | (handle-delim (if (> (length args) 1) | |
182 | (cadr args) | |
183 | 'trim)) | |
184 | (line/delim (%read-line port)) | |
185 | (line (car line/delim)) | |
186 | (delim (cdr line/delim))) | |
187 | (case handle-delim | |
188 | ((trim) line) | |
189 | ((split) line/delim) | |
190 | ((concat) (if (and (string? line) (char? delim)) | |
191 | (string-append line (string delim)) | |
192 | line)) | |
193 | ((peek) (if (char? delim) | |
194 | (unread-char delim port)) | |
195 | line) | |
196 | (else | |
197 | (error "unexpected handle-delim value: " handle-delim))))) |