From: Chris Hanson Date: Fri, 16 Jun 2000 17:56:12 +0000 (+0000) Subject: Large-scale editing pass over the front-end code. Code should now be X-Git-Tag: 20090517-FFI~3504 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bb7b44b0e9b5ed9214d4063950d1994144444436;p=mit-scheme.git Large-scale editing pass over the front-end code. Code should now be clearer and better organized. --- diff --git a/v7/src/imail/imail-summary.scm b/v7/src/imail/imail-summary.scm index 2eefc391f..fe5b0343a 100644 --- a/v7/src/imail/imail-summary.scm +++ b/v7/src/imail/imail-summary.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-summary.scm,v 1.21 2000/06/15 19:13:23 cph Exp $ +;;; $Id: imail-summary.scm,v 1.22 2000/06/16 17:56:10 cph Exp $ ;;; ;;; Copyright (c) 2000 Massachusetts Institute of Technology ;;; @@ -346,112 +346,6 @@ SUBJECT is a string of regexps separated by commas." (string-head s i) s)))) -;;;; IMAIL Summary mode - -(define-major-mode imail-summary imail "IMAIL Summary" - "Major mode in effect in IMAIL summary buffer. -Each line summarizes a single mail message. -The columns describing the message are, left to right: - -1. Several flag characters, each indicating whether the message is - marked with the corresponding flag. The characters are, in order, - `D' (deleted), `U' (not seen), `A' (answered), `R' (resent or - forwarded), and `F' (filed). - -2. The message index number. - -3. The approximate length of the message in bytes. Large messages are - abbreviated using the standard metric suffixes (`k'=1,000, - `M'=1,000,000, etc.) The length includes all of the header fields, - including those that aren't normally shown. (In IMAP folders, the - length is slightly higher because it counts line endings as two - characters whereas Edwin counts them as one.) - -4. The date the message was sent, abbreviated by the day and month. - The date field is optional; see imail-summary-show-date. - -5. The subject line from the message, truncated if it is too long to - fit in the available space. The width of the subject area is - controlled by the variable imail-summary-subject-width. - -6. The sender of the message, from the message's `From:' header. - -Additional variables controlling this mode: - -imail-summary-pop-up-message keep message buffer visible -imail-summary-highlight-message highlight line for current message -imail-summary-show-date show date message sent -imail-summary-subject-width width of subject field - -The commands in this buffer are mostly the same as those for IMAIL -mode (the mode used by the buffer that shows the message contents), -with some additions to make navigation more natural. - -\\{imail-summary}" - (lambda (buffer) - (buffer-put! buffer 'REVERT-BUFFER-METHOD imail-summary-revert-buffer) - (remove-kill-buffer-hook buffer imail-kill-buffer) - (local-set-variable! truncate-lines #t buffer) - (local-set-variable! mode-line-process - (list ": " - (buffer-get buffer - 'IMAIL-SUMMARY-DESCRIPTION - "All")) - buffer) - (event-distributor/invoke! (ref-variable imail-summary-mode-hook buffer) - buffer))) - -(define-variable imail-summary-mode-hook - "An event distributor that is invoked when entering IMAIL Summary mode." - (make-event-distributor)) - -(define (imail-summary-revert-buffer buffer dont-use-auto-save? dont-confirm?) - dont-use-auto-save? - (if (or dont-confirm? (prompt-for-yes-or-no? "Revert summary buffer")) - (rebuild-imail-summary-buffer buffer))) - -(define-key 'imail-summary #\space 'imail-summary-select-message) -(define-key 'imail-summary #\rubout 'imail-undelete-previous-message) -(define-key 'imail-summary #\c-n 'imail-next-message) -(define-key 'imail-summary #\c-p 'imail-previous-message) -(define-key 'imail-summary #\. 'undefined) -(define-key 'imail-summary #\u 'imail-undelete-forward) -(define-key 'imail-summary #\m-< 'imail-first-message) -(define-key 'imail-summary #\m-> 'imail-last-message) - -(define-key 'imail-summary (make-special-key 'down 0) '(imail-summary . #\c-n)) -(define-key 'imail-summary (make-special-key 'up 0) '(imail-summary . #\c-p)) - -(define-key 'imail-summary button1-down 'imail-summary-mouse-select-message) -(define-key 'imail-summary button4-down '(imail-summary . #\c-p)) -(define-key 'imail-summary button5-down '(imail-summary . #\c-n)) - -(define-command imail-summary-select-message - "Select the message that point is on and show it in another window." - () - (lambda () - (select-message (selected-folder) - (or (selected-message #f) - (editor-error "No message on this line.")) - #t) - (imail-summary-pop-up-message-buffer (selected-buffer)))) - -(define-command imail-summary-mouse-select-message - "Select the message that mouse is on and show it in another window." - () - (lambda () - (let ((button-event (current-button-event))) - (let ((window (button-event/window button-event))) - (select-window window) - (set-current-point! - (line-start (or (window-coordinates->mark - window - (button-event/x button-event) - (button-event/y button-event)) - (buffer-end (window-buffer window))) - 0)))) - ((ref-command imail-summary-select-message)))) - ;;;; Navigation (define (imail-summary-navigators buffer) @@ -604,4 +498,110 @@ with some additions to make navigation more natural. (if (and last (mark>= last (imail-summary-first-line buffer))) last - end)))) \ No newline at end of file + end)))) + +;;;; IMAIL Summary mode + +(define-major-mode imail-summary imail "IMAIL Summary" + "Major mode in effect in IMAIL summary buffer. +Each line summarizes a single mail message. +The columns describing the message are, left to right: + +1. Several flag characters, each indicating whether the message is + marked with the corresponding flag. The characters are, in order, + `D' (deleted), `U' (unseen), `A' (answered), `R' (re-sent or + forwarded), and `F' (filed). + +2. The message index number. + +3. The approximate length of the message in bytes. Large messages are + abbreviated using the standard metric suffixes (`k'=1,000, + `M'=1,000,000, etc.) The length includes all of the header fields, + including those that aren't normally shown. (In IMAP folders, the + length is slightly higher because the server counts line endings as + two characters whereas Edwin counts them as one.) + +4. The date the message was sent, abbreviated by the day and month. + The date field is optional; see imail-summary-show-date. + +5. The subject line from the message, truncated if it is too long to + fit in the available space. The width of the subject area is + controlled by the variable imail-summary-subject-width. + +6. The sender of the message, from the message's `From:' header. + +Additional variables controlling this mode: + +imail-summary-pop-up-message keep message buffer visible +imail-summary-highlight-message highlight line for current message +imail-summary-show-date show date message sent +imail-summary-subject-width width of subject field + +The commands in this buffer are mostly the same as those for IMAIL +mode (the mode used by the buffer that shows the message contents), +with some additions to make navigation more natural. + +\\{imail-summary}" + (lambda (buffer) + (buffer-put! buffer 'REVERT-BUFFER-METHOD imail-summary-revert-buffer) + (remove-kill-buffer-hook buffer imail-kill-buffer) + (local-set-variable! truncate-lines #t buffer) + (local-set-variable! mode-line-process + (list ": " + (buffer-get buffer + 'IMAIL-SUMMARY-DESCRIPTION + "All")) + buffer) + (event-distributor/invoke! (ref-variable imail-summary-mode-hook buffer) + buffer))) + +(define-variable imail-summary-mode-hook + "An event distributor that is invoked when entering IMAIL Summary mode." + (make-event-distributor)) + +(define (imail-summary-revert-buffer buffer dont-use-auto-save? dont-confirm?) + dont-use-auto-save? + (if (or dont-confirm? (prompt-for-yes-or-no? "Revert summary buffer")) + (rebuild-imail-summary-buffer buffer))) + +(define-key 'imail-summary #\space 'imail-summary-select-message) +(define-key 'imail-summary #\rubout 'imail-undelete-previous-message) +(define-key 'imail-summary #\c-n 'imail-next-message) +(define-key 'imail-summary #\c-p 'imail-previous-message) +(define-key 'imail-summary #\. 'undefined) +(define-key 'imail-summary #\u 'imail-undelete-forward) +(define-key 'imail-summary #\m-< 'imail-first-message) +(define-key 'imail-summary #\m-> 'imail-last-message) + +(define-key 'imail-summary (make-special-key 'down 0) '(imail-summary . #\c-n)) +(define-key 'imail-summary (make-special-key 'up 0) '(imail-summary . #\c-p)) + +(define-key 'imail-summary button1-down 'imail-summary-mouse-select-message) +(define-key 'imail-summary button4-down '(imail-summary . #\c-p)) +(define-key 'imail-summary button5-down '(imail-summary . #\c-n)) + +(define-command imail-summary-select-message + "Select the message that point is on and show it in another window." + () + (lambda () + (select-message (selected-folder) + (or (selected-message #f) + (editor-error "No message on this line.")) + #t) + (imail-summary-pop-up-message-buffer (selected-buffer)))) + +(define-command imail-summary-mouse-select-message + "Select the message that mouse is on and show it in another window." + () + (lambda () + (let ((button-event (current-button-event))) + (let ((window (button-event/window button-event))) + (select-window window) + (set-current-point! + (line-start (or (window-coordinates->mark + window + (button-event/x button-event) + (button-event/y button-event)) + (buffer-end (window-buffer window))) + 0)))) + ((ref-command imail-summary-select-message)))) \ No newline at end of file diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index df934aa69..7dc81395a 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.163 2000/06/15 20:54:22 cph Exp $ +;;; $Id: imail-top.scm,v 1.164 2000/06/16 17:56:12 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -166,6 +166,12 @@ Likewise, a text/plain entity is always shown inline. Note that this variable does not affect subparts of multipart/alternative." '(HTML ENRICHED) list-of-strings?) + +(define-variable imail-use-original-mime-boundaries + "If true, multipart message parts are separated with MIME boundary strings. +Otherwise, simple dashed-line separators are used." + #f + boolean?) (define-command imail "Read and edit incoming mail. @@ -173,7 +179,7 @@ Given a prefix argument, it prompts for an IMAIL URL, then visits the mail folder at that URL. IMAIL URLs take one of the following forms. -imap://[@]{:]/ +imap://[@][:]/ Specifies a folder on an IMAP server. The portions in brackets are optional and are filled in automatically if omitted. @@ -215,196 +221,6 @@ regardless of the folder type." (selected-message #f)) #t))))))) -(define (prompt-for-imail-url-string prompt default . options) - (let ((get-option - (lambda (key) - (let loop ((options options)) - (and (pair? options) - (pair? (cdr options)) - (if (eq? (car options) key) - (cadr options) - (loop (cddr options))))))) - (default - (cond ((string? default) default) - ((url? default) (url->string default)) - ((not default) (url-container-string (imail-default-url))) - (else (error "Illegal default:" default))))) - (let ((history (get-option 'HISTORY))) - (if (null? (prompt-history-strings history)) - (set-prompt-history-strings! history (list default)))) - (apply prompt-for-completed-string - prompt - (if (= (or (get-option 'HISTORY-INDEX) -1) -1) default #f) - (lambda (string if-unique if-not-unique if-not-found) - (url-complete-string string imail-get-default-url - if-unique if-not-unique if-not-found)) - (lambda (string) - (url-string-completions string imail-get-default-url)) - (lambda (string) - (let ((url - (ignore-errors - (lambda () - (parse-url-string string imail-get-default-url))))) - (and (url? url) - (url-exists? url)))) - 'DEFAULT-TYPE 'INSERTED-DEFAULT - options))) - -(define (imail-default-url) - (let ((primary-folder (ref-variable imail-primary-folder))) - (if primary-folder - (imail-parse-partial-url primary-folder) - (imail-get-default-url #f)))) - -(define (imail-parse-partial-url string) - (parse-url-string string imail-get-default-url)) - -(define (imail-get-default-url protocol) - (let ((do-imap - (lambda () - (call-with-values - (lambda () - (let ((server (ref-variable imail-default-imap-server))) - (let ((colon (string-find-next-char server #\:))) - (if colon - (values - (string-head server colon) - (or (string->number (string-tail server (+ colon 1))) - (error "Invalid port specification:" server))) - (values server 143))))) - (lambda (host port) - (make-imap-url (or (ref-variable imail-default-user-id) - (current-user-name)) - host - port - (ref-variable imail-default-imap-mailbox))))))) - (cond ((not protocol) - (let ((folder - (buffer-get (chase-imail-buffer (selected-buffer)) - 'IMAIL-FOLDER - #f))) - (if folder - (folder-url folder) - (do-imap)))) - ((string-ci=? protocol "imap") (do-imap)) - ((string-ci=? protocol "rmail") (make-rmail-url "~/RMAIL")) - ((string-ci=? protocol "umail") (make-umail-url "~/inbox.mail")) - (else (error:bad-range-argument protocol))))) - -(define (imail-ui:present-user-alert procedure) - (call-with-output-to-temporary-buffer " *IMAP alert*" - '(READ-ONLY SHRINK-WINDOW - FLUSH-ON-SPACE) - procedure)) - -(define (imail-ui:message-wrapper . arguments) - (let ((prefix (string-append (message-args->string arguments) "..."))) - (lambda (thunk) - (fluid-let ((*imail-message-wrapper-prefix* prefix)) - (message prefix) - (let ((v (thunk))) - (message prefix "done") - v))))) - -(define (imail-ui:progress-meter current total) - (if (and *imail-message-wrapper-prefix* (< 0 current total)) - (message *imail-message-wrapper-prefix* - (string-pad-left - (number->string (round->exact (* (/ current total) 100))) - 3) - "% (of " - (number->string total) - ")"))) - -(define *imail-message-wrapper-prefix* #f) - -(define imail-ui:message message) -(define imail-ui:prompt-for-yes-or-no? prompt-for-yes-or-no?) - -(define (imail-ui:body-cache-limit message) - (ref-variable imail-body-cache-limit - (let ((folder (message-folder message))) - (and folder - (imail-folder->buffer folder #f))))) - -(define (imail-ui:call-with-pass-phrase url receiver) - (let ((key (url-pass-phrase-key url)) - (retention-time (ref-variable imail-pass-phrase-retention-time #f))) - (let ((entry (hash-table/get memoized-pass-phrases key #f))) - (if entry - (begin - (without-interrupts - (lambda () - (deregister-timer-event (vector-ref entry 1)) - (set-up-pass-phrase-timer! entry key retention-time))) - (call-with-unobscured-pass-phrase (vector-ref entry 0) receiver)) - (call-with-pass-phrase - (string-append "Pass phrase for " key) - (lambda (pass-phrase) - (if (> retention-time 0) - (hash-table/put! - memoized-pass-phrases - key - (let ((entry - (vector (obscure-pass-phrase pass-phrase) #f #f))) - (set-up-pass-phrase-timer! entry key retention-time) - entry))) - (receiver pass-phrase))))))) - -(define (imail-ui:delete-stored-pass-phrase url) - (hash-table/remove! memoized-pass-phrases (url-pass-phrase-key url))) - -(define (set-up-pass-phrase-timer! entry key retention-time) - ;; A race condition can occur when the timer event is re-registered. - ;; If the previous timer event is queued but not executed before - ;; being deregistered, then it will run after the re-registration - ;; and try to delete the record. By matching on ID, the previous - ;; event sees that it has been superseded and does nothing. - (let ((id (list 'ID))) - (vector-set! entry 2 id) - (vector-set! entry 1 - (register-timer-event (* retention-time 60000) - (lambda () - (without-interrupts - (lambda () - (let ((entry (hash-table/get memoized-pass-phrases key #f))) - (if (and entry (eq? (vector-ref entry 2) id)) - (hash-table/remove! memoized-pass-phrases key)))))))))) - -(define memoized-pass-phrases - (make-string-hash-table)) - -(define (obscure-pass-phrase clear-text) - (let ((n (string-length clear-text))) - (let ((noise (random-byte-vector n))) - (let ((obscured-text (make-string (* 2 n)))) - (string-move! noise obscured-text 0) - (do ((i 0 (fix:+ i 1))) - ((fix:= i n)) - (vector-8b-set! obscured-text (fix:+ i n) - (fix:xor (vector-8b-ref clear-text i) - (vector-8b-ref noise i)))) - obscured-text)))) - -(define (call-with-unobscured-pass-phrase obscured-text receiver) - (let ((n (quotient (string-length obscured-text) 2)) - (clear-text)) - (dynamic-wind - (lambda () - (set! clear-text (make-string n)) - unspecific) - (lambda () - (do ((i 0 (fix:+ i 1))) - ((fix:= i n)) - (vector-8b-set! clear-text i - (fix:xor (vector-8b-ref obscured-text i) - (vector-8b-ref obscured-text (fix:+ i n))))) - (receiver clear-text)) - (lambda () - (string-fill! clear-text #\NUL) - (set! clear-text) - unspecific)))) - (define-major-mode imail read-only "IMAIL" (lambda () (with-string-output-port @@ -457,19 +273,14 @@ regardless of the folder type." (make-event-distributor)) (define (add-adaptive-fill-regexp! regexp buffer) - (local-set-variable! - adaptive-fill-regexp - (string-append regexp - "\\|" - (variable-default-value - (ref-variable-object adaptive-fill-regexp))) - buffer) + (local-set-variable! adaptive-fill-regexp + (string-append regexp "\\|" + (ref-variable adaptive-fill-regexp #f)) + buffer) (local-set-variable! adaptive-fill-first-line-regexp - (string-append regexp - "\\|" - (variable-default-value - (ref-variable-object adaptive-fill-first-line-regexp))) + (string-append regexp "\\|" + (ref-variable adaptive-fill-first-line-regexp #f)) buffer)) (define imail-mode-description @@ -504,13 +315,6 @@ Instead, these commands are available: \\[imail-output] Append this message to a specified folder. \\[imail-save-attachment] Save a MIME attachment to a file. -\\[imail-copy-messages] Copy all messages in this folder to another folder. -\\[imail-copy-folder] Copy all messages from one folder to another. - -\\[imail-create-folder] Create a new folder. (Normally not needed as output commands - create folders automatically.) -\\[imail-delete-folder] Delete an existing folder and all its messages. -\\[imail-rename-folder] Rename a folder. \\[imail-add-flag] Add flag to message. It will be displayed in the mode line. \\[imail-kill-flag] Remove flag from message. @@ -521,12 +325,52 @@ Instead, these commands are available: Any other flag is present only if you add it with `\\[imail-add-flag]'. \\[imail-previous-flagged-message] Move to previous message with specified flag. +\\[imail-create-folder] Create a new folder. (Normally not needed as output commands + create folders automatically.) +\\[imail-delete-folder] Delete an existing folder and all its messages. +\\[imail-rename-folder] Rename a folder. +\\[imail-copy-folder] Copy all messages from one folder to another. + \\[imail-summary] Show headers buffer, with a one line summary of each message. \\[imail-summary-by-flags] Like \\[imail-summary] only just messages with particular flag(s). \\[imail-summary-by-recipients] Like \\[imail-summary] only just messages with particular recipient(s). \\[imail-toggle-message] Toggle between standard and raw message formats.") +(define (imail-revert-buffer buffer dont-use-auto-save? dont-confirm?) + dont-use-auto-save? + (let ((folder (selected-folder #t buffer))) + (if (let ((status (folder-sync-status folder))) + (case status + ((UNSYNCHRONIZED) + #t) + ((SYNCHRONIZED PERSISTENT-MODIFIED) + (or dont-confirm? + (prompt-for-yes-or-no? "Revert buffer from folder"))) + ((CACHE-MODIFIED) + (prompt-for-yes-or-no? "Discard your changes to folder")) + ((BOTH-MODIFIED) + (prompt-for-yes-or-no? + "Persistent copy of folder changed; discard your changes")) + ((PERSISTENT-DELETED) + (editor-error "Persistent copy of folder deleted.")) + (else + (error "Unknown folder-sync status:" status)))) + (begin + (discard-folder-cache folder) + (select-message + folder + (or (selected-message #f buffer) + (first-unseen-message folder)) + #t))))) + +(define (imail-kill-buffer buffer) + (let ((folder (selected-folder #f buffer))) + (if folder + (begin + (close-folder folder) + (unmemoize-folder (folder-url folder)))))) + (define-key 'imail #\a 'imail-add-flag) (define-key 'imail #\b 'imail-bury) (define-key 'imail #\c 'imail-continue) @@ -546,7 +390,6 @@ Instead, these commands are available: (define-key 'imail #\c-m-n 'imail-next-flagged-message) (define-key 'imail #\o 'imail-output) (define-key 'imail #\c-o 'imail-save-attachment) -(define-key 'imail #\m-o 'imail-copy-messages) (define-key 'imail #\p 'imail-previous-undeleted-message) (define-key 'imail #\m-p 'imail-previous-message) (define-key 'imail #\c-m-p 'imail-previous-flagged-message) @@ -578,9 +421,9 @@ Instead, these commands are available: ;; These commands have no equivalent in RMAIL. (define-key 'imail #\C 'imail-copy-folder) +(define-key 'imail #\D 'imail-delete-folder) (define-key 'imail #\R 'imail-rename-folder) (define-key 'imail #\+ 'imail-create-folder) -(define-key 'imail #\- 'imail-delete-folder) ;; These commands not yet implemented. ;;(define-key 'imail #\m-m 'imail-retry-failure) @@ -593,40 +436,6 @@ Instead, these commands are available: ;;(define-key 'imail '(#\c-c #\c-s #\c-l) 'imail-sort-by-lines) ;;(define-key 'imail '(#\c-c #\c-s #\c-k) 'imail-sort-by-keywords) -(define (imail-revert-buffer buffer dont-use-auto-save? dont-confirm?) - dont-use-auto-save? - (let ((folder (selected-folder #t buffer))) - (if (let ((status (folder-sync-status folder))) - (case status - ((UNSYNCHRONIZED) - #t) - ((SYNCHRONIZED PERSISTENT-MODIFIED) - (or dont-confirm? - (prompt-for-yes-or-no? "Revert buffer from folder"))) - ((FOLDER-MODIFIED) - (prompt-for-yes-or-no? "Discard your changes to folder")) - ((BOTH-MODIFIED) - (prompt-for-yes-or-no? - "Persistent copy of folder changed; discard your changes")) - ((PERSISTENT-DELETED) - (editor-error "Persistent copy of folder deleted.")) - (else - (error "Unknown folder-sync status:" status)))) - (begin - (discard-folder-cache folder) - (select-message - folder - (or (selected-message #f buffer) - (first-unseen-message folder)) - #t))))) - -(define (imail-kill-buffer buffer) - (let ((folder (selected-folder #f buffer))) - (if folder - (begin - (close-folder folder) - (unmemoize-folder (folder-url folder)))))) - ;;;; Navigation (define-command imail-select-message @@ -657,7 +466,10 @@ Instead, these commands are available: () (lambda () (let ((folder (selected-folder))) - (select-message folder (navigator/first-unseen-message folder))))) + (let ((m (navigator/first-unseen-message folder))) + (if m + (select-message folder m) + (message "No unseen messages")))))) (define-command imail-next-message "Show following message whether deleted or not. @@ -674,7 +486,7 @@ or forward if N is negative." "p" (lambda (delta) ((ref-command imail-next-message) (- delta)))) - + (define-command imail-next-undeleted-message "Show following non-deleted message. With prefix argument N, moves forward N non-deleted messages, @@ -690,7 +502,7 @@ or forward if N is negative." "p" (lambda (delta) ((ref-command imail-next-undeleted-message) (- delta)))) - + (define-command imail-next-same-subject "Go to the next mail message having the same subject header. With prefix argument N, do this N times. @@ -720,7 +532,7 @@ If N is negative, go forwards instead." "p" (lambda (delta) ((ref-command imail-next-same-subject) (- delta)))) - + (define-command imail-next-flagged-message "Show next message with one of the flags FLAGS. FLAGS should be a comma-separated list of flag names. @@ -765,777 +577,571 @@ With prefix argument N moves backward N messages with these flags." 'DEFAULT-TYPE 'INSERTED-DEFAULT 'HISTORY 'IMAIL-PROMPT-FOR-FLAGS 'HISTORY-INDEX 0)) + +;;;; Message deletion -(define (move-relative-any argument operation) - (move-relative argument #f "message" operation)) +(define-command imail-delete-message + "Delete this message and stay on it." + () + (lambda () + (delete-message (selected-message)))) -(define (move-relative-undeleted argument operation) - (move-relative argument message-undeleted? "undeleted message" operation)) +(define-command imail-delete-forward + "Delete this message and move to next nondeleted one. +With prefix argument N, deletes forward N messages, + or backward if N is negative. +Deleted messages stay in the file until the \\[imail-expunge] command is given." + "p" + (lambda (delta) + (move-relative-undeleted delta delete-message))) -(define (move-relative argument predicate noun operation) - (if argument - (let ((delta (command-argument-numeric-value argument))) - (if (not (= 0 delta)) - (call-with-values - (lambda () - (if (< delta 0) - (values (- delta) navigator/previous-message "previous") - (values delta navigator/next-message "next"))) - (lambda (n step direction) - (let ((folder (selected-folder)) - (msg (selected-message))) - (if (and operation (> n 0)) - (operation msg)) - (let loop ((n n) (msg msg) (winner #f)) - (let ((next (step msg predicate))) - (cond ((not next) - (if winner (select-message folder winner)) - (message "No " direction " " noun)) - ((= n 1) - (select-message folder next)) - (else - (if operation (operation next)) - (loop (- n 1) next next)))))))))) - (if operation (operation (selected-message))))) - -;;;; Message selection +(define-command imail-delete-backward + "Delete this message and move to previous nondeleted one. +With prefix argument N, deletes backward N messages, + or forward if N is negative. +Deleted messages stay in the file until the \\[imail-expunge] command is given." + "p" + (lambda (delta) + ((ref-command imail-delete-forward) (- delta)))) -(define (select-message folder selector #!optional force? raw?) - (let ((buffer (imail-folder->buffer folder #t)) - (message - (let loop ((selector selector)) - (cond ((message? selector) - (and (message-attached? selector folder) - selector - (loop (message-index selector)))) - ((not selector) - (last-message folder)) - ((and (exact-integer? selector) - (<= 0 selector) - (< selector (folder-length folder))) - (get-message folder selector)) - (else - (error:wrong-type-argument selector "message selector" - 'SELECT-MESSAGE))))) - (raw? (if (default-object? raw?) #f raw?))) - (if (or (if (default-object? force?) #f force?) - (not (eq? message (buffer-get buffer 'IMAIL-MESSAGE 'UNKNOWN)))) - (begin - (set-buffer-writeable! buffer) - (buffer-widen! buffer) - (region-delete! (buffer-region buffer)) - (associate-imail-with-buffer buffer folder message) - (set-buffer-major-mode! buffer (ref-mode-object imail)) - (let ((mark (mark-left-inserting-copy (buffer-start buffer)))) - (with-read-only-defeated mark - (lambda () - (if message - (begin - (store-property! message 'RAW? raw?) - (insert-header-fields message raw? mark) - (cond (raw? - (insert-string (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)))))) - (insert-string "[This folder has no messages in it.]" - mark)))) - (mark-temporary! mark)) - (set-buffer-point! buffer (buffer-start buffer)) - (buffer-not-modified! buffer))) - (if message - (message-seen message)) - (folder-event folder 'SELECT-MESSAGE message))) +(define-command imail-undelete-previous-message + "Back up to deleted message, select it, and undelete it." + () + (lambda () + (let ((message (selected-message))) + (if (message-deleted? message) + (undelete-message message) + (let ((message + (navigator/previous-message message message-deleted?))) + (if (not message) + (editor-error "No previous deleted message.")) + (undelete-message message) + (select-message (message-folder message) message)))))) -(define (insert-header-fields headers raw? mark) - (insert-string (header-fields->string - (let ((headers (->header-fields headers))) - (if raw? - headers - (maybe-reformat-headers - headers - (or (and (message? headers) - (imail-message->buffer headers #f)) - mark))))) - mark) - (insert-newline mark)) +(define-command imail-undelete-forward + "Undelete this message and move to next one. +With prefix argument N, undeletes forward N messages, + or backward if N is negative." + "p" + (lambda (delta) (move-relative-any delta undelete-message))) + +(define-command imail-undelete-backward + "Undelete this message and move to previous one. +With prefix argument N, undeletes backward N messages, + or forward if N is negative." + "p" + (lambda (delta) ((ref-command imail-undelete-forward) (- delta)))) -(define (selected-folder #!optional error? buffer) - (let ((buffer - (chase-imail-buffer - (if (or (default-object? buffer) (not buffer)) - (selected-buffer) - buffer)))) - (let ((folder (buffer-get buffer 'IMAIL-FOLDER 'UNKNOWN))) - (if (eq? 'UNKNOWN folder) - (error "IMAIL-FOLDER property not bound:" buffer)) - (or folder - (and (if (default-object? error?) #t error?) - (error:bad-range-argument buffer 'SELECTED-FOLDER)))))) +(define-command imail-expunge + "Actually erase all deleted messages in the folder." + () + (lambda () + (let ((folder (selected-folder))) + (let ((n (count-messages folder message-deleted?))) + (cond ((= n 0) + (message "No messages to expunge")) + ((let ((confirmation (ref-variable imail-expunge-confirmation))) + (or (null? confirmation) + (let ((prompt + (string-append "Expunge " + (number->string n) + " message" + (if (> n 1) "s" "") + " marked for deletion"))) + (let ((do-prompt + (lambda () + (if (memq 'BRIEF confirmation) + (prompt-for-confirmation? prompt) + (prompt-for-yes-or-no? prompt))))) + (if (memq 'SHOW-MESSAGES confirmation) + (cleanup-pop-up-buffers + (lambda () + (imail-expunge-pop-up-messages folder) + (do-prompt))) + (do-prompt)))))) + (let ((message (selected-message))) + (if (message-deleted? message) + (select-message + folder + (or (next-message message message-undeleted?) + (previous-message message message-undeleted?) + (next-message message) + (previous-message message))))) + (expunge-deleted-messages folder)) + (else + (message "Messages not expunged"))))))) -(define (selected-message #!optional error? buffer) - (or (let ((buffer - (if (or (default-object? buffer) (not buffer)) - (selected-buffer) - buffer))) - (let ((method (navigator/selected-message buffer))) - (if method - (method buffer) - (let ((buffer (chase-imail-buffer buffer))) - (let ((message (buffer-get buffer 'IMAIL-MESSAGE 'UNKNOWN))) - (if (eq? message 'UNKNOWN) - (error "IMAIL-MESSAGE property not bound:" buffer)) - (and message - (let ((folder (selected-folder #f buffer))) - (if (message-attached? message folder) - message - (let ((message - (let ((index - (and folder - (message-detached? message) - (message-index message)))) - (and index - (< index (folder-length folder)) - (get-message folder index))))) - (buffer-put! buffer 'IMAIL-MESSAGE message) - message))))))))) - (and (if (default-object? error?) #t error?) - (error "No selected IMAIL message.")))) +(define (count-messages folder predicate) + (let ((n (folder-length folder))) + (do ((i 0 (+ i 1)) + (k 0 (if (predicate (get-message folder i)) (+ k 1) k))) + ((= i n) k)))) -(define (maybe-reformat-headers headers buffer) - (let ((headers - (cond ((ref-variable imail-kept-headers buffer) - => (lambda (regexps) - (append-map! - (lambda (regexp) - (list-transform-positive headers - (lambda (header) - (re-string-match regexp - (header-field-name header) - #t)))) - regexps))) - ((ref-variable imail-ignored-headers buffer) - => (lambda (regexp) - (list-transform-negative headers - (lambda (header) - (re-string-match regexp - (header-field-name header) - #t))))) - (else 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))) +(define (imail-expunge-pop-up-messages folder) + (pop-up-temporary-buffer " *imail-message*" '(READ-ONLY SHRINK-WINDOW) + (lambda (buffer window) + window + (local-set-variable! truncate-lines #t buffer) + (let ((mark (mark-left-inserting-copy (buffer-point buffer))) + (n (folder-length folder))) + (let ((index-digits (exact-nonnegative-integer-digits (- n 1)))) + (do ((i 0 (+ i 1))) + ((= i n)) + (let ((m (get-message folder i))) + (if (message-deleted? m) + (write-imail-summary-line! m index-digits mark))))))))) -;;;; Buffer associations +;;;; Message flags -(define (associate-imail-with-buffer buffer folder message) - (without-interrupts - (lambda () - (buffer-put! buffer 'IMAIL-FOLDER folder) - (buffer-put! buffer 'IMAIL-MESSAGE message) - (store-property! folder 'BUFFER buffer) - (set-buffer-default-directory! - buffer - (if (file-folder? folder) - (directory-pathname (file-folder-pathname folder)) - (user-homedir-pathname))) - (add-event-receiver! (folder-modification-event folder) - (lambda (folder type parameters) - (if (eq? type 'EXPUNGE) - (maybe-add-command-suffix! notice-message-expunge - folder - (car parameters)) - (maybe-add-command-suffix! notice-folder-modifications folder)))) - (add-kill-buffer-hook buffer delete-associated-buffers) - (add-kill-buffer-hook buffer stop-probe-folder-thread) - (start-probe-folder-thread buffer)))) +(define-command imail-add-flag + "Add FLAG to flags associated with current IMAIL message. +Completion is performed over known flags when reading. +With prefix argument N, removes FLAG to next N messages, + or previous -N if N is negative." + (lambda () + (list (command-argument) + (imail-read-flag "Add flag" #f))) + (lambda (argument flag) + (move-relative-any argument + (lambda (message) (set-message-flag message flag))))) -(define (delete-associated-buffers folder-buffer) - (for-each (lambda (buffer) - (if (buffer-alive? buffer) - (kill-buffer buffer))) - (buffer-get folder-buffer 'IMAIL-ASSOCIATED-BUFFERS '()))) +(define-command imail-kill-flag + "Remove FLAG from flags associated with current IMAIL message. +Completion is performed over known flags when reading. +With prefix argument N, removes FLAG from next N messages, + or previous -N if N is negative." + (lambda () + (list (command-argument) + (imail-read-flag "Remove flag" #t))) + (lambda (argument flag) + (move-relative-any argument + (lambda (message) (clear-message-flag message flag))))) -(define (imail-folder->buffer folder error?) - (or (let ((buffer (get-property folder 'BUFFER #f))) - (and buffer - (if (buffer-alive? buffer) - buffer - (begin - (remove-property! folder 'BUFFER) - #f)))) - (and error? (error:bad-range-argument folder 'IMAIL-FOLDER->BUFFER)))) +(define (imail-read-flag prompt require-match?) + (prompt-for-string-table-name + prompt #f + (alist->string-table + (map list + (remove-duplicates (append standard-message-flags + (folder-flags (selected-folder))) + string=?))) + 'DEFAULT-TYPE 'INSERTED-DEFAULT + 'HISTORY 'IMAIL-READ-FLAG + 'REQUIRE-MATCH? require-match?)) + +;;;; Message I/O -(define (imail-message->buffer message error?) - (or (list-search-positive (buffer-list) - (lambda (buffer) - (eq? (buffer-get buffer 'IMAIL-MESSAGE #f) message))) - (and error? (error:bad-range-argument message 'IMAIL-MESSAGE->BUFFER)))) +(define-command imail-input-from-folder + "Append messages to this folder from a specified folder." + (lambda () + (list (prompt-for-imail-url-string "Get messages from folder" #f + 'HISTORY 'IMAIL-INPUT + 'HISTORY-INDEX 0 + 'REQUIRE-MATCH? #t))) + (lambda (url-string) + (let ((url (imail-parse-partial-url url-string)) + (folder (selected-folder))) + (let ((from (open-folder url)) + (to (folder-url folder))) + (let ((n (folder-length from))) + (do ((i 0 (+ i 1))) + ((= i n)) + ((message-wrapper #f + "Copying message " + (number->string (+ i 1)) + "/" + (number->string n)) + (lambda () (append-message (get-message from i) to)))) + ((ref-command imail-get-new-mail) #f) + (message (number->string n) + " message" + (if (= n 1) "" "s") + " copied from " + (url->string url))))))) -(define (associate-buffer-with-imail-buffer folder-buffer buffer) - (without-interrupts - (lambda () - (buffer-put! buffer 'IMAIL-FOLDER-BUFFER folder-buffer) - (let ((buffers (buffer-get folder-buffer 'IMAIL-ASSOCIATED-BUFFERS '()))) - (if (not (memq buffer buffers)) - (buffer-put! folder-buffer 'IMAIL-ASSOCIATED-BUFFERS - (cons buffer buffers)))) - (add-kill-buffer-hook buffer dissociate-buffer-from-imail-buffer)))) +(define-command imail-output + "Append this message to a specified folder." + (lambda () + (list (prompt-for-imail-url-string "Output to folder" #f + 'HISTORY 'IMAIL-OUTPUT + 'HISTORY-INDEX 0) + (command-argument))) + (lambda (url-string argument) + (let ((url (imail-parse-partial-url url-string)) + (delete? (ref-variable imail-delete-after-output))) + (move-relative-undeleted (or argument (and delete? 1)) + (lambda (message) + (append-message message url) + (message-filed message) + (if delete? (delete-message message)))) + (let ((n (if argument (command-argument-numeric-value argument) 1))) + (message (number->string n) + " message" + (if (= n 1) "" "s") + " written to " + (url->string url)))))) + +;;;; Attachments -(define (dissociate-buffer-from-imail-buffer buffer) - (without-interrupts - (lambda () - (let ((folder-buffer (buffer-get buffer 'IMAIL-FOLDER-BUFFER #f))) - (if folder-buffer - (begin - (buffer-remove! buffer 'IMAIL-FOLDER-BUFFER) - (buffer-put! folder-buffer 'IMAIL-ASSOCIATED-BUFFERS - (delq! buffer - (buffer-get folder-buffer - 'IMAIL-ASSOCIATED-BUFFERS - '())))))) - (remove-kill-buffer-hook buffer dissociate-buffer-from-imail-buffer)))) +(define-command imail-save-attachment + "Save the attachment at point. +If point is not on an attachment, prompts for the attachment to save. +With prefix argument, prompt even when point is on an attachment." + "P" + (lambda (always-prompt?) + (let ((attachment + (maybe-prompt-for-mime-attachment (current-point) always-prompt?))) + (save-mime-attachment (car attachment) + (cdr attachment) + (selected-message) + (selected-buffer))))) -(define (chase-imail-buffer buffer) - (or (buffer-get buffer 'IMAIL-FOLDER-BUFFER #f) - buffer)) - -;;;; Mode-line updates +(define (maybe-prompt-for-mime-attachment mark always-prompt?) + (let ((attachment (mark-mime-attachment mark))) + (if (and attachment (not always-prompt?)) + attachment + (let ((attachments (buffer-mime-attachments (mark-buffer mark)))) + (if (null? attachments) + (editor-error "This message has no attachments.")) + (let ((alist + (uniquify-mime-attachment-names + (map (lambda (b.s) + (cons (mime-attachment-name (car b.s) (cdr b.s) #t) + b.s)) + attachments)))) + (prompt-for-alist-value "Save attachment" + alist + (and attachment + (let ((entry + (list-search-positive alist + (lambda (entry) + (eq? (cdr entry) + attachment))))) + (and entry + (car entry)))) + #f)))))) -(define (notice-folder-modifications folder) - (let ((buffer (imail-folder->buffer folder #f))) - (if buffer +(define (uniquify-mime-attachment-names alist) + (let loop ((alist alist) (converted '())) + (if (pair? alist) + (loop (cdr alist) + (cons (cons (let ((name (caar alist))) + (let loop ((name* name) (n 1)) + (if (there-exists? converted + (lambda (entry) + (string=? (car entry) name*))) + (loop (string-append + name "<" (number->string n) ">") + (+ n 1)) + name*))) + (cdar alist)) + converted)) + (reverse! converted)))) + +(define (save-mime-attachment body selector message buffer) + (let ((filename + (prompt-for-file + "Save attachment as" + (let ((filename (mime-body-disposition-filename body))) + (and filename + (list + (merge-pathnames + (filter-mime-attachment-filename filename) + (or (buffer-get buffer 'IMAIL-MIME-ATTACHMENT-DIRECTORY #f) + (buffer-default-directory buffer))))))))) + (if (or (not (file-exists? filename)) + (prompt-for-yes-or-no? "File already exists; overwrite")) (begin - (local-set-variable! mode-line-process - (imail-mode-line-summary-string buffer) - buffer) - (buffer-modeline-event! buffer 'PROCESS-STATUS))))) + (call-with-binary-output-file filename + (lambda (port) + (let ((string (message-mime-body-part message selector #f)) + (text? + (let ((type (mime-body-type body))) + (or (eq? type 'TEXT) + (eq? type 'MESSAGE))))) + (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)))))) + (buffer-put! buffer 'IMAIL-MIME-ATTACHMENT-DIRECTORY + (directory-pathname filename)))))) -(define (notice-message-expunge folder index) - (let ((buffer (imail-folder->buffer folder #f))) - (if buffer - (let ((m (selected-message #f buffer))) - (if (or (not m) - (message-detached? m)) - (select-message folder - (let ((length (folder-length folder))) - (cond ((< index length) index) - ((> length 0) (- length 1)) - (else #f))) - #t))))) - (notice-folder-modifications folder)) +(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 (imail-mode-line-summary-string buffer) - (let ((folder (selected-folder #f buffer)) - (message (selected-message #f buffer))) - (and folder - (let ((status (folder-connection-status folder))) - (string-append - (if (eq? status 'NO-SERVER) - "" - (string-append " " (symbol->string status))) - (if (and message (message-attached? message folder)) - (let ((index (message-index message))) - (if index - (let ((n (folder-length folder))) - (string-append - " " - (number->string (+ 1 index)) - "/" - (number->string n) - (let loop ((i 0) (unseen 0)) - (if (< i n) - (loop (+ i 1) - (if (message-unseen? - (get-message folder i)) - (+ unseen 1) - unseen)) - (if (> unseen 0) - (string-append " (" - (number->string unseen) - " unseen)") - ""))) - (let ((flags - (flags-delete "seen" (message-flags message)))) - (if (pair? flags) - (string-append - " " - (decorated-string-append "" "," "" flags)) - "")))) - " 0/0")) - "")))))) - -;;;; Probe-folder thread +(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 (start-probe-folder-thread buffer) - (stop-probe-folder-thread buffer) - (let ((folder (buffer-get buffer 'IMAIL-FOLDER #f)) - (interval (ref-variable imail-update-interval #f))) - (if (and folder interval - (not (get-property folder 'PROBE-REGISTRATION #f))) - (let ((registration (list #f))) - (set-car! registration - (register-inferior-thread! - (let ((thread - (create-thread - editor-thread-root-continuation - (probe-folder-thread registration - (* 1000 interval))))) - (detach-thread thread) - thread) - (probe-folder-output-processor - (weak-cons folder unspecific)))) - (store-property! folder 'PROBE-REGISTRATION registration))))) +(define (mime-body-disposition-filename body) + (let ((disposition (mime-body-disposition body))) + (and disposition + (let ((entry (assq 'FILENAME (cdr disposition)))) + (and entry + (cdr entry)))))) -(define ((probe-folder-thread registration interval)) - (do () (#f) - (let ((registration (car registration))) - (cond ((eq? registration 'KILL-THREAD) (exit-current-thread unspecific)) - (registration (inferior-thread-output! registration)))) - (sleep-current-thread interval))) +(define (filter-mime-attachment-filename filename) + (let ((filename + (let ((index + (string-find-previous-char-in-set + filename + char-set:mime-attachment-filename-delimiters))) + (if index + (string-tail filename (+ index 1)) + filename)))) + (and (not (string-find-next-char-in-set + filename + char-set:rejected-mime-attachment-filename)) + (if (eq? microcode-id/operating-system 'UNIX) + (string-replace filename #\space #\_) + filename)))) -(define ((probe-folder-output-processor folder)) - (let ((folder (weak-car folder))) - (and folder - (eq? (folder-connection-status folder) 'ONLINE) - (begin - (probe-folder folder) - #t)))) +(define char-set:mime-attachment-filename-delimiters + (char-set #\/ #\\ #\:)) -(define (stop-probe-folder-thread buffer) - (without-interrupts - (lambda () - (let ((folder (buffer-get buffer 'IMAIL-FOLDER #f))) - (if folder - (begin - (let ((holder (get-property folder 'PROBE-REGISTRATION #f))) - (if holder - (begin - (let ((registration (car holder))) - (if (and registration - (not (eq? registration 'KILL-THREAD))) - (deregister-inferior-thread! registration))) - (set-car! holder 'KILL-THREAD)))) - (remove-property! folder 'PROBE-REGISTRATION))))))) +(define char-set:rejected-mime-attachment-filename + (char-set-invert + (char-set-difference char-set:graphic + char-set:mime-attachment-filename-delimiters))) -;;;; MIME message formatting +;;;; Sending mail -(define (insert-mime-message-body message mark) - (insert-mime-message-part message - (message-mime-body-structure message) - #f - '() - mark)) +(define-command imail-mail + "Send mail in another window. +While composing the message, use \\[mail-yank-original] to yank the +original message into it." + () + (lambda () + (make-mail-buffer '(("To" "") ("Subject" "")) + (chase-imail-buffer (selected-buffer)) + select-buffer-other-window))) -(define-generic insert-mime-message-part - (message body enclosure selector mark)) +(define-command imail-reply + "Reply to the current message. +Normally include CC: to all other recipients of original message; + prefix argument means ignore them. +While composing the reply, use \\[mail-yank-original] to yank the + original message into it." + "P" + (lambda (just-sender?) + (let ((message (selected-message))) + (make-mail-buffer (imail-reply-headers message (not just-sender?)) + (chase-imail-buffer (selected-buffer)) + (lambda (mail-buffer) + (message-answered message) + (select-buffer-other-window mail-buffer)))))) -(define-method insert-mime-message-part - (message (body ) enclosure selector mark) - message enclosure - (insert-mime-message-attachment 'ATTACHMENT body selector mark)) +(define-command imail-continue + "Continue composing outgoing message previously being composed." + () + (lambda () ((ref-command mail-other-window) #t))) -(define-method insert-mime-message-part - (message (body ) enclosure selector mark) - enclosure - (let ((boundary (mime-body-parameter body 'BOUNDARY "----------"))) - (do ((parts (mime-body-multipart-parts body) (cdr parts)) - (i 0 (fix:+ i 1))) - ((null? parts)) - (if (fix:> i 0) - (begin - (insert-newline mark) - (insert-string "--" mark) - (insert-string boundary mark) - (insert-newline mark) - (insert-newline mark))) - (let ((part (car parts)) - (selector `(,@selector ,i))) - (if (and (fix:> i 0) - (eq? (mime-body-subtype body) 'ALTERNATIVE)) - (insert-mime-message-attachment 'ALTERNATIVE part selector mark) - (insert-mime-message-part message part body selector mark)))))) - -(define-method insert-mime-message-part - (message (body ) enclosure selector mark) - enclosure - (insert-header-fields (message-mime-body-part message - `(,@selector HEADER) - #t) - #f - mark) - (insert-mime-message-part message - (mime-body-message-body body) - body - selector - mark)) +;;; This procedure is invoked by M-x mail-yank-original in Mail mode. -(define-method insert-mime-message-part - (message (body ) enclosure selector mark) - (let* ((message-enclosure? - (and enclosure - (eq? (mime-body-type enclosure) 'MESSAGE) - (eq? (mime-body-subtype enclosure) 'RFC822))) - (encoding - (let ((encoding - (and message-enclosure? - (mime-body-one-part-encoding enclosure)))) - (if (and encoding (not (memq encoding '(7BIT 8BIT BINARY)))) - ;; This is illegal, but Netscape does it. - encoding - (mime-body-one-part-encoding body))))) - (if (and (or (not enclosure) - (let ((disposition (mime-body-disposition body))) - (and disposition - (eq? (car disposition) 'INLINE))) - (let ((subtype (mime-body-subtype body))) - (or (eq? subtype 'PLAIN) - (memq subtype - (ref-variable imail-inline-mime-text-subtypes - mark))))) - (known-mime-encoding? encoding) - (re-string-match - (string-append "\\`" - (apply regexp-group - (ref-variable imail-known-mime-charsets - mark)) - "\\'") - (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)))))) - (insert-mime-message-attachment 'ATTACHMENT body selector mark)))) +(define (imail-yank-original buffer mark) + (let ((message (selected-message #t buffer))) + (insert-header-fields message #f mark) + (insert-string (message-body message) mark))) -(define (insert-mime-message-attachment class body selector mark) - (let ((start (mark-right-inserting-copy mark))) - (insert-string "string class)) mark) - (insert-string " " mark) - (let ((column (mark-column mark))) - (let ((name (mime-attachment-name body selector #f))) - (if name - (begin - (insert-string "name=" mark) - (insert name mark) - (insert-newline mark) - (change-column column mark)))) - (insert-string "type=" mark) - (insert (mime-body-type body) mark) - (insert-string "/" mark) - (insert (mime-body-subtype body) mark) - (insert-newline mark) - (if (eq? (mime-body-type body) 'TEXT) - (begin - (change-column column mark) - (insert-string "charset=" mark) - (insert (mime-body-parameter body 'CHARSET "us-ascii") mark) - (insert-newline mark))) - (let ((encoding (mime-body-one-part-encoding body))) - (if (not (known-mime-encoding? encoding)) - (begin - (change-column column mark) - (insert-string "encoding=" mark) - (insert encoding mark) - (insert-newline mark)))) - (change-column column mark) - (insert-string "length=" mark) - (insert (mime-body-one-part-n-octets body) mark)) - (insert-string ">" mark) - (region-put! start mark 'IMAIL-MIME-ATTACHMENT (cons body selector)) - (mark-temporary! start)) - (insert-newline mark)) - -(define (known-mime-encoding? encoding) - (memq encoding '(7BIT 8BIT BINARY QUOTED-PRINTABLE BASE64))) - -(define (mime-attachment-name body selector provide-default?) - (or (mime-body-parameter body 'NAME #f) - (and provide-default? - (string-append "unnamed-attachment-" - (if (null? selector) - "0" - (decorated-string-append - "" "." "" - (map (lambda (n) (number->string (+ n 1))) - selector))))))) +(define-command imail-forward + "Forward the current message to another user. +With prefix argument, \"resend\" the message instead of forwarding it; +see the documentation of `imail-resend'." + "P" + (lambda (resend?) + (if resend? + (dispatch-on-command (ref-command-object imail-resend)) + (imail-forward)))) -(define (mark-mime-attachment mark) - (region-get mark 'IMAIL-MIME-ATTACHMENT #f)) +(define (imail-forward) + (let ((message (selected-message))) + (make-mail-buffer + `(("To" "") + ("Subject" + ,(string-append + "[" + (let ((from (get-first-header-field-value message "from" #f))) + (if from + (rfc822:canonicalize-address-string from) + "")) + ": " + (message-subject message) + "]"))) + #f + (lambda (mail-buffer) + (let ((raw? (ref-variable imail-forward-all-headers mail-buffer))) + (if (ref-variable imail-forward-using-mime mail-buffer) + (add-buffer-mime-attachment! + mail-buffer + 'MESSAGE 'RFC822 '() '(INLINE) + (map header-field->mail-header + (let ((headers (message-header-fields message))) + (if raw? + headers + (maybe-reformat-headers headers mail-buffer)))) + (message-body message)) + (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))) + (mark-temporary! mark)))) + (if (window-has-no-neighbors? (current-window)) + (select-buffer mail-buffer) + (select-buffer-other-window mail-buffer)) + (message-forwarded message))))) -(define (buffer-mime-attachments buffer) - (let ((end (buffer-end buffer))) - (let loop ((start (buffer-start buffer)) (attachments '())) - (let ((index - (next-specific-property-change (mark-group start) - (mark-index start) - (mark-index end) - 'IMAIL-MIME-ATTACHMENT)) - (attachments - (let ((attachment (region-get start 'IMAIL-MIME-ATTACHMENT #f))) - (if attachment - (cons attachment attachments) - attachments)))) - (if index - (loop (make-mark (mark-group start) index) attachments) - (reverse! attachments)))))) +(define-command imail-resend + "Resend current message to ADDRESSES. +ADDRESSES is a string consisting of several addresses separated by commas." + "sResend to" + (lambda (addresses) + (let ((buffer (selected-buffer)) + (message (selected-message))) + (make-mail-buffer + `(("Resent-From" ,(mail-from-string buffer)) + ("Resent-Date" ,(universal-time->string (get-universal-time))) + ("Resent-To" ,addresses) + ,@(if (ref-variable mail-self-blind buffer) + `(("Resent-Bcc" ,(mail-from-string buffer))) + '()) + ,@(map header-field->mail-header + (list-transform-negative (message-header-fields message) + (lambda (header) + (string-ci=? (header-field-name header) "sender"))))) + #f + (lambda (mail-buffer) + (with-buffer-point-preserved mail-buffer + (lambda () + (insert-string (message-body message) (buffer-end mail-buffer)))) + (disable-buffer-mime-processing! mail-buffer) + (if (window-has-no-neighbors? (current-window)) + (select-buffer mail-buffer) + (select-buffer-other-window mail-buffer)) + (message-resent message)))))) -;;;; Automatic wrap/fill +(define (imail-reply-headers message cc?) + (let ((resent-reply-to + (get-last-header-field-value message "resent-reply-to" #f)) + (from (get-first-header-field-value message "from" #f))) + `(("To" + ,(rfc822:canonicalize-address-string + (or resent-reply-to + (get-all-header-field-values message "reply-to") + from))) + ("CC" + ,(and cc? + (let ((to + (if resent-reply-to + (get-last-header-field-value message "resent-to" #f) + (get-all-header-field-values message "to"))) + (cc + (if resent-reply-to + (get-last-header-field-value message "resent-cc" #f) + (get-all-header-field-values message "cc")))) + (let ((cc + (if (and to cc) + (string-append to ", " cc) + (or to cc)))) + (and cc + (let ((addresses + (imail-dont-reply-to + (rfc822:string->addresses cc)))) + (and (pair? addresses) + (rfc822:addresses->string addresses)))))))) + ("In-reply-to" + ,(if resent-reply-to + (make-in-reply-to-field + from + (get-last-header-field-value message "resent-date" #f) + (get-last-header-field-value message "resent-message-id" #f)) + (make-in-reply-to-field + from + (get-first-header-field-value message "date" #f) + (get-first-header-field-value message "message-id" #f)))) + ("Subject" + ,(let ((subject + (or (and resent-reply-to + (let ((subject + (get-last-header-field-value message + "resent-subject" + #f))) + (and subject + (strip-subject-re subject)))) + (message-subject message)))) + (if (ref-variable imail-reply-with-re) + (string-append "Re: " subject) + subject)))))) -(define (call-with-auto-wrapped-output-mark mark generator) - (case (ref-variable imail-auto-wrap mark) - ((#F) - (call-with-output-mark mark generator)) - ((FILL) - (let ((start (mark-right-inserting-copy mark)) - (end (mark-left-inserting-copy mark))) - (call-with-output-mark mark generator) - (fill-individual-paragraphs start end - (ref-variable fill-column start) #f #f) - (mark-temporary! start) - (mark-temporary! end))) - (else - (let ((start (mark-right-inserting-copy mark)) - (end (mark-left-inserting-copy mark))) - (call-with-output-mark mark generator) - (wrap-individual-paragraphs start end (- (mark-x-size mark) 1) #f) - (mark-temporary! start) - (mark-temporary! end))))) +(define (imail-dont-reply-to addresses) + (let ((pattern + (re-compile-pattern + (string-append (regexp-group ".*!" "") + (regexp-group (imail-dont-reply-to-names))) + #t))) + (let loop ((addresses addresses)) + (if (pair? addresses) + (if (re-string-match pattern (car addresses)) + (loop (cdr addresses)) + (cons (car addresses) (loop (cdr addresses)))) + '())))) + +(define (imail-dont-reply-to-names) + (or (ref-variable imail-dont-reply-to-names #f) + (let ((regexp + (string-append + (let ((r (ref-variable imail-default-dont-reply-to-names #f))) + (if r + (string-append r "\\|") + "")) + (re-quote-string (current-user-name)) + "\\>"))) + (set-variable! imail-dont-reply-to-names regexp #f) + regexp))) -;;;; Navigation hooks +(define (message-subject message) + (let ((subject (get-first-header-field-value message "subject" #f))) + (if subject + (strip-subject-re subject) + ""))) -(define (navigator/first-unseen-message folder) - ((or (imail-navigator imail-navigators/first-unseen-message) - first-unseen-message) - folder)) +(define (strip-subject-re subject) + (if (string-prefix-ci? "re:" subject) + (strip-subject-re (string-trim-left (string-tail subject 3))) + subject)) -(define (navigator/first-message folder) - ((or (imail-navigator imail-navigators/first-message) - first-message) - folder)) +(define (header-field->mail-header header) + (list (header-field-name header) + (let ((v (header-field-value header))) + (if (string-prefix? " " v) + (string-tail v 1) + v)))) -(define (navigator/last-message folder) - ((or (imail-navigator imail-navigators/last-message) - last-message) - folder)) +(define (with-buffer-point-preserved buffer thunk) + (let ((point (mark-right-inserting-copy (buffer-point buffer)))) + (let ((value (thunk))) + (set-buffer-point! buffer point) + (mark-temporary! point) + value))) + +;;;; Folder Operations -(define (navigator/next-message message #!optional predicate) - ((or (imail-navigator imail-navigators/next-message) - next-message) - message - (if (default-object? predicate) #f predicate))) - -(define (navigator/previous-message message #!optional predicate) - ((or (imail-navigator imail-navigators/previous-message) - previous-message) - message - (if (default-object? predicate) #f predicate))) - -(define (imail-navigator accessor) - (let ((navigators (buffer-get (selected-buffer) 'IMAIL-NAVIGATORS #f))) - (and navigators - (accessor navigators)))) - -(define (navigator/selected-message buffer) - (let ((navigators (buffer-get buffer 'IMAIL-NAVIGATORS #f))) - (and navigators - (imail-navigators/selected-message navigators)))) - -(define-structure (imail-navigators safe-accessors - (conc-name imail-navigators/)) - (first-unseen-message #f read-only #t) - (first-message #f read-only #t) - (last-message #f read-only #t) - (next-message #f read-only #t) - (previous-message #f read-only #t) - (selected-message #f read-only #t)) - -;;;; Message deletion - -(define-command imail-delete-message - "Delete this message and stay on it." - () - (lambda () - (delete-message (selected-message)))) - -(define-command imail-delete-forward - "Delete this message and move to next nondeleted one. -With prefix argument N, deletes forward N messages, - or backward if N is negative. -Deleted messages stay in the file until the \\[imail-expunge] command is given." - "p" - (lambda (delta) - (move-relative-undeleted delta delete-message))) - -(define-command imail-delete-backward - "Delete this message and move to previous nondeleted one. -With prefix argument N, deletes backward N messages, - or forward if N is negative. -Deleted messages stay in the file until the \\[imail-expunge] command is given." - "p" - (lambda (delta) - ((ref-command imail-delete-forward) (- delta)))) - -(define-command imail-undelete-previous-message - "Back up to deleted message, select it, and undelete it." - () - (lambda () - (let ((message (selected-message))) - (if (message-deleted? message) - (undelete-message message) - (let ((message - (navigator/previous-message message message-deleted?))) - (if (not message) - (editor-error "No previous deleted message.")) - (undelete-message message) - (select-message (message-folder message) message)))))) - -(define-command imail-undelete-forward - "Undelete this message and move to next one. -With prefix argument N, undeletes forward N messages, - or backward if N is negative." - "p" - (lambda (delta) (move-relative-any delta undelete-message))) - -(define-command imail-undelete-backward - "Undelete this message and move to previous one. -With prefix argument N, undeletes backward N messages, - or forward if N is negative." - "p" - (lambda (delta) ((ref-command imail-undelete-forward) (- delta)))) - -(define-command imail-expunge - "Actually erase all deleted messages in the folder." - () - (lambda () - (let ((folder (selected-folder))) - (let ((n (count-messages folder message-deleted?))) - (cond ((= n 0) - (message "No messages to expunge")) - ((let ((confirmation (ref-variable imail-expunge-confirmation))) - (or (null? confirmation) - (let ((prompt - (string-append "Expunge " - (number->string n) - " message" - (if (> n 1) "s" "") - " marked for deletion"))) - (let ((do-prompt - (lambda () - (if (memq 'BRIEF confirmation) - (prompt-for-confirmation? prompt) - (prompt-for-yes-or-no? prompt))))) - (if (memq 'SHOW-MESSAGES confirmation) - (cleanup-pop-up-buffers - (lambda () - (imail-expunge-pop-up-messages folder) - (do-prompt))) - (do-prompt)))))) - (let ((message (selected-message))) - (if (message-deleted? message) - (select-message - folder - (or (next-message message message-undeleted?) - (previous-message message message-undeleted?) - (next-message message) - (previous-message message))))) - (expunge-deleted-messages folder)) - (else - (message "Messages not expunged"))))))) - -(define (count-messages folder predicate) - (let ((n (folder-length folder))) - (do ((i 0 (+ i 1)) - (k 0 (if (predicate (get-message folder i)) (+ k 1) k))) - ((= i n) k)))) - -(define (imail-expunge-pop-up-messages folder) - (pop-up-temporary-buffer " *imail-message*" '(READ-ONLY SHRINK-WINDOW) - (lambda (buffer window) - window - (local-set-variable! truncate-lines #t buffer) - (let ((mark (mark-left-inserting-copy (buffer-point buffer))) - (n (folder-length folder))) - (let ((index-digits (exact-nonnegative-integer-digits (- n 1)))) - (do ((i 0 (+ i 1))) - ((= i n)) - (let ((m (get-message folder i))) - (if (message-deleted? m) - (write-imail-summary-line! m index-digits mark))))))))) - -;;;; Message flags - -(define-command imail-add-flag - "Add FLAG to flags associated with current IMAIL message. -Completion is performed over known flags when reading. -With prefix argument N, removes FLAG to next N messages, - or previous -N if N is negative." - (lambda () - (list (command-argument) - (imail-read-flag "Add flag" #f))) - (lambda (argument flag) - (move-relative-any argument - (lambda (message) (set-message-flag message flag))))) - -(define-command imail-kill-flag - "Remove FLAG from flags associated with current IMAIL message. -Completion is performed over known flags when reading. -With prefix argument N, removes FLAG from next N messages, - or previous -N if N is negative." - (lambda () - (list (command-argument) - (imail-read-flag "Remove flag" #t))) - (lambda (argument flag) - (move-relative-any argument - (lambda (message) (clear-message-flag message flag))))) - -(define (imail-read-flag prompt require-match?) - (prompt-for-string-table-name - prompt #f - (alist->string-table - (map list - (remove-duplicates (append standard-message-flags - (folder-flags (selected-folder))) - string=?))) - 'DEFAULT-TYPE 'INSERTED-DEFAULT - 'HISTORY 'IMAIL-READ-FLAG - 'REQUIRE-MATCH? require-match?)) - -;;;; Message I/O - -(define-command imail-create-folder - "Create a new folder with the specified name. -An error if signalled if the folder already exists." - (lambda () - (list (prompt-for-imail-url-string "Create folder" #f - 'HISTORY 'IMAIL-CREATE-FOLDER))) - (lambda (url-string) - (let ((url (imail-parse-partial-url url-string))) - (create-folder url) - (message "Created folder " (url->string url))))) +(define-command imail-create-folder + "Create a new folder with the specified name. +An error if signalled if the folder already exists." + (lambda () + (list (prompt-for-imail-url-string "Create folder" #f + 'HISTORY 'IMAIL-CREATE-FOLDER))) + (lambda (url-string) + (let ((url (imail-parse-partial-url url-string))) + (create-folder url) + (message "Created folder " (url->string url))))) (define-command imail-delete-folder "Delete a specified folder and all its messages." @@ -1573,78 +1179,6 @@ The folder's type may not be changed." (rename-folder from to) (message "Folder renamed to " (url->string to))))) -(define-command imail-input - "Run IMAIL on a specified folder." - (lambda () - (list (prompt-for-imail-url-string "Run IMAIL on folder" #f - 'HISTORY 'IMAIL - 'REQUIRE-MATCH? #t))) - (lambda (url-string) - ((ref-command imail) url-string))) - -(define-command imail-input-from-folder - "Append messages to this folder from a specified folder." - (lambda () - (list (prompt-for-imail-url-string "Get messages from folder" #f - 'HISTORY 'IMAIL-INPUT - 'HISTORY-INDEX 0 - 'REQUIRE-MATCH? #t))) - (lambda (url-string) - (let ((url (imail-parse-partial-url url-string)) - (folder (selected-folder))) - (let ((from (open-folder url)) - (to (folder-url folder))) - (let ((n (folder-length from))) - (do ((i 0 (+ i 1))) - ((= i n)) - ((message-wrapper #f - "Copying message " - (number->string (+ i 1)) - "/" - (number->string n)) - (lambda () (append-message (get-message from i) to)))) - ((ref-command imail-get-new-mail) #f) - (message (number->string n) - " message" - (if (= n 1) "" "s") - " copied from " - (url->string url))))))) - -(define-command imail-output - "Append this message to a specified folder." - (lambda () - (list (prompt-for-imail-url-string "Output to folder" #f - 'HISTORY 'IMAIL-OUTPUT - 'HISTORY-INDEX 0) - (command-argument))) - (lambda (url-string argument) - (let ((url (imail-parse-partial-url url-string)) - (delete? (ref-variable imail-delete-after-output))) - (move-relative-undeleted (or argument (and delete? 1)) - (lambda (message) - (append-message message url) - (message-filed message) - (if delete? (delete-message message)))) - (let ((n (if argument (command-argument-numeric-value argument) 1))) - (message (number->string n) - " message" - (if (= n 1) "" "s") - " written to " - (url->string url)))))) - -(define-command imail-copy-messages - "Append all messages from this folder to a specified folder. -The messages are NOT marked as filed. -The messages are NOT deleted even if imail-delete-after-output is true. -This command is meant to be used to move the contents of a folder - either to or from an IMAP server." - (lambda () - (list (prompt-for-imail-url-string "Copy all messages to folder" #f - 'HISTORY 'IMAIL-OUTPUT - 'HISTORY-INDEX 0))) - (lambda (url-string) - (copy-folder (selected-folder) (imail-parse-partial-url url-string)))) - (define-command imail-copy-folder "Copy all messages from a specified folder to another folder. If the target folder exists, the messages are appended to it. @@ -1667,496 +1201,973 @@ If it doesn't exist, it is created first." (url-base-name (imail-parse-partial-url from))) 'HISTORY 'IMAIL-COPY-FOLDER-TARGET)))) (lambda (from to) - (copy-folder (open-folder (imail-parse-partial-url from)) - (imail-parse-partial-url to)))) - -(define (copy-folder folder to) - (with-open-connection to - (lambda () - (let ((n (folder-length folder))) - (do ((i 0 (+ i 1))) - ((= i n)) - ((message-wrapper #f - "Copying message " - (number->string (+ i 1)) - "/" - (number->string n)) - (lambda () (append-message (get-message folder i) to)))) - (message (number->string n) - " message" - (if (= n 1) "" "s") - " copied to " - (url->string to)))))) + (let ((folder (open-folder (imail-parse-partial-url from))) + (to (imail-parse-partial-url to))) + (with-open-connection to + (lambda () + (let ((n (folder-length folder))) + (do ((i 0 (+ i 1))) + ((= i n)) + ((message-wrapper #f + "Copying message " + (number->string (+ i 1)) + "/" + (number->string n)) + (lambda () (append-message (get-message folder i) to)))) + (message (number->string n) + " message" + (if (= n 1) "" "s") + " copied to " + (url->string to)))))))) + +(define (copy-folder folder to)) -;;;; Attachments - -(define-command imail-save-attachment - "Save the attachment at point. -If point is not on an attachment, prompts for the attachment to save. -With prefix argument, prompt even when point is on an attachment." - "P" - (lambda (always-prompt?) - (let ((attachment - (maybe-prompt-for-mime-attachment (current-point) always-prompt?))) - (save-mime-attachment (car attachment) - (cdr attachment) - (selected-message) - (selected-buffer))))) - -(define (maybe-prompt-for-mime-attachment mark always-prompt?) - (let ((attachment (mark-mime-attachment mark))) - (if (and attachment (not always-prompt?)) - attachment - (let ((attachments (buffer-mime-attachments (mark-buffer mark)))) - (if (null? attachments) - (editor-error "This message has no attachments.")) - (let ((alist - (uniquify-mime-attachment-names - (map (lambda (b.s) - (cons (mime-attachment-name (car b.s) (cdr b.s) #t) - b.s)) - attachments)))) - (prompt-for-alist-value "Save attachment" - alist - (and attachment - (let ((entry - (list-search-positive alist - (lambda (entry) - (eq? (cdr entry) - attachment))))) - (and entry - (car entry)))) - #f)))))) - -(define (uniquify-mime-attachment-names alist) - (let loop ((alist alist) (converted '())) - (if (pair? alist) - (loop (cdr alist) - (cons (cons (let ((name (caar alist))) - (let loop ((name* name) (n 1)) - (if (there-exists? converted - (lambda (entry) - (string=? (car entry) name*))) - (loop (string-append - name "<" (number->string n) ">") - (+ n 1)) - name*))) - (cdar alist)) - converted)) - (reverse! converted)))) - -(define (save-mime-attachment body selector message buffer) - (let ((filename - (prompt-for-file - "Save attachment as" - (let ((filename (mime-body-disposition-filename body))) - (and filename - (list - (merge-pathnames - (filter-mime-attachment-filename filename) - (or (buffer-get buffer 'IMAIL-MIME-ATTACHMENT-DIRECTORY #f) - (buffer-default-directory buffer))))))))) - (if (or (not (file-exists? filename)) - (prompt-for-yes-or-no? "File already exists; overwrite")) - (begin - (call-with-binary-output-file filename - (lambda (port) - (let ((string (message-mime-body-part message selector #f)) - (text? - (let ((type (mime-body-type body))) - (or (eq? type 'TEXT) - (eq? type 'MESSAGE))))) - (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)))))) - (buffer-put! buffer 'IMAIL-MIME-ATTACHMENT-DIRECTORY - (directory-pathname filename)))))) - -(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))) +;;;; Miscellany -(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-command imail-quit + "Quit out of IMAIL." + () + (lambda () + (let ((folder (selected-folder))) + (close-folder folder) + (imail-bury folder)))) -(define (mime-body-disposition-filename body) - (let ((disposition (mime-body-disposition body))) - (and disposition - (let ((entry (assq 'FILENAME (cdr disposition)))) - (and entry - (cdr entry)))))) +(define-command imail-bury + "Bury current IMAIL buffer and its summary buffer." + () + (lambda () + (imail-bury (selected-folder)))) -(define (filter-mime-attachment-filename filename) - (let ((filename - (let ((index - (string-find-previous-char-in-set - filename - char-set:mime-attachment-filename-delimiters))) - (if index - (string-tail filename (+ index 1)) - filename)))) - (and (not (string-find-next-char-in-set - filename - char-set:rejected-mime-attachment-filename)) - (if (eq? microcode-id/operating-system 'UNIX) - (string-replace filename #\space #\_) - filename)))) +(define (imail-bury folder) + (let ((folder-buffer (imail-folder->buffer folder #t))) + (for-each + (lambda (buffer) + (if (buffer-alive? buffer) + (let ((buffer* (other-buffer buffer))) + (for-each (lambda (window) + (if (window-has-no-neighbors? window) + (if buffer* + (select-buffer-in-window buffer* window #f)) + (window-delete! window))) + (buffer-windows buffer)) + (bury-buffer buffer)))) + (buffer-get folder-buffer 'IMAIL-ASSOCIATED-BUFFERS '())) + (let ((buffer (other-buffer folder-buffer))) + (if buffer + (for-each (lambda (window) + (select-buffer-in-window buffer window #f)) + (buffer-windows folder-buffer)))) + (bury-buffer folder-buffer))) -(define char-set:mime-attachment-filename-delimiters - (char-set #\/ #\\ #\:)) +(define-command imail-input + "Run IMAIL on a specified folder." + (lambda () + (list (prompt-for-imail-url-string "Run IMAIL on folder" #f + 'HISTORY 'IMAIL + 'REQUIRE-MATCH? #t))) + (lambda (url-string) + ((ref-command imail) url-string))) -(define char-set:rejected-mime-attachment-filename - (char-set-invert - (char-set-difference char-set:graphic - char-set:mime-attachment-filename-delimiters))) - -;;;; Sending mail +(define-command imail-save-folder + "Save the currently selected IMAIL folder." + () + (lambda () + (message + (if (save-folder (selected-folder)) + "Folder saved" + "(No changes need to be saved)")))) -(define-command imail-mail - "Send mail in another window. -While composing the message, use \\[mail-yank-original] to yank the -original message into it." +(define-command imail-toggle-message + "Toggle between standard and raw formats for message." () (lambda () - (make-mail-buffer '(("To" "") ("Subject" "")) - (chase-imail-buffer (selected-buffer)) - select-buffer-other-window))) + (let ((message (selected-message))) + (select-message (selected-folder) + message + #t + (not (get-property message 'RAW? #f)))))) + +(define-command imail-get-new-mail + "Probe the mail server for new mail. +Selects the first new message if any new mail. + (Currently useful only for IMAP folders.) -(define (imail-yank-original buffer mark) - (let ((message (selected-message #t buffer))) - (insert-header-fields message #f mark) - (insert-string (message-body message) mark))) +You can also specify another folder to get mail from. +A prefix argument says to prompt for a URL and append all messages + from that folder to the current one." + (lambda () + (list (and (command-argument) + (prompt-for-imail-url-string "Get messages from folder" #f + 'HISTORY 'IMAIL-INPUT + 'HISTORY-INDEX 0 + 'REQUIRE-MATCH? #t)))) + (lambda (url-string) + (if url-string + ((ref-command imail-input-from-folder) url-string) + (let* ((folder (selected-folder)) + (count (folder-modification-count folder))) + (probe-folder folder) + (if (> (folder-modification-count folder) count) + (select-message folder + (or (navigator/first-unseen-message folder) + (selected-message #f))) + (message "(No changes to mail folder)")))))) -(define-command imail-continue - "Continue composing outgoing message previously being composed." +(define-command imail-disconnect + "Disconnect the selected IMAIL folder from its server. +Has no effect on non-server-based folders." () - (lambda () ((ref-command mail-other-window) #t))) - -(define-command imail-forward - "Forward the current message to another user. -With prefix argument, \"resend\" the message instead of forwarding it; -see the documentation of `imail-resend'." - "P" - (lambda (resend?) - (if resend? - (dispatch-on-command (ref-command-object imail-resend)) - (imail-forward)))) + (lambda () + (disconnect-folder (selected-folder)))) -(define (imail-forward) - (let ((message (selected-message))) - (make-mail-buffer - `(("To" "") - ("Subject" - ,(string-append - "[" - (let ((from (get-first-header-field-value message "from" #f))) - (if from - (rfc822:canonicalize-address-string from) - "")) - ": " - (message-subject message) - "]"))) - #f - (lambda (mail-buffer) - (let ((raw? (ref-variable imail-forward-all-headers mail-buffer))) - (if (ref-variable imail-forward-using-mime mail-buffer) - (add-buffer-mime-attachment! - mail-buffer - 'MESSAGE 'RFC822 '() '(INLINE) - (map header-field->mail-header - (let ((headers (message-header-fields message))) - (if raw? - headers - (maybe-reformat-headers headers mail-buffer)))) - (message-body message)) - (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))) - (mark-temporary! mark)))) - (if (window-has-no-neighbors? (current-window)) - (select-buffer mail-buffer) - (select-buffer-other-window mail-buffer)) - (message-forwarded message))))) +(define-command imail-search + "Show message containing next match for given string. +Negative argument means search in reverse." + (lambda () + (let ((reverse? (< (command-argument-numeric-value (command-argument)) 0))) + (list (prompt-for-string (string-append (if reverse? "Reverse " "") + "IMAIL search") + #f + 'DEFAULT-TYPE 'INSERTED-DEFAULT + 'HISTORY 'IMAIL-SEARCH + 'HISTORY-INDEX 0) + reverse?))) + (lambda (pattern reverse?) + (let ((folder (selected-folder)) + (msg + (string-append (if reverse? "Reverse " "") + "IMAIL search for " pattern "..."))) + (message msg) + (let ((index + (let ((index (message-index (selected-message)))) + (let loop + ((indexes + (let ((indexes (search-folder folder pattern))) + (if reverse? + (reverse indexes) + indexes)))) + (and (pair? indexes) + (if (if reverse? + (< (car indexes) index) + (> (car indexes) index)) + (car indexes) + (loop (cdr indexes)))))))) + (if index + (begin + (select-message folder index) + (message msg "done")) + (editor-failure "Search failed: " pattern)))))) -(define-command imail-resend - "Resend current message to ADDRESSES. -ADDRESSES is a string consisting of several addresses separated by commas." - "sResend to" - (lambda (addresses) - (let ((buffer (selected-buffer)) - (message (selected-message))) - (make-mail-buffer - `(("Resent-From" ,(mail-from-string buffer)) - ("Resent-Date" ,(universal-time->string (get-universal-time))) - ("Resent-To" ,addresses) - ,@(if (ref-variable mail-self-blind buffer) - `(("Resent-Bcc" ,(mail-from-string buffer))) - '()) - ,@(map header-field->mail-header - (list-transform-negative (message-header-fields message) - (lambda (header) - (string-ci=? (header-field-name header) "sender"))))) - #f - (lambda (mail-buffer) - (with-buffer-point-preserved mail-buffer +;;;; URLs + +(define (imail-default-url) + (let ((primary-folder (ref-variable imail-primary-folder #f))) + (if primary-folder + (imail-parse-partial-url primary-folder) + (imail-get-default-url #f)))) + +(define (imail-parse-partial-url string) + (parse-url-string string imail-get-default-url)) + +(define (imail-get-default-url protocol) + (let ((do-imap + (lambda () + (call-with-values + (lambda () + (let ((server (ref-variable imail-default-imap-server #f))) + (let ((colon (string-find-next-char server #\:))) + (if colon + (values + (string-head server colon) + (or (string->number (string-tail server (+ colon 1))) + (error "Invalid port specification:" server))) + (values server 143))))) + (lambda (host port) + (make-imap-url (or (ref-variable imail-default-user-id #f) + (current-user-name)) + host + port + (ref-variable imail-default-imap-mailbox + #f))))))) + (cond ((not protocol) + (let ((folder + (buffer-get (chase-imail-buffer (selected-buffer)) + 'IMAIL-FOLDER + #f))) + (if folder + (folder-url folder) + (do-imap)))) + ((string-ci=? protocol "imap") (do-imap)) + ((string-ci=? protocol "rmail") (make-rmail-url "~/RMAIL")) + ((string-ci=? protocol "umail") (make-umail-url "~/inbox.mail")) + (else (error:bad-range-argument protocol))))) + +(define (prompt-for-imail-url-string prompt default . options) + (let ((get-option + (lambda (key) + (let loop ((options options)) + (and (pair? options) + (pair? (cdr options)) + (if (eq? (car options) key) + (cadr options) + (loop (cddr options))))))) + (default + (cond ((string? default) default) + ((url? default) (url->string default)) + ((not default) (url-container-string (imail-default-url))) + (else (error "Illegal default:" default))))) + (let ((history (get-option 'HISTORY))) + (if (null? (prompt-history-strings history)) + (set-prompt-history-strings! history (list default)))) + (apply prompt-for-completed-string + prompt + (if (= (or (get-option 'HISTORY-INDEX) -1) -1) default #f) + (lambda (string if-unique if-not-unique if-not-found) + (url-complete-string string imail-get-default-url + if-unique if-not-unique if-not-found)) + (lambda (string) + (url-string-completions string imail-get-default-url)) + (lambda (string) + (let ((url + (ignore-errors + (lambda () + (parse-url-string string imail-get-default-url))))) + (and (url? url) + (url-exists? url)))) + 'DEFAULT-TYPE 'INSERTED-DEFAULT + options))) + +;;;; Core interface to front end + +;;; The mailer core abstraction, which otherwise doesn't know about +;;; the presentation layer, occasionally needs some presentation +;;; services. The hooks in this section provide them. + +(define (imail-ui:present-user-alert procedure) + (call-with-output-to-temporary-buffer " *IMAP alert*" + '(READ-ONLY SHRINK-WINDOW + FLUSH-ON-SPACE) + procedure)) + +(define (imail-ui:message-wrapper . arguments) + (let ((prefix (string-append (message-args->string arguments) "..."))) + (lambda (thunk) + (fluid-let ((*imail-message-wrapper-prefix* prefix)) + (message prefix) + (let ((v (thunk))) + (message prefix "done") + v))))) + +(define (imail-ui:progress-meter current total) + (if (and *imail-message-wrapper-prefix* (< 0 current total)) + (message *imail-message-wrapper-prefix* + (string-pad-left + (number->string (round->exact (* (/ current total) 100))) + 3) + "% (of " + (number->string total) + ")"))) + +(define *imail-message-wrapper-prefix* #f) + +(define imail-ui:message message) +(define imail-ui:prompt-for-yes-or-no? prompt-for-yes-or-no?) + +(define (imail-ui:body-cache-limit message) + (ref-variable imail-body-cache-limit + (let ((folder (message-folder message))) + (and folder + (imail-folder->buffer folder #f))))) + +(define (imail-ui:call-with-pass-phrase url receiver) + (let ((key (url-pass-phrase-key url)) + (retention-time (ref-variable imail-pass-phrase-retention-time #f))) + (let ((entry (hash-table/get memoized-pass-phrases key #f))) + (if entry + (begin + (without-interrupts + (lambda () + (deregister-timer-event (vector-ref entry 1)) + (set-up-pass-phrase-timer! entry key retention-time))) + (call-with-unobscured-pass-phrase (vector-ref entry 0) receiver)) + (call-with-pass-phrase + (string-append "Pass phrase for " key) + (lambda (pass-phrase) + (if (> retention-time 0) + (hash-table/put! + memoized-pass-phrases + key + (let ((entry + (vector (obscure-pass-phrase pass-phrase) #f #f))) + (set-up-pass-phrase-timer! entry key retention-time) + entry))) + (receiver pass-phrase))))))) + +(define (imail-ui:delete-stored-pass-phrase url) + (hash-table/remove! memoized-pass-phrases (url-pass-phrase-key url))) + +(define (set-up-pass-phrase-timer! entry key retention-time) + ;; A race condition can occur when the timer event is re-registered. + ;; If the previous timer event is queued but not executed before + ;; being deregistered, then it will run after the re-registration + ;; and try to delete the record. By matching on ID, the previous + ;; event sees that it has been superseded and does nothing. + (let ((id (list 'ID))) + (vector-set! entry 2 id) + (vector-set! entry 1 + (register-timer-event (* retention-time 60000) + (lambda () + (without-interrupts (lambda () - (insert-string (message-body message) (buffer-end mail-buffer)))) - (disable-buffer-mime-processing! mail-buffer) - (if (window-has-no-neighbors? (current-window)) - (select-buffer mail-buffer) - (select-buffer-other-window mail-buffer)) - (message-resent message)))))) + (let ((entry (hash-table/get memoized-pass-phrases key #f))) + (if (and entry (eq? (vector-ref entry 2) id)) + (hash-table/remove! memoized-pass-phrases key)))))))))) + +(define memoized-pass-phrases + (make-string-hash-table)) + +(define (obscure-pass-phrase clear-text) + (let ((n (string-length clear-text))) + (let ((noise (random-byte-vector n))) + (let ((obscured-text (make-string (* 2 n)))) + (string-move! noise obscured-text 0) + (do ((i 0 (fix:+ i 1))) + ((fix:= i n)) + (vector-8b-set! obscured-text (fix:+ i n) + (fix:xor (vector-8b-ref clear-text i) + (vector-8b-ref noise i)))) + obscured-text)))) + +(define (call-with-unobscured-pass-phrase obscured-text receiver) + (let ((n (quotient (string-length obscured-text) 2)) + (clear-text)) + (dynamic-wind + (lambda () + (set! clear-text (make-string n)) + unspecific) + (lambda () + (do ((i 0 (fix:+ i 1))) + ((fix:= i n)) + (vector-8b-set! clear-text i + (fix:xor (vector-8b-ref obscured-text i) + (vector-8b-ref obscured-text (fix:+ i n))))) + (receiver clear-text)) + (lambda () + (string-fill! clear-text #\NUL) + (set! clear-text) + unspecific)))) + +;;;; Navigation aids + +(define (move-relative-any argument operation) + (move-relative argument #f "message" operation)) + +(define (move-relative-undeleted argument operation) + (move-relative argument message-undeleted? "undeleted message" operation)) + +(define (move-relative argument predicate noun operation) + (if argument + (let ((delta (command-argument-numeric-value argument))) + (if (not (= 0 delta)) + (call-with-values + (lambda () + (if (< delta 0) + (values (- delta) navigator/previous-message "previous") + (values delta navigator/next-message "next"))) + (lambda (n step direction) + (let ((folder (selected-folder)) + (msg (selected-message))) + (let loop ((n n) (msg msg) (winner #f)) + (if operation (operation next)) + (let ((next (step msg predicate))) + (cond ((not next) + (if winner (select-message folder winner)) + (message "No " direction " " noun)) + ((= n 1) + (select-message folder next)) + (else + (loop (- n 1) next next)))))))))) + (if operation (operation (selected-message))))) + +;;;; Message selection + +(define (select-message folder selector #!optional force? raw?) + (let ((buffer (imail-folder->buffer folder #t)) + (message + (cond ((message? selector) + (and (message-attached? selector folder) + selector + (let ((index (message-index selector))) + (if (< index (folder-length folder)) + index + (last-message folder))))) + ((not selector) + (last-message folder)) + ((and (exact-integer? selector) + (<= 0 selector) + (< selector (folder-length folder))) + (get-message folder selector)) + (else + (error:wrong-type-argument selector "message selector" + 'SELECT-MESSAGE)))) + (raw? (if (default-object? raw?) #f raw?))) + (if (or (if (default-object? force?) #f force?) + (not (eq? message (buffer-get buffer 'IMAIL-MESSAGE 'UNKNOWN)))) + (begin + (set-buffer-writeable! buffer) + (buffer-widen! buffer) + (region-delete! (buffer-region buffer)) + (associate-imail-with-buffer buffer folder message) + (set-buffer-major-mode! buffer (ref-mode-object imail)) + (let ((mark (mark-left-inserting-copy (buffer-start buffer)))) + (with-read-only-defeated mark + (lambda () + (if message + (begin + (store-property! message 'RAW? raw?) + (insert-header-fields message raw? mark) + (cond (raw? + (insert-string (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)))))) + (insert-string "[This folder has no messages in it.]" + mark)))) + (mark-temporary! mark)) + (set-buffer-point! buffer (buffer-start buffer)) + (buffer-not-modified! buffer))) + (if message + (message-seen message)) + (folder-event folder 'SELECT-MESSAGE message))) + +(define (selected-folder #!optional error? buffer) + (or (let ((buffer + (chase-imail-buffer + (if (or (default-object? buffer) (not buffer)) + (selected-buffer) + buffer)))) + (let ((folder (buffer-get buffer 'IMAIL-FOLDER 'UNKNOWN))) + (if (eq? 'UNKNOWN folder) + (error "IMAIL-FOLDER property not bound:" buffer)) + folder)) + (and (if (default-object? error?) #t error?) + (error "No selected IMAIL folder.")))) + +(define (selected-message #!optional error? buffer) + (or (let ((buffer + (if (or (default-object? buffer) (not buffer)) + (selected-buffer) + buffer))) + (let ((method (navigator/selected-message buffer))) + (if method + (method buffer) + (let ((buffer (chase-imail-buffer buffer))) + (let ((message (buffer-get buffer 'IMAIL-MESSAGE 'UNKNOWN))) + (if (eq? message 'UNKNOWN) + (error "IMAIL-MESSAGE property not bound:" buffer)) + (and message + (let ((folder (selected-folder #f buffer))) + (if (message-attached? message folder) + message + (let ((message + (let ((index + (and folder + (message-detached? message) + (message-index message)))) + (and index + (< index (folder-length folder)) + (get-message folder index))))) + (buffer-put! buffer 'IMAIL-MESSAGE message) + message))))))))) + (and (if (default-object? error?) #t error?) + (error "No selected IMAIL message.")))) + +;;;; Buffer associations + +(define (associate-imail-with-buffer buffer folder message) + (without-interrupts + (lambda () + (buffer-put! buffer 'IMAIL-FOLDER folder) + (buffer-put! buffer 'IMAIL-MESSAGE message) + (store-property! folder 'BUFFER buffer) + (set-buffer-default-directory! + buffer + (if (file-folder? folder) + (directory-pathname (file-folder-pathname folder)) + (user-homedir-pathname))) + (add-event-receiver! (folder-modification-event folder) + (lambda (folder type parameters) + (if (eq? type 'EXPUNGE) + (maybe-add-command-suffix! notice-message-expunge + folder + (car parameters)) + (maybe-add-command-suffix! notice-folder-modifications folder)))) + (add-kill-buffer-hook buffer delete-associated-buffers) + (add-kill-buffer-hook buffer stop-probe-folder-thread) + (start-probe-folder-thread buffer)))) + +(define (delete-associated-buffers folder-buffer) + (for-each (lambda (buffer) + (if (buffer-alive? buffer) + (kill-buffer buffer))) + (buffer-get folder-buffer 'IMAIL-ASSOCIATED-BUFFERS '()))) + +(define (imail-folder->buffer folder error?) + (or (let ((buffer (get-property folder 'BUFFER #f))) + (and buffer + (if (buffer-alive? buffer) + buffer + (begin + (remove-property! folder 'BUFFER) + #f)))) + (and error? (error:bad-range-argument folder 'IMAIL-FOLDER->BUFFER)))) + +(define (imail-message->buffer message error?) + (or (list-search-positive (buffer-list) + (lambda (buffer) + (eq? (buffer-get buffer 'IMAIL-MESSAGE #f) message))) + (and error? (error:bad-range-argument message 'IMAIL-MESSAGE->BUFFER)))) + +(define (associate-buffer-with-imail-buffer folder-buffer buffer) + (without-interrupts + (lambda () + (buffer-put! buffer 'IMAIL-FOLDER-BUFFER folder-buffer) + (let ((buffers (buffer-get folder-buffer 'IMAIL-ASSOCIATED-BUFFERS '()))) + (if (not (memq buffer buffers)) + (buffer-put! folder-buffer 'IMAIL-ASSOCIATED-BUFFERS + (cons buffer buffers)))) + (add-kill-buffer-hook buffer dissociate-buffer-from-imail-buffer)))) + +(define (dissociate-buffer-from-imail-buffer buffer) + (without-interrupts + (lambda () + (let ((folder-buffer (buffer-get buffer 'IMAIL-FOLDER-BUFFER #f))) + (if folder-buffer + (begin + (buffer-remove! buffer 'IMAIL-FOLDER-BUFFER) + (buffer-put! folder-buffer 'IMAIL-ASSOCIATED-BUFFERS + (delq! buffer + (buffer-get folder-buffer + 'IMAIL-ASSOCIATED-BUFFERS + '())))))) + (remove-kill-buffer-hook buffer dissociate-buffer-from-imail-buffer)))) + +(define (chase-imail-buffer buffer) + (or (buffer-get buffer 'IMAIL-FOLDER-BUFFER #f) + buffer)) + +;;;; Mode-line updates + +(define (notice-message-expunge folder index) + (let ((buffer (imail-folder->buffer folder #f))) + (if buffer + (let ((m (selected-message #f buffer))) + (if (or (not m) + (message-detached? m)) + (select-message folder + (let ((length (folder-length folder))) + (cond ((< index length) index) + ((> length 0) (- length 1)) + (else #f))) + #t))))) + (notice-folder-modifications folder)) + +(define (notice-folder-modifications folder) + (let ((buffer (imail-folder->buffer folder #f))) + (if buffer + (begin + (local-set-variable! mode-line-process + (imail-mode-line-summary-string buffer) + buffer) + (buffer-modeline-event! buffer 'PROCESS-STATUS))))) + +(define (imail-mode-line-summary-string buffer) + (let ((folder (selected-folder #f buffer)) + (message (selected-message #f buffer))) + (and folder + (let ((status (folder-connection-status folder))) + (string-append + (if (eq? status 'NO-SERVER) + "" + (string-append " " (symbol->string status))) + (if (and message (message-attached? message folder)) + (let ((index (message-index message))) + (if index + (let ((n (folder-length folder))) + (string-append + " " + (number->string (+ 1 index)) + "/" + (number->string n) + (let loop ((i 0) (unseen 0)) + (if (< i n) + (loop (+ i 1) + (if (message-unseen? + (get-message folder i)) + (+ unseen 1) + unseen)) + (if (> unseen 0) + (string-append " (" + (number->string unseen) + " unseen)") + ""))) + (let ((flags + (flags-delete "seen" (message-flags message)))) + (if (pair? flags) + (string-append + " " + (decorated-string-append "" "," "" flags)) + "")))) + " 0/0")) + "")))))) + +;;;; Probe-folder thread + +(define (start-probe-folder-thread buffer) + (stop-probe-folder-thread buffer) + (let ((folder (buffer-get buffer 'IMAIL-FOLDER #f)) + (interval (ref-variable imail-update-interval #f))) + (if (and folder interval + (not (get-property folder 'PROBE-REGISTRATION #f))) + (let ((holder (list #f))) + (set-car! holder + (register-inferior-thread! + (let ((thread + (create-thread + editor-thread-root-continuation + (probe-folder-thread holder + (* 1000 interval))))) + (detach-thread thread) + thread) + (probe-folder-output-processor + (weak-cons folder unspecific)))) + (store-property! folder 'PROBE-REGISTRATION holder))))) -(define (header-field->mail-header header) - (list (header-field-name header) - (let ((v (header-field-value header))) - (if (string-prefix? " " v) - (string-tail v 1) - v)))) +(define ((probe-folder-thread holder interval)) + (do () (#f) + (let ((registration (car holder))) + (cond ((eq? registration 'KILL-THREAD) (exit-current-thread unspecific)) + (registration (inferior-thread-output! registration)))) + (sleep-current-thread interval))) -(define (with-buffer-point-preserved buffer thunk) - (let ((point (mark-right-inserting-copy (buffer-point buffer)))) - (let ((value (thunk))) - (set-buffer-point! buffer point) - (mark-temporary! point) - value))) +(define ((probe-folder-output-processor folder)) + (let ((folder (weak-car folder))) + (and folder + (eq? (folder-connection-status folder) 'ONLINE) + (begin + (probe-folder folder) + #t)))) + +(define (stop-probe-folder-thread buffer) + (without-interrupts + (lambda () + (let ((folder (buffer-get buffer 'IMAIL-FOLDER #f))) + (if folder + (begin + (let ((holder (get-property folder 'PROBE-REGISTRATION #f))) + (if holder + (begin + (let ((registration (car holder))) + (if (and registration + (not (eq? registration 'KILL-THREAD))) + (deregister-inferior-thread! registration))) + (set-car! holder 'KILL-THREAD)))) + (remove-property! folder 'PROBE-REGISTRATION))))))) -(define-command imail-reply - "Reply to the current message. -Normally include CC: to all other recipients of original message; - prefix argument means ignore them. -While composing the reply, use \\[mail-yank-original] to yank the - original message into it." - "P" - (lambda (just-sender?) - (let ((message (selected-message))) - (make-mail-buffer (imail-reply-headers message (not just-sender?)) - (chase-imail-buffer (selected-buffer)) - (lambda (mail-buffer) - (message-answered message) - (select-buffer-other-window mail-buffer)))))) +(define (insert-header-fields headers raw? mark) + (for-each (lambda (header) + (insert-string (header-field-name header) mark) + (insert-char #\: mark) + (insert-string (header-field-value header) mark) + (insert-newline mark)) + (let ((headers (->header-fields headers))) + (if raw? + headers + (maybe-reformat-headers + headers + (or (and (message? headers) + (imail-message->buffer headers #f)) + mark))))) + (insert-newline mark)) -(define (imail-reply-headers message cc?) - (let ((resent-reply-to - (get-last-header-field-value message "resent-reply-to" #f)) - (from (get-first-header-field-value message "from" #f))) - `(("To" - ,(rfc822:canonicalize-address-string - (or resent-reply-to - (get-all-header-field-values message "reply-to") - from))) - ("CC" - ,(and cc? - (let ((to - (if resent-reply-to - (get-last-header-field-value message "resent-to" #f) - (get-all-header-field-values message "to"))) - (cc - (if resent-reply-to - (get-last-header-field-value message "resent-cc" #f) - (get-all-header-field-values message "cc")))) - (let ((cc - (if (and to cc) - (string-append to ", " cc) - (or to cc)))) - (and cc - (let ((addresses - (imail-dont-reply-to - (rfc822:string->addresses cc)))) - (and (pair? addresses) - (rfc822:addresses->string addresses)))))))) - ("In-reply-to" - ,(if resent-reply-to - (make-in-reply-to-field - from - (get-last-header-field-value message "resent-date" #f) - (get-last-header-field-value message "resent-message-id" #f)) - (make-in-reply-to-field - from - (get-first-header-field-value message "date" #f) - (get-first-header-field-value message "message-id" #f)))) - ("Subject" - ,(let ((subject - (or (and resent-reply-to - (let ((subject - (get-last-header-field-value message - "resent-subject" - #f))) - (and subject - (strip-subject-re subject)))) - (message-subject message)))) - (if (ref-variable imail-reply-with-re) - (string-append "Re: " subject) - subject)))))) +(define (maybe-reformat-headers headers buffer) + (let ((headers + (cond ((ref-variable imail-kept-headers buffer) + => (lambda (regexps) + (append-map! + (lambda (regexp) + (list-transform-positive headers + (lambda (header) + (re-string-match regexp + (header-field-name header) + #t)))) + regexps))) + ((ref-variable imail-ignored-headers buffer) + => (lambda (regexp) + (list-transform-negative headers + (lambda (header) + (re-string-match regexp + (header-field-name header) + #t))))) + (else 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))) -(define (imail-dont-reply-to addresses) - (if (not (ref-variable imail-dont-reply-to-names)) - (set-variable! - imail-dont-reply-to-names - (string-append - (let ((imail-default-dont-reply-to-names - (ref-variable imail-default-dont-reply-to-names))) - (if imail-default-dont-reply-to-names - (string-append imail-default-dont-reply-to-names "\\|") - "")) - (re-quote-string (current-user-name)) - "\\>"))) - (let ((pattern - (re-compile-pattern - (string-append "\\(.*!\\|\\)\\(" - (ref-variable imail-dont-reply-to-names) - "\\)") - #t))) - (let loop ((addresses addresses)) - (if (pair? addresses) - (if (re-string-match pattern (car addresses)) - (loop (cdr addresses)) - (cons (car addresses) (loop (cdr addresses)))) - '())))) +;;;; MIME message formatting + +(define (insert-mime-message-body message mark) + (insert-mime-message-part message + (message-mime-body-structure message) + #f + '() + mark)) + +(define-generic insert-mime-message-part + (message body enclosure selector mark)) + +(define-method insert-mime-message-part + (message (body ) enclosure selector mark) + message enclosure + (insert-mime-message-attachment 'ATTACHMENT body selector mark)) + +(define-method insert-mime-message-part + (message (body ) enclosure selector mark) + enclosure + (let ((boundary (mime-body-parameter body 'BOUNDARY "----------"))) + (do ((parts (mime-body-multipart-parts body) (cdr parts)) + (i 0 (fix:+ i 1))) + ((null? parts)) + (if (fix:> i 0) + (begin + (insert-newline mark) + (if (ref-variable imail-use-original-mime-boundaries mark) + (begin + (insert-string "--" mark) + (insert-string boundary mark)) + (insert-chars #\- (- (mark-x-size mark) 1) mark)) + (insert-newline mark) + (insert-newline mark))) + (let ((part (car parts)) + (selector `(,@selector ,i))) + (if (and (fix:> i 0) + (eq? (mime-body-subtype body) 'ALTERNATIVE)) + (insert-mime-message-attachment 'ALTERNATIVE part selector mark) + (insert-mime-message-part message part body selector mark)))))) + +(define-method insert-mime-message-part + (message (body ) enclosure selector mark) + enclosure + (insert-header-fields (message-mime-body-part message + `(,@selector HEADER) + #t) + #f + mark) + (insert-mime-message-part message + (mime-body-message-body body) + body + selector + mark)) + +(define-method insert-mime-message-part + (message (body ) enclosure selector mark) + (let* ((message-enclosure? + (and enclosure + (eq? (mime-body-type enclosure) 'MESSAGE) + (eq? (mime-body-subtype enclosure) 'RFC822))) + (encoding + (let ((encoding + (and message-enclosure? + (mime-body-one-part-encoding enclosure)))) + (if (and encoding (not (memq encoding '(7BIT 8BIT BINARY)))) + ;; This is illegal, but Netscape does it. + encoding + (mime-body-one-part-encoding body))))) + (if (and (or (not enclosure) + (let ((disposition (mime-body-disposition body))) + (and disposition + (eq? (car disposition) 'INLINE))) + (let ((subtype (mime-body-subtype body))) + (or (eq? subtype 'PLAIN) + (memq subtype + (ref-variable imail-inline-mime-text-subtypes + mark))))) + (known-mime-encoding? encoding) + (re-string-match + (string-append "\\`" + (apply regexp-group + (ref-variable imail-known-mime-charsets + mark)) + "\\'") + (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)))))) + (insert-mime-message-attachment 'ATTACHMENT body selector mark)))) + +(define (insert-mime-message-attachment class body selector mark) + (let ((start (mark-right-inserting-copy mark))) + (insert-string "string class)) mark) + (insert-string " " mark) + (let ((column (mark-column mark))) + (let ((name (mime-attachment-name body selector #f))) + (if name + (begin + (insert-string "name=" mark) + (insert name mark) + (insert-newline mark) + (change-column column mark)))) + (insert-string "type=" mark) + (insert (mime-body-type body) mark) + (insert-string "/" mark) + (insert (mime-body-subtype body) mark) + (insert-newline mark) + (if (eq? (mime-body-type body) 'TEXT) + (begin + (change-column column mark) + (insert-string "charset=" mark) + (insert (mime-body-parameter body 'CHARSET "us-ascii") mark) + (insert-newline mark))) + (let ((encoding (mime-body-one-part-encoding body))) + (if (not (known-mime-encoding? encoding)) + (begin + (change-column column mark) + (insert-string "encoding=" mark) + (insert encoding mark) + (insert-newline mark)))) + (change-column column mark) + (insert-string "length=" mark) + (insert (mime-body-one-part-n-octets body) mark)) + (insert-string ">" mark) + (region-put! start mark 'IMAIL-MIME-ATTACHMENT (cons body selector)) + (mark-temporary! start)) + (insert-newline mark)) -(define (message-subject message) - (let ((subject (get-first-header-field-value message "subject" #f))) - (if subject - (strip-subject-re subject) - ""))) +(define (known-mime-encoding? encoding) + (memq encoding '(7BIT 8BIT BINARY QUOTED-PRINTABLE BASE64))) -(define (strip-subject-re subject) - (if (string-prefix-ci? "re:" subject) - (strip-subject-re (string-trim-left (string-tail subject 3))) - subject)) - -;;;; Miscellany +(define (mime-attachment-name body selector provide-default?) + (or (mime-body-parameter body 'NAME #f) + (and provide-default? + (string-append "unnamed-attachment-" + (if (null? selector) + "0" + (decorated-string-append + "" "." "" + (map (lambda (n) (number->string (+ n 1))) + selector))))))) -(define-command imail-quit - "Quit out of IMAIL." - () - (lambda () - (let ((folder (selected-folder))) - (close-folder folder) - (imail-bury folder)))) +(define (mark-mime-attachment mark) + (region-get mark 'IMAIL-MIME-ATTACHMENT #f)) -(define-command imail-bury - "Bury current IMAIL buffer and its summary buffer." - () - (lambda () - (imail-bury (selected-folder)))) +(define (buffer-mime-attachments buffer) + (let ((end (buffer-end buffer))) + (let loop ((start (buffer-start buffer)) (attachments '())) + (let ((index + (next-specific-property-change (mark-group start) + (mark-index start) + (mark-index end) + 'IMAIL-MIME-ATTACHMENT)) + (attachments + (let ((attachment (region-get start 'IMAIL-MIME-ATTACHMENT #f))) + (if attachment + (cons attachment attachments) + attachments)))) + (if index + (loop (make-mark (mark-group start) index) attachments) + (reverse! attachments)))))) + +;;;; Automatic wrap/fill -(define (imail-bury folder) - (let ((folder-buffer (imail-folder->buffer folder #t))) - (for-each - (lambda (buffer) - (if (buffer-alive? buffer) - (let ((buffer* (other-buffer buffer))) - (for-each (lambda (window) - (if (window-has-no-neighbors? window) - (if buffer* - (select-buffer-in-window buffer* window #f)) - (window-delete! window))) - (buffer-windows buffer)) - (bury-buffer buffer)))) - (buffer-get folder-buffer 'IMAIL-ASSOCIATED-BUFFERS '())) - (let ((buffer (other-buffer folder-buffer))) - (if buffer - (for-each (lambda (window) - (select-buffer-in-window buffer window #f)) - (buffer-windows folder-buffer)))) - (bury-buffer folder-buffer))) +(define (call-with-auto-wrapped-output-mark mark generator) + (case (ref-variable imail-auto-wrap mark) + ((#F) + (call-with-output-mark mark generator)) + ((FILL) + (let ((start (mark-right-inserting-copy mark)) + (end (mark-left-inserting-copy mark))) + (call-with-output-mark mark generator) + (fill-individual-paragraphs start end + (ref-variable fill-column start) #f #f) + (mark-temporary! start) + (mark-temporary! end))) + (else + (let ((start (mark-right-inserting-copy mark)) + (end (mark-left-inserting-copy mark))) + (call-with-output-mark mark generator) + (wrap-individual-paragraphs start end (- (mark-x-size mark) 1) #f) + (mark-temporary! start) + (mark-temporary! end))))) -(define-command imail-get-new-mail - "Probe the mail server for new mail. -Selects the first new message if any new mail. - (Currently useful only for IMAP folders.) +;;;; Navigation hooks -You can also specify another folder to get mail from. -A prefix argument says to prompt for a URL and append all messages - from that folder to the current one." - (lambda () - (list (and (command-argument) - (prompt-for-imail-url-string "Get messages from folder" #f - 'HISTORY 'IMAIL-INPUT - 'HISTORY-INDEX 0 - 'REQUIRE-MATCH? #t)))) - (lambda (url-string) - (if url-string - ((ref-command imail-input-from-folder) url-string) - (let* ((folder (selected-folder)) - (count (folder-modification-count folder))) - (probe-folder folder) - (if (> (folder-modification-count folder) count) - (select-message folder - (or (navigator/first-unseen-message folder) - (selected-message #f))) - (message "(No changes to mail folder)")))))) +(define (navigator/first-unseen-message folder) + ((or (imail-navigator imail-navigators/first-unseen-message) + first-unseen-message) + folder)) -(define-command imail-save-folder - "Save the currently selected IMAIL folder." - () - (lambda () - (message - (if (save-folder (selected-folder)) - "Folder saved" - "(No changes need to be saved)")))) +(define (navigator/first-message folder) + ((or (imail-navigator imail-navigators/first-message) + first-message) + folder)) -(define-command imail-toggle-message - "Toggle between standard and raw formats for message." - () - (lambda () - (let ((message (selected-message))) - (select-message (selected-folder) - message - #t - (not (get-property message 'RAW? #f)))))) +(define (navigator/last-message folder) + ((or (imail-navigator imail-navigators/last-message) + last-message) + folder)) -(define-command imail-disconnect - "Disconnect the selected IMAIL folder from its server. -Has no effect on non-server-based folders." - () - (lambda () - (disconnect-folder (selected-folder)))) - -(define-command imail-search - "Show message containing next match for given string. -Negative argument means search in reverse." - (lambda () - (let ((reverse? (< (command-argument-numeric-value (command-argument)) 0))) - (list (prompt-for-string (string-append (if reverse? "Reverse " "") - "IMAIL search") - #f - 'DEFAULT-TYPE 'INSERTED-DEFAULT - 'HISTORY 'IMAIL-SEARCH - 'HISTORY-INDEX 0) - reverse?))) - (lambda (pattern reverse?) - (let ((folder (selected-folder)) - (msg - (string-append (if reverse? "Reverse " "") - "IMAIL search for " pattern "..."))) - (message msg) - (let ((index - (let ((index (message-index (selected-message)))) - (let loop - ((indexes - (let ((indexes (search-folder folder pattern))) - (if reverse? - (reverse indexes) - indexes)))) - (and (pair? indexes) - (if (if reverse? - (< (car indexes) index) - (> (car indexes) index)) - (car indexes) - (loop (cdr indexes)))))))) - (if index - (begin - (select-message folder index) - (message msg "done")) - (editor-failure "Search failed: " pattern)))))) \ No newline at end of file +(define (navigator/next-message message #!optional predicate) + ((or (imail-navigator imail-navigators/next-message) + next-message) + message + (if (default-object? predicate) #f predicate))) + +(define (navigator/previous-message message #!optional predicate) + ((or (imail-navigator imail-navigators/previous-message) + previous-message) + message + (if (default-object? predicate) #f predicate))) + +(define (imail-navigator accessor) + (let ((navigators (buffer-get (selected-buffer) 'IMAIL-NAVIGATORS #f))) + (and navigators + (accessor navigators)))) + +(define (navigator/selected-message buffer) + (let ((navigators (buffer-get buffer 'IMAIL-NAVIGATORS #f))) + (and navigators + (imail-navigators/selected-message navigators)))) + +(define-structure (imail-navigators safe-accessors + (conc-name imail-navigators/)) + (first-unseen-message #f read-only #t) + (first-message #f read-only #t) + (last-message #f read-only #t) + (next-message #f read-only #t) + (previous-message #f read-only #t) + (selected-message #f read-only #t)) \ No newline at end of file