From: Chris Hanson Date: Mon, 19 Mar 2001 19:33:06 +0000 (+0000) Subject: Extend use of external-string storage to all file folders. Don't X-Git-Tag: 20090517-FFI~2892 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1f61c64b1ce87149357d52f95c879e2028bd12b2;p=mit-scheme.git Extend use of external-string storage to all file folders. Don't pre-compute message headers; compute them on the fly from the external string when needed. --- diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm index 6bff833d2..be3400866 100644 --- a/v7/src/imail/imail-file.scm +++ b/v7/src/imail/imail-file.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-file.scm,v 1.59 2000/08/18 16:55:20 cph Exp $ +;;; $Id: imail-file.scm,v 1.60 2001/03/19 19:32:58 cph Exp $ ;;; -;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology +;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -16,7 +16,8 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;;; 02111-1307, USA. ;;;; IMAIL mail reader: file-based folder support @@ -132,7 +133,8 @@ (file-modification-time define standard initial-value #f) (file-modification-count define standard - initial-value #f)) + initial-value #f) + (xstring define standard)) (define (file-folder-messages folder) (if (eq? 'UNKNOWN (%file-folder-messages folder)) @@ -145,6 +147,10 @@ (file-url-pathname (folder-url folder))) (define-method %close-folder ((folder )) + (discard-file-folder-messages folder) + (discard-file-folder-xstring folder)) + +(define (discard-file-folder-messages folder) (without-interrupts (lambda () (let ((messages (%file-folder-messages folder))) @@ -153,6 +159,13 @@ (set-file-folder-messages! folder 'UNKNOWN) (for-each detach-message! messages))))))) +(define (discard-file-folder-xstring folder) + (without-interrupts + (lambda () + (set-file-folder-xstring! folder #f) + (set-file-folder-file-modification-time! folder #f) + (set-file-folder-file-modification-count! folder #f)))) + (define-method folder-length ((folder )) (length (file-folder-messages folder))) @@ -276,18 +289,32 @@ (set-file-folder-file-modification-time! folder t)) (loop))))))) -(define (synchronize-file-folder-read folder reader) - (let ((pathname (file-folder-pathname folder))) - (let loop () - (let ((t (file-modification-time pathname))) - (reader folder pathname) - (if (= t (file-modification-time pathname)) - (begin - (set-file-folder-file-modification-time! folder t) - (set-file-folder-file-modification-count! - folder - (folder-modification-count folder))) - (loop)))))) +(define (read-file-folder-contents folder reader) + (discard-file-folder-messages folder) + (let ((t (file-folder-file-modification-time folder)) + (pathname (file-folder-pathname folder))) + (if (not (and t (= t (file-modification-time pathname)))) + (begin + (if t (discard-file-folder-xstring folder)) + (let loop () + (let ((t (file-modification-time pathname))) + ((imail-ui:message-wrapper "Reading file " + (->namestring pathname)) + (lambda () + (set-file-folder-xstring! folder + (read-file-into-xstring pathname)))) + (if (= t (file-modification-time pathname)) + (begin + (set-file-folder-file-modification-time! folder t) + (set-file-folder-file-modification-count! + folder + (folder-modification-count folder))) + (loop))))))) + (set-file-folder-messages! + folder + ((imail-ui:message-wrapper "Parsing messages") + (lambda () + (call-with-input-xstring (file-folder-xstring folder) 0 reader))))) (define-method discard-folder-cache ((folder )) (close-folder folder)) @@ -319,7 +346,42 @@ ;;;; Message (define-class () - (body define accessor)) + body) + +(define (file-message-xstring message) + (file-folder-xstring (message-folder message))) + +(define (file-external-ref? object) + (and (pair? object) + (exact-nonnegative-integer? (car object)) + (exact-nonnegative-integer? (cdr object)))) + +(define (make-file-external-ref start end) (cons start end)) +(define (file-external-ref/start ref) (car ref)) +(define (file-external-ref/end ref) (cdr ref)) + +(define (define-file-external-message-method procedure class slot operator) + (let ((accessor (slot-accessor class slot))) + (define-method procedure ((message class)) + (let ((item (accessor message))) + (if (file-external-ref? item) + (operator + (xsubstring (file-message-xstring message) + (file-external-ref/start item) + (file-external-ref/end item))) + (call-next-method message)))))) + +(define-file-external-message-method message-header-fields + + 'HEADER-FIELDS + string->header-fields) + +(define-generic file-message-body (message)) + +(define-file-external-message-method file-message-body + + 'BODY + (lambda (s) s)) (define-method file-message-body ((message )) (with-string-output-port @@ -331,49 +393,72 @@ (define-method set-message-flags! ((message ) flags) (%set-message-flags! message flags)) - -(define-method message-length ((message )) - (+ (apply + (map header-field-length (message-header-fields message))) - 1 - (string-length (file-message-body message)))) + +(let ((get-header-fields (slot-accessor 'HEADER-FIELDS)) + (get-body (slot-accessor 'BODY))) + (define-method message-length ((message )) + (+ (let ((headers (get-header-fields message))) + (if (file-external-ref? headers) + (- (file-external-ref/end headers) + (file-external-ref/start headers)) + (apply + + (map header-field-length + (message-header-fields message))))) + 1 + (let ((body (get-body message))) + (if (file-external-ref? body) + (- (file-external-ref/end body) + (file-external-ref/start body)) + (string-length (file-message-body message))))))) (define-method message-internal-time ((message )) - (header-fields->internal-time message)) - -(define (header-fields->internal-time headers) (or (let loop - ((headers (get-all-header-fields headers "received")) (winner #f)) + ((headers (get-all-header-fields message "received")) (winner #f)) (if (pair? headers) (loop (cdr headers) - (let ((time (received-header-time (car headers)))) - (if (and time (or (not winner) (< time winner))) + (let ((time + (ignore-errors + (lambda () + (call-with-values + (lambda () + (rfc822:received-header-components + (header-field-value (car headers)))) + (lambda (from by via with id for time) + from by via with id for ;ignored + time)))))) + (if (and time + (not (condition? time)) + (or (not winner) (< time winner))) time winner))) winner)) - (message-time headers))) - -(define (received-header-time header) - (let ((time - (ignore-errors - (lambda () - (call-with-values - (lambda () - (rfc822:received-header-components - (header-field-value header))) - (lambda (from by via with id for time) - from by via with id for ;ignored - time)))))) - (and (not (condition? time)) - time))) - -(define (message-time message) - (let ((date (get-first-header-field-value message "date" #f))) - (and date - (let ((t - (ignore-errors - (lambda () - (string->universal-time - (rfc822:tokens->string - (rfc822:strip-comments (rfc822:string->tokens date)))))))) - (and (not (condition? t)) - t))))) \ No newline at end of file + (message-time message) + (file-folder-modification-time (message-folder message)))) + +(define (file-folder-modification-time folder) + (or (let ((t + (or (file-folder-file-modification-time folder) + (file-modification-time (file-folder-pathname folder))))) + (and t + (file-time->universal-time t))) + (get-universal-time))) + +(define (file-folder-strip-internal-headers folder ref) + (call-with-input-xstring (file-folder-xstring folder) + (file-external-ref/start ref) + (lambda (port) + (let loop ((header-lines '())) + (let ((line (read-line port)) + (finish + (lambda (offset) + (values (make-file-external-ref + (- (xstring-port/position port) + offset) + (file-external-ref/end ref)) + (lines->header-fields (reverse! header-lines)))))) + (cond ((eof-object? line) + (finish 0)) + ((re-string-match "X-IMAIL-[^:]+:\\|[ \t]" line) + (loop (cons line header-lines))) + (else + (finish (+ (string-length line) 1))))))))) \ No newline at end of file diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm index b46d8c0fc..c2719e957 100644 --- a/v7/src/imail/imail-rmail.scm +++ b/v7/src/imail/imail-rmail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-rmail.scm,v 1.55 2001/03/18 06:47:48 cph Exp $ +;;; $Id: imail-rmail.scm,v 1.56 2001/03/19 19:33:01 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -91,24 +91,25 @@ displayed-header-fields internal-time))) () - (displayed-header-fields define accessor) - (internal-time accessor message-internal-time)) - -(define-method file-message-body ((message )) - (let ((body (call-next-method message))) - (if (string? body) - body - (let ((xstring (vector-ref body 0)) - (start (vector-ref body 1)) - (end (vector-ref body 2))) - (let ((body (make-string (- end start)))) - (xsubstring-move! xstring start end body 0) - body))))) + displayed-header-fields + internal-time) + +(define-generic rmail-message-displayed-header-fields (message)) + +(define-file-external-message-method rmail-message-displayed-header-fields + + 'DISPLAYED-HEADER-FIELDS + string->header-fields) (define-method rmail-message-displayed-header-fields ((message )) message 'UNDEFINED) +(let ((accessor (slot-accessor 'INTERNAL-TIME))) + (define-method message-internal-time ((message )) + (or (accessor message) + (call-next-method message)))) + (define-method make-message-copy ((message ) (folder )) folder (make-rmail-message (message-header-fields message) @@ -120,47 +121,36 @@ ;;;; Read RMAIL file (define-method revert-file-folder ((folder )) - (synchronize-file-folder-read folder - (lambda (folder pathname) - (without-interrupts - (lambda () - (let ((messages (%file-folder-messages folder))) - (if (not (eq? 'UNKNOWN messages)) - (for-each detach-message! messages))) - (set-file-folder-messages! folder '()))) - (call-with-input-xstring - (call-with-binary-input-file pathname - (lambda (port) - (let ((n-bytes ((port/operation port 'LENGTH) port))) - (let ((xstring (allocate-external-string n-bytes))) - (read-substring! xstring 0 n-bytes port) - xstring)))) - (lambda (port) - (set-rmail-folder-header-fields! folder (read-rmail-prolog port)) - (let loop ((line #f)) - (call-with-values (lambda () (read-rmail-message port line)) - (lambda (message line) - (if message - (begin - (append-message message (folder-url folder)) - (loop line))))))))))) + (read-file-folder-contents folder + (lambda (port) + (set-rmail-folder-header-fields! folder (read-rmail-prolog port)) + (let loop ((line #f) (index 0) (messages '())) + (if (= 0 (remainder index 10)) + (imail-ui:progress-meter index #f)) + (call-with-values (lambda () (read-rmail-message folder port line)) + (lambda (message line) + (if message + (begin + (attach-message! message folder index) + (loop line (+ index 1) (cons message messages))) + (reverse! messages)))))))) (define (read-rmail-prolog port) (if (not (rmail-prolog-start-line? (read-required-line port))) (error "Not an RMAIL file:" port)) (lines->header-fields (read-lines-to-eom port))) -(define (read-rmail-message port read-ahead-line) +(define (read-rmail-message folder port read-ahead-line) (let ((line (or read-ahead-line (read-line port)))) (cond ((eof-object? line) (values #f #f)) ((rmail-prolog-start-line? line) (discard-to-eom port) - (read-rmail-message port #f)) + (read-rmail-message folder port #f)) ((rmail-message-start-line? line) - (values (read-rmail-message-1 port) #f)) + (values (read-rmail-message-1 folder port) #f)) ((umail-delimiter? line) - (read-umail-message line port + (read-umail-message folder line port (lambda (line) (or (rmail-prolog-start-line? line) (rmail-message-start-line? line) @@ -168,80 +158,86 @@ (else (error "Malformed RMAIL file:" port))))) -(define (read-rmail-message-1 port) - (call-with-values - (lambda () (parse-attributes-line (read-required-line port))) +(define (read-rmail-message-1 folder port) + (call-with-values (lambda () (read-rmail-attributes-line port)) (lambda (formatted? flags) - (let* ((headers (read-rmail-header-fields port)) - (displayed-headers - (lines->header-fields (read-header-lines port))) - (body - (let ((start (xstring-port/position port))) - (input-port/discard-chars port rmail-message:end-char-set) - (let ((end (xstring-port/position port))) - (input-port/discard-char port) - (vector (xstring-port/xstring port) start end)))) + (let* ((headers (read-rmail-alternate-headers port)) + (displayed-headers (read-rmail-displayed-headers port)) + (body (read-rmail-body port)) (finish (lambda (headers displayed-headers) (call-with-values - (lambda () (rmail-internal-time-header headers)) + (lambda () + (parse-rmail-internal-time-header folder headers)) (lambda (headers time) - (make-rmail-message headers body flags + (make-rmail-message headers + body + flags displayed-headers - (or time - (header-fields->internal-time - headers) - (get-universal-time)))))))) + time)))))) (if formatted? (finish headers displayed-headers) (finish displayed-headers 'UNDEFINED)))))) -(define (parse-attributes-line line) - (let ((parts (map string-trim (burst-string line #\, #f)))) - (if (not (and (fix:= 2 (count-matching-items parts string-null?)) - (or (string=? "0" (car parts)) - (string=? "1" (car parts))) - (string-null? (car (last-pair parts))))) - (error "Malformed RMAIL message-attributes line:" line)) - (call-with-values - (lambda () (cut-list! (except-last-pair (cdr parts)) string-null?)) - (lambda (attributes labels) - (values (string=? "1" (car parts)) - (rmail-markers->flags attributes - (if (pair? labels) - (cdr labels) - labels))))))) - -(define (read-rmail-header-fields port) - (lines->header-fields - (source->list - (lambda () - (let ((line (read-required-line port))) - (cond ((string-null? line) - (if (not (string=? rmail-message:headers-separator - (read-required-line port))) - (error "Missing RMAIL message-header separator string:" - port)) - (make-eof-object port)) - ((string=? rmail-message:headers-separator line) - (make-eof-object port)) - (else line))))))) - -(define (rmail-internal-time-header headers) - (let ((header (get-first-header-field headers "X-IMAIL-INTERNAL-TIME" #f))) - (if header - (values (delq! header headers) - (let ((t - (ignore-errors - (lambda () - (string->universal-time - (rfc822:tokens->string - (rfc822:strip-comments - (rfc822:string->tokens - (header-field-value header))))))))) - (and (not (condition? t)) - t))) - (values headers #f)))) +(define (read-rmail-attributes-line port) + (let ((line (read-required-line port))) + (let ((parts (map string-trim (burst-string line #\, #f)))) + (if (not (and (fix:= 2 (count-matching-items parts string-null?)) + (or (string=? "0" (car parts)) + (string=? "1" (car parts))) + (string-null? (car (last-pair parts))))) + (error "Malformed RMAIL message-attributes line:" line)) + (call-with-values + (lambda () (cut-list! (except-last-pair (cdr parts)) string-null?)) + (lambda (attributes labels) + (values + (string=? "1" (car parts)) + (rmail-markers->flags attributes + (if (pair? labels) (cdr labels) labels)))))))) + +(define (read-rmail-alternate-headers port) + (let ((start (xstring-port/position port))) + (make-file-external-ref + start + (let ((line (read-required-line port))) + (cond ((string-null? line) + (let ((end (- (xstring-port/position port) 1))) + (skip-rmail-message-headers-separator port) + end)) + ((string=? line rmail-message:headers-separator) + (- (xstring-port/position port) + (+ (string-length line) 1))) + (else + (skip-past-blank-line port) + (- (xstring-port/position port) 1))))))) + +(define (read-rmail-displayed-headers port) + (let ((start (xstring-port/position port))) + (skip-past-blank-line port) + (make-file-external-ref start (- (xstring-port/position port) 1)))) + +(define (skip-rmail-message-headers-separator port) + (if (not (string=? rmail-message:headers-separator + (read-required-line port))) + (error "Missing RMAIL headers-separator string:" port))) + +(define (read-rmail-body port) + (let ((start (xstring-port/position port))) + (input-port/discard-chars port rmail-message:end-char-set) + (input-port/discard-char port) + (make-file-external-ref start (- (xstring-port/position port) 1)))) + +(define (parse-rmail-internal-time-header folder headers) + (call-with-values + (lambda () (file-folder-strip-internal-headers folder headers)) + (lambda (headers internal-headers) + (values headers + (let ((v + (get-first-header-field internal-headers + "X-IMAIL-INTERNAL-TIME" + #f))) + (and v + (parse-header-field-date v))))))) ;;;; Write RMAIL file diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm index d783da7df..06a9245c0 100644 --- a/v7/src/imail/imail-umail.scm +++ b/v7/src/imail/imail-umail.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-umail.scm,v 1.40 2000/10/20 00:44:34 cph Exp $ +;;; $Id: imail-umail.scm,v 1.41 2001/03/19 19:33:03 cph Exp $ ;;; -;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology +;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -16,7 +16,8 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;;; 02111-1307, USA. ;;;; IMAIL mail reader: RMAIL back end @@ -98,65 +99,64 @@ ;;;; Read unix mail file (define-method revert-file-folder ((folder )) - (synchronize-file-folder-read folder - (lambda (folder pathname) - (set-file-folder-messages! - folder - (call-with-binary-input-file pathname - (lambda (port) - (let ((from-line (read-line port))) - (if (eof-object? from-line) - '() - (begin - (if (not (umail-delimiter? from-line)) - (error "Malformed unix mail file:" port)) - (let loop ((from-line from-line) (index 0) (messages '())) - (call-with-values - (lambda () - (read-umail-message from-line - port - umail-delimiter?)) - (lambda (message from-line) - (attach-message! message folder index) - (let ((messages (cons message messages))) - (if from-line - (loop from-line (+ index 1) messages) - (reverse! messages))))))))))))))) - -(define (read-umail-message from-line port delimiter?) - (let loop ((lines '())) - (let ((line (read-line port))) - (cond ((eof-object? line) - (values (read-umail-message-1 from-line (reverse! lines)) #f)) - ((delimiter? line) - (values (read-umail-message-1 from-line (reverse! lines)) line)) - (else - (loop (cons line lines))))))) - -(define (read-umail-message-1 from-line lines) - (let loop ((lines lines) (header-lines '())) - (if (pair? lines) - (if (string-null? (car lines)) - (read-umail-message-2 from-line - (reverse! header-lines) - (cdr lines)) - (loop (cdr lines) (cons (car lines) header-lines))) - (read-umail-message-2 from-line (reverse! header-lines) '())))) - -(define (read-umail-message-2 from-line header-lines body-lines) + (read-file-folder-contents folder + (lambda (port) + (let ((from-line (read-line port))) + (if (eof-object? from-line) + '() + (begin + (if (not (umail-delimiter? from-line)) + (error "Malformed unix mail file:" port)) + (let loop ((from-line from-line) (index 0) (messages '())) + (if (= 0 (remainder index 10)) + (imail-ui:progress-meter index #f)) + (call-with-values + (lambda () + (read-umail-message folder + from-line + port + umail-delimiter?)) + (lambda (message from-line) + (attach-message! message folder index) + (let ((messages (cons message messages))) + (if from-line + (loop from-line (+ index 1) messages) + (reverse! messages)))))))))))) + +(define (read-umail-message folder from-line port delimiter?) + (let ((h-start (xstring-port/position port))) + (skip-past-blank-line port) + (let ((b-start (xstring-port/position port))) + (let ((finish + (lambda (b-end line) + (values + (read-umail-message-1 + folder + from-line + (make-file-external-ref h-start (- b-start 1)) + (make-file-external-ref b-start b-end)) + line)))) + (let loop () + (let ((line (read-line port))) + (cond ((eof-object? line) + (finish (xstring-port/position port) #f)) + ((delimiter? line) + (finish (- (xstring-port/position port) + (+ (string-length line) 1)) + line)) + (else + (loop))))))))) + +(define (read-umail-message-1 folder from-line headers body) (call-with-values - (lambda () - (parse-imail-header-fields (lines->header-fields header-lines))) - (lambda (headers flags) - (make-umail-message headers - (lines->string - (map (lambda (line) - (if (string-prefix-ci? ">From " line) - (string-tail line 1) - line)) - body-lines)) - flags - from-line)))) + (lambda () (file-folder-strip-internal-headers folder headers)) + (lambda (headers internal-headers) + (call-with-values + (lambda () + (parse-imail-header-fields internal-headers)) + (lambda (internal-headers flags) + internal-headers + (make-umail-message headers body flags from-line)))))) (define (umail-delimiter? line) (re-string-match unix-mail-delimiter line)) diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm index 1bfa96460..b5d11fc4b 100644 --- a/v7/src/imail/imail-util.scm +++ b/v7/src/imail/imail-util.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-util.scm,v 1.32 2001/03/18 06:27:47 cph Exp $ +;;; $Id: imail-util.scm,v 1.33 2001/03/19 19:33:06 cph Exp $ ;;; ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; @@ -176,16 +176,17 @@ (if (default-object? line-ending) "\n" line-ending) lines)) -(define (read-lines port) - (source->list (lambda () (read-line port)))) +(define (read-required-char port) + (let ((char (read-char port))) + (if (eof-object? char) + (error "Premature end of file:" port)) + char)) -(define (read-header-lines port) - (source->list - (lambda () - (let ((line (read-required-line port))) - (if (string-null? line) - (make-eof-object port) - line))))) +(define (peek-required-char port) + (let ((char (peek-char port))) + (if (eof-object? char) + (error "Premature end of file:" port)) + char)) (define (read-required-line port) (let ((line (read-line port))) @@ -193,6 +194,29 @@ (error "Premature end of file:" port)) line)) +(define (skip-to-line-start port) + (let loop () + (if (not (char=? (read-required-char port) #\newline)) + (loop)))) + +(define (skip-past-blank-line port) + (let loop () + (if (not (char=? (read-required-char port) #\newline)) + (begin + (skip-to-line-start port) + (loop))))) + +(define (parse-header-field-date field-value) + (let ((t + (ignore-errors + (lambda () + (string->universal-time + (rfc822:tokens->string + (rfc822:strip-comments + (rfc822:string->tokens field-value)))))))) + (and (not (condition? t)) + t))) + (define (abbreviate-exact-nonnegative-integer n k) (if (< n (expt 10 (- k 1))) (string-append (string-pad-left (number->string n) (- k 1)) " ") @@ -368,25 +392,38 @@ ;;;; Extended-string input port -(define (call-with-input-xstring xstring receiver) - (let ((port (open-xstring-input-port xstring))) +(define (read-file-into-xstring pathname) + (call-with-binary-input-file pathname + (lambda (port) + (let ((n-bytes ((port/operation port 'LENGTH) port))) + (let ((xstring (allocate-external-string n-bytes))) + (let ((n-read (read-substring! xstring 0 n-bytes port))) + (if (not (= n-read n-bytes)) + (error "Failed to read complete file:" + pathname n-read n-bytes))) + xstring))))) + +(define (call-with-input-xstring xstring position receiver) + (let ((port (open-xstring-input-port xstring position))) (let ((value (receiver port))) (close-port port) value))) -(define (open-xstring-input-port xstring) - (let ((state (make-xstring-input-state xstring))) +(define (open-xstring-input-port xstring position) + (if (not (<= 0 position (external-string-length xstring))) + (error:bad-range-argument position 'OPEN-XSTRING-INPUT-PORT)) + (let ((state (make-xstring-input-state xstring position))) (read-xstring-buffer state) (make-port xstring-input-type state))) (define-structure (xstring-input-state - (constructor make-xstring-input-state (xstring)) + (constructor make-xstring-input-state (xstring position)) (conc-name xstring-input-state/)) - (xstring #f) - (position 0) - (buffer (make-string 512) read-only #t) - (buffer-start 0) - (buffer-end 0)) + xstring + position + (buffer (make-string 65536) read-only #t) + (buffer-start position) + (buffer-end position)) (define (xstring-port/xstring port) (xstring-input-state/xstring (port/state port))) @@ -407,6 +444,11 @@ (set-xstring-input-state/buffer-end! state end) (xsubstring-move! xstring start end buffer 0))) #t))))) + +(define (xsubstring xstring start end) + (let ((buffer (make-string (- end start)))) + (xsubstring-move! xstring start end buffer 0) + buffer)) (define xstring-input-type (make-port-type