alx/mu4e
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

* mm updates

Browse Source
This commit is contained in:
djcb
2011-11-05 10:26:24 +02:00
parent 19e93a52f1
commit cc7a09bd93
6 changed files with 261 additions and 242 deletions
Download Patch File Download Diff File Expand all files Collapse all files

145
toys/mm/mm-common.el
View File

@ -1,145 +0,0 @@
;;; mm-common.el -- part of mm, the mu mail user agent
;;
;; Copyright (C) 2011 Dirk-Jan C. Binnema
;; Author: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
;; Maintainer: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
;; Keywords: email
;; Version: 0.0
;; This file is not part of GNU Emacs.
;;
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(eval-when-compile (require 'cl))
(require 'ido)
;;; converting flags->string and vice-versa ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mm/flags-to-string (flags)
"Remove duplicates and sort the output of `mm/flags-to-string-raw'."
(concat
(sort (remove-duplicates (append (mm/flags-to-string-raw flags) nil)) '>)))
(defun mm/flags-to-string-raw (flags)
"Convert a list of flags into a string as seen in Maildir
message files; flags are symbols draft, flagged, new, passed,
replied, seen, trashed and the string is the concatenation of the
uppercased first letters of these flags, as per [1]. Other flags
than the ones listed here are ignored.
Also see `mm/flags-to-string'.
\[1\]: http://cr.yp.to/proto/maildir.html"
(when flags
(let ((kar (case (car flags)
('draft ?D)
('flagged ?F)
('new ?N)
('passed ?P)
('replied ?R)
('seen ?S)
('trashed ?T)
('attach ?a)
('encrypted ?x)
('signed ?s)
('unread ?u))))
(concat (and kar (string kar))
(mm/flags-to-string-raw (cdr flags))))))
(defun mm/string-to-flags (str)
"Remove duplicates from the output of `mm/string-to-flags-1'"
(remove-duplicates (mm/string-to-flags-1 str)))
(defun mm/string-to-flags-1 (str)
"Convert a string with message flags as seen in Maildir
messages into a list of flags in; flags are symbols draft,
flagged, new, passed, replied, seen, trashed and the string is
the concatenation of the uppercased first letters of these flags,
as per [1]. Other letters than the ones listed here are ignored.
Also see `mu/flags-to-string'.
\[1\]: http://cr.yp.to/proto/maildir.html"
(when (/= 0 (length str))
(let ((flag
(case (string-to-char str)
(?D 'draft)
(?F 'flagged)
(?P 'passed)
(?R 'replied)
(?S 'seen)
(?T 'trashed))))
(append (when flag (list flag))
(mm/string-to-flags-1 (substring str 1))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; other helper function ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TODO: make this recursive
(defun mm/get-sub-maildirs (maildir)
"Get all readable sub-maildirs under MAILDIR."
(let ((maildirs (remove-if
(lambda (dentry)
(let ((path (concat maildir "/" dentry)))
(or
(string= dentry ".")
(string= dentry "..")
(not (file-directory-p path))
(not (file-readable-p path))
(file-exists-p (concat path "/.noindex")))))
(directory-files maildir))))
(map 'list (lambda (dir) (concat "/" dir)) maildirs)))
(defun mm/ask-maildir (prompt)
"Ask user with PROMPT for a maildir name, if fullpath is
non-nill, return the fulpath (i.e., `mm/maildir' prepended to the
chosen folder)."
(unless (and mm/inbox-folder mm/drafts-folder mm/sent-folder)
(error "`mm/inbox-folder', `mm/drafts-folder' and
`mm/sent-folder' must be set"))
(unless mm/maildir (error "`mm/maildir' must be set"))
(interactive)
(ido-completing-read prompt (mm/get-sub-maildirs mm/maildir)))
(defun mm/new-buffer (bufname)
"Return a new buffer BUFNAME; if such already exists, kill the
old one first."
(when (get-buffer bufname)
(progn
(message (format "Killing %s" bufname))
(kill-buffer bufname)))
(get-buffer-create bufname))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide 'mm-common)

57
toys/mm/mm-hdrs.el
View File

@ -34,10 +34,8 @@
(eval-when-compile (require 'cl)) (eval-when-compile (require 'cl))
(require 'mm-common)
(require 'mm-proc) (require 'mm-proc)
;;;; internal variables/constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; internal variables/constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar mm/last-expr nil (defvar mm/last-expr nil
"*internal* The most recent search expression.") "*internal* The most recent search expression.")
@ -194,7 +192,6 @@ after the end of the search results."
;;; hdrs-mode and mode-map ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; hdrs-mode and mode-map ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq mm/hdrs-mode-map nil) (setq mm/hdrs-mode-map nil)
(defvar mm/hdrs-mode-map nil (defvar mm/hdrs-mode-map nil
@ -221,6 +218,7 @@ after the end of the search results."
(define-key map (kbd "<delete>") 'mm/mark-for-delete) (define-key map (kbd "<delete>") 'mm/mark-for-delete)
(define-key map "D" 'mm/mark-for-delete) (define-key map "D" 'mm/mark-for-delete)
(define-key map "a" 'mm/mark-for-move-quick)
(define-key map "u" 'mm/unmark) (define-key map "u" 'mm/unmark)
(define-key map "U" 'mm/unmark-all) (define-key map "U" 'mm/unmark-all)
@ -299,13 +297,22 @@ after the end of the search results."
mode-name "*mm-headers*" mode-name "*mm-headers*"
truncate-lines t truncate-lines t
buffer-read-only t buffer-read-only t
overwrite-mode 'overwrite-mode-binary)) overwrite-mode 'overwrite-mode-binary)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq header-line-format
(cons "* "
(map 'list
;;; headers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (lambda (item) ;; FIXME
(let ((field (cdr (assoc (car item) mm/header-names)))
(width (cdr item)))
(concat
(propertize
(if width
(truncate-string-to-width field width 0 ?\s t)
field)
'face 'mm/title-face) " ")))
mm/header-fields))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar mm/msg-map nil (defvar mm/msg-map nil
"*internal* A map (hashtable) which maps a database (Xapian) "*internal* A map (hashtable) which maps a database (Xapian)
docid (which uniquely identifies a message to a marker. where docid (which uniquely identifies a message to a marker. where
@ -584,11 +591,12 @@ return the new docid. Otherwise, return nil."
(mm/hdrs-search (concat "maildir:" fld)))) (mm/hdrs-search (concat "maildir:" fld))))
(defun mm/mark-for-move () (defun mm/mark-for-move (&optional target)
"Mark message at point for moving to a maildir." "Mark message at point for moving to maildir TARGET. If target is
not provided, function asks for it."
(interactive) (interactive)
(with-current-buffer mm/hdrs-buffer (with-current-buffer mm/hdrs-buffer
(let* ((target (mm/ask-maildir "Target maildir for move: ")) (let* ((target (or target (mm/ask-maildir "Target maildir for move: ")))
(fulltarget (concat mm/maildir target))) (fulltarget (concat mm/maildir target)))
(when (or (file-directory-p fulltarget) (when (or (file-directory-p fulltarget)
(and (yes-or-no-p (and (yes-or-no-p
@ -597,6 +605,31 @@ return the new docid. Otherwise, return nil."
(mm/hdrs-mark 'move target) (mm/hdrs-mark 'move target)
(mm/next-header))))) (mm/next-header)))))
(defun mm/mark-for-move-quick ()
"Mark message at point (or all messages in region) for moving to
a folder; see `mm/move-quick-targets'."
(interactive)
(unless mm/move-quick-targets
(error "`mm/move-quick-targets' has not been defined"))
(let* ((fnames
(mapconcat
(lambda (item)
(concat
"["
(propertize (make-string 1 (cdr item)) 'face 'mm/view-link-face)
"]"
(car item)))
mm/move-quick-targets ", "))
(kar (read-char (concat "Move to: " fnames)))
(targetitem
(find-if (lambda (item) (= kar (cdr item))) mm/move-quick-targets))
(target (and targetitem (car targetitem))))
;; if the target is not found, we simply exit
(when target
(mm/mark-for-move target))))
(defun mm/mark-for-trash () (defun mm/mark-for-trash ()
"Mark message at point for moving to the trash "Mark message at point for moving to the trash
folder (`mm/trash-folder')." folder (`mm/trash-folder')."

33
toys/mm/mm-proc.el
View File

@ -27,8 +27,6 @@
;;; Code: ;;; Code:
(eval-when-compile (require 'cl)) (eval-when-compile (require 'cl))
(require 'mm-common)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; internal vars ;; internal vars
@ -139,16 +137,18 @@ process."
(defun mm/kill-proc () (defun mm/kill-proc ()
"Kill the mu server process." "Kill the mu server process."
(let (buf (get-buffer mm/server-name)) (let* ((buf (get-buffer mm/server-name))
(when buf (proc (and buf (get-buffer-process buf))))
(when proc
(let ((delete-exited-processes t)) (let ((delete-exited-processes t))
;; send SIGINT (C-c) to process, so it can exit gracefully
(signal-process (get-buffer-process buf) 'SIGINT)
;; the mu server signal handler will make it quit after 'quit' ;; the mu server signal handler will make it quit after 'quit'
(mm/proc-send-command "quit")) (mm/proc-send-command "quit"))
(setq ;; try sending SIGINT (C-c) to process, so it can exit gracefully
mm/mu-proc nil (ignore-errors
mm/buf nil)))) (signal-process proc 'SIGINT))))
(setq
mm/mu-proc nil
mm/buf nil))
(defun mm/proc-is-running () (defun mm/proc-is-running ()
(and mm/mu-proc (eq (process-status mm/mu-proc) 'run))) (and mm/mu-proc (eq (process-status mm/mu-proc) 'run)))
@ -160,10 +160,10 @@ process."
Function returns this sexp, or nil if there was none. `mm/buf' is Function returns this sexp, or nil if there was none. `mm/buf' is
updated as well, with all processed sexp data removed." updated as well, with all processed sexp data removed."
(when mm/buf (when mm/buf
;; TODO: maybe try a non-regexp solution?
(let* ((b (string-match "\376\\([0-9]+\\)\376" mm/buf)) (let* ((b (string-match "\376\\([0-9]+\\)\376" mm/buf))
(sexp-len (sexp-len
(when b (string-to-number (match-string 1 mm/buf))))) (when b (string-to-number (match-string 1 mm/buf)))))
;; does mm/buf contain the full sexp? ;; does mm/buf contain the full sexp?
(when (and b (>= (length mm/buf) (+ sexp-len (match-end 0)))) (when (and b (>= (length mm/buf) (+ sexp-len (match-end 0))))
;; clear-up start ;; clear-up start
@ -171,10 +171,13 @@ updated as well, with all processed sexp data removed."
;; note: we read the input in binary mode -- here, we take the part that ;; note: we read the input in binary mode -- here, we take the part that
;; is the sexp, and convert that to utf-8, before we interpret it. ;; is the sexp, and convert that to utf-8, before we interpret it.
(let ((objcons (let ((objcons
(read-from-string (ignore-errors ;; note: this may fail if we killed the process
(decode-coding-string (substring mm/buf 0 sexp-len) 'utf-8)))) ;; in the middle
(setq mm/buf (substring mm/buf sexp-len)) (read-from-string
(car objcons)))))) (decode-coding-string (substring mm/buf 0 sexp-len) 'utf-8)))))
(when objcons
(setq mm/buf (substring mm/buf sexp-len))
(car objcons)))))))
(defun mm/proc-filter (proc str) (defun mm/proc-filter (proc str)
@ -292,6 +295,8 @@ terminates."
(t (message (format "mu server process received signal %d" code))))) (t (message (format "mu server process received signal %d" code)))))
((eq status 'exit) ((eq status 'exit)
(cond (cond
((eq code 0)
(message nil)) ;; don't do anything
((eq code 11) ((eq code 11)
(message "Database is locked by another process")) (message "Database is locked by another process"))
((eq code 19) ((eq code 19)

37
toys/mm/mm-send.el
View File

@ -148,8 +148,10 @@ The result is either nil or a string which can be used for the To:-field."
(if reply-all (if reply-all
(progn ;; reply-all (progn ;; reply-all
(setq to-lst ;; append Reply-To:, or if not set, From: if set (setq to-lst ;; append Reply-To:, or if not set, From: if set
(if reply-to (cons `(nil . ,reply-to) to-lst) (if reply-to
(if from (append to-lst from) (cons `(nil . ,reply-to) to-lst)
(if from
(append to-lst from)
to-lst))) to-lst)))
;; and remove myself from To: ;; and remove myself from To:
@ -169,8 +171,7 @@ is either nil or a string to be used for the Cc: field."
(let ((cc-lst (plist-get msg :cc))) (let ((cc-lst (plist-get msg :cc)))
(when (and reply-all cc-lst) (when (and reply-all cc-lst)
(mm/msg-recipients-to-string (mm/msg-recipients-to-string
(mm/msg-recipients-remove cc-lst (mm/msg-recipients-remove cc-lst user-mail-address)))))
user-mail-address)))))
(defun mm/msg-from-create () (defun mm/msg-from-create ()
"Construct a value for the From:-field of the reply to MSG, "Construct a value for the From:-field of the reply to MSG,
@ -288,18 +289,22 @@ body from headers)."
already exist, and optionally fill it with STR. Function also adds already exist, and optionally fill it with STR. Function also adds
the new message to the database. When the draft message is added to the new message to the database. When the draft message is added to
the database, `mm/path-docid-map' will be updated, so that we can the database, `mm/path-docid-map' will be updated, so that we can
use the new docid. Return the full path to the new message." use the new docid. Returns the full path to the new message."
(let ((draft (let* ((hostname
(concat mm/maildir mm/drafts-folder "/cur/" (downcase
(format "%s-%x%x:2,D" ;; 'D': rarely used, but hey, it's available (save-match-data
(format-time-string "%Y%m%d" (current-time)) (substring system-name
(emacs-pid) (string-match "^[^.]+" system-name) (match-end 0)))))
(random t)))) ;; TODO: include hostname (draft
(str (case compose-type (concat mm/maildir mm/drafts-folder "/cur/"
(reply (mm/msg-create-reply msg)) (format "%s-%x%x.%s:2,D" ;; 'D': rarely used, but hey, it's available
(forward (mm/msg-create-forward msg)) (format-time-string "%Y%m%d" (current-time))
(new (mm/msg-create-new)) (emacs-pid) (random t) hostname)))
(t (error "unsupported compose-type %S" compose-type))))) (str (case compose-type
(reply (mm/msg-create-reply msg))
(forward (mm/msg-create-forward msg))
(new (mm/msg-create-new))
(t (error "unsupported compose-type %S" compose-type)))))
(when str (when str
(with-temp-file draft (with-temp-file draft
(insert str) (insert str)

67
toys/mm/mm-view.el
View File

@ -32,7 +32,6 @@
;;; Code: ;;; Code:
(eval-when-compile (require 'cl)) (eval-when-compile (require 'cl))
(require 'mm-common)
(require 'html2text) (require 'html2text)
(require 'filladapt) (require 'filladapt)
@ -61,28 +60,34 @@ marking if it still had that."
(insert (insert
(mapconcat (mapconcat
(lambda (field) (lambda (field)
(case field (let ((fieldname (cdr (assoc field mm/header-names)))
(:subject (mm/view-header "Subject" (plist-get msg :subject))) (fieldval (plist-get msg field)))
(:path (mm/view-header "Path" (plist-get msg :path))) (case field
(:to (mm/view-contacts msg field))
(:from (mm/view-contacts msg field)) (:subject (mm/view-header fieldname fieldval))
(:cc (mm/view-contacts msg field)) (:path (mm/view-header fieldname fieldval))
(:bcc (mm/view-contacts msg field)) (:maildir (mm/view-header fieldname fieldval))
(:date (:flags (mm/view-header fieldname (format "%S" fieldval)))
(let* ((date (plist-get msg :date))
(datestr (when date (format-time-string "%c" date)))) ;; contact fields
(if datestr (mm/view-header "Date" datestr) ""))) (:to (mm/view-contacts msg field))
(:from (mm/view-contacts msg field))
(:cc (mm/view-contacts msg field))
(:bcc (mm/view-contacts msg field))
(:flags "") ;; TODO ;; date
(:maildir (mm/view-header "Maildir" (plist-get msg :maildir))) (:date
(:size (mm/view-size msg) (let ((datestr
(let* ((size (plist-get msg :size)) (when fieldval (format-time-string "%c" fieldval))))
(sizestr (when size (format "%d bytes")))) (if datestr (mm/view-header fieldname datestr) "")))
(if sizestr (mm/view-header "Size" sizestr)))) ;; size
(:size (mm/view-size msg)
(:attachments (mm/view-attachments msg)) (let ((sizestr (when size (format "%d bytes"))))
(t (error "Unsupported field: %S" field)))) (if sizestr (mm/view-header fieldname sizestr))))
mm/view-headers "") ;; attachments
(:attachments (mm/view-attachments msg))
(t (error "Unsupported field: %S" field)))))
mm/view-fields "")
"\n" "\n"
(mm/view-body msg)) (mm/view-body msg))
@ -91,7 +96,7 @@ marking if it still had that."
(setq ;; these are buffer-local (setq ;; these are buffer-local
mode-name (if (plist-get msg :subject) mode-name (if (plist-get msg :subject)
(truncate-string-to-width (plist-get msg :subject) 16 0 nil t) (truncate-string-to-width (plist-get msg :subject) 16 0 nil t)
"No subject") (propertize "No subject" 'face 'mm/system-face))
mm/current-msg msg mm/current-msg msg
mm/hdrs-buffer hdrsbuf mm/hdrs-buffer hdrsbuf
mm/link-map (make-hash-table :size 32 :rehash-size 2 :weakness nil)) mm/link-map (make-hash-table :size 32 :rehash-size 2 :weakness nil))
@ -116,7 +121,7 @@ or if not available, :body-html converted to text)."
(defun mm/view-header (key val) (defun mm/view-header (key val)
"Show header FIELD for MSG with KEY. ie. <KEY>: value-of-FIELD\n." "Show header FIELD for MSG with KEY. ie. <KEY>: value-of-FIELD."
(if val (if val
(concat (concat
(propertize key 'face 'mm/view-header-key-face) ": " (propertize key 'face 'mm/view-header-key-face) ": "
@ -125,20 +130,20 @@ or if not available, :body-html converted to text)."
(defun mm/view-contacts (msg field) (defun mm/view-contacts (msg field)
(unless (member field '(:to :from :bcc :cc)) (error "Wrong type")) "Add a header for a contact field (ie., :to, :from, :cc, :bcc)."
(let* ((lst (plist-get msg field)) (let* ((lst (plist-get msg field))
(fieldname (cdr (assoc field mm/header-names)))
(contacts (contacts
(when lst (and lst
(mapconcat (mapconcat
(lambda(c) (lambda(c)
(let ((name (car c)) (email (cdr c))) (let ((name (car c)) (email (cdr c)))
(if name (if name
(format "%s <%s>" name email) (format "%s <%s>" name email)
(format "%s" email)))) lst ", ")))) (format "%s" email)))) lst ", "))))
(message "%S %S" field fieldname)
(if contacts (if contacts
(mm/view-header (mm/view-header fieldname contacts)
(case field (:to "To") (:from "From") (:bcc "Bcc") (:cc "Cc"))
contacts)
""))) "")))
(defvar mm/attach-map nil (defvar mm/attach-map nil
@ -207,7 +212,7 @@ or if not available, :body-html converted to text)."
(define-key map (kbd "<delete>") 'mm/view-mark-for-delete) (define-key map (kbd "<delete>") 'mm/view-mark-for-delete)
(define-key map "D" 'mm/view-mark-for-delete) (define-key map "D" 'mm/view-mark-for-delete)
(define-key map "a" 'mm/mark-for-move-quick)
(define-key map "m" 'mm/view-mark-for-move) (define-key map "m" 'mm/view-mark-for-move)
;; misc ;; misc
@ -249,7 +254,7 @@ or if not available, :body-html converted to text)."
'("Mark for trash" . mm/view-mark-for-trash)) '("Mark for trash" . mm/view-mark-for-trash))
(define-key menumap [mark-move] (define-key menumap [mark-move]
'("Mark for move" . mm/view-mark-for-move)) '("Mark for move" . mm/view-mark-for-move))
(define-key menumap [sepa2] '("--")) (define-key menumap [sepa2] '("--"))
(define-key menumap [compose-new] '("Compose new" . mm/compose-new)) (define-key menumap [compose-new] '("Compose new" . mm/compose-new))
(define-key menumap [forward] '("Forward" . mm/compose-forward)) (define-key menumap [forward] '("Forward" . mm/compose-forward))

164
toys/mm/mm.el
View File

@ -1,4 +1,4 @@
;;; mm.el -- part of mm, the mu mail user agent
;; ;;
;; Copyright (C) 2011 Dirk-Jan C. Binnema ;; Copyright (C) 2011 Dirk-Jan C. Binnema
@ -31,7 +31,6 @@
(require 'mm-hdrs) (require 'mm-hdrs)
(require 'mm-view) (require 'mm-view)
(require 'mm-send) (require 'mm-send)
(require 'mm-common)
(require 'mm-proc) (require 'mm-proc)
@ -79,11 +78,9 @@ PATH, you can specifiy the full path."
:safe 'stringp) :safe 'stringp)
(defvar mm/debug nil (defvar mm/debug nil
"When set to non-nil, log debug information to the *mm-log* buffer.") "When set to non-nil, log debug information to the *mm-log* buffer.")
;; Folders ;; Folders
(defgroup mm/folders nil (defgroup mm/folders nil
@ -119,6 +116,18 @@ PATH, you can specifiy the full path."
:group 'mm/folders) :group 'mm/folders)
(defcustom mm/move-quick-targets nil
"A list of targets quickly moving messages towards (i.e.,
archiving or refiling). The list contains elements of the form
(foldername . shortcut), where FOLDERNAME is a maildir (such as
\"/archive/\"), and shortcut a single shortcut character. With
this, in the header buffer and view buffer you can execute
`mm/mark-for-move-quick' (or 'a', by default) followed by the designated
character for the target folder, and the message at point (or all
the messages in the region) will be marked for moving to the target
folder.")
;; the headers view ;; the headers view
(defgroup mm/headers nil (defgroup mm/headers nil
"Settings for the headers view." "Settings for the headers view."
@ -133,20 +142,17 @@ PATH, you can specifiy the full path."
"A list of header fields to show in the headers buffer, and their "A list of header fields to show in the headers buffer, and their
respective widths in characters. A width of `nil' means respective widths in characters. A width of `nil' means
'unrestricted', and this is best reserved fo the rightmost (last) 'unrestricted', and this is best reserved fo the rightmost (last)
field.") field. For the complete list of available headers, see `mm/header-names'")
(defcustom mm/hdrs-on-top t
"If non-nil, display headers above the message view; otherwise, display the headers on the left of the message view"
)
;; the message view ;; the message view
(defgroup mm/view nil (defgroup mm/view nil
"Settings for the message view." "Settings for the message view."
:group 'mm) :group 'mm)
(defcustom mm/view-headers (defcustom mm/view-fields
'(:from :to :cc :subject :flags :date :maildir :path :attachments) '(:from :to :cc :subject :flags :date :maildir :path :attachments)
"Header fields to display in the message view buffer." "Header fields to display in the message view buffer. For the
complete list of available headers, see `mm/header-names'"
:type (list 'symbol) :type (list 'symbol)
:group 'mm/view) :group 'mm/view)
@ -253,7 +259,6 @@ flag set)."
"Face for the mark in the headers list." "Face for the mark in the headers list."
:group 'mm/faces) :group 'mm/faces)
(defface mm/system-face (defface mm/system-face
'((t :inherit font-lock-comment-face :slant italic)) '((t :inherit font-lock-comment-face :slant italic))
"Face for system message (such as the footers for message "Face for system message (such as the footers for message
@ -263,13 +268,31 @@ headers)."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; internal variables / constant ;; internal variables / constants
(defconst mm/mm-buffer-name "*mm*" (defconst mm/mm-buffer-name "*mm*"
"*internal* Name of the mm main buffer.") "*internal* Name of the mm main buffer.")
(defvar mm/mu-version nil (defvar mm/mu-version nil
"*interal* version of the mu binary") "*interal* version of the mu binary")
(defconst mm/header-names
'( (:attachments . "Attach")
(:bcc . "Bcc")
(:cc . "Cc")
(:date . "Date")
(:flags . "Flags")
(:from . "From")
(:from-or-to . "From/To")
(:maildir . "Maildir")
(:path . "Path")
(:subject . "Subject")
(:to . "To"))
"A alist of all possible header fields; this is used in the UI (the
column headers in the header list, and the fields the message
view). Most fields should be self-explanatory. A special one is
`:from-or-to', which is equal to `:from' unless `:from' matches ,
in which case it will be equal to `:to'.)")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; mm mode + keybindings ;; mm mode + keybindings
(defvar mm/mm-mode-map (defvar mm/mm-mode-map
@ -344,18 +367,8 @@ headers)."
" * toggle " (propertize "m" 'face 'highlight) "ail sending mode " " * toggle " (propertize "m" 'face 'highlight) "ail sending mode "
"\n" "\n"
" * " (propertize "q" 'face 'highlight) "uit mm\n") " * " (propertize "q" 'face 'highlight) "uit mm\n")
(mm/mm-mode) (mm/mm-mode)
(switch-to-buffer buf)))) (switch-to-buffer buf))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; window management
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -402,9 +415,11 @@ headers)."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; General helper functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mm/quit-mm() (defun mm/quit-mm()
"Quit the mm session." "Quit the mm session."
(interactive) (interactive)
@ -413,4 +428,105 @@ headers)."
(mm/kill-proc) (mm/kill-proc)
(kill-buffer))) (kill-buffer)))
;; TODO: make this recursive
(defun mm/get-sub-maildirs (maildir)
"Get all readable sub-maildirs under MAILDIR."
(let ((maildirs (remove-if
(lambda (dentry)
(let ((path (concat maildir "/" dentry)))
(or
(string= dentry ".")
(string= dentry "..")
(not (file-directory-p path))
(not (file-readable-p path))
(file-exists-p (concat path "/.noindex")))))
(directory-files maildir))))
(map 'list (lambda (dir) (concat "/" dir)) maildirs)))
(defun mm/ask-maildir (prompt)
"Ask user with PROMPT for a maildir name, if fullpath is
non-nill, return the fulpath (i.e., `mm/maildir' prepended to the
chosen folder)."
(unless (and mm/inbox-folder mm/drafts-folder mm/sent-folder)
(error "`mm/inbox-folder', `mm/drafts-folder' and
`mm/sent-folder' must be set"))
(unless mm/maildir (error "`mm/maildir' must be set"))
(interactive)
(ido-completing-read prompt (mm/get-sub-maildirs mm/maildir)))
(defun mm/new-buffer (bufname)
"Return a new buffer BUFNAME; if such already exists, kill the
old one first."
(when (get-buffer bufname)
(progn
(message (format "Killing %s" bufname))
(kill-buffer bufname)))
(get-buffer-create bufname))
;;; converting flags->string and vice-versa ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mm/flags-to-string (flags)
"Remove duplicates and sort the output of `mm/flags-to-string-raw'."
(concat
(sort (remove-duplicates (append (mm/flags-to-string-raw flags) nil)) '>)))
(defun mm/flags-to-string-raw (flags)
"Convert a list of flags into a string as seen in Maildir
message files; flags are symbols draft, flagged, new, passed,
replied, seen, trashed and the string is the concatenation of the
uppercased first letters of these flags, as per [1]. Other flags
than the ones listed here are ignored.
Also see `mm/flags-to-string'.
\[1\]: http://cr.yp.to/proto/maildir.html"
(when flags
(let ((kar (case (car flags)
('draft ?D)
('flagged ?F)
('new ?N)
('passed ?P)
('replied ?R)
('seen ?S)
('trashed ?T)
('attach ?a)
('encrypted ?x)
('signed ?s)
('unread ?u))))
(concat (and kar (string kar))
(mm/flags-to-string-raw (cdr flags))))))
(defun mm/string-to-flags (str)
"Remove duplicates from the output of `mm/string-to-flags-1'"
(remove-duplicates (mm/string-to-flags-1 str)))
(defun mm/string-to-flags-1 (str)
"Convert a string with message flags as seen in Maildir
messages into a list of flags in; flags are symbols draft,
flagged, new, passed, replied, seen, trashed and the string is
the concatenation of the uppercased first letters of these flags,
as per [1]. Other letters than the ones listed here are ignored.
Also see `mu/flags-to-string'.
\[1\]: http://cr.yp.to/proto/maildir.html"
(when (/= 0 (length str))
(let ((flag
(case (string-to-char str)
(?D 'draft)
(?F 'flagged)
(?P 'passed)
(?R 'replied)
(?S 'seen)
(?T 'trashed))))
(append (when flag (list flag))
(mm/string-to-flags-1 (substring str 1))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide 'mm) (provide 'mm)