--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/rmail.scm,v 1.1 1991/05/08 22:51:35 cph Exp $
+;;;
+;;; Copyright (c) 1991 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+;;; NOTE: Parts of this program (Edwin) were created by translation
+;;; from corresponding parts of GNU Emacs. Users should be aware that
+;;; the GNU GENERAL PUBLIC LICENSE may apply to these parts. A copy
+;;; of that license should have been included along with this file.
+;;;
+
+;;;; RMAIL Mail Reader
+
+(declare (usual-integrations))
+\f
+(define rmail-spool-directory
+ "/usr/mail/")
+
+(define-variable rmail-file-name
+ ""
+ "~/RMAIL"
+ string?)
+
+(define-variable rmail-last-file
+ "Last file used by \\[rmail-output]."
+ "~/xmail"
+ string?)
+
+(define-variable rmail-last-rmail-file
+ "Last file used by \\[rmail-output-to-rmail-file]."
+ "~/XMAIL"
+ string?)
+
+(define-variable rmail-inbox-list
+ ""
+ '()
+ list-of-strings?)
+
+(define-variable rmail-primary-inbox-list
+ "List of files which are inboxes for user's primary mail file ~/RMAIL.
+Empty list means the default, which is (\"~/mbox\" \"/usr/spool/mail/$USER\")
+\(the second name varies depending on the operating system)."
+ '()
+ list-of-strings?)
+
+(define-variable rmail-dont-reply-to-names
+ "A regular expression specifying names to prune in replying to messages.
+#f means don't reply to yourself."
+ false
+ string-or-false?)
+
+(define-variable rmail-default-dont-reply-to-names
+ "A regular expression specifying part of the value of the default value of
+the variable `rmail-dont-reply-to-names', for when the user does not set
+`rmail-dont-reply-to-names' explicitly. (The other part of the default
+value is the user's name.)
+It is useful to set this variable in the site customisation file."
+ "info-"
+ string?)
+
+(define-variable rmail-ignored-headers
+ "Gubbish header fields one would rather not see."
+ "^via:\\|^mail-from:\\|^origin:\\|^status:\\|^received:\\|^[a-z-]*message-id:\\|^summary-line:\\|^errors-to:"
+ string-or-false?)
+
+(define-variable rmail-message-filter
+ "If not #f, is a filter procedure for new headers in RMAIL.
+Called with the start and end marks of the header as arguments."
+ false
+ (lambda (object) (or (not object) (procedure? object))))
+
+(define-variable rmail-delete-after-output
+ "True means automatically delete a message that is copied to a file."
+ false
+ boolean?)
+
+(define-variable rmail-mode-hook
+ "An event distributor that is invoked when entering RMAIL mode."
+ (make-event-distributor))
+\f
+(define-major-mode rmail read-only "RMAIL"
+ "Rmail Mode is used by \\[rmail] for editing Rmail files.
+All normal editing commands are turned off.
+Instead, these commands are available:
+
+. Move point to front of this message (same as \\[beginning-of-buffer]).
+SPC Scroll to next screen of this message.
+DEL Scroll to previous screen of this message.
+n Move to Next non-deleted message.
+p Move to Previous non-deleted message.
+M-n Move to Next message whether deleted or not.
+M-p Move to Previous message whether deleted or not.
+> Move to the last message in Rmail file.
+j Jump to message specified by numeric position in file.
+M-s Search for string and show message it is found in.
+d Delete this message, move to next nondeleted.
+C-d Delete this message, move to previous nondeleted.
+u Undelete message. Tries current message, then earlier messages
+ till a deleted message is found.
+e Expunge deleted messages.
+s Expunge and save the file.
+q Quit Rmail: expunge, save, then switch to another buffer.
+C-x C-s Save without expunging.
+g Move new mail from system spool directory or mbox into this file.
+m Mail a message (same as \\[mail-other-window]).
+c Continue composing outgoing message started before.
+r Reply to this message. Like m but initializes some fields.
+f Forward this message to another user.
+o Output this message to an Rmail file (append it).
+C-o Output this message to a Unix-format mail file (append it).
+i Input Rmail file. Run Rmail on that file.
+a Add label to message. It will be displayed in the mode line.
+k Kill label. Remove a label from current message.
+C-M-n Move to Next message with specified label
+ (label defaults to last one specified).
+ Standard labels: filed, unseen, answered, forwarded, deleted.
+ Any other label is present only if you add it with `a'.
+C-M-p Move to Previous message with specified label
+C-M-h Show headers buffer, with a one line summary of each message.
+C-M-l Like h only just messages with particular label(s) are summarized.
+C-M-r Like h only just messages with particular recipient(s) are summarized.
+t Toggle header, show Rmail header if unformatted or vice versa.
+w Edit the current message. C-c C-c to return to Rmail."
+ (guarantee-variables-initialized)
+ (let ((buffer (current-buffer)))
+ (local-set-variable! mode-line-modified "--- ")
+ (local-set-variable! version-control 'NEVER)
+ ;;(local-set-variable! file-precious-flag true)
+ (local-set-variable! require-final-newline false)
+ (local-set-variable! rmail-last-file (ref-variable rmail-last-file))
+ (local-set-variable!
+ rmail-inbox-list
+ (let ((inboxes (parse-file-inboxes buffer)))
+ (if (and (null? inboxes)
+ (pathname=? (buffer-pathname buffer)
+ (->pathname (ref-variable rmail-file-name))))
+ (ref-variable rmail-primary-inbox-list)
+ inboxes)))
+ (buffer-put! buffer 'REVERT-BUFFER-METHOD rmail-revert-buffer)
+ (memoize-buffer buffer)
+ (set-buffer-read-only! buffer))
+ (event-distributor/invoke! (ref-variable rmail-mode-hook)))
+
+(define-major-mode rmail-edit text "RMAIL Edit"
+ "Major mode for editing the contents of an RMAIL message.
+The editing commands are the same as in Text mode,
+together with two commands to return to regular RMAIL:
+ * \\[rmail-abort-edit] cancels the changes you have made and returns to RMAIL
+ * \\[rmail-cease-edit] makes them permanent.")
+\f
+(define (guarantee-variables-initialized)
+ (if (null? (ref-variable rmail-primary-inbox-list))
+ (set-variable! rmail-primary-inbox-list
+ (list "~/mbox"
+ (string-append rmail-spool-directory
+ (unix/current-user-name)))))
+ (if (not (ref-variable rmail-dont-reply-to-names))
+ (set-variable!
+ rmail-dont-reply-to-names
+ (string-append
+ (let ((rmail-default-dont-reply-to-names
+ (ref-variable rmail-default-dont-reply-to-names)))
+ (if rmail-default-dont-reply-to-names
+ (string-append rmail-default-dont-reply-to-names "\\|")
+ ""))
+ (re-quote-string (unix/current-user-name))
+ "\\>")))
+ (if (not umail-message-end-regexp)
+ (set! umail-message-end-regexp
+ (string-append "\\("
+ umail-message-start-regexp
+ "\\|"
+ mmdf-message-start-regexp
+ "\\|"
+ babyl-header-start-regexp
+ "\\|^[\037]?"
+ babyl-message-start-regexp
+ "\\)"))))
+
+(define (parse-file-inboxes buffer)
+ (let ((start (buffer-start buffer))
+ (end (buffer-end buffer)))
+ (if (re-match-forward babyl-header-start-regexp start end false)
+ (let ((end
+ (or (re-search-forward babyl-header-end-regexp start end false)
+ end)))
+ (let ((start (search-forward "\nMail:" start end true)))
+ (if start
+ (parse-comma-list start end)
+ '())))
+ '())))
+
+(define (parse-comma-list start end)
+ (let loop ((start start))
+ (let ((start (skip-chars-forward " " start end)))
+ (let ((m (skip-chars-forward "^," start end)))
+ (cons (extract-string start (skip-chars-backward " " m start))
+ (if (mark< m end)
+ (loop (mark1+ m))
+ '()))))))
+\f
+(define-key 'rmail #\. 'beginning-of-buffer)
+(define-key 'rmail #\space 'scroll-up)
+(define-key 'rmail #\rubout 'scroll-down)
+(define-key 'rmail #\n 'rmail-next-undeleted-message)
+(define-key 'rmail #\p 'rmail-previous-undeleted-message)
+(define-key 'rmail #\m-n 'rmail-next-message)
+(define-key 'rmail #\m-p 'rmail-previous-message)
+(define-key 'rmail #\c-m-n 'rmail-next-labeled-message)
+(define-key 'rmail #\c-m-p 'rmail-previous-labeled-message)
+(define-key 'rmail #\a 'rmail-add-label)
+(define-key 'rmail #\k 'rmail-kill-label)
+(define-key 'rmail #\d 'rmail-delete-forward)
+(define-key 'rmail #\u 'rmail-undelete-previous-message)
+(define-key 'rmail #\e 'rmail-expunge)
+(define-key 'rmail #\x 'rmail-expunge)
+(define-key 'rmail #\s 'rmail-expunge-and-save)
+(define-key 'rmail #\g 'rmail-get-new-mail)
+(define-key 'rmail #\h 'rmail-summary)
+(define-key 'rmail #\c-m-h 'rmail-summary)
+(define-key 'rmail #\l 'rmail-summary-by-labels)
+(define-key 'rmail #\c-m-l 'rmail-summary-by-labels)
+(define-key 'rmail #\c-m-r 'rmail-summary-by-recipients)
+(define-key 'rmail #\t 'rmail-toggle-header)
+(define-key 'rmail #\m 'rmail-mail)
+(define-key 'rmail #\r 'rmail-reply)
+(define-key 'rmail #\c 'rmail-continue)
+(define-key 'rmail #\f 'rmail-forward)
+(define-key 'rmail #\m-s 'rmail-search)
+(define-key 'rmail #\j 'rmail-show-message)
+(define-key 'rmail #\o 'rmail-output-to-rmail-file)
+(define-key 'rmail #\c-o 'rmail-output)
+(define-key 'rmail #\i 'rmail-input)
+(define-key 'rmail #\q 'rmail-quit)
+(define-key 'rmail #\> 'rmail-last-message)
+(define-key 'rmail #\? 'describe-mode)
+(define-key 'rmail #\w 'rmail-edit-current-message)
+(define-key 'rmail #\c-d 'rmail-delete-backward)
+\f
+(define-command rmail
+ "Read and edit incoming mail.
+Moves messages into file named by rmail-file-name (a babyl format file)
+ and edits that file in RMAIL Mode.
+Type \\[describe-mode] once editing that file, for a list of RMAIL commands.
+
+May be called with filename as argument;
+then performs rmail editing on that file,
+but does not copy any new mail into the file."
+ (lambda ()
+ (list (and (command-argument)
+ (pathname->string
+ (prompt-for-input-truename "Run rmail on RMAIL file"
+ false)))))
+ (lambda (filename)
+ (rmail-find-file (or filename (ref-variable rmail-file-name)))
+ (let ((mode (current-major-mode)))
+ (cond ((eq? mode (ref-mode-object rmail-edit))
+ (editor-error "Exit rmail-edit mode before getting new mail"))
+ ((not (eq? mode (ref-mode-object rmail)))
+ (set-current-major-mode! (ref-mode-object rmail)))))
+ ((ref-command rmail-get-new-mail) false)))
+
+(define-command rmail-input
+ "Run RMAIL on file FILENAME."
+ "FRun rmail on RMAIL file"
+ (ref-command rmail))
+
+(define (rmail-find-file filename)
+ (fluid-let ((after-find-file rmail-after-find-file))
+ (find-file filename)))
+
+(define (rmail-find-file-revert buffer)
+ (fluid-let ((after-find-file rmail-after-find-file))
+ (find-file-revert buffer)))
+
+(define (rmail-revert-buffer buffer dont-use-auto-save? dont-confirm?)
+ (let ((n
+ (let ((memo (buffer-msg-memo buffer)))
+ (and (msg-memo? memo)
+ (msg-memo/number memo)))))
+ (fluid-let ((after-find-file rmail-after-find-file))
+ (revert-buffer-default buffer dont-use-auto-save? dont-confirm?))
+ (show-message buffer
+ (and n
+ (let ((memo (buffer-msg-memo buffer)))
+ (and (msg-memo? memo)
+ (<= n (msg-memo/number (msg-memo/last memo)))
+ n))))))
+
+(define (rmail-after-find-file buffer pathname)
+ pathname
+ ;; No need to auto save RMAIL files.
+ (disable-buffer-auto-save! buffer)
+ (convert-buffer-to-babyl-format buffer)
+ (set-buffer-major-mode! buffer (ref-mode-object rmail)))
+
+(define-command rmail-quit
+ "Quit out of RMAIL."
+ ()
+ (lambda ()
+ ((ref-command rmail-expunge-and-save))
+ ((ref-command bury-buffer))))
+
+(define-command rmail-expunge-and-save
+ "Expunge and save RMAIL file."
+ ()
+ (lambda ()
+ ((ref-command rmail-expunge))
+ ((ref-command save-buffer) false)))
+\f
+;;;; Mail input
+
+(define-command rmail-get-new-mail
+ "Move any new mail from this RMAIL file's inbox files.
+The inbox files can be specified with the file's Mail: option.
+The variable rmail-primary-inbox-list specifies the inboxes for
+your primary RMAIL file if it has no Mail: option.
+These are normally your ~/mbox and your /usr/spool/mail/$USER.
+
+You can also specify the file to get new mail from. In this
+case, the file of new mail is not changed or deleted.
+Noninteractively, you can pass the inbox file name as an argument.
+Interactively, a prefix argument causes us to read a file name
+and use that file as the inbox."
+ (lambda ()
+ (list (and (command-argument)
+ (pathname->string
+ (prompt-for-input-truename "Get new mail from file"
+ false)))))
+ (lambda (filename)
+ (let ((buffer (current-buffer)))
+ (rmail-find-file-revert buffer)
+ (let ((n-messages
+ (let ((memo (buffer-msg-memo buffer)))
+ (if (msg-memo? memo)
+ (msg-memo/number (msg-memo/last memo))
+ 0))))
+ (with-buffer-open buffer
+ (lambda ()
+ (with-buffer-undo-disabled buffer
+ (lambda ()
+ (if filename
+ (get-new-mail buffer (list filename) false)
+ (get-new-mail buffer
+ (ref-variable rmail-inbox-list)
+ true))))))
+ (show-message
+ buffer
+ (let ((memo (buffer-msg-memo buffer)))
+ (cond ((not (msg-memo? memo)) 0)
+ ((> (msg-memo/number (msg-memo/last memo)) n-messages)
+ (+ n-messages 1))
+ (else (msg-memo/number memo)))))))))
+\f
+(define (get-new-mail buffer inbox-list delete-inboxes?)
+ (let ((start (mark-right-inserting-copy (buffer-end buffer)))
+ (end (mark-left-inserting-copy (buffer-end buffer)))
+ (modified? (buffer-modified? buffer)))
+ (delete-string (skip-chars-backward " \t\n" end) end)
+ (let ((inserted-inboxes
+ (let loop ((filenames inbox-list) (result '()))
+ (if (null? filenames)
+ result
+ (loop (cdr filenames)
+ (let ((pathname
+ (insert-inbox-text buffer
+ end
+ (car filenames)
+ delete-inboxes?)))
+ (if pathname
+ (cons pathname result)
+ result)))))))
+ (let ((new-messages (convert-region-to-babyl-format start end)))
+ (if (> new-messages 0)
+ (begin
+ (memoize-messages buffer start end)
+ (save-buffer buffer
+ ;; If buffer has not changed yet, and has
+ ;; not been saved yet, don't replace the
+ ;; old backup file now.
+ (if (and (ref-variable make-backup-files buffer)
+ modified?)
+ false
+ 'NO-BACKUP))))
+ (if delete-inboxes?
+ (for-each (lambda (pathname)
+ (catch-file-errors (lambda () unspecific)
+ (lambda () (delete-file pathname))))
+ inserted-inboxes))
+ (cond ((> new-messages 0)
+ (message new-messages
+ " new message"
+ (if (= new-messages 1) "" "s")
+ " read"))
+ ((not (null? inbox-list))
+ (message "(No new mail has arrived)")))
+ (mark-temporary! end)
+ (mark-temporary! start)
+ new-messages))))
+\f
+(define (insert-inbox-text buffer mark filename rename?)
+ (let ((insert
+ (lambda (pathname)
+ (and (file-exists? pathname)
+ (let ((mark (mark-left-inserting-copy mark)))
+ (insert-file mark pathname)
+ (if (let ((char (mark-left-char mark)))
+ (and char
+ (not (char=? char #\newline))))
+ (insert-newline mark))
+ (mark-temporary! mark)
+ pathname)))))
+ (let ((source (->pathname filename)))
+ (cond ((not rename?)
+ (insert source))
+ ((string=? rmail-spool-directory
+ (pathname-directory-string source))
+ (rename-inbox-using-movemail source
+ insert
+ (buffer-default-directory buffer)))
+ (else
+ (rename-inbox-using-rename source insert))))))
+
+(define (rename-inbox-using-rename source insert)
+ (let ((target
+ (string->pathname (string-append (pathname->string source) "~"))))
+ (let ((msg
+ (string-append "Getting mail from "
+ (pathname->string source)
+ "...")))
+ (message msg)
+ (if (and (file-exists? source) (not (file-exists? target)))
+ (rename-file source target))
+ (let ((value (insert target)))
+ (message msg "done")
+ value))))
+
+(define (rename-inbox-using-movemail source insert directory)
+ (let ((source
+ ;; On some systems, /usr/spool/mail/foo is a directory and
+ ;; the actual inbox is /usr/spool/mail/foo/foo.
+ (if (file-directory? source)
+ (merge-pathnames (string->pathname (pathname-name source))
+ (pathname-as-directory source))
+ source))
+ (target
+ (merge-pathnames (string->pathname ".newmail")
+ (->pathname directory))))
+ (let ((msg
+ (string-append "Getting mail from "
+ (pathname->string source)
+ "...")))
+ (message msg)
+ (if (and (file-exists? source)
+ (not (file-exists? target)))
+ (let ((error-buffer (temporary-buffer " movemail errors")))
+ (let ((start (buffer-start error-buffer))
+ (end (buffer-end error-buffer)))
+ (run-synchronous-process false
+ start
+ (pathname->string
+ (edwin-etc-pathname "movemail"))
+ (pathname->string source)
+ (pathname->string target))
+ (if (mark< start end)
+ (error
+ (let ((m
+ (or (match-forward "movemail: " start end false)
+ start)))
+ (string-append
+ "movemail: "
+ (extract-string
+ m
+ (skip-chars-backward " \t" (line-end m 0) m)))))))
+ (kill-buffer error-buffer)))
+ (let ((value (insert target)))
+ (message msg "done")
+ value))))
+\f
+;;;; Moving around
+
+(define-command rmail-next-message
+ "Show following message whether deleted or not.
+With prefix argument N, moves forward N messages,
+or backward if N is negative."
+ "p"
+ (lambda (n)
+ (cond ((> n 0)
+ (let loop ((n n) (memo (current-msg-memo)) (winner false))
+ (let ((next (msg-memo/next memo)))
+ (cond ((not next)
+ (if winner (set-current-msg-memo! winner))
+ (message "No following message"))
+ ((= n 1)
+ (set-current-msg-memo! next))
+ (else
+ (loop (- n 1) next next))))))
+ ((< n 0)
+ ((ref-command rmail-previous-message) (- n))))))
+
+(define-command rmail-previous-message
+ "Show previous message whether deleted or not.
+With prefix argument N, moves backward N messages,
+or forward if N is negative."
+ "p"
+ (lambda (n)
+ (cond ((> n 0)
+ (let loop ((n n) (memo (current-msg-memo)) (winner false))
+ (let ((previous (msg-memo/previous memo)))
+ (cond ((not previous)
+ (if winner (set-current-msg-memo! winner))
+ (message "No previous message"))
+ ((= n 1)
+ (set-current-msg-memo! previous))
+ (else
+ (loop (- n 1) previous previous))))))
+ ((< n 0)
+ ((ref-command rmail-next-message) (- n))))))
+
+(define-command rmail-next-undeleted-message
+ "Show following non-deleted message.
+With prefix argument N, moves forward N non-deleted messages,
+or backward if N is negative."
+ "p"
+ (lambda (n)
+ (cond ((> n 0)
+ (let loop ((n n) (memo (current-msg-memo)) (winner false))
+ (let ((next (msg-memo/next-undeleted memo)))
+ (cond ((not next)
+ (if winner (set-current-msg-memo! winner))
+ (message "No following undeleted message"))
+ ((= n 1)
+ (set-current-msg-memo! next))
+ (else
+ (loop (- n 1) next next))))))
+ ((< n 0)
+ ((ref-command rmail-previous-undeleted-message) (- n))))))
+
+(define-command rmail-previous-undeleted-message
+ "Show previous non-deleted message.
+With prefix argument N, moves backward N non-deleted messages,
+or forward if N is negative."
+ "p"
+ (lambda (n)
+ (cond ((> n 0)
+ (let loop ((n n) (memo (current-msg-memo)) (winner false))
+ (let ((previous (msg-memo/previous-undeleted memo)))
+ (cond ((not previous)
+ (if winner (set-current-msg-memo! winner))
+ (message "No previous undeleted message"))
+ ((= n 1)
+ (set-current-msg-memo! previous))
+ (else
+ (loop (- n 1) previous previous))))))
+ ((< n 0)
+ ((ref-command rmail-next-undeleted-message) (- n))))))
+\f
+(define-command rmail-show-message
+ "Show message number N (prefix argument), counting from start of file."
+ "p"
+ (lambda (n)
+ (show-message (current-buffer) n)))
+
+(define-command rmail-last-message
+ "Show last message in file."
+ ()
+ (lambda ()
+ (set-current-msg-memo! (last-msg-memo))))
+
+(define-command rmail-search
+ "Show message containing next match for REGEXP.
+Search in reverse (earlier messages) with 2nd arg REVERSEP true.
+Interactively, empty argument means use same regexp used last time,
+and reverse search is specified by a negative numeric arg."
+ (lambda ()
+ (let ((reverse? (< (command-argument-numeric-value (command-argument)) 0)))
+ (let ((regexp
+ (prompt-for-string (string-append (if reverse? "Reverse " "")
+ "Rmail search (regexp)")
+ search-last-regexp)))
+ (set! search-last-regexp regexp)
+ (list regexp reverse?))))
+ (lambda (regexp reverse?)
+ (let ((buffer (current-buffer))
+ (memo (current-msg-memo))
+ (msg
+ (string-append (if reverse? "Reverse " "")
+ "Rmail search for "
+ regexp
+ "...")))
+ (message msg)
+ (with-values
+ (lambda ()
+ (without-clipping buffer
+ (lambda ()
+ (if reverse?
+ (let loop ((memo memo))
+ (let ((memo (msg-memo/previous memo)))
+ (cond ((not memo)
+ (values false false))
+ ((re-search-backward regexp
+ (msg-memo/end-body memo)
+ (msg-memo/start-body memo))
+ =>
+ (lambda (mark) (values memo mark)))
+ (else
+ (loop memo)))))
+ (let loop ((memo memo))
+ (let ((memo (msg-memo/next memo)))
+ (cond ((not memo)
+ (values false false))
+ ((re-search-forward regexp
+ (msg-memo/start-body memo)
+ (msg-memo/end-body memo))
+ =>
+ (lambda (mark) (values memo mark)))
+ (else
+ (loop memo)))))))))
+ (lambda (memo mark)
+ (if memo
+ (begin
+ (select-message buffer memo)
+ (set-current-point! mark)
+ (message msg "done"))
+ (editor-failure "Search failed: " regexp)))))))
+
+(define search-last-regexp
+ false)
+\f
+(define (show-message buffer n)
+ (let ((memo (buffer-msg-memo buffer)))
+ (if (not (msg-memo? memo))
+ (begin
+ (let ((start (buffer-start buffer)))
+ (let ((m
+ (re-search-backward babyl-header-end-regexp
+ (buffer-end buffer)
+ start
+ false)))
+ (if m
+ (narrow-to-region start (mark1+ m))))
+ (set-buffer-point! buffer start))
+ (if (current-buffer? buffer)
+ (message "No messages")))
+ (let ((last (msg-memo/last memo)))
+ (cond ((not n)
+ (select-message buffer last))
+ ((<= 1 n (msg-memo/number last))
+ (select-message buffer (msg-memo/nth memo n)))
+ ((current-buffer? buffer)
+ (message "No such message")))))))
+
+(define (current-msg-memo)
+ (let ((memo (buffer-msg-memo (current-buffer))))
+ (if (not (msg-memo? memo))
+ (editor-error "No messages"))
+ memo))
+
+(define (last-msg-memo)
+ (msg-memo/last (current-msg-memo)))
+
+(define (set-current-msg-memo! memo)
+ (select-message (mark-buffer (msg-memo/start memo)) memo))
+
+(define (select-message buffer memo)
+ (let ((start (msg-memo/start memo)))
+ (set-buffer-msg-memo! buffer memo)
+ (widen start)
+ (let ((end (msg-memo/end memo)))
+ (if (match-forward "\f\n0" start end false)
+ (with-read-only-defeated start
+ (lambda ()
+ (reformat-message start end))))
+ (clear-attribute! memo 'UNSEEN)
+ (update-mode-line! buffer)
+ (let ((start (re-search-forward babyl-eooh-regexp start end false)))
+ (narrow-to-region start (mark-1+ end))
+ (set-buffer-point! buffer start)))))
+
+(define (update-mode-line! buffer)
+ (define-variable-local-value! buffer (ref-variable-object mode-line-process)
+ (mode-line-summary-string buffer))
+ (buffer-modeline-event! buffer 'PROCESS-STATUS))
+
+(define (mode-line-summary-string buffer)
+ (let ((memo (buffer-msg-memo buffer)))
+ (and (msg-memo? memo)
+ (apply string-append
+ " "
+ (number->string (msg-memo/number memo))
+ "/"
+ (number->string (msg-memo/number (msg-memo/last memo)))
+ (append-map!
+ (lambda (label) (list "," label))
+ (append! (map symbol->string (msg-memo/attributes memo))
+ (parse-labels (msg-memo/start memo))))))))
+\f
+;;;; Message deletion
+
+(define-command rmail-delete-message
+ "Delete this message and stay on it."
+ ()
+ (lambda () (set-attribute! (current-msg-memo) 'DELETED)))
+
+(define-command rmail-undelete-previous-message
+ "Back up to deleted message, select it, and undelete it."
+ ()
+ (lambda ()
+ (let ((memo (current-msg-memo)))
+ (if (msg-memo/deleted? memo)
+ (clear-attribute! memo 'DELETED)
+ (let ((memo (msg-memo/previous-deleted memo)))
+ (if (not memo) (editor-error "No previous deleted message"))
+ (clear-attribute! memo 'DELETED)
+ (set-current-msg-memo! memo))))))
+
+(define-command rmail-delete-forward
+ "Delete this message and move to next nondeleted one.
+Deleted messages stay in the file until the \\[rmail-expunge] command is given.
+With prefix argument, delete and move backward."
+ "P"
+ (lambda (backward?)
+ (set-attribute! (current-msg-memo) 'DELETED)
+ ((ref-command rmail-next-undeleted-message) (if backward? -1 1))))
+
+(define-command rmail-delete-backward
+ "Delete this message and move to previous nondeleted one.
+Deleted messages stay in the file until the \\[rmail-expunge] command is given."
+ ()
+ (lambda () ((ref-command rmail-delete-forward) true)))
+
+(define-command rmail-expunge
+ "Actually erase all deleted messages in the file."
+ ()
+ (lambda ()
+ (let ((buffer (current-buffer)))
+ (let ((memo (buffer-msg-memo buffer)))
+ (if (msg-memo? memo)
+ (show-message
+ buffer
+ (with-buffer-open buffer (lambda () (expunge buffer memo)))))))))
+
+(define (expunge buffer memo)
+ (let ((old-n (msg-memo/number memo)))
+ (let loop ((memo (msg-memo/first memo)) (n 1))
+ (let ((next (msg-memo/next memo)))
+ (cond ((not (msg-memo/deleted? memo))
+ (set-msg-memo/number! memo n)
+ (if (or (= n old-n) (and (not next) (< n old-n)))
+ (set-buffer-msg-memo! buffer memo))
+ (if next
+ (loop next (+ n 1))
+ (min n old-n)))
+ (next
+ (let ((start (msg-memo/start memo)))
+ (delete-string start (msg-memo/start next))
+ (mark-temporary! start))
+ (let ((previous (msg-memo/previous memo)))
+ (if previous (set-msg-memo/next! previous next))
+ (set-msg-memo/previous! next previous))
+ (loop next n))
+ (else
+ (let ((start (msg-memo/start memo))
+ (end (buffer-last-msg-end buffer)))
+ (set-buffer-last-msg-end! buffer start)
+ (delete-string start end)
+ (mark-temporary! end))
+ (let ((previous (msg-memo/previous memo)))
+ (if previous
+ (begin
+ (set-msg-memo/next! previous false)
+ (if (<= n old-n) (set-buffer-msg-memo! buffer previous))
+ (min (- n 1) old-n))
+ (begin
+ (set-buffer-msg-memo! buffer true)
+ false)))))))))
+\f
+;;;; Mailing commands
+
+(define-command rmail-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 false select-buffer-other-window
+ false false false false (current-buffer))))
+
+(define-command rmail-continue
+ "Continue composing outgoing message previously being composed."
+ ()
+ (lambda ()
+ ((ref-command mail-other-window) true)))
+
+(define-command rmail-forward
+ "Forward the current message to another user."
+ ()
+ (lambda ()
+ (let ((buffer (current-buffer))
+ (memo (current-msg-memo)))
+ (set-attribute! memo 'FORWARDED)
+ (make-mail-buffer
+ false
+ (if (window-has-no-neighbors? (current-window))
+ select-buffer
+ select-buffer-other-window)
+ false
+ (without-clipping buffer
+ (lambda ()
+ (with-values (lambda () (original-header-limits memo))
+ (lambda (start end)
+ (string-append
+ "["
+ (let ((from (fetch-first-field "from" start end)))
+ (if from
+ (addresses->string (strip-quoted-names from))
+ ""))
+ ": "
+ (or (fetch-first-field "subject" start end) "")
+ "]")))))
+ false
+ false
+ false)
+ (let ((mark (buffer-end (current-buffer))))
+ (insert-newline mark)
+ (insert-region (buffer-start buffer) (buffer-end buffer) mark)))))
+\f
+(define-command rmail-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 ((buffer (current-buffer))
+ (memo (current-msg-memo)))
+ (set-attribute! memo 'ANSWERED)
+ (without-clipping buffer
+ (lambda ()
+ (with-values (lambda () (original-header-limits memo))
+ (lambda (start end)
+ (let ((resent-reply-to
+ (fetch-last-field "resent-reply-to" start end))
+ (from (fetch-first-field "from" start end)))
+ (make-mail-buffer
+ false
+ select-buffer-other-window
+ (addresses->string
+ (strip-quoted-names
+ (or resent-reply-to
+ (fetch-all-fields "reply-to" start end)
+ from)))
+ (let ((subject
+ (or (and resent-reply-to
+ (fetch-last-field "resent-subject" start end))
+ (fetch-first-field "subject" start end))))
+ (if (string-prefix-ci? "re: " subject)
+ (string-tail subject 4)
+ subject))
+ (if resent-reply-to
+ (make-in-reply-to-field
+ from
+ (fetch-last-field "resent-date" start end)
+ (fetch-last-field "resent-message-id" start end))
+ (make-in-reply-to-field
+ from
+ (fetch-first-field "date" start end)
+ (fetch-first-field "message-id" start end)))
+ (and (not just-sender?)
+ (let ((to
+ (if resent-reply-to
+ (fetch-last-field "resent-to" start end)
+ (fetch-all-fields "to" start end)))
+ (cc
+ (if resent-reply-to
+ (fetch-last-field "resent-cc" start end)
+ (fetch-all-fields "cc" start end))))
+ (let ((cc
+ (if (and to cc)
+ (string-append to ", " cc)
+ (or to cc))))
+ (and cc
+ (addresses->string
+ (dont-reply-to (strip-quoted-names cc)))))))
+ buffer)))))))))
+\f
+(define (original-header-limits memo)
+ (let ((start (msg-memo/start memo))
+ (end (msg-memo/end memo)))
+ (if (match-forward "\f\n0" start end false)
+ (begin
+ (if (not (re-search-forward babyl-eooh-regexp start end false))
+ (editor-error))
+ (let ((hstart (re-match-end 0)))
+ (values hstart (or (search-forward "\n\n" hstart end false) end))))
+ (values
+ (let ((start (line-start start 2 'ERROR)))
+ (if (match-forward "Summary-line:" start end true)
+ (line-start start 1 'ERROR)
+ start))
+ (begin
+ (if (not (re-search-forward babyl-eooh-regexp start end false))
+ (editor-error))
+ (re-match-start 0))))))
+
+(define (fetch-first-field field start end)
+ (let ((fs (re-search-forward (field-name->regexp field) start end true)))
+ (and fs
+ (extract-field fs end))))
+
+(define (fetch-last-field field start end)
+ (and (re-search-backward (field-name->regexp field) end start true)
+ (extract-field (re-match-end 0) end)))
+
+(define (fetch-all-fields field start end)
+ (let ((strings
+ (let ((regexp (field-name->regexp field)))
+ (let loop ((start start))
+ (let ((fs (re-search-forward regexp start end true)))
+ (if fs
+ (let ((string (extract-field fs end))
+ (strings (loop fs)))
+ (if string
+ (cons string
+ (if strings
+ (cons ", " strings)
+ '()))
+ strings))
+ '()))))))
+ (and (not (null? strings))
+ (apply string-append strings))))
+
+(define (extract-field fs end)
+ (let ((fe
+ (skip-chars-backward " \t\n"
+ (if (re-search-forward "^[^ \t]" fs end false)
+ (re-match-start 0)
+ end)
+ fs)))
+ (and (mark< fs fe)
+ (extract-string fs fe))))
+
+(define (field-name->regexp field)
+ (string-append "^" (re-quote-string field) "[ \t]*:[ \t]*"))
+\f
+(define (strip-quoted-names string)
+ (let ((address-list (strip-quoted-names-1 (string->rfc822-tokens string))))
+ (if (and address-list (null? (cdr address-list)))
+ (car address-list)
+ (let ((end (string-length string)))
+ (let loop ((start 0))
+ (let ((index (substring-find-next-char string start end #\,)))
+ (if index
+ (cons (string-trim (substring string start index))
+ (loop (+ index 1)))
+ (list (string-trim (substring string start end))))))))))
+
+(define (dont-reply-to addresses)
+ (let ((pattern
+ (re-compile-pattern
+ (string-append "\\(.*!\\|\\)\\("
+ (ref-variable rmail-dont-reply-to-names)
+ "\\)")
+ true)))
+ (let loop ((addresses addresses))
+ (cond ((null? addresses)
+ '())
+ ((re-match-string-forward pattern true false (car addresses))
+ (loop (cdr addresses)))
+ (else
+ (cons (car addresses) (loop (cdr addresses))))))))
+
+(define (addresses->string addresses)
+ (and (not (null? addresses))
+ (separated-append addresses ", ")))
+
+(define (separated-append tokens separator)
+ (if (null? (cdr tokens))
+ (car tokens)
+ (apply string-append
+ (let loop ((tokens tokens))
+ (if (null? (cdr tokens))
+ (list (car tokens))
+ (cons* (car tokens) separator (loop (cdr tokens))))))))
+
+(define (make-in-reply-to-field from date message-id)
+ message-id
+ (and (or from date)
+ (string-append "Msg"
+ (if date
+ (string-append " of " date)
+ "")
+ (if from
+ (string-append " from " from)
+ ""))))
+\f
+;;;; Address Extraction
+
+(define (strip-quoted-names-1 tokens)
+ (define (parse-addr-spec tokens)
+ (let ((local-part (parse-list tokens parse-word #\.)))
+ (and local-part
+ (not (null? (cdr local-part)))
+ (eqv? #\@ (cadr local-part))
+ (let ((domain (parse-domain (cddr local-part))))
+ (and domain
+ (cons (string-append (separated-append (car local-part) ".")
+ "@"
+ (separated-append (car domain) "."))
+ (cdr domain)))))))
+ (define (parse-domain tokens)
+ (parse-list tokens
+ (lambda (tokens)
+ (and (not (null? tokens))
+ (string? (car tokens))
+ (not (eqv? #\" (string-ref (car tokens) 0)))
+ tokens))
+ #\.))
+ (define (parse-list tokens parse-element separator)
+ (let ((first (parse-element tokens)))
+ (and first
+ (let loop ((tokens (cdr first)) (words (list (car first))))
+ (let ((next
+ (and (not (null? tokens))
+ (eqv? separator (car tokens))
+ (parse-element (cdr tokens)))))
+ (if next
+ (loop (cdr next) (cons (car next) words))
+ (cons (reverse! words) tokens)))))))
+ (define (parse-word tokens)
+ (and (not (null? tokens))
+ (string? (car tokens))
+ (not (eqv? #\[ (string-ref (car tokens) 0)))
+ tokens))
+ (parse-list
+ tokens
+ (lambda (tokens)
+ (or (parse-addr-spec tokens)
+ (let ((word (parse-word tokens)))
+ (and word
+ (let ((tokens
+ (let loop ((tokens (cdr word)))
+ (let ((word (parse-word tokens)))
+ (if word
+ (loop (cdr word))
+ tokens)))))
+ (and (not (null? tokens))
+ (eqv? #\< (car tokens))
+ (let ((addr-spec
+ (parse-addr-spec
+ (let ((domains
+ (parse-list
+ (cdr tokens)
+ (lambda (tokens)
+ (and (not (null? tokens))
+ (eqv? #\@ (car tokens))
+ (parse-domain (cdr tokens))))
+ #\,)))
+ (if (and domains
+ (not (null? (cdr domains)))
+ (eqv? #\: (cadr domains)))
+ (cddr domains)
+ (cdr tokens))))))
+ (and addr-spec
+ (not (null? (cdr addr-spec)))
+ (eqv? #\> (cadr addr-spec))
+ (cons (car addr-spec) (cddr addr-spec))))))))))
+ #\,))
+\f
+;;;; RFC 822 parser
+
+(define (string->rfc822-tokens string)
+ (rfc822-clean-tokens (rfc822-read-tokens (string->input-port string))))
+
+(define (rfc822-clean-tokens tokens)
+ (let loop ((tokens tokens))
+ (if (null? tokens)
+ '()
+ (let ((rest (loop (cdr tokens))))
+ (if (cond ((char? (car tokens))
+ (eqv? #\space (car tokens)))
+ ((string? (car tokens))
+ (char=? #\( (string-ref (car tokens) 0)))
+ (else true))
+ rest
+ (cons (car tokens) rest))))))
+
+(define rfc822-read-tokens
+ (let* ((special-chars
+ (char-set #\( #\) #\[ #\] #\< #\> #\@ #\, #\; #\: #\\ #\" #\.))
+ (atom-chars
+ (char-set-difference (ascii-range->char-set #x21 #x7F)
+ special-chars)))
+ (lambda (port)
+ (let ((special-char?
+ (lambda (char) (char-set-member? special-chars char)))
+ (atom-char? (lambda (char) (char-set-member? atom-chars char)))
+ (lwsp?
+ (lambda (char) (or (char=? #\space char) (char=? #\tab char))))
+ (loser
+ (lambda (chars)
+ (list (cons 'UNTERMINATED (apply string (reverse! chars)))))))
+ (let dispatch ()
+ (let ((char (input-port/read-char port)))
+ (cond ((eof-object? char)
+ '())
+ ((lwsp? char)
+ (do ()
+ ((not (lwsp? (input-port/peek-char port))))
+ (input-port/discard-char port))
+ (cons #\space (dispatch)))
+ ((atom-char? char)
+ ;; atom
+ (let loop ((chars (list char)))
+ (let ((char (input-port/peek-char port)))
+ (if (and (not (eof-object? char))
+ (atom-char? char))
+ (begin
+ (input-port/discard-char port)
+ (loop (cons char chars)))
+ (cons (apply string (reverse! chars))
+ (dispatch))))))
+ ((char=? #\" char)
+ ;; quoted string
+ (let loop ((chars (list char)))
+ (let ((char (input-port/read-char port)))
+ (cond ((eof-object? char)
+ (loser chars))
+ ((char=? #\" char)
+ (cons (apply string (reverse! (cons char chars)))
+ (dispatch)))
+ ((char=? #\\ char)
+ (let ((char (input-port/read-char port))
+ (chars (cons char chars)))
+ (if (eof-object? char)
+ (loser chars)
+ (loop (cons char chars)))))
+ ((char=? #\newline char)
+ (let ((char (input-port/peek-char port)))
+ (if (lwsp? char)
+ (begin
+ (input-port/discard-char port)
+ (loop (cons char chars)))
+ (loser chars))))
+ (else
+ (loop (cons char chars)))))))
+ ((char=? #\( char)
+ ;; comment
+ (let loop ((level 1) (chars (list char)))
+ (let ((char (input-port/read-char port)))
+ (cond ((eof-object? char)
+ (loser chars))
+ ((char=? #\( char)
+ (loop (+ level 1) (cons char chars)))
+ ((char=? #\) char)
+ (let ((chars (cons char chars)))
+ (if (= level 1)
+ (cons (apply string (reverse! chars))
+ (dispatch))
+ (loop (- level 1) chars))))
+ ((char=? #\\ char)
+ (let ((char (input-port/read-char port))
+ (chars (cons char chars)))
+ (if (eof-object? char)
+ (loser chars)
+ (loop level (cons char chars)))))
+ ((char=? #\newline char)
+ (let ((char (input-port/peek-char port)))
+ (if (lwsp? char)
+ (begin
+ (input-port/discard-char port)
+ (loop level (cons char chars)))
+ (loser chars))))
+ (else
+ (loop level (cons char chars)))))))
+ ((char=? #\[ char)
+ ;; domain literal
+ (let loop ((chars (list char)))
+ (let ((char (input-port/peek-char port)))
+ (cond ((or (eof-object? char)
+ (char=? #\[ char))
+ (loser chars))
+ ((char=? #\] char)
+ (input-port/discard-char port)
+ (cons (apply string (reverse! (cons char chars)))
+ (dispatch)))
+ ((char=? #\\ char)
+ (input-port/discard-char port)
+ (let ((char (input-port/read-char port))
+ (chars (cons char chars)))
+ (if (eof-object? char)
+ (loser chars)
+ (loop (cons char chars)))))
+ ((char=? #\newline char)
+ (input-port/discard-char port)
+ (let ((char (input-port/peek-char port)))
+ (if (lwsp? char)
+ (begin
+ (input-port/discard-char port)
+ (loop (cons char chars)))
+ (loser chars))))
+ (else
+ (input-port/discard-char port)
+ (loop (cons char chars)))))))
+ ((char=? #\newline char)
+ (let ((char (input-port/peek-char port)))
+ (if (and (not (eof-object? char))
+ (lwsp? char))
+ (dispatch)
+ '())))
+ (else
+ (cons (if (special-char? char)
+ char
+ (cons 'ILLEGAL char))
+ (dispatch))))))))))
+\f
+;;;; Message memoization
+
+(define (memoize-buffer buffer)
+ (let ((end (buffer-end buffer)))
+ (let ((m
+ (re-match-forward babyl-header-start-regexp
+ (buffer-start buffer)
+ end
+ false)))
+ (if m
+ (let ((m (re-search-forward babyl-header-end-regexp m end false)))
+ (if m
+ (memoize-messages buffer m end)))))))
+
+(define (memoize-messages buffer start end)
+ (message "Counting messages...")
+ (let ((memo (buffer-msg-memo buffer)))
+ (let loop
+ ((start (mark-left-inserting-copy start))
+ (tail (and (msg-memo? memo) (msg-memo/last memo)))
+ (n 1))
+ (let ((mend (search-forward babyl-message-end-regexp start end false)))
+ (if mend
+ (let ((mend (mark-left-inserting-copy mend)))
+ (canonicalize-message-attributes start)
+ (let ((memo
+ (make-msg-memo tail
+ false
+ start
+ (if tail (+ (msg-memo/number tail) 1) 1)
+ (parse-attributes start))))
+ (if tail
+ (set-msg-memo/next! tail memo))
+ (if (zero? (remainder n 20))
+ (message "Counting messages..." n))
+ (loop mend memo (+ n 1))))
+ (begin
+ (if (not (msg-memo? memo))
+ (set-buffer-msg-memo! buffer (or tail true)))
+ (let ((old-end (buffer-last-msg-end buffer)))
+ (if old-end
+ (mark-temporary! old-end)))
+ (set-buffer-last-msg-end! buffer start))))))
+ (message "Counting messages...done"))
+
+(define-structure (msg-memo (conc-name msg-memo/))
+ previous
+ next
+ (start false read-only true)
+ number
+ attributes)
+
+(define (msg-memo/end memo)
+ (let ((next (msg-memo/next memo)))
+ (if next
+ (msg-memo/start next)
+ (buffer-last-msg-end (mark-buffer (msg-memo/start memo))))))
+
+(define (msg-memo/start-body memo)
+ (let ((start (msg-memo/start memo)))
+ (or (re-search-forward babyl-eooh-regexp start (msg-memo/end memo) false)
+ start)))
+
+(define (msg-memo/end-body memo)
+ (mark-1+ (msg-memo/end memo)))
+
+(define-integrable (buffer-msg-memo buffer)
+ (buffer-get buffer 'RMAIL-MSG-MEMO))
+
+(define-integrable (set-buffer-msg-memo! buffer memo)
+ (buffer-put! buffer 'RMAIL-MSG-MEMO memo))
+
+(define-integrable (buffer-last-msg-end buffer)
+ (buffer-get buffer 'RMAIL-LAST-MSG-END))
+
+(define-integrable (set-buffer-last-msg-end! buffer memo)
+ (buffer-put! buffer 'RMAIL-LAST-MSG-END memo))
+\f
+(define (msg-memo/first memo)
+ (let loop ((memo memo))
+ (let ((previous (msg-memo/previous memo)))
+ (if previous
+ (loop previous)
+ memo))))
+
+(define (msg-memo/last memo)
+ (let loop ((memo memo))
+ (let ((next (msg-memo/next memo)))
+ (if next
+ (loop next)
+ memo))))
+
+(define (msg-memo/nth memo n)
+ (if (= n (msg-memo/number memo))
+ memo
+ (let ((msg-memo/next
+ (if (< n (msg-memo/number memo))
+ msg-memo/previous
+ msg-memo/next)))
+ (let loop ((memo memo))
+ (let ((next (msg-memo/next memo)))
+ (cond ((not next) memo)
+ ((= n (msg-memo/number next)) next)
+ (else (loop next))))))))
+
+(define-integrable (msg-memo/deleted? memo)
+ (memq 'DELETED (msg-memo/attributes memo)))
+
+(define (msg-memo/next-undeleted memo)
+ (let ((next (msg-memo/next memo)))
+ (and next
+ (if (msg-memo/deleted? next)
+ (msg-memo/next-undeleted next)
+ next))))
+
+(define (msg-memo/previous-undeleted memo)
+ (let ((previous (msg-memo/previous memo)))
+ (and previous
+ (if (msg-memo/deleted? previous)
+ (msg-memo/previous-undeleted previous)
+ previous))))
+
+(define (msg-memo/next-deleted memo)
+ (let ((next (msg-memo/next memo)))
+ (and next
+ (if (msg-memo/deleted? next)
+ next
+ (msg-memo/next-deleted next)))))
+
+(define (msg-memo/previous-deleted memo)
+ (let ((previous (msg-memo/previous memo)))
+ (and previous
+ (if (msg-memo/deleted? previous)
+ previous
+ (msg-memo/previous-deleted previous)))))
+\f
+;;;; Attributes and Labels
+
+(define (canonicalize-message-attributes mstart)
+ (let ((start (attributes-start-mark mstart)))
+ (let ((end (line-end start 0)))
+ (let loop ((m start) (in-labels? false))
+ (cond ((re-match-forward " [^ ,]+," m end false)
+ (loop (re-match-end 0) in-labels?))
+ ((and (not in-labels?) (match-forward "," m end false))
+ => (lambda (m) (loop m true)))
+ ((and in-labels? (mark= m end))
+ unspecific)
+ ((re-match-forward " *\\([^ ,]+\\)," m end false)
+ (loop (replace-match " \\1,") in-labels?))
+ ((and (not in-labels?) (re-match-forward " +," m end false))
+ (loop (replace-match ",") true))
+ ((and in-labels? (re-match-forward " +$" m end false))
+ (delete-match))
+ (else
+ (editor-error "Malformed message attributes: "
+ (extract-string start end))))))))
+
+(define (set-attribute! memo attribute)
+ (if (not (memq attribute (msg-memo/attributes memo)))
+ (begin
+ (set-msg-memo/attributes! memo
+ (cons attribute
+ (msg-memo/attributes memo)))
+ (let ((start (msg-memo/start memo)))
+ (with-group-open (mark-group start)
+ (lambda ()
+ (insert-string (attribute->string attribute)
+ (attributes-end-mark start))
+ (update-mode-line! (mark-buffer start))))))))
+
+(define (clear-attribute! memo attribute)
+ (if (memq attribute (msg-memo/attributes memo))
+ (begin
+ (set-msg-memo/attributes! memo
+ (delq! attribute
+ (msg-memo/attributes memo)))
+ (let ((start (msg-memo/start memo)))
+ (with-group-open (mark-group start)
+ (lambda ()
+ (if (search-forward (attribute->string attribute)
+ (attributes-start-mark start)
+ (attributes-end-mark start)
+ true)
+ (delete-match))
+ (update-mode-line! (mark-buffer start))))))))
+
+(define (attribute->string attribute)
+ (string-append " " (string-downcase (symbol->string attribute)) ","))
+\f
+(define (attributes-start-mark mstart)
+ (let ((m
+ (re-match-forward babyl-message-start-regexp
+ mstart
+ (group-end mstart)
+ false)))
+ (if (not m)
+ (editor-error "Mark not at message start: " mstart))
+ m))
+
+(define (attributes-end-mark mstart)
+ (mark-1+ (labels-start-mark mstart)))
+
+(define (labels-start-mark mstart)
+ (let ((m
+ (let ((lstart (line-start mstart 1 'ERROR)))
+ (search-forward ",," lstart (line-end lstart 0) false))))
+ (if (not m)
+ (editor-error "Can't find attributes/labels separator"))
+ m))
+
+(define (labels-end-mark mstart)
+ (line-end mstart 1 'ERROR))
+
+(define (parse-attributes mstart)
+ (map intern
+ (parse-label-list (attributes-start-mark mstart)
+ (attributes-end-mark mstart))))
+
+(define (parse-labels mstart)
+ (parse-label-list (labels-start-mark mstart)
+ (labels-end-mark mstart)))
+
+(define (parse-label-list start end)
+ (let loop ((m start))
+ (if (mark< m end)
+ (let ((aend (char-search-forward #\, m end false)))
+ (cons (string-downcase (extract-string (mark1+ m) (mark-1+ aend)))
+ (loop aend)))
+ '())))
+\f
+(define-command rmail-toggle-header
+ "Show original message header if pruned header currently shown, or vice versa."
+ ()
+ (lambda ()
+ (let ((buffer (current-buffer)))
+ (let ((memo (current-msg-memo)))
+ (with-buffer-open buffer
+ (lambda ()
+ (let ((start (msg-memo/start memo))
+ (end (msg-memo/end memo)))
+ (cond ((match-forward "\f\n0" start end false)
+ (reformat-message start end))
+ ((match-forward "\f\n1" start end false)
+ (unformat-message start end)))))))
+ (set-current-point! (buffer-start buffer)))))
+
+(define (reformat-message start end)
+ (let ((m (mark+ start 2)))
+ (delete-right-char m)
+ (insert-char #\1 m))
+ (if (not (re-search-forward babyl-eooh-regexp start end false))
+ (editor-error))
+ (let ((eooh (re-match-start 0)))
+ (let ((hstart (mark-right-inserting-copy (line-start eooh 1 'ERROR))))
+ (let ((hend
+ (let ((m (search-forward "\n\n" hstart end false)))
+ (if m
+ (mark-left-inserting-copy m)
+ (let ((m (mark-left-inserting-copy end)))
+ (if (char-match-backward #\newline m)
+ (insert-newline m)
+ (insert-newlines 2 m))
+ m)))))
+ (insert-string (extract-string hstart hend) eooh)
+ (let ((regexp (ref-variable rmail-ignored-headers)))
+ (if regexp
+ (do ()
+ ((not (re-search-forward regexp hstart hend true)))
+ (let ((m (line-start (re-match-start 0) 0)))
+ (delete-string
+ m
+ (mark-1+ (re-search-forward "\n[^ \t]" m hend false)))))))
+ (let ((filter (ref-variable rmail-message-filter)))
+ (if filter
+ (filter hstart hend)))
+ (mark-temporary! hend)
+ (mark-temporary! hstart)))))
+
+(define (unformat-message start end)
+ (let ((m (mark+ start 2)))
+ (delete-right-char m)
+ (insert-char #\0 m))
+ (let ((start
+ (let ((start (line-start start 2 'ERROR)))
+ (if (match-forward "Summary-line:" start end true)
+ (line-start start 1 'ERROR)
+ start))))
+ (if (not (re-search-forward babyl-eooh-regexp start end false))
+ (editor-error))
+ (let ((header (extract-and-delete-string start (re-match-start 0))))
+ (let ((hstart (line-start start 1)))
+ (delete-string hstart
+ (or (search-forward "\n\n" hstart end false) end))
+ (insert-string header hstart)))))
+\f
+;;;; Mail conversion
+
+(define (convert-region-to-babyl-format start end)
+ (define (loop point count)
+ (text-clip point end)
+ (cond ((mark= point end)
+ count)
+ ((re-match-forward babyl-header-start-regexp point end false)
+ (delete-string
+ point
+ (or (search-forward babyl-header-end-regexp point end false) end))
+ (loop point count))
+ ((re-match-forward babyl-message-start-regexp point end false)
+ (let ((m
+ (or (search-forward babyl-message-end-regexp point end false)
+ (missing-end end "Babyl"))))
+ (delete-string m (skip-chars-forward " \t\n" m end))
+ (loop m (+ count 1))))
+ ((re-match-forward umail-message-start-regexp point end false)
+ (let ((point (mark-left-inserting-copy point)))
+ (insert-string babyl-initial-message-start point)
+ (nuke-pinhead-header point end)
+ (mark-temporary! point)
+ (process-message-body
+ point
+ count
+ (if (re-search-forward umail-message-end-regexp point end false)
+ (re-match-start 0)
+ end))))
+ ((re-match-forward mmdf-message-start-regexp point end true)
+ (let ((start (replace-match babyl-initial-message-start)))
+ (process-message-body
+ start
+ count
+ (if (re-search-forward mmdf-message-end-regexp start end true)
+ (mark-1+ (replace-match "\037"))
+ (missing-end end "MMDF")))))
+ (else
+ (editor-error "error converting to Babyl format")
+ true)))
+
+ (define (process-message-body point count mend)
+ (let ((mend (mark-left-inserting-copy mend)))
+ (do ((m point (replace-match "\n^_")))
+ ((not (search-forward "\n\037" m mend false))))
+ (let ((m (match-forward "\037" mend end false)))
+ (if m
+ (move-mark-to! mend m)
+ (insert-string "\037" mend)))
+ (mark-temporary! mend)
+ (loop mend (+ count 1))))
+
+ (define (missing-end end type)
+ (message "Invalid " type " format in inbox!")
+ (sit-for 1)
+ end)
+
+ (with-text-clipped start end (lambda () (loop start 0))))
+\f
+(define (convert-buffer-to-babyl-format buffer)
+ (with-buffer-open buffer
+ (lambda ()
+ (let ((start (buffer-start buffer))
+ (end (buffer-end buffer)))
+ (if (not (re-match-forward babyl-header-start-regexp start end false))
+ (insert-string babyl-initial-header start))
+ (search-backward "\n\037" end start false)
+ (let ((start (re-match-end 0)))
+ (let ((m (skip-chars-forward "\n" start end)))
+ (cond ((and (mark= m end)
+ (mark< start m))
+ (delete-string start m))
+ ((re-match-forward umail-message-start-regexp m end false)
+ (delete-string start m)
+ (message "Converting to Babyl format...")
+ (convert-region-to-babyl-format start end)
+ (message "Converting to Babyl format...done")))))))))
+
+(define (nuke-pinhead-header start end)
+ (let ((hend
+ (or (search-forward "\n\n" start end false)
+ (begin
+ (insert-string "\n\n" end)
+ end))))
+ (let ((has-from (search-forward "\nFrom:" start hend true))
+ (has-date (search-forward "\nDate:" start hend true)))
+ (if (and has-from has-date)
+ (delete-string start (line-start start 1))
+ (begin
+ (re-match-forward umail-message-start-regexp start hend false)
+ (replace-match
+ (let ((from "From: \\1")
+ (date
+ (if (mark< (re-match-start 7) (re-match-end 7))
+ "Date: \\3, \\5 \\4 \\8 \\6\\7"
+ "Date: \\3, \\5 \\4 \\8 \\6 EST")))
+ (cond (has-from date)
+ (has-date from)
+ (else (string-append date "\n" from))))))))))
+\f
+;;;; Utilities
+
+(define (without-clipping buffer thunk)
+ (let ((group (buffer-group buffer)))
+ (with-group-text-clipped! group 0 (group-length group) thunk)))
+
+(define-integrable (with-buffer-open buffer thunk)
+ (with-group-open (buffer-group buffer) thunk))
+
+(define-integrable (with-buffer-undo-disabled buffer thunk)
+ (with-group-undo-disabled (buffer-group buffer) thunk))
+
+(define (with-group-open group thunk)
+ (let ((outside-ro)
+ (inside-ro false)
+ (outside-start)
+ (outside-end)
+ (inside-start (mark-permanent! (group-absolute-start group)))
+ (inside-end (mark-permanent! (group-absolute-end group))))
+ (dynamic-wind (lambda ()
+ (set! outside-ro (group-read-only? group))
+ (set! outside-start (group-start-mark group))
+ (set! outside-end (group-end-mark group))
+ (vector-set! group group-index:read-only? inside-ro)
+ (vector-set! group group-index:start-mark inside-start)
+ (vector-set! group group-index:end-mark inside-end))
+ thunk
+ (lambda ()
+ (set! inside-ro (group-read-only? group))
+ (set! inside-start (group-start-mark group))
+ (set! inside-end (group-end-mark group))
+ (vector-set! group group-index:read-only? outside-ro)
+ (vector-set! group group-index:start-mark outside-start)
+ (vector-set! group group-index:end-mark outside-end)))))
+\f
+;;;; Constants
+
+(define umail-message-start-regexp
+ "^From \\([^ \n]*\\(\\|\".*\"[^ \n]*\\)\\) ?\\([^ \n]*\\) \\([^ \n]*\\) *\\([0-9]*\\) \\([0-9:]*\\)\\( ?[A-Z]?[A-Z][A-Z]T\\| ?[-+]?[0-9][0-9][0-9][0-9]\\|\\) 19\\([0-9]*\\) *\\(remote from .*\\)?$")
+
+(define umail-message-end-regexp
+ false)
+
+(define mmdf-message-start-regexp
+ "^\001\001\001\001\n")
+
+(define mmdf-message-end-regexp
+ "^\001\001\001\001\n")
+
+(define babyl-header-start-regexp
+ "^BABYL OPTIONS:")
+
+(define babyl-header-end-regexp
+ "\n\037")
+
+(define babyl-initial-header
+ "BABYL OPTIONS:
+Version: 5
+Labels:
+Note: This is the header of an rmail file.
+Note: If you are seeing it in rmail,
+Note: it means the file has no messages in it.\n\037")
+
+(define babyl-message-start-regexp
+ "\f\n[01],")
+
+(define babyl-message-end-regexp
+ "\n\037")
+
+(define babyl-eooh-string
+ "*** EOOH ***\n")
+
+(define babyl-eooh-regexp
+ (string-append "^" (re-quote-string babyl-eooh-string)))
+
+(define babyl-initial-message-start
+ (string-append "\f\n0, unseen,,\n" babyl-eooh-string))
\ No newline at end of file
projects / mit-scheme.git / commitdiff