From: Chris Hanson Date: Mon, 19 Jun 2000 04:37:25 +0000 (+0000) Subject: Fix bug: when expunging last message in folder, IMAIL was generating X-Git-Tag: 20090517-FFI~3493 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=92d27ebef239856ca27293ccb56d4b9fec52e023;p=mit-scheme.git Fix bug: when expunging last message in folder, IMAIL was generating an error. --- diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index d8ea0ce6c..3e8b74520 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.168 2000/06/18 20:39:36 cph Exp $ +;;; $Id: imail-top.scm,v 1.169 2000/06/19 04:37:25 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -872,14 +872,12 @@ With prefix argument, prompt even when point is on an attachment." ((if text? call-with-output-file call-with-binary-output-file) filename (lambda (port) - (let ((string (message-mime-body-part message selector #f))) - (case (mime-body-one-part-encoding body) - ((QUOTED-PRINTABLE) - (decode-quoted-printable-string string port text?)) - ((BASE64) - (decode-base64-string string port text?)) - (else - (write-string string port)))))) + (call-with-mime-decoding-output-port + (mime-body-one-part-encoding body) + port + text? + (lambda (port) + (write-mime-message-body-part message selector #f port))))) (set-variable! imail-mime-attachment-directory (directory-pathname filename) buffer))))) @@ -907,16 +905,51 @@ With prefix argument, prompt even when point is on an attachment." (char-set-invert (char-set-difference char-set:graphic char-set:mime-attachment-filename-delimiters))) - -(define (decode-quoted-printable-string string port text?) - (let ((context (decode-quoted-printable:initialize port text?))) - (decode-quoted-printable:update context string 0 (string-length string)) - (decode-quoted-printable:finalize context))) - -(define (decode-base64-string string port text?) - (let ((context (decode-base64:initialize port text?))) - (decode-base64:update context string 0 (string-length string)) - (decode-base64:finalize context))) + +(define (call-with-mime-decoding-output-port encoding port text? generator) + (case encoding + ((QUOTED-PRINTABLE) + (call-with-decode-quoted-printable-output-port port text? generator)) + ((BASE64) + (call-with-decode-base64-output-port port text? generator)) + (else + (generator port)))) + +(define (call-with-decode-quoted-printable-output-port port text? generator) + (let ((port + (make-port decode-quoted-printable-port-type + (decode-quoted-printable:initialize port text?)))) + (let ((v (generator port))) + (close-output-port port) + v))) + +(define decode-quoted-printable-port-type + (make-port-type + `((WRITE-SUBSTRING + ,(lambda (port string start end) + (decode-quoted-printable:update (port/state port) string start end))) + (CLOSE-OUTPUT + ,(lambda (port) + (decode-quoted-printable:finalize (port/state port))))) + #f)) + +(define (call-with-decode-base64-output-port port text? generator) + (let ((port + (make-port decode-base64-port-type + (decode-base64:initialize port text?)))) + (let ((v (generator port))) + (close-output-port port) + v))) + +(define decode-base64-port-type + (make-port-type + `((WRITE-SUBSTRING + ,(lambda (port string start end) + (decode-base64:update (port/state port) string start end))) + (CLOSE-OUTPUT + ,(lambda (port) + (decode-base64:finalize (port/state port))))) + #f)) ;;;; Sending mail @@ -954,7 +987,7 @@ While composing the reply, use \\[mail-yank-original] to yank the (define (imail-yank-original buffer mark) (let ((message (selected-message #t buffer))) (insert-header-fields message #f mark) - (insert-string (message-body message) mark))) + (insert-message-body message mark))) (define-command imail-forward "Forward the current message to another user. @@ -992,12 +1025,12 @@ see the documentation of `imail-resend'." (if raw? headers (maybe-reformat-headers headers mail-buffer)))) - (message-body message)) + (lambda (port) (write-message-body message port))) (let ((mark (mark-left-inserting-copy (buffer-end mail-buffer)))) (with-buffer-point-preserved mail-buffer (lambda () (insert-header-fields message raw? mark) - (insert-string (message-body message) mark))) + (insert-message-body message mark))) (mark-temporary! mark)))) (if (window-has-no-neighbors? (current-window)) (select-buffer mail-buffer) @@ -1026,7 +1059,7 @@ ADDRESSES is a string consisting of several addresses separated by commas." (lambda (mail-buffer) (with-buffer-point-preserved mail-buffer (lambda () - (insert-string (message-body message) (buffer-end mail-buffer)))) + (insert-message-body message (buffer-end mail-buffer)))) (disable-buffer-mime-processing! mail-buffer) (if (window-has-no-neighbors? (current-window)) (select-buffer mail-buffer) @@ -1316,8 +1349,8 @@ A prefix argument says to prompt for a URL and append all messages (let ((unseen (navigator/first-unseen-message folder))) (if unseen (select-message folder unseen) - (message "No unseen messages."))) - (message "No changes to mail folder.")))))) + (message "No unseen messages"))) + (message "No changes to mail folder")))))) (define-command imail-disconnect "Disconnect the selected IMAIL folder from its server. @@ -1377,7 +1410,10 @@ Negative argument means search in reverse." (define (imail-get-default-url protocol) (cond ((not protocol) - (let ((folder (selected-folder #f))) + (let ((folder + (buffer-get (chase-imail-buffer (selected-buffer)) + 'IMAIL-FOLDER + #f))) (if folder (folder-url folder) (imail-get-default-url "imap")))) @@ -1628,14 +1664,13 @@ Negative argument means search in reverse." (store-property! message 'RAW? raw?) (insert-header-fields message raw? mark) (cond (raw? - (insert-string (message-body message) mark)) + (insert-message-body message mark)) ((folder-supports-mime? folder) (insert-mime-message-body message mark)) (else (call-with-auto-wrapped-output-mark mark (lambda (port) - (write-string (message-body message) - port)))))) + (write-message-body message port)))))) (insert-string "[This folder has no messages in it.]" mark)))) (mark-temporary! mark)) @@ -1771,9 +1806,10 @@ Negative argument means search in reverse." (message-detached? m)) (select-message folder (let ((length (folder-length folder))) - (cond ((< index length) index) - ((> length 0) (- length 1)) - (else #f))) + (and (> length 0) + (if (< index length) + index + (- length 1)))) #t))))) (notice-folder-modifications folder)) @@ -1879,6 +1915,8 @@ Negative argument means search in reverse." (set-car! holder 'KILL-THREAD)))) (remove-property! folder 'PROBE-REGISTRATION))))))) +;;;; Message insertion procedures + (define (insert-header-fields headers raw? mark) (for-each (lambda (header) (insert-string (header-field-name header) mark) @@ -1924,12 +1962,17 @@ Negative argument means search in reverse." (header-field-value header))) headers))) headers))) + +(define (insert-message-body message mark) + (call-with-output-mark mark + (lambda (port) + (write-message-body message port)))) ;;;; MIME message formatting (define (insert-mime-message-body message mark) (insert-mime-message-part message - (message-mime-body-structure message) + (mime-message-body-structure message) #f '() mark)) @@ -1969,9 +2012,12 @@ Negative argument means search in reverse." (define-method insert-mime-message-part (message (body ) enclosure selector mark) enclosure - (insert-header-fields (message-mime-body-part message - `(,@selector HEADER) - #t) + (insert-header-fields (with-string-output-port + (lambda (port) + (write-mime-message-body-part message + `(,@selector HEADER) + #t + port))) #f mark) (insert-mime-message-part message @@ -2012,22 +2058,17 @@ Negative argument means search in reverse." "\\'") (mime-body-parameter body 'CHARSET "us-ascii") #t)) - (let ((text - (message-mime-body-part - message - (if (or (not enclosure) message-enclosure?) - `(,@selector TEXT) - selector) - #t))) - (call-with-auto-wrapped-output-mark mark - (lambda (port) - (case encoding - ((QUOTED-PRINTABLE) - (decode-quoted-printable-string text port #t)) - ((BASE64) - (decode-base64-string text port #t)) - (else - (write-string text port)))))) + (call-with-auto-wrapped-output-mark mark + (lambda (port) + (call-with-mime-decoding-output-port encoding port #t + (lambda (port) + (write-mime-message-body-part message + (if (or (not enclosure) + message-enclosure?) + `(,@selector TEXT) + selector) + #t + port))))) (insert-mime-message-attachment 'ATTACHMENT body selector mark)))) (define (insert-mime-message-attachment class body selector mark)