From: Chris Hanson Date: Fri, 28 Apr 2000 18:43:53 +0000 (+0000) Subject: Fix various bugs found during debugging of IMAP folders. X-Git-Tag: 20090517-FFI~3967 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3d512908cfea8f02330ec0d1caf8f532f34d9b15;p=mit-scheme.git Fix various bugs found during debugging of IMAP folders. --- diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 7d32af5e3..cf88683b9 100644 --- a/v7/src/imail/imail-core.scm +++ b/v7/src/imail/imail-core.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-core.scm,v 1.32 2000/04/28 16:14:32 cph Exp $ +;;; $Id: imail-core.scm,v 1.33 2000/04/28 18:43:53 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -437,7 +437,8 @@ ;;;; Message Navigation -(define (first-unseen-message folder) +(define-generic first-unseen-message (folder)) +(define-method first-unseen-message ((folder )) (let ((message (first-message folder))) (and message (let loop ((message message)) diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index 11e6c980d..7cd242284 100644 --- a/v7/src/imail/imail-top.scm +++ b/v7/src/imail/imail-top.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-top.scm,v 1.24 2000/04/27 02:16:43 cph Exp $ +;;; $Id: imail-top.scm,v 1.25 2000/04/28 18:43:32 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -94,7 +94,7 @@ May be called with an IMAIL folder URL as argument; (or (imail-folder->buffer folder #f) (let ((buffer (new-buffer (imail-url->buffer-name url)))) (associate-imail-folder-with-buffer folder buffer) - (select-message folder (first-unseen-message folder)) + (select-message folder (first-unseen-message folder) #t) buffer)))))) (if (not url-string) ((ref-command imail-get-new-mail) #f)))) @@ -123,7 +123,13 @@ May be called with an IMAIL folder URL as argument; notice-folder-modifications)) (define (imail-folder->buffer folder error?) - (or (folder-get folder 'BUFFER #f) + (or (let ((buffer (folder-get folder 'BUFFER #f))) + (and buffer + (if (buffer-alive? buffer) + buffer + (begin + (folder-remove! folder 'BUFFER) + #f)))) (and error? (error:bad-range-argument folder 'IMAIL-FOLDER->BUFFER)))) (define (notice-folder-modifications folder) @@ -506,36 +512,23 @@ With prefix argument N moves backward N messages with these flags." " 0/0"))))) (define (maybe-reformat-headers message buffer) - (let ((displayed - (get-message-property message - "displayed-header-fields" - 'NONE))) - (if (eq? 'NONE displayed) - (let ((trimmed - (let ((headers - (let ((headers (message-header-fields message)) - (regexp - (ref-variable imail-ignored-headers buffer))) - (if regexp - (list-search-negative headers - (lambda (header) - (re-string-match regexp - (header-field-name header)))) - headers))) - (filter (ref-variable rmail-message-filter buffer))) - (if filter - (map (lambda (n.v) - (make-header-field (car n.v) (cdr n.v))) - (filter (map (lambda (header) - (cons (header-field-name header) - (header-field-value header))) - headers))) - headers)))) - (set-message-property message - "displayed-header-fields" - trimmed) - trimmed) - displayed))) + (let ((headers + (let ((headers (message-header-fields message)) + (regexp (ref-variable imail-ignored-headers buffer))) + (if regexp + (list-transform-negative headers + (lambda (header) + (re-string-match regexp (header-field-name header) #t))) + headers))) + (filter (ref-variable imail-message-filter buffer))) + (if filter + (map (lambda (n.v) + (make-header-field (car n.v) (cdr n.v))) + (filter (map (lambda (header) + (cons (header-field-name header) + (header-field-value header))) + headers))) + headers))) ;;;; Message deletion diff --git a/v7/src/imail/imap-response.scm b/v7/src/imail/imap-response.scm index 2f89284cf..73b7652e8 100644 --- a/v7/src/imail/imap-response.scm +++ b/v7/src/imail/imap-response.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imap-response.scm,v 1.9 2000/04/28 16:48:30 cph Exp $ +;;; $Id: imap-response.scm,v 1.10 2000/04/28 18:43:46 cph Exp $ ;;; ;;; Copyright (c) 2000 Massachusetts Institute of Technology ;;; @@ -23,7 +23,7 @@ (declare (usual-integrations)) (define (imap:read-server-response port) - (let ((tag (read-string char-set:space port))) + (let ((tag (read-string-internal char-set:space port))) (if (eof-object? tag) tag (begin @@ -258,7 +258,14 @@ (discard-known-char #\return port) (discard-known-char #\linefeed port) (let ((s (make-string n))) - (read-string! s port) + (let loop ((start 0)) + (let ((m (read-substring! s start n port))) + (if (fix:= m 0) + (error "Premature EOF:" port)) + (if (fix:< m (fix:- n start)) + (loop (fix:+ start m))))) + (if trace-imap-server-responses? + (write-string s (notification-output-port))) s))) (define (read-list port #!optional read-item) @@ -298,7 +305,7 @@ (define (read-bracketed-string port) (discard-known-char #\[ port) - (let ((s (read-string char-set:close-bracket port))) + (let ((s (read-string-internal char-set:close-bracket port))) (discard-known-char #\] port) s)) @@ -322,7 +329,7 @@ (define (string-reader constituents) (let ((delimiters (char-set-invert constituents))) (lambda (port) - (read-string delimiters port)))) + (read-string-internal delimiters port)))) (define (non-null-string-reader constituents) (let ((reader (string-reader constituents))) @@ -426,9 +433,15 @@ (define (read-char-internal port) (let ((char (read-char port))) (if trace-imap-server-responses? - (write-char char)) + (write-char char (notification-output-port))) char)) +(define (read-string-internal delimiters port) + (let ((s (read-string delimiters port))) + (if trace-imap-server-responses? + (write-string s (notification-output-port))) + s)) + (define trace-imap-server-responses? #f) (define (imap:response:bad? response) (eq? (car response) 'BAD))