From bebcf53d3bb0673c8c08bd2c0c1bdf2ceb0721aa Mon Sep 17 00:00:00 2001 From: djcb Date: Wed, 9 Nov 2011 08:35:24 +0200 Subject: [PATCH] * mm updates --- toys/mm/mm-hdrs.el | 34 ++++++++++++++++------- toys/mm/mm-send.el | 58 +++++++++++++++------------------------ toys/mm/mm-view.el | 17 ++++++++---- toys/mm/mm.el | 67 +++++++++++++++++++++++++--------------------- 4 files changed, 94 insertions(+), 82 deletions(-) diff --git a/toys/mm/mm-hdrs.el b/toys/mm/mm-hdrs.el index 42aadea6..2571b06c 100644 --- a/toys/mm/mm-hdrs.el +++ b/toys/mm/mm-hdrs.el @@ -126,6 +126,15 @@ the current list of headers." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun mm/hdrs-contact-str (contacts) + "Turn the list of contacts CONTACTS (with elements (NAME . EMAIL) +into a string." + (mapconcat + (lambda (ct) + (let ((name (car ct)) (email (cdr ct))) + (or name email "?"))) contacts ", ")) + + (defun mm/hdrs-header-handler (msg &optional point) "Create a one line description of MSG in this buffer, at POINT, if provided, or at the end of the buffer otherwise." @@ -135,13 +144,18 @@ if provided, or at the end of the buffer otherwise." (val (plist-get msg field)) (str (case field - (:subject val) - ((:to :from :cc :bcc) - (mapconcat - (lambda (ct) - (let ((name (car ct)) (email (cdr ct))) - (or name email "?"))) val ", ")) - (:date (format-time-string "%x %X" val)) + ((:subject :maildir :path) val) + ((:to :from :cc :bcc) (mm/hdrs-contact-str val)) + ;; if we (ie. `user-mail-address' is the 'From', show 'To', otherwise + ;; show From + (:from-or-to + (let* ((from-lst (plist-get msg :from)) + (from (and from-lst (cdar from-lst)))) + (if (and from (string-match mm/user-mail-address-regexp from)) + (concat (propertize "To " 'face 'mm/system-face) + (mm/hdrs-contact-str (plist-get msg :to))) + (mm/hdrs-contact-str from-lst)))) + (:date (format-time-string mm/headers-date-format val)) (:flags (mm/flags-to-string val)) (:size (cond @@ -155,7 +169,7 @@ if provided, or at the end of the buffer otherwise." (if (not width) str (truncate-string-to-width str width 0 ?\s t))))) - mm/header-fields " ")) + mm/headers-fields " ")) (flags (plist-get msg :flags)) (line (cond ((member 'draft flags) @@ -239,7 +253,7 @@ after the end of the search results." (let ((menumap (make-sparse-keymap "Headers"))) (define-key map [menu-bar headers] (cons "Headers" menumap)) - (define-key menumap [quit-buffer] '("Quit" . mm/quit-buffer)) + (define-key menumap [quit-buffer] '("Quit view" . mm/quit-buffer)) (define-key menumap [sepa0] '("--")) (define-key menumap [execute-marks] '("Execute marks" . mm/execute-marks)) @@ -313,7 +327,7 @@ after the end of the search results." (truncate-string-to-width field width 0 ?\s t) field) 'face 'mm/title-face) " "))) - mm/header-fields)))) + mm/headers-fields)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar mm/msg-map nil "*internal* A map (hashtable) which maps a database (Xapian) diff --git a/toys/mm/mm-send.el b/toys/mm/mm-send.el index af7e90a5..3d1ab171 100644 --- a/toys/mm/mm-send.el +++ b/toys/mm/mm-send.el @@ -78,7 +78,8 @@ or if not available, :body-html converted to text)." (with-temp-buffer (plist-get msg :body-html) (html2text) - (buffer-string))))) + (buffer-string)))) + (body (and body (replace-regexp-in-string "[\r\240]" " " body)))) (when body (concat (format "On %s, %s wrote:" @@ -129,49 +130,32 @@ return nil." (lambda (msgid) (format "<%s>" msgid)) refs ",")))) -(defun mm/msg-to-create (msg reply-all) +(defun mm/msg-to-create (msg) "Construct the To: header for a reply-message based on some -message MSG. If REPLY-ALL is nil, this the the Reply-To addresss of -MSG if it exist, or the From:-address othewise. If reply-all is -non-nil, the To: is what was in the old To: with either the -Reply-To: or From: appended, and then the -receiver (i.e. `user-mail-address') removed. - -So: - reply-all nil: Reply-To: or From: of MSG - reply-all t : Reply-To: or From: of MSG + To: of MSG - `user-mail-address' - -The result is either nil or a string which can be used for the To:-field." +message MSG. This the the Reply-To address of MSG if it exist, or +the From:-address otherwise. The result is either nil or a string +which can be used for the To:-field." (let ((to-lst (plist-get msg :to)) (reply-to (plist-get msg :reply-to)) (from (plist-get msg :from))) - (if reply-all - (progn ;; reply-all - (setq to-lst ;; append Reply-To:, or if not set, From: if set - (if reply-to - (cons `(nil . ,reply-to) to-lst) - (if from - (append to-lst from) - to-lst))) - - ;; and remove myself from To: - (setq to-lst (mm/msg-recipients-remove to-lst user-mail-address)) - (mm/msg-recipients-to-string to-lst)) - - ;; reply single - (progn - (or reply-to (mm/msg-recipients-to-string from)))))) + (setq to-lst (or reply-to from)) + (mm/msg-recipients-to-string to-lst))) (defun mm/msg-cc-create (msg reply-all) "Get the list of Cc-addresses for the reply to MSG. If REPLY-ALL -is nil this is simply empty, otherwise it is the same list as the -one in MSG, minus `user-mail-address'. The result of this function -is either nil or a string to be used for the Cc: field." - (let ((cc-lst (plist-get msg :cc))) - (when (and reply-all cc-lst) - (mm/msg-recipients-to-string - (mm/msg-recipients-remove cc-lst user-mail-address))))) +is nil this is simply empty, otherwise it is the old CC-list +together with the old TO-list, minus `user-mail-address'. The +result of this function is either nil or a string to be used for +the Cc: field." + (let ((cc-lst (plist-get msg :cc)) + (to-lst (plist-get msg :to))) + (when reply-all + (setq cc-lst (append cc-lst to-lst))) + ;; remove myself from cc + (setq cc-lst (mm/msg-recipients-remove cc-lst user-mail-address)) + (mm/msg-recipients-to-string cc-lst))) + (defun mm/msg-from-create () "Construct a value for the From:-field of the reply to MSG, @@ -212,7 +196,7 @@ And finally, the cited body of MSG, as per `mm/msg-cite-original'." (when (boundp 'mail-reply-to) (mm/msg-header "Reply-To" mail-reply-to)) - (mm/msg-header "To" (or (mm/msg-to-create msg reply-all) "")) + (mm/msg-header "To" (or (mm/msg-to-create msg) "")) (mm/msg-header "Cc" (mm/msg-cc-create msg reply-all)) (mm/msg-header "User-agent" (mm/msg-user-agent)) diff --git a/toys/mm/mm-view.el b/toys/mm/mm-view.el index 319d94ea..33611d29 100644 --- a/toys/mm/mm-view.el +++ b/toys/mm/mm-view.el @@ -75,10 +75,19 @@ marking if it still had that." (:cc (mm/view-contacts msg field)) (:bcc (mm/view-contacts msg field)) + ;; if we (`user-mail-address' are the From, show To, otherwise, + ;; show From + (:from-or-to + (let* ((from (plist-get msg :from)) + (from (and from (cdar from)))) + (if (and from (string-match mm/user-mail-address-regexp from)) + (mm/view-contacts msg :to) + (mm/view-contacts msg :from)))) + ;; date (:date (let ((datestr - (when fieldval (format-time-string "%c" fieldval)))) + (when fieldval (format-time-string mm/view-date-format fieldval)))) (if datestr (mm/view-header fieldname datestr) ""))) ;; size (:size (mm/view-size msg) @@ -141,7 +150,6 @@ or if not available, :body-html converted to text)." (if name (format "%s <%s>" name email) (format "%s" email)))) lst ", ")))) - (message "%S %S" field fieldname) (if contacts (mm/view-header fieldname contacts) ""))) @@ -232,7 +240,7 @@ or if not available, :body-html converted to text)." (let ((menumap (make-sparse-keymap "View"))) (define-key map [menu-bar headers] (cons "View" menumap)) - (define-key menumap [quit-buffer] '("Quit" . mm/quit-buffer)) + (define-key menumap [quit-buffer] '("Quit view" . mm/quit-buffer)) (define-key menumap [sepa0] '("--")) (define-key menumap [wrap-lines] @@ -433,7 +441,7 @@ removing '^M' etc." (defun mm/view-extract-attachment (attnum) "Extract the attachment with ATTNUM" (unless mm/attachment-dir (error "`mm/attachment-dir' is not set")) - (when (zerop (hash-table-count mm/attach-map)) + (when (or (null mm/attach-map) (zerop (hash-table-count mm/attach-map))) (error "No attachments for this message")) (interactive "nAttachment to extract:") (let* ((att (gethash attnum mm/attach-map)) @@ -456,7 +464,6 @@ removing '^M' etc." (unless att (error "Not a valid attachment number")) (mm/proc-open (plist-get mm/current-msg :docid) (car att)))) - (defun mm/view-unmark () "Warn user that unmarking only works in the header list." (interactive) diff --git a/toys/mm/mm.el b/toys/mm/mm.el index ef327d94..0fb864bc 100644 --- a/toys/mm/mm.el +++ b/toys/mm/mm.el @@ -33,10 +33,8 @@ (require 'mm-send) (require 'mm-proc) - -;; TODO: get this version through to Makefile magic -(defconst mm/version "0.9.8pre" - "*internal* my version") +;; mm-version.el is autogenerated, and defines mm/mu-version +(require 'mm-version) ;; Customization @@ -63,7 +61,6 @@ PATH, you can specifiy the full path." :safe 'stringp :group 'mm) - (defcustom mm/get-mail-command nil "Shell command to run to retrieve new mail; e.g. 'offlineimap' or 'fetchmail'." @@ -77,6 +74,15 @@ PATH, you can specifiy the full path." :group 'mm :safe 'stringp) +(defvar mm/user-mail-address-regexp "$^" + "Regular expression matching the user's mail address(es). This is +used to distinguish ourselves from others, e.g. when replying and +in :from-or-to headers. By default, match nothing.") + + +(defvar mm/date-format-long "%c" + "Date format to use in the message view, in the format of + `format-time-string'.") (defvar mm/debug nil "When set to non-nil, log debug information to the *mm-log* buffer.") @@ -133,7 +139,7 @@ designated shortcut character for the maildir.") :group 'mm) -(defcustom mm/header-fields +(defcustom mm/headers-fields '( (:date . 25) (:flags . 6) (:from . 22) @@ -141,7 +147,16 @@ designated shortcut character for the maildir.") "A list of header fields to show in the headers buffer, and their respective widths in characters. A width of `nil' means 'unrestricted', and this is best reserved fo the rightmost (last) - field. For the complete list of available headers, see `mm/header-names'") + field. For the complete list of available headers, see `mm/header-names'" + :type (list 'symbol) + :group 'mm/headers) + +(defcustom mm/headers-date-format "%x %X" + "Date format to use in the headers view, in the format of + `format-time-string'." + :type 'string + :group 'mm/headers) + ;; the message view (defgroup mm/view nil @@ -151,10 +166,15 @@ designated shortcut character for the maildir.") (defcustom mm/view-fields '(:from :to :cc :subject :flags :date :maildir :path :attachments) "Header fields to display in the message view buffer. For the -complete list of available headers, see `mm/header-names'" +complete list of available headers, see `mm/header-names'." :type (list 'symbol) :group 'mm/view) +(defcustom mm/view-date-format "%c" + "Date format to use in the message view, in the format of + `format-time-string'." + :type 'string + :group 'mm/headers) ;; Composing / Sending messages (defgroup mm/compose nil @@ -264,16 +284,11 @@ flag set)." headers)." :group 'mm/faces) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; internal variables / constants (defconst mm/mm-buffer-name "*mm*" "*internal* Name of the mm main buffer.") -(defvar mm/mu-version nil - "*interal* version of the mu binary") - (defconst mm/header-names '( (:attachments . "Attach") (:bcc . "Bcc") @@ -341,24 +356,16 @@ in which case it will be equal to `:to'.)") (insert "* " (propertize "mm - mail for emacs version " 'face 'mm/title-face) - (propertize mm/version 'face 'mm/view-header-value-face) + (propertize mm/mu-version 'face 'mm/view-header-value-face) " (send: " (propertize (if smtpmail-queue-mail "queued" "direct") 'face 'mm/view-header-key-face) ")" "\n\n" " Watcha wanna do?\n\n" - " * Show me some messages:\n" - " - In your " (propertize "I" 'face 'highlight) "nbox\n" - " - " (propertize "U" 'face 'highlight) "nread messages\n" - " - " (propertize "D" 'face 'highlight) "raft messages\n" - " - Received " (propertize "T" 'face 'highlight) "oday\n" - " - Received this " (propertize "W" 'face 'highlight) "eek\n" - "\n" - " * " (propertize "j" 'face 'highlight) "ump to a folder\n" - " * " (propertize "s" 'face 'highlight) "earch for a specific message\n" - "\n" - " * " (propertize "c" 'face 'highlight) "ompose a new message\n" + " - " (propertize "j" 'face 'highlight) "ump to some maildir\n" + " - " (propertize "s" 'face 'highlight) "earch for a specific message\n" + " - " (propertize "c" 'face 'highlight) "ompose a new message\n" "\n" "\n" @@ -456,7 +463,6 @@ maildirs under `mm/maildir." (fnames (mapconcat (lambda (item) - (message "%S" item) (concat "[" (propertize (make-string 1 (cdr item)) 'face 'mm/view-link-face) @@ -464,11 +470,12 @@ maildirs under `mm/maildir." (car item))) mlist ", ")) (kar (read-char (concat prompt fnames)))) - (if (= kar ?o) ;; user chose 'other'? + (if (= kar ?o) ;; user chose 'other'? (ido-completing-read prompt (mm/get-sub-maildirs mm/maildir)) - (car-safe - (find-if (lambda (item) (= kar (cdr item))) mm/maildir-shortcuts)))))) - + (unless (car-safe + (find-if (lambda (item) (= kar (cdr item))) mm/maildir-shortcuts)) + (error "Invalid shortcut")))))) + (defun mm/new-buffer (bufname) "Return a new buffer BUFNAME; if such already exists, kill the