From 435d5ab132a765d5ca1328bd04ade007292e9011 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Wed, 2 Jan 2019 05:50:59 +0000 Subject: [PATCH] Use runtime's string ports. Also read file in one swell foop, rather than character by character in a slow painful chain of indirections thousands of times slower. We'll use legacy strings here because this code was all written under the assumption that `string' meant byte vector, and legacy strings still have that semantics. Eventually this should all be adapted to use bytevectors instead for storage, and interpret things as strings only as necessary for text processing beyond mail data formats. --- src/imail/imail-file.scm | 2 +- src/imail/imail-util.scm | 167 ++++----------------------------------- 2 files changed, 17 insertions(+), 152 deletions(-) diff --git a/src/imail/imail-file.scm b/src/imail/imail-file.scm index 95e19fe25..a536f8a72 100644 --- a/src/imail/imail-file.scm +++ b/src/imail/imail-file.scm @@ -447,7 +447,7 @@ USA. folder ((imail-ui:message-wrapper "Parsing messages") (lambda () - (call-with-input-string (file-folder-string folder) 0 reader))))) + (call-with-input-string (file-folder-string folder) reader))))) (define-method discard-folder-cache ((folder )) (discard-file-folder-messages folder) diff --git a/src/imail/imail-util.scm b/src/imail/imail-util.scm index f9defe1a3..369024aaa 100644 --- a/src/imail/imail-util.scm +++ b/src/imail/imail-util.scm @@ -419,162 +419,27 @@ USA. (lambda () (file-directory? pathname)))) -;;;; Extended-string input port +(define type-code:legacy-string (microcode-type 'character-string)) (define (read-file-into-string pathname) - (call-with-input-file pathname + (call-with-binary-input-file pathname (lambda (port) - (port/set-coding port 'iso-8859-1) - (port/set-line-ending port 'newline) - (let ((n-bytes ((textual-port-operation port 'LENGTH) port))) - (let ((string (make-string n-bytes))) - (let loop ((start 0)) - (if (< start n-bytes) - (let ((n-read (read-string! string port))) - (if (= n-read 0) - (error "Failed to read complete file:" - (+ start n-read) n-bytes pathname)) - (loop (+ start n-read))))) - string))))) - -(define (call-with-input-string string position receiver) - (let ((port (open-string-input-port string position))) - (let ((value (receiver port))) - (close-port port) - value))) - -(define (open-string-input-port string position) - (if (not (<= 0 position (string-length string))) - (error:bad-range-argument position 'OPEN-STRING-INPUT-PORT)) - (let ((state (make-istate string position position position))) - (read-string-buffer state) - (make-port string-input-type state))) - -(define-structure (istate - (constructor make-istate - (string position buffer-start buffer-end)) - (conc-name istate-)) - string - position - (buffer (make-string #x10000) read-only #t) - buffer-start - buffer-end) - -(define (string-port/string port) - (istate-string (port/state port))) + ;; XXX Fail gracefully if this is not a regular file. + (let* ((length (binary-port-length port)) + ;; XXX Store in an external buffer like we used to. + (buffer (make-bytevector length)) + (nread (read-bytevector! buffer port))) + ;; Check to make sure that the length didn't change under us + ;; while we were reading. If it did, this is no good. + (and (= nread length) + (object-new-type type-code:legacy-string buffer)))))) (define (string-port/position port) - (istate-position (port/state port))) - -(define (read-string-buffer state) - (let ((string (istate-string state)) - (start (istate-position state))) - (let ((xend (string-length string))) - (and (< start xend) - (let* ((buffer (istate-buffer state)) - (end (min (+ start (string-length buffer)) xend))) - (without-interrupts - (lambda () - (set-istate-buffer-start! state start) - (set-istate-buffer-end! state end) - (substring-move! string start end buffer 0))) - #t))))) - -(define (string-input-port/discard-chars port delimiters) - (let ((state (port/state port))) - (if (or (< (istate-position state) (istate-buffer-end state)) - (read-string-buffer state)) - (let loop () - (let* ((start (istate-buffer-start state)) - (index - (substring-find-next-char-in-set - (istate-buffer state) - (- (istate-position state) start) - (- (istate-buffer-end state) start) - delimiters))) - (if index - (set-istate-position! state (+ start index)) - (begin - (set-istate-position! state (istate-buffer-end state)) - (if (read-string-buffer state) - (loop))))))))) - -(define (string-input-port/read-string port delimiters) - (let ((state (port/state port))) - (if (or (< (istate-position state) (istate-buffer-end state)) - (read-string-buffer state)) - (let loop ((prefix #f)) - (let* ((start (istate-buffer-start state)) - (b (istate-buffer state)) - (si (- (istate-position state) start)) - (ei (- (istate-buffer-end state) start)) - (index (substring-find-next-char-in-set b si ei delimiters))) - (if index - (begin - (set-istate-position! state (+ start index)) - (let ((s (make-string (fix:- index si)))) - (substring-move! b si index s 0) - (if prefix - (string-append prefix s) - s))) - (begin - (set-istate-position! state (istate-buffer-end state)) - (let ((s (make-string (fix:- ei si)))) - (substring-move! b si ei s 0) - (let ((p - (if prefix - (string-append prefix s) - s))) - (if (read-string-buffer state) - (loop p) - p))))))) - (eof-object)))) - -(define string-input-type - (make-port-type - `((PEEK-CHAR - ,(lambda (port) - (let ((state (port/state port))) - (let ((position (istate-position state))) - (if (or (< position (istate-buffer-end state)) - (read-string-buffer state)) - (string-ref (istate-buffer state) - (- position (istate-buffer-start state))) - (eof-object)))))) - (READ-CHAR - ,(lambda (port) - (let ((state (port/state port))) - (let ((position (istate-position state))) - (if (or (< position (istate-buffer-end state)) - (read-string-buffer state)) - (let ((char - (string-ref (istate-buffer state) - (- position (istate-buffer-start state))))) - (set-istate-position! state (+ position 1)) - char) - (eof-object)))))) - (UNREAD-CHAR - ,(lambda (port char) - char - (let ((state (port/state port))) - (let ((position (istate-position state))) - (if (> position (istate-buffer-start state)) - (set-istate-position! state (- position 1))))))) - (EOF? - ,(lambda (port) - (let ((state (port/state port))) - (>= (istate-position state) - (string-length (istate-string state)))))) - (CLOSE - ,(lambda (port) - (let ((state (port/state port))) - (without-interrupts - (lambda () - (set-istate-string! state #f) - (set-istate-position! state 0) - (set-istate-buffer-start! state 0) - (set-istate-buffer-end! state 0))))))) - #f)) + (cond ((textual-port-operation port 'position) + => (lambda (position) + (position port))) + (else + (error "Non-positionable port:" port)))) ;;;; Properties -- 2.25.1