;;; -*-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
;;;
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?)
\f
(define-command imail
"Read and edit incoming mail.
then visits the mail folder at that URL.
IMAIL URLs take one of the following forms.
-imap://[<user-name>@]<host-name>
{:<port>]/<folder-name>
+imap://[<user-name>@]<host-name>
[:<port>]/<folder-name>
Specifies a folder on an IMAP server. The portions in brackets
are optional and are filled in automatically if omitted.
(selected-message #f))
#t)))))))
\f
-(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)))
-\f
-(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)))))
-\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))))
-\f
(define-major-mode imail read-only "IMAIL"
(lambda ()
(with-string-output-port
(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))
\f
(define imail-mode-description
\\[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.
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.")
\f
+(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))))))
+\f
(define-key 'imail #\a 'imail-add-flag)
(define-key 'imail #\b 'imail-bury)
(define-key 'imail #\c 'imail-continue)
(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)
;; 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)
;;(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)
\f
-(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))))))
-\f
;;;; Navigation
(define-command imail-select-message
()
(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.
"p"
(lambda (delta)
((ref-command imail-next-message) (- delta))))
-\f
+
(define-command imail-next-undeleted-message
"Show following non-deleted message.
With prefix argument N, moves forward N non-deleted messages,
"p"
(lambda (delta)
((ref-command imail-next-undeleted-message) (- delta))))
-
+\f
(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.
"p"
(lambda (delta)
((ref-command imail-next-same-subject) (- delta))))
-\f
+
(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.
'DEFAULT-TYPE 'INSERTED-DEFAULT
'HISTORY 'IMAIL-PROMPT-FOR-FLAGS
'HISTORY-INDEX 0))
+\f
+;;;; 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)))))
-\f
-;;;; 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))))
\f
-(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)))))))))
\f
-;;;; 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?))
+\f
+;;;; 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))))))
+\f
+;;;; 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))
-\f
-;;;; 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))))
+\f
+(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"))
- ""))))))
-\f
-;;;; 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)))
\f
-;;;; 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 <mime-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 <mime-body-multipart>) 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))))))
-\f
-(define-method insert-mime-message-part
- (message (body <mime-body-message>) 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 <mime-body-text>) 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)))
\f
-(define (insert-mime-message-attachment class body selector mark)
- (let ((start (mark-right-inserting-copy mark)))
- (insert-string "<IMAIL-" mark)
- (insert-string (string-upcase (symbol->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))))))
\f
-;;;; 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)))
\f
-;;;; 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)))
+\f
+;;;; 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))
-\f
-;;;; 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))))
-\f
-(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)))))))))
-\f
-;;;; 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?))
-\f
-;;;; 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."
(rename-folder from to)
(message "Folder renamed to " (url->string to)))))
\f
-(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)))))))
-\f
-(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.
(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))
\f
-;;;; 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))))
-\f
-(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)))
-\f
-;;;; 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))))))
+\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))))))
\f
-(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)))
+\f
+;;;; 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)))))
+\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))))
+\f
+;;;; 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)))))
+\f
+;;;; 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)))
+\f
+(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."))))
+\f
+;;;; 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))
+\f
+;;;; 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"))
+ ""))))))
+\f
+;;;; 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)))))))
\f
-(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)))
\f
-(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 <mime-body>) enclosure selector mark)
+ message enclosure
+ (insert-mime-message-attachment 'ATTACHMENT body selector mark))
+
+(define-method insert-mime-message-part
+ (message (body <mime-body-multipart>) 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 <mime-body-message>) 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))
+\f
+(define-method insert-mime-message-part
+ (message (body <mime-body-text>) 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))))
+\f
+(define (insert-mime-message-attachment class body selector mark)
+ (let ((start (mark-right-inserting-copy mark)))
+ (insert-string "<IMAIL-" mark)
+ (insert-string (string-upcase (symbol->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))
-\f
-;;;; 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))))))
+\f
+;;;; 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)))))
\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.)
+;;;; 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))))
-\f
-(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
projects / mit-scheme.git / commitdiff