;;; -*-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
;;;
;;; 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
(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))
(file-url-pathname (folder-url folder)))
(define-method %close-folder ((folder <file-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)))
(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 <file-folder>))
(length (file-folder-messages folder)))
(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)))))
\f
(define-method discard-folder-cache ((folder <file-folder>))
(close-folder folder))
;;;; Message
(define-class <file-message> (<message>)
- (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
+ <file-message>
+ 'HEADER-FIELDS
+ string->header-fields)
+
+(define-generic file-message-body (message))
+
+(define-file-external-message-method file-message-body
+ <file-message>
+ 'BODY
+ (lambda (s) s))
(define-method file-message-body ((message <message>))
(with-string-output-port
(define-method set-message-flags! ((message <file-message>) flags)
(%set-message-flags! message flags))
-
-(define-method message-length ((message <file-message>))
- (+ (apply + (map header-field-length (message-header-fields message)))
- 1
- (string-length (file-message-body message))))
+\f
+(let ((get-header-fields (slot-accessor <file-message> 'HEADER-FIELDS))
+ (get-body (slot-accessor <file-message> 'BODY)))
+ (define-method message-length ((message <file-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 <file-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
;;; -*-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
;;;
displayed-header-fields
internal-time)))
(<file-message>)
- (displayed-header-fields define accessor)
- (internal-time accessor message-internal-time))
-
-(define-method file-message-body ((message <rmail-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
+ <rmail-message>
+ 'DISPLAYED-HEADER-FIELDS
+ string->header-fields)
(define-method rmail-message-displayed-header-fields ((message <message>))
message
'UNDEFINED)
+(let ((accessor (slot-accessor <rmail-message> 'INTERNAL-TIME)))
+ (define-method message-internal-time ((message <rmail-message>))
+ (or (accessor message)
+ (call-next-method message))))
+
(define-method make-message-copy ((message <message>) (folder <rmail-folder>))
folder
(make-rmail-message (message-header-fields message)
;;;; Read RMAIL file
(define-method revert-file-folder ((folder <rmail-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)
(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))))))
\f
-(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)))))))
\f
;;;; Write RMAIL file
;;; -*-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
;;;
;;; 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
;;;; Read unix mail file
(define-method revert-file-folder ((folder <umail-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))
;;; -*-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
;;;
(if (default-object? line-ending) "\n" line-ending)
lines))
\f
-(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)))
(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)))
+\f
(define (abbreviate-exact-nonnegative-integer n k)
(if (< n (expt 10 (- k 1)))
(string-append (string-pad-left (number->string n) (- k 1)) " ")
\f
;;;; 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)))
(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))
\f
(define xstring-input-type
(make-port-type
projects / mit-scheme.git / commitdiff