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