1;;; fileio.scm: low-level file IO functions for uim.
2;;;
3;;; Copyright (c) 2009-2013 uim Project https://github.com/uim/uim
4;;;
5;;; All rights reserved.
6;;;
7;;; Redistribution and use in source and binary forms, with or without
8;;; modification, are permitted provided that the following conditions
9;;; are met:
10;;; 1. Redistributions of source code must retain the above copyright
11;;;    notice, this list of conditions and the following disclaimer.
12;;; 2. Redistributions in binary form must reproduce the above copyright
13;;;    notice, this list of conditions and the following disclaimer in the
14;;;    documentation and/or other materials provided with the distribution.
15;;; 3. Neither the name of authors nor the names of its contributors
16;;;    may be used to endorse or promote products derived from this software
17;;;    without specific prior written permission.
18;;;
19;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
20;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
21;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
22;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
23;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
24;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
25;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
26;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
27;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
28;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
29;;; SUCH DAMAGE.
30;;;;
31
32(require-extension (srfi 9 48))
33
34(require-dynlib "fileio")
35
36(define file-bufsiz 16384)
37
38(define file-open-flags-alist (file-open-flags?))
39(define file-open-mode-alist (file-open-mode?))
40(define file-position-whence-alist (file-position-whence?))
41(define file-poll-flags-alist (file-poll-flags?))
42
43(define (file-set-flag l alist)
44  (apply logior
45         (map (lambda (s)
46                (assq-cdr s alist))
47              l)))
48(define (file-open-flags-number l)
49  (file-set-flag l file-open-flags-alist))
50(define (file-open-mode-number l)
51  (file-set-flag l file-open-mode-alist))
52(define (file-poll-flags-number l)
53  (file-set-flag l file-poll-flags-alist))
54
55(define (file-position field)
56  (file-position-set! field 0 (assq-cdr '$SEEK_CUR file-position-whence-alist)))
57
58(define (string->file-buf str)
59  (string->list str))
60(define (file-buf->string buf)
61  (list->string buf))
62(define (file-read-string s len)
63  (let ((ret (file-read s len)))
64    (if (eof-object? ret)
65        ret
66        (file-buf->string ret))))
67(define (file-write-string s str)
68  (file-write s (string->file-buf str)))
69
70(define (file-read-string-with-terminate-char socket term-char)
71  (let loop ((c (file-read socket 1))
72             (rest '()))
73    (cond ((eof-object? c)
74           (uim-notify-fatal (N_ "unexpected terminate string."))
75           "")
76          ((eq? (car c) term-char)
77           (file-buf->string (reverse rest)))
78          (else
79           (loop (file-read socket 1) (cons (car c) rest))))))
80
81(define (file-read-string-with-terminate-chars socket term-chars)
82  (let ((buf (file-read socket (length term-chars))))
83    (cond ((eof-object? buf)
84           (raise (N_ "unexpected terminate string.")))
85          ((equal? term-chars buf)
86           "")
87          (else
88           (let loop ((c (file-read socket 1))
89                      (buf buf)
90                      (rest '()))
91             (cond ((eof-object? c)
92                    (raise (N_ "unexpected terminate string.")))
93                   ((equal? term-chars (append (cdr buf) c))
94                    (file-buf->string (append rest (list (car buf)))))
95                   (else
96                    ;; enqueue
97                    (loop (file-read socket 1)
98                          (append (cdr buf) c)
99                          (append rest (list (car buf)))))))))))
100
101(define (file-read-string-with-terminate socket term-char)
102  (if (char? term-char)
103      (file-read-string-with-terminate-char socket term-char)
104      (file-read-string-with-terminate-chars socket term-char)))
105
106(define-record-type file-port
107  (make-file-port context fd inbufsiz inbuf read write) file-port?
108  (context  context?  context!)
109  (fd       fd?       fd!)
110  (inbufsiz inbufsiz? inbufsiz!)
111  (inbuf    inbuf?    inbuf!)
112  (read     read?     read!)
113  (write    write?    write!))
114
115(define (open-file-port fd)
116  (make-file-port fd fd file-bufsiz '() file-read file-write))
117
118(define (close-file-port port)
119  (inbuf! port '())
120  (file-close (context? port))
121  (context! port #f)
122  (fd! port #f))
123
124(define (call-with-open-file-port fd thunk)
125  (and (not (null? fd))
126       (< 0 fd)
127       (let ((ret (thunk (open-file-port fd))))
128         (file-close fd)
129         ret)))
130
131(define (file-read-char port)
132  (if (null? (inbuf? port))
133      (begin
134        ;; XXX: block
135        (file-ready? (list (fd? port)) -1)
136        (inbuf! port ((read? port) (context? port) (inbufsiz? port)))))
137  (let ((buf (inbuf? port)))
138    (if (or (eof-object? buf) ;; disconnect?
139            (not buf))
140        buf
141        (let ((c (car buf)))
142          (inbuf! port (cdr buf))
143          c))))
144
145(define (file-peek-char port)
146  (if (null? (inbuf? port))
147      (inbuf! port ((read? port) (context? port) (inbufsiz? port))))
148  (let ((buf (inbuf? port)))
149    (if (or (eof-object? buf) ;; disconnect?
150            (not buf))
151        buf
152        (let ((c (car buf)))
153          c))))
154
155(define (file-display str port)
156  ((write? port) (context? port) (string->file-buf str)))
157
158(define (file-newline port)
159  ((write? port) (context? port) (string->file-buf (list->string '(#\newline)))))
160
161(define (file-read-line port)
162  (let loop ((c (file-read-char port))
163             (rest '()))
164    (cond ((eq? #\newline c)
165           (list->string (reverse rest)))
166          ((or (eof-object? c) ;; disconnect?
167               (not c))
168           (if (null? rest)
169             c
170             (list->string (reverse rest))))
171          (else
172           (loop (file-read-char port) (cons c rest))))))
173
174(define (file-read-buffer port len)
175  (list->string (map (lambda (i) (file-read-char port)) (iota len))))
176
177(define (file-get-buffer port)
178  (file-buf->string (inbuf? port)))
179
180(define (file-write-sexp l port)
181  ((write? port) (context? port) (string->file-buf (write-to-string l))))
182
183;; XXX: multi ports are not considered
184(define %*file-reading* #f)
185
186(cond-expand
187 (sigscheme
188  (define %file-eof-error?
189    (lambda (err)
190      (and (%%error-object? err)
191           (string-prefix? "in read: EOF " (cadr err)))))) ;; XXX
192 (else
193  (error "cannot detect EOF error")))
194
195(define (%file-partial-read . args)
196  (guard (err
197          ((%file-eof-error? err) err))
198         (apply read args)))
199
200(define file-read-sexp
201  (let ((p (open-input-string ""))
202        (buf ""))
203    (lambda (port)
204      (let ((expr (%file-partial-read p)))
205
206        (if (or (eof-object? expr)
207                (%file-eof-error? expr))
208            (let ((line (file-read-line port)))
209              (if (null? line) ;; disconnect?
210                  (begin
211                    (set! buf "")
212                    (set! %*file-reading* #f)
213                    expr)
214                  (if (eof-object? line)
215                      (if (%file-eof-error? expr)
216                          (raise expr)
217                          line)
218                      (begin
219                        (set! buf (if (%file-eof-error? expr)
220                                      (string-append buf line)
221                                      line))
222                        (set! p (open-input-string buf))
223                        (set! %*file-reading* #t)
224                        (file-read-sexp port)))))
225            (begin
226              (set! buf "")
227              (set! %*file-reading* #f)
228              expr))))))
229
230(define (duplicate-fileno oldd . args)
231  (let-optionals* args ((newd #f))
232     (duplicate2-fileno oldd newd)))
233
234(define (file-ready? fd-list timeout)
235  (let* ((fds (map (lambda (fd)
236                     (cons fd (assq-cdr '$POLLIN file-poll-flags-alist)))
237                   fd-list))
238         (ret (file-poll fds timeout)))
239    (cond ((not ret)
240           (uim-notify-fatal (format "~a: '~a'" (_ "poll error") (posix-error-string)))
241           #f)
242          ((null? ret)
243           ;;(uim-notify-info (N_ "timeout"))
244           #f)
245          (else
246           ret))))
247
248