From 288a5763a6fc5f9b5a1149bc342c41e23e101c28 Mon Sep 17 00:00:00 2001 From: "Dirk-Jan C. Binnema" Date: Sun, 18 Sep 2011 14:39:36 +0300 Subject: [PATCH] * many updates to `mm', the mu-based MUA for emacs --- toys/mm/mm-common.el | 242 ++---------------------- toys/mm/mm-hdrs.el | 282 +++++++++++++++++----------- toys/mm/mm-proc.el | 295 ++++++++++++++++++----------- toys/mm/mm-send.el | 436 +++++++++++++++++++++++++++++++++++++++++++ toys/mm/mm-view.el | 253 +++++++++++++++++++++++++ toys/mm/mm.el | 233 ++++++++++++++++++++--- 6 files changed, 1274 insertions(+), 467 deletions(-) create mode 100644 toys/mm/mm-send.el create mode 100644 toys/mm/mm-view.el diff --git a/toys/mm/mm-common.el b/toys/mm/mm-common.el index d17c1604..f6d09cdd 100644 --- a/toys/mm/mm-common.el +++ b/toys/mm/mm-common.el @@ -30,56 +30,6 @@ (require 'ido) -(defun mm/eval-msg-string (str) - "Get the plist describing an email message, from STR containing -a message sexp. - - a message sexp looks something like: - \( - :from ((\"Donald Duck\" . \"donald@example.com\")) - :to ((\"Mickey Mouse\" . \"mickey@example.com\")) - :subject \"Wicked stuff\" - :date (20023 26572 0) - :size 15165 - :references (\"200208121222.g7CCMdb80690@msg.id\") - :in-reply-to \"200208121222.g7CCMdb80690@msg.id\" - :message-id \"foobar32423847ef23@pluto.net\" - :maildir: \"/archive\" - :path \"/home/mickey/Maildir/inbox/cur/1312254065_3.32282.pluto,4cd5bd4e9:2,\" - :priority high - :flags (new unread) - :attachments ((2 \"hello.jpg\" \"image/jpeg\") (3 \"laah.mp3\" \"audio/mp3\")) - :body-txt \" \" -\) -other fields are :cc, :bcc, :body-html - -When the s-expression comes from the database ('mu find'), the -fields :attachments, :body-txt, :body-html, :references, :in-reply-to -are missing (because that information is not stored in the -database -- at least not in a usable way." - (condition-case nil - (car (read-from-string str));; read-from-string returns a cons - (error "Failed to parse message"))) - - -(defun mm/msg-field (msg field) - "Get a field from this message, or nil. The fields are the -fields of the message, which are the various items of the plist -as described in `mm/eval-msg-string' - -There is also the special field :body (which is either :body-txt, -or if not available, :body-html converted to text)." - (case field - (:body - (let* ((body (mm/msg-field msg :body-txt)) - (body (or body (with-temp-buffer - (mm/msg-field msg :body-html) - (html2text) - (buffer-string))))))) - (t (plist-get msg field)))) - - - @@ -203,176 +153,29 @@ nil. (mm/db-update-execute) t)))) -;;; some functions for *asyncronously* updating the database - -(defvar mm/db-update-proc nil - "*internal* Process for async db updates.") -(defvar mm/db-update-name "*mm-db-update*" - "*internal* name of the db-update process") -(defvar mm/db-add-paths nil - "*internal* List of message paths to add to the database.") -(defvar mm/db-remove-paths nil - "*internal* List of message paths to remove from the database.") - - -(defun mm/db-update-proc-sentinel (proc msg) - "Check the database update process upon completion." - (let ((procbuf (process-buffer proc)) - (status (process-status proc)) - (exit-status (process-exit-status proc))) - (when (and (buffer-live-p procbuf) (memq status '(exit signal))) - (case status - ('signal (mm/log "Process killed")) - ('exit - (case exit-status - (mm/log "Result: %s" (mm/error-string exit-status)))))) - ;; try to update again, maybe there are some new updates - (mm/db-update-execute))) - - -(defun mm/db-update-execute () - "Update the database; remove paths in `mm/db-remove-paths', -and add paths in `mm/db-add-paths'. Updating is ansynchronous." - - ;; when it's already running, do nothing - (unless (and mm/db-update-proc (eq (process-status mm/db-update-proc) 'run)) - (when mm/db-remove-paths - (let ((remove-paths (copy-list mm/db-remove-paths))) - (mm/log (concat mm/mu-binary " remove " - (mapconcat 'identity remove-paths " "))) - (setq mm/db-remove-paths nil) ;; clear the old list - (setq mm/db-update-proc - (apply 'start-process mm/db-update-name mm/db-update-name mm/mu-binary - "remove" remove-paths)) - (set-process-sentinel mm/db-update-proc 'mm/db-update-proc-sentinel))))) - - ;; when it's already running, do nothing - (unless (and mm/db-update-proc (eq (process-status mm/db-update-proc) 'run)) - (when mm/db-add-paths - (let ((add-paths (copy-list mm/db-add-paths))) - (mm/log (concat mm/mu-binary " add " (mapconcat 'identity add-paths " "))) - (setq mm/db-add-paths nil) ;; clear the old list - (setq mm/db-update-proc - (apply 'start-process mm/db-update-name mm/db-update-name mm/mu-binary - "add" add-paths)) - (set-process-sentinel mm/db-update-proc 'mm/db-update-proc-sentinel)))) - -(defun mm/db-add-async (path-or-paths) - "Asynchronously add msg at PATH-OR-PATHS to -database. PATH-OR-PATHS is either a single path or a list of them." - (setq mm/db-add-paths - (append mm/db-add-paths - (if (listp path-or-paths) path-or-paths `(,path-or-paths))))) -;; (mm/db-update-execute)) - -(defun mm/db-remove-async (path-or-paths) - "Asynchronously remove msg at PATH-OR-PATHS from -database. PATH-OR-PATHS is either a single path or a list of -them." - (setq mm/db-remove-paths - (append mm/db-remove-paths - (if (listp path-or-paths) path-or-paths `(,path-or-paths))))) -;; (mm/db-update-execute)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - - - - - - -;;; error codes / names ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; generated with: -;; cat mu-util.h | sed 's/\([A-Z_]\+\).*=\(.*\),/(defconst \L\1 \2)/' < "$<" \ -;; | sed 's/_/-/g' > mu-errors.el -(defconst mm/err 1) -(defconst mm/err-in-parameters 2) -(defconst mm/err-internal 3) -(defconst mm/err-no-matches 4) -(defconst mm/err-xapian 11) -(defconst mm/err-xapian-query 13) -(defconst mm/err-xapian-dir-not-accessible 14) -(defconst mm/err-xapian-not-up-to-date 15) -(defconst mm/err-xapian-missing-data 16) -(defconst mm/err-xapian-corruption 17) -(defconst mm/err-xapian-cannot-get-writelock 18) -(defconst mm/err-gmime 30) -(defconst mm/err-contacts 50) -(defconst mm/err-contacts-cannot-retrieve 51) -(defconst mm/err-file 70) -(defconst mm/err-file-invalid-name 71) -(defconst mm/err-file-cannot-link 72) -(defconst mm/err-file-cannot-open 73) -(defconst mm/err-file-cannot-read 74) -(defconst mm/err-file-cannot-create 75) -(defconst mm/err-file-cannot-mkdir 76) -(defconst mm/err-file-stat-failed 77) -(defconst mm/err-file-readdir-failed 78) -(defconst mm/err-file-invalid-source 79) -(defconst mm/err-file-target-equals-source 80) - -;; TODO: use 'case' instead... -(defun mm/error-string (err) - "Convert an exit code from mu into a string." - (cond - ((eql err mm/err) "General error") - ((eql err mm/err-in-parameters) "Error in parameters") - ((eql err mm/err-internal) "Internal error") - ((eql err mm/err-no-matches) "No matches") - ((eql err mm/err-xapian) "Xapian error") - ((eql err mm/err-xapian-query) "Error in query") - ((eql err mm/err-xapian-dir-not-accessible) "Database dir not accessible") - ((eql err mm/err-xapian-not-up-to-date) "Database is not up-to-date") - ((eql err mm/err-xapian-missing-data) "Missing data") - ((eql err mm/err-xapian-corruption) "Database seems to be corrupted") - ((eql err mm/err-xapian-cannot-get-writelock)"Database is locked") - ((eql err mm/err-gmime) "GMime-related error") - ((eql err mm/err-contacts) "Contacts-related error") - ((eql err mm/err-contacts-cannot-retrieve) "Failed to retrieve contacts") - ((eql err mm/err-file) "File error") - ((eql err mm/err-file-invalid-name) "Invalid file name") - ((eql err mm/err-file-cannot-link) "Failed to link file") - ((eql err mm/err-file-cannot-open) "Cannot open file") - ((eql err mm/err-file-cannot-read) "Cannot read file") - ((eql err mm/err-file-cannot-create) "Cannot create file") - ((eql err mm/err-file-cannot-mkdir) "mu-mkdir failed") - ((eql err mm/err-file-stat-failed) "stat(2) failed") - ((eql err mm/err-file-readdir-failed) "readdir failed") - ((eql err mm/err-file-invalid-source) "Invalid source file") - ((eql err mm/err-file-target-equals-source) "Source is same as target") - (t (format "Unknown error (%d)" err)))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; other helper function ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun mm/mu-run (&rest args) - "Run 'mu' synchronously with ARGS as command-line argument;, -where is the exit code of the program, or 1 if the -process was killed. contains whatever the command wrote on -standard output/error, or nil if there was none or in case of -error. `mm/mu-run' is like `shell-command-to-string', but with -better possibilities for error handling. The --muhome= parameter is -added automatically if `mm/mu-home' is non-nil." - (let* ((rv) - (allargs (remove-if 'not - (append args (when mm/mu-home (concat "--muhome=" mm/mu-home))))) - (cmdstr (concat mm/mu-binary " " (mapconcat 'identity allargs " "))) - (str (with-output-to-string - (with-current-buffer standard-output ;; but we also get stderr... - (setq rv (apply 'call-process mm/mu-binary nil t nil - args)))))) - (mm/log "%s %s => %S" mm/mu-binary (mapconcat 'identity args " ") rv) - (when (and (numberp rv) (/= 0 rv)) - (error (mm/error-string rv))) - `(,(if (numberp rv) rv 1) . ,str))) +;; 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 &optional fullpath) +(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)." @@ -381,11 +184,7 @@ chosen folder)." `mm/sent-folder' must be set")) (unless mm/maildir (error "`mm/maildir' must be set")) (interactive) - (let* ((showfolders - (append (list mm/inbox-folder mm/drafts-folder mm/sent-folder) - mm/working-folders)) - (chosen (ido-completing-read prompt showfolders))) - (concat (if fullpath mm/maildir "") chosen))) + (ido-completing-read prompt (mm/get-sub-maildirs mm/maildir))) (defun mm/new-buffer (bufname) @@ -398,15 +197,6 @@ old one first." (get-buffer-create bufname)) -(defconst mm/log-buffer-name "*mm-log*" - "*internal* Name of the logging buffer.") - -(defun mm/log (frm &rest args) - "Write something in the *mm-log* buffer - mainly useful for debugging." - (with-current-buffer (get-buffer-create mm/log-buffer-name) - (goto-char (point-max)) - (insert (apply 'format (concat (format-time-string "%x %X " (current-time)) - frm "\n") args)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/toys/mm/mm-hdrs.el b/toys/mm/mm-hdrs.el index 1b945542..e8b262c6 100644 --- a/toys/mm/mm-hdrs.el +++ b/toys/mm/mm-hdrs.el @@ -28,7 +28,7 @@ ;; descriptions of emails, aka 'headers' (not to be confused with headers like ;; 'To:' or 'Subject:') -;; mu +;; mm ;;; Code: @@ -53,7 +53,7 @@ "*internal Whether to sort in descending order") -(defconst mm/hdrs-buffer-name "*headers*" +(defconst mm/hdrs-buffer-name "*mm-headers*" "*internal* Name of the buffer for message headers.") (defvar mm/hdrs-buffer nil @@ -63,62 +63,101 @@ "Search in the mu database for EXPR, and switch to the output buffer for the results." (interactive "s[mu] search for: ") - ;; make sure we get a brand new buffer - (setq mm/hdrs-buffer (mm/new-buffer mm/hdrs-buffer-name)) + (let ((buf (get-buffer-create mm/hdrs-buffer-name)) + (inhibit-read-only t)) + (with-current-buffer buf + (erase-buffer) + (mm/hdrs-mode) + (setq mm/msg-map nil mm/mm/marks-map nil) + (mm/msg-map-init) + (setq + mode-name expr + mm/last-expr expr + mm/hdrs-buffer buf))) (switch-to-buffer mm/hdrs-buffer) - (mm/hdrs-mode) - (setq mm/last-expr expr) - (mm/msg-map-init) - (let ((inhibit-read-only t)) (erase-buffer)) ;; FIXME -- why is this needed?! - - ;; all set -- now execute the search (mm/proc-find expr)) -(defun mm/hdrs-message-handler (msg) - (message "Received message %d (%s)" - (plist-get msg :docid) - (plist-get msg :subject))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; handler functions +;; +;; next are a bunch of handler functions; those will be called from mm-proc in +;; response to output from the server process + + +(defun mm/hdrs-view-handler (msg) + "Handler function for displaying a message." + (mm/view msg mm/hdrs-buffer)) (defun mm/hdrs-error-handler (err) - (message "Error %d: %s" - (plist-get err :error) - (plist-get err :error-message))) + "Handler function for showing an error." + (let ((errcode (plist-get err :error)) + (errmsg (plist-get err :error-message))) + (case errcode + (4 (message "No matches for this search query.")) + (t (message (format "Error %d: %s" errcode errmsg)))))) -(defun mm/hdrs-update-handler (update) - "Update handler, will be called when we get '(:update ... )' from -the mu server process. This function will update the current list -of headers." - (message "We received a database update: %S" update) - (let* ((type (plist-get update :update)) (docid (plist-get update :docid)) - (marker (mm/msg-map-get-marker docid))) - (unless docid (error "Invalid update %S" update)) - (unless marker (error "Message %d not found" docid)) +(defun mm/hdrs-update-handler (msg is-move) + "Update handler, will be called when a message has been updated +in the database. This function will update the current list of +headers." + (when (buffer-live-p mm/hdrs-buffer) (with-current-buffer mm/hdrs-buffer + (let* ((docid (plist-get msg :docid)) + (marker (mm/msg-map-get-marker docid))) + (unless docid (error "Invalid update %S" update)) + (unless marker (error "Message %d not found" docid)) + (save-excursion + (goto-char (marker-position marker)) + ;; sanity check + (unless (eq docid (get-text-property (point) 'docid)) + (error "Unexpected docid")) + ;; if it's marked, unmark it now + (when (mm/hdrs-docid-is-marked docid) + (mm/hdrs-mark 'unmark)) + (let ((inhibit-read-only t) (bol (line-beginning-position)) + (eol (line-beginning-position 2))) + ;; hide the old line (removing it causes some problems) + (put-text-property bol eol 'invisible t) + ;; now, if this update was about *moving* a message, we don't show it + ;; anymore (of course, we cannot be sure if the message really no + ;; longer matches the query, but this seem a good heuristic. + ;; if it was only a flag-change, show the message with its updated flags. + (unless is-move + (mm/hdrs-header-handler msg bol)))))))) + +(defun mm/hdrs-remove-handler (docid) + "Remove handler, will be called when a message has been removed +from the database. This function will hide the remove message in +the current list of headers." + (with-current-buffer mm/hdrs-buffer + (let ((marker (mm/msg-map-get-marker docid))) + (unless marker (error "Message %d not found" docid)) (save-excursion (goto-char (marker-position marker)) ;; sanity check (unless (eq docid (get-text-property (point) 'docid)) (error "Unexpected docid")) - (mm/hdrs-mark 'unmark) + ;; if it's marked, unmark it now + (when (mm/hdrs-docid-is-marked docid) + (mm/hdrs-mark 'unmark)) (let ((inhibit-read-only t) (bol (line-beginning-position)) (eol (line-beginning-position 2))) - (case type - (remove (put-text-property bol eol 'invisible t)) - (move (put-text-property bol eol 'face 'mm/moved-face)) - (t (error "Invalid update %S" update)))))))) + ;; hide the message + (set-text-properties bol eol '(invisible t))))))) - -(defun mm/hdrs-header-handler (msg) - "Function to insert a line for a message. This will be called by +(defun mm/hdrs-header-handler (msg &optional point) + "Function to add a line for a message. This will be called by `mm/proc-find'. Function expects to be in the output buffer -already." - (let* ((docid (mm/msg-field msg :docid)) +already. Normally, msg is appended to the end of the buffer, but if +POINT is given, message is insert at POINT." + (let* ((docid (plist-get msg :docid)) (line (propertize (concat " " (mm/hdrs-line msg) "\n") 'docid docid))) ;; add message to the docid=>path map, see `mm/msg-map'. (with-current-buffer mm/hdrs-buffer (save-excursion - (goto-char (point-max)) + ;; append to end, or insert at POINT if that was provided + (goto-char (if point point (point-max))) (mm/msg-map-add msg (point-marker)) (let ((inhibit-read-only t)) (insert line)))))) @@ -126,11 +165,11 @@ already." (defun mm/hdrs-line (msg) "Get the one-line description of MSG (as per `mm/hdrs-raw-line'), and apply text-properties based on the message flags." - (let ((line (mm/hdrs-raw-line msg)) - (flags (plist-get msg :flags))) + (let ((line (mm/hdrs-raw-line msg)) (flags (plist-get msg :flags))) (cond - ((member 'unread flags) (propertize line 'face 'mm/unread-face)) - (t (propertize line 'face 'mm/header-face))))) + ((member 'trashed flags) (propertize line 'face 'mm/trashed-face)) + ((member 'unread flags) (propertize line 'face 'mm/unread-face)) + (t (propertize line 'face 'mm/header-face))))) (defun mm/hdrs-raw-line (msg) "Create a one line description of MSG in this buffer at @@ -189,9 +228,9 @@ point. Line does not include a newline or any text-properties." (define-key map "x" 'mm/execute-marks) ;; message composition - ;; (define-key map "r" 'mua/hdrs-reply) - ;; (define-key map "f" 'mua/hdrs-forward) - ;; (define-key map "c" 'mua/hdrs-compose) + (define-key map "r" 'mm/compose-reply) + (define-key map "f" 'mm/compose-forward) + (define-key map "c" 'mm/compose-new) (define-key map (kbd "RET") 'mm/view-message) map) @@ -205,7 +244,6 @@ point. Line does not include a newline or any text-properties." (kill-all-local-variables) (use-local-map mm/hdrs-mode-map) - (make-local-variable 'mm/buf) (make-local-variable 'mm/last-expr) (make-local-variable 'mm/hdrs-proc) (make-local-variable 'mm/marks-map) @@ -215,7 +253,10 @@ point. Line does not include a newline or any text-properties." (setq mm/proc-error-func 'mm/hdrs-error-handler) (setq mm/proc-update-func 'mm/hdrs-update-handler) (setq mm/proc-header-func 'mm/hdrs-header-handler) - (setq mm/proc-message-func 'mm/hdrs-message-handler) + (setq mm/proc-view-func 'mm/hdrs-view-handler) + (setq mm/proc-remove-func 'mm/hdrs-remove-handler) + ;; this last one is defined in mm-send.el + (setq mm/proc-compose-func 'mm/send-compose-handler) (setq mm/marks-map (make-hash-table :size 16 :rehash-size 2) @@ -317,9 +358,6 @@ The following marks are available, and the corresponding props: (delete-char 2) (insert (propertize (concat markkar " ") 'docid docid)))))) - - - (defun mm/hdrs-marks-execute () "Execute the actions for all marked messages in this buffer. @@ -332,31 +370,21 @@ we need to rerun the search, but we don't want to do that automatically, as it may be too slow and/or break the users flow. Therefore, we hide the message, which in practice seems to work well." - (unless (/= 0 (hash-table-count mm/marks-map)) - (error "Nothing is marked")) - (maphash - (lambda (docid val) - (let* ((marker (nth 0 val)) (mark (nth 1 val)) (target (nth 2 val)) - (ok (case mark - (move - (mm/proc-move-msg docid target)) - (trash - (unless mm/maildir "`mm/maildir' not set") - (unless mm/trash-folder "`mm/trash-folder' not set") - (mm/proc-move-msg docid (concat mm/maildir "/" mm/trash-folder) "+T")) - (delete - (mm/proc-remove-msg docid))))) - ;; (when ok - ;; (save-excursion - ;; (goto-char (marker-position marker)) - ;; (mm/hdrs-mark 'unmark) - ;; ;; hide the line - ;; (let ((inhibit-read-only t)) - ;; (put-text-property (line-beginning-position) (line-beginning-position 2) - ;; 'invisible t)))))) - )) - mm/marks-map)) - + (if (= 0 (hash-table-count mm/marks-map)) + (message "Nothing is marked") + (maphash + (lambda (docid val) + (let* + ((marker (nth 0 val)) (mark (nth 1 val)) (target (nth 2 val)) + (ok (case mark + (move + (mm/proc-move-msg docid target)) + (trash + (unless mm/trash-folder "`mm/trash-folder' not set") + (mm/proc-move-msg docid mm/trash-folder "+T")) + (delete + (mm/proc-remove-msg docid))))))) + mm/marks-map)) ) (defun mm/hdrs-unmark-all () "Unmark all marked messages." @@ -370,13 +398,22 @@ work well." mm/marks-map)) (defun mm/hdrs-view () - "View message at point" + "View message at point." (let ((docid (get-text-property (point) 'docid))) (unless docid (error "No message at point.")) (mm/proc-view-msg docid))) +(defun mm/hdrs-compose (reply-or-forward) + "Compose either a reply or a forward based on the message at +point." + (let ((docid (get-text-property (point) 'docid))) + (unless docid (error "No message at point.")) + (mm/proc-compose-msg docid reply-or-forward))) +(defun mm/hdrs-docid-is-marked (docid) + "Is the given docid marked?" + (when (gethash docid mm/marks-map) t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -384,19 +421,29 @@ work well." ;;; interactive functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun mm/ignore-marks () + (let* + ((num + (hash-table-count mm/marks-map)) + (unmark (or (= 0 num) + (y-or-n-p + (format "Sure you want to unmark %d message(s)?" num))))) + (message nil) + unmark)) -;; TODO warn if marks exist (defun mm/search () "Start a new mu search." (interactive) - (call-interactively 'mm/hdrs-search)) + (when (mm/ignore-marks) + (call-interactively 'mm/hdrs-search))) -;; TODO warn if marks exist -;; TODO: return to previous buffer (defun mm/quit-buffer () "Quit the current buffer." (interactive) - (kill-buffer (current-buffer))) + (when (mm/ignore-marks) + (mm/kill-proc) ;; hmmm... + (kill-buffer) + (mm))) ;; TODO implement (defun mm/change-sort () @@ -409,9 +456,10 @@ work well." "Rerun the search for the last search expression; if none exists, do a new search." (interactive) - (if mm/last-expr - (mm/hdrs-search mm/last-expr) - (mm/search))) + (when (mm/ignore-marks) + (if mm/last-expr + (mm/hdrs-search mm/last-expr) + (mm/search)))) (defun mm/view-message () "View the message at point." @@ -419,16 +467,28 @@ do a new search." (mm/hdrs-view)) (defun mm/next-header () - "Move point to the next header." + "Move point to the next message header. If this succeeds, return +the new docid. Otherwise, return nil." (interactive) - (when (or (/= 0 (forward-line 1)) (not (get-text-property (point) 'docid))) - (error "No header after this one"))) + (if (= 0 (forward-line 1)) + (let ((docid (get-text-property (point) 'docid))) + (if docid + docid + (mm/next-header))) ;; skip non-headers + (progn (message "No next message available") nil))) + (defun mm/prev-header () - "Move point to the previous header." + "Move point to the previous message header. If this succeeds, +return the new docid. Otherwise, return nil." (interactive) - (when (or (/= 0 (forward-line -1)) (not (get-text-property (point) 'docid))) - (error "No header before this one"))) + (if (= 0 (forward-line -1)) + (let ((docid (get-text-property (point) 'docid))) + (if docid + docid + (mm/prev-header))) ;; skip non-headers + (progn (message "No previous message available") nil))) + (defun mm/jump-to-maildir () "Show the messages in one of the standard folders." @@ -436,14 +496,16 @@ do a new search." (let ((fld (mm/ask-maildir "Jump to maildir: "))) (mm/hdrs-search (concat "maildir:" fld)))) + (defun mm/mark-for-move () "Mark message at point for moving to a maildir." (interactive) - (let ((target (mm/ask-maildir "Target maildir for move: "))) - (when (or (file-directory-p target) + (let* ((target (mm/ask-maildir "Target maildir for move: ")) + (fulltarget (concat mm/maildir target))) + (when (or (file-directory-p fulltarget) (and (yes-or-no-p - (format "%s does not exist. Create now?" target)) - (mm/proc-mkdir target))) + (format "%s does not exist. Create now?" fulltarget)) + (mm/proc-mkdir fulltarget))) (mm/hdrs-mark 'move target) (mm/next-header)))) @@ -470,24 +532,34 @@ folder (`mm/trash-folder')." (defun mm/unmark-all () "Unmark all messages." (interactive) - (unless (/= 0 (hash-table-count mm/marks-map)) - (error "Nothing is marked")) - (when (y-or-n-p (format "Sure you want to unmark %d message(s)?" - (hash-table-count mm/marks-map))) - (mm/hdrs-unmark-all))) + (if (= 0 (hash-table-count mm/marks-map)) + (message "Nothing is marked") + (when (mm/ignore-marks) + (mm/hdrs-unmark-all)))) (defun mm/execute-marks () "Execute the actions for the marked messages." (interactive) - (unless (/= 0 (hash-table-count mm/marks-map)) - (error "Nothing is marked")) - (when (y-or-n-p (format "Sure you want to execute marks on %d message(s)?" - (hash-table-count mm/marks-map))) - (mm/hdrs-marks-execute))) + (if (= 0 (hash-table-count mm/marks-map)) + (message "Nothing is marked") + (when (y-or-n-p (format "Sure you want to execute marks on %d message(s)?" + (hash-table-count mm/marks-map))) + (mm/hdrs-marks-execute) + (message nil)))) + +(defun mm/compose-reply () + "Start composing a reply to the current message." + (interactive) + (mm/hdrs-compose 'reply)) + + +(defun mm/compose-forward () + "Start composing a forward to the current message." + (interactive) + (mm/hdrs-compose 'forward)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (provide 'mm-hdrs) diff --git a/toys/mm/mm-proc.el b/toys/mm/mm-proc.el index 707a40d0..d63b422d 100644 --- a/toys/mm/mm-proc.el +++ b/toys/mm/mm-proc.el @@ -35,33 +35,64 @@ (defvar mm/mu-proc nil "*internal* The mu-server process") -(defvar mm/proc-header-func nil - "*internal* A function called for each message returned from the -server process; the function is passed a msg plist as argument. See -`mm/proc-eval-server-output' for the format.") - (defvar mm/proc-error-func nil "*internal* A function called for each error returned from the server process; the function is passed an error plist as -argument. See `mm/proc-eval-server-output' for the format.") +argument. See `mm/proc-filter' for the format.") (defvar mm/proc-update-func nil - "*internal* A function called for each update sexp returned from -the server process; the function is passed an update plist as -argument. See `mm/proc-eval-server-output' for the format.") + "*internal* A function called for each :update sexp returned from +the server process; the function is passed a msg sexp as +argument. See `mm/proc-filter' for the format.") -(defvar mm/proc-message-func nil - "*internal* A function called for each message sexp returned from -the server process. This is designed for viewing a message. See -`mm/proc-eval-server-output' for the format.") +(defvar mm/proc-remove-func nil + "*internal* A function called for each :remove sexp returned from +the server process, when some message has been deleted. The +function is passed the docid of the removed message.") + +(defvar mm/proc-view-func nil + "*internal* A function called for each single message sexp +returned from the server process. The function is passed a message +sexp as argument. See `mm/proc-filter' for the +format.") + +(defvar mm/proc-header-func nil + "*internal* A function called for each message returned from the +server process; the function is passed a msg plist as argument. See +`mm/proc-filter' for the format.") + +(defvar mm/proc-compose-func nil + "*internal* A function called for each message returned from the +server process that is used as basis for composing a new +message (ie., either a reply or a forward); the function is passed +msg and a symbol (either reply or forward). See `mm/proc-filter' +for the format of .") + +(defvar mm/proc-info-func nil + "*internal* A function called for each (:info type ....) sexp +received from the server process.") -(defconst mm/eox-mark "\n;;eox\n" - "*internal* Marker for the end of a sexp") - -(defvar mm/buf "" +(defvar mm/buf nil "*internal* Buffer for results data.") +(defun mm/proc-info-handler (info) + "Handler function for (:info ...) sexps received from the server +process." + (let ((type (plist-get info :info))) + (cond + ;; (:info :version "3.1") + ((eq type 'version) (setq mm/mu-version (plist-get info :version))) + ((eq type 'index) + (if (eq (plist-get info :status) 'running) + (message (format "Indexing... processed %d, updated %d" + (plist-get info :processed) (plist-get info :updated))) + (message + (format "Indexing completed; processed %d, updated %d, cleaned-up %d" + (plist-get info :processed) (plist-get info :updated) + (plist-get info :cleaned-up)))))))) + + (defun mm/start-proc () "Start the mu server process." ;; TODO: add version check @@ -71,8 +102,11 @@ the server process. This is designed for viewing a message. See (args '("server")) (args (append args (when mm/mu-home (list (concat "--muhome=" mm/mu-home)))))) + (setq mm/buf "") (setq mm/mu-proc (apply 'start-process "*mu-server*" "*mu-server*" mm/mu-binary args)) + ;; register a function for (:info ...) sexps + (setq mm/proc-info-func 'mm/proc-info-handler) (when mm/mu-proc (set-process-filter mm/mu-proc 'mm/proc-filter) (set-process-sentinel mm/mu-proc 'mm/proc-sentinel)))) @@ -82,66 +116,44 @@ the server process. This is designed for viewing a message. See (when (mm/proc-is-running) (let ((delete-exited-processes t)) (kill-process mm/mu-proc) - (setq mm/mu-proc nil)))) + (setq + mm/mu-proc nil + mm/buf nil)))) (defun mm/proc-is-running () (and mm/mu-proc (eq (process-status mm/mu-proc) 'run))) +(defun mm/proc-eat-sexp-from-buf () + "'Eat' the next s-expression from `mm/buf'. `mm/buf gets its + contents from the mu-servers in the following form: + \376\376 +Function returns this sexp, or nil if there was none. `mm/buf' is +updated as well, with all processed sexp data removed." + (let* ((b (string-match "\376\\([0-9]+\\)\376" mm/buf)) + (sexp-len + (when b (string-to-number (match-string 1 mm/buf))))) + ;; does mm/buf contain the full sexp? + (when (and b (>= (length mm/buf) (+ sexp-len (match-end 0)))) + ;; clear-up start + (setq mm/buf (substring mm/buf (match-end 0))) + (let ((objcons (read-from-string mm/buf))) + (setq mm/buf (substring mm/buf sexp-len)) + (car objcons))))) + (defun mm/proc-filter (proc str) "A process-filter for the 'mu server' output; it accumulates the - strings into valid sexps by checking of the ';;eox' end-of-msg - marker, and then evaluating them." - (setq mm/buf (concat mm/buf str)) ;; update our buffer - (let ((eox (string-match mm/eox-mark mm/buf))) - (while eox - ;; Process the sexp in `mm/buf', and remove it if it worked and return - ;; t. If no complete sexp is found, return nil." - (let ( (after-eox (match-end 0)) - (sexp (mm/proc-eval-server-output (substring mm/buf 0 eox)))) - ;; the sexp we get can either be a message or an error - (message "[%S]" sexp) - (cond - ((plist-get sexp :error) (funcall mm/proc-error-func sexp)) - ;; if it has :docid, it's a message; if it's dbonly prop is `t', it's - ;; a header, otherwise it's a message (for viewing) - ((eq (plist-get sexp :msgtype) 'header) - (funcall mm/proc-header-func sexp)) - ((eq (plist-get sexp :msgtype) 'view) - (funcall mm/proc-message-func sexp)) - ((plist-get sexp :update) (funcall mm/proc-update-func sexp)) - (t (message "%S" sexp))) - ;;(t (error "Unexpected data from server")))) - (setq mm/buf (substring mm/buf after-eox))) - (setq eox (string-match mm/eox-mark mm/buf))))) + strings into valid sexps by checking of the ';;eox' end-of-sexp + marker, and then evaluating them. -(defun mm/proc-sentinel (proc msg) - "Function that will be called when the mu-server process -terminates." - (let ((status (process-status proc)) (code (process-exit-status proc))) - (setq mm/mu-proc nil) - (setq mm/buf "") ;; clear any half-received sexps - (cond - ((eq status 'signal) - (message (format "mu server process received signal %d" code))) - ((eq status 'exit) - (cond - ((eq code 11) (message "Database is locked by another process")) - (t (message (format "mu server process ended with exit code %d" code))))) - (t - (message "something bad happened to the mu server process"))))) + The server output is as follows: -(defun mm/proc-eval-server-output (str) - "Evaluate a blob of server output; the output describe either a -message, a database update or an error. - -An error sexp looks something like: - - (:error 2 :error-message \"unknown command\") -;; eox - -a message sexp looks something like: + 1. an error + (:error 2 :error-message \"unknown command\") + ;; eox + => this will be passed to `mm/proc-error-func'. + 2. a message sexp looks something like: \( :docid 1585 :from ((\"Donald Duck\" . \"donald@example.com\")) @@ -160,34 +172,96 @@ a message sexp looks something like: :body-txt \" \" \) ;; eox + => this will be passed to `mm/proc-header-func'. -a database update looks like: -\(:update 1585 :path \"/home/user/Maildir/foo/cur/12323213:,R\") - when a message has been moved to a new location, or -\(:update 1585 :path \"/dev/null\") - when it has been removed. + 3. a view looks like: + (:view ) + => the (see 2.) will be passed to `mm/proc-view-func'. -other fields are :cc, :bcc, :body-html + 4. a database update looks like: + (:update :move ) -When the s-expression comes from the database ('mu find'), the -fields :attachments, :body-txt, :body-html, :references, :in-reply-to -are missing (because that information is not stored in the -database). + => the (see 2.) will be passed to + `mm/proc-update-func', :move tells us whether this is a move to + another maildir, or merely a flag change. -On the other hand, if the information comes from the message file, -there won't be a :docid field." - (condition-case nil - (car (read-from-string str));; read-from-string returns a cons - (error "Failed to parse sexp [%S]" str))) + 5. a remove looks like: + (:remove ) + => the docid will be passed to `mm/proc-remove-func' + + 6. a compose looks like: + (:compose :action ) => the + and either 'reply or 'forward will be passed + `mm/proc-compose-func'." + (setq mm/buf (concat mm/buf str)) ;; update our buffer + (let ((sexp (mm/proc-eat-sexp-from-buf))) + (while sexp + (mm/proc-log "%S" sexp) + (cond + ((eq (plist-get sexp :msgtype) 'header) + (funcall mm/proc-header-func sexp)) + ((plist-get sexp :view) + (funcall mm/proc-view-func (plist-get sexp :view))) + ((plist-get sexp :update) + (funcall mm/proc-update-func + (plist-get sexp :update) (plist-get sexp :move))) + ((plist-get sexp :remove) + (funcall mm/proc-remove-func (plist-get sexp :remove))) + ((plist-get sexp :compose) + (funcall mm/proc-compose-func + (plist-get sexp :compose) + (plist-get sexp :action))) + ((plist-get sexp :info) + (funcall mm/proc-info-func sexp)) + ((plist-get sexp :error) + (funcall mm/proc-error-func sexp)) + (t (message "Unexpected data from server [%S]" sexp))) + (setq sexp (mm/proc-eat-sexp-from-buf))))) + + +(defun mm/proc-sentinel (proc msg) + "Function that will be called when the mu-server process +terminates." + (let ((status (process-status proc)) (code (process-exit-status proc))) + (setq mm/mu-proc nil) + (setq mm/buf "") ;; clear any half-received sexps + (cond + ((eq status 'signal) + (cond + ((eq code 9) (message "the mu server process has been stopped")) + (t (message (format "mu server process received signal %d" code))))) + ((eq status 'exit) + (cond + ((eq code 11) (message "Database is locked by another process")) + (t (message (format "mu server process ended with exit code %d" code))))) + (t + (message "something bad happened to the mu server process"))))) + + +(defconst mm/proc-log-buffer-name "*mm-log*" + "*internal* Name of the logging buffer.") + +(defun mm/proc-log (frm &rest args) + "Write something in the *mm-log* buffer - mainly useful for debugging." + (with-current-buffer (get-buffer-create mm/proc-log-buffer-name) + (goto-char (point-max)) + (insert (apply 'format (concat (format-time-string "%Y-%m-%d %T " + (current-time)) frm "\n") args)))) + +(defun mm/proc-send-command (frm &rest args) + "Send as command to the mu server process; start the process if needed." + (unless (mm/proc-is-running) + (mm/start-proc)) + (let ((cmd (apply 'format frm args))) + (mm/proc-log cmd) + (process-send-string mm/mu-proc (concat cmd "\n")))) (defun mm/proc-remove-msg (docid) "Remove message identified by DOCID. The results are reporter through either (:update ... ) or (:error ) sexp, which are handled my `mm/proc-update-func' and `mm/proc-error-func', respectively." - (unless (mm/proc-is-running) (mm/start-proc)) - (when mm/mu-proc - (process-send-string mm/mu-proc (format "remove %d\n" docid)))) + (mm/proc-send-command "remove %d" docid)) (defun mm/proc-find (expr) @@ -196,17 +270,16 @@ function is called, depending on the kind of result. The variables `mm/proc-header-func' and `mm/proc-error-func' contain the function that will be called for, resp., a message (header row) or an error." - (unless (mm/proc-is-running) (mm/start-proc)) - (when mm/mu-proc - (process-send-string mm/mu-proc (format "find %s\n" expr)))) + (mm/proc-send-command "find \"%s\"" expr)) -(defun mm/proc-move-msg (docid targetdir flags) - "Move message identified by DOCID to TARGETDIR, setting FLAGS in -the process. +(defun mm/proc-move-msg (docid targetmdir &optional flags) + "Move message identified by DOCID to TARGETMDIR, optionally +setting FLAGS in the process. TARGETDIR must be a maildir, that is, the part _without_ cur/ or -new/. +new/ or the root-maildir-prefix. E.g. \"/archive\". This directory +must already exist. The FLAGS parameter can have the following forms: 1. a list of flags such as '(passed replied seen) @@ -225,32 +298,38 @@ The results are reported through either (:update ... ) or (:error ) sexp, which are handled my `mm/proc-update-func' and `mm/proc-error-func', respectively." (let - ((flagstr (if (stringp flags) flags (mm/flags-to-string flags)))) - (unless (and (file-directory-p targetdir) (file-writable-p targetdir)) - (error "Not a writable directory: %s" targetdir)) - - (unless (mm/proc-is-running) (mm/start-proc)) - (when mm/mu-proc - (process-send-string mm/mu-proc - (format "move %d %s %s\n" docid targetdir flagstr))))) + ((flagstr (if (stringp flags) flags (mm/flags-to-string flags))) + (fullpath (concat mm/maildir targetmdir))) + (unless (and (file-directory-p fullpath) (file-writable-p fullpath)) + (error "Not a writable directory: %s" fullpath)) + (mm/proc-send-command "move %d %s %s" docid targetmdir flagstr))) (defun mm/proc-flag-msg (docid flags) "Set FLAGS for the message identified by DOCID." (let ((flagstr (if (stringp flags) flags (mm/flags-to-string flags)))) - (unless (mm/proc-is-running) (mm/start-proc)) - (when mm/mu-proc - (process-send-string mm/mu-proc - (format "flag %d %s\n" docid flagstr))))) + (mm/proc-send-command "flag %d %s" docid flagstr))) +(defun mm/proc-index (maildir) + "Update the message database." + (mm/proc-send-command "index %s" maildir)) (defun mm/proc-view-msg (docid) "Get one particular message based on its DOCID. The result will be delivered to the function registered as `mm/proc-message-func'." - (unless (mm/proc-is-running) (mm/start-proc)) - (when mm/mu-proc - (process-send-string mm/mu-proc - (format "view %d\n" docid)))) + (mm/proc-send-command "view %d" docid)) + +(defun mm/proc-compose-msg (docid reply-or-forward) + "Start composing a message as either a forward or reply to +message with DOCID. REPLY-OR-FORWARD is either 'reply or 'forward. + +The result will be delivered to the function registered as +`mm/proc-compose-func'." + (let ((action (cond + ((eq reply-or-forward 'forward) "forward") + ((eq reply-or-forward 'reply) "reply") + (t (error "symbol must be eiter 'reply or 'forward"))))) + (mm/proc-send-command "compose %s %d" action docid))) (provide 'mm-proc) diff --git a/toys/mm/mm-send.el b/toys/mm/mm-send.el new file mode 100644 index 00000000..c4a75405 --- /dev/null +++ b/toys/mm/mm-send.el @@ -0,0 +1,436 @@ +;; mm-send.el -- part of mm, the mu mail user agent +;; +;; Copyright (C) 2011 Dirk-Jan C. Binnema + +;; Author: Dirk-Jan C. Binnema +;; Maintainer: Dirk-Jan C. Binnema +;; 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 . + +;;; Commentary: + +;; In this file, various functions to compose/send messages, piggybacking on +;; gnus + +;; mm + +;;; Code: + +(eval-when-compile (require 'cl)) + +;; we use some stuff from gnus... +(require 'message) +(require 'mail-parse) + + +;; internal variables / constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defconst mm/msg-draft-name "*mm-draft*" + "Name for draft messages.") + +(defconst mm/msg-separator "--text follows this line--\n\n" + "separator between headers and body, needed for `message-mode'") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; FIXME +(defun mm/mu-binary-version () "0.98pre") + + +(defun mm/msg-user-agent () + "Return the User-Agent string for mm. This is either the value +of `mm/user-agent', or, if not set, a string based on the +version of mm and emacs." + (or mm/user-agent + (format "mu %s; emacs %s" (mm/mu-binary-version) emacs-version))) + +(defun mm/view-body (msg) + "Get the body for this message, which is either :body-txt, +or if not available, :body-html converted to text)." + (or (plist-get msg :body-txt) + (with-temp-buffer + (plist-get msg :body-html) + (html2text) + (buffer-string)) + "No body found")) + + + +(defun mm/msg-cite-original (msg) + "Cite the body text of MSG, with a \"On %s, %s wrote:\" + line (with the %s's replaced with the date of MSG and the name + or e-mail address of its sender (or 'someone' if nothing + else)), followed of the quoted body of MSG, constructed by by + prepending `mm/msg-citation-prefix' to each line. If there is + no body in MSG, return nil." + (let* ((from (plist-get msg :from)) + ;; first try plain-text, then html + (body (or (plist-get msg :body-txt) + (with-temp-buffer + (plist-get msg :body-html) + (html2text) + (buffer-string))))) + (when body + (concat + (format "On %s, %s wrote:" + (format-time-string "%c" (plist-get msg :date)) + (if (and from (car from)) ;; a list (( . )) + (or (caar from) (cdar from) "someone") + "someone")) + "\n\n" + (replace-regexp-in-string "^" " > " body))))) + +(defun mm/msg-recipients-remove (lst email-to-remove) + "Remove the recipient with EMAIL from the recipient list (of form +'( (\"A\" . \"a@example.com\") (\"B\" . \"B@example.com\"))." + (remove-if + (lambda (name-email) + (let ((email (cdr name-email))) + (when email (string= email-to-remove (downcase email))))) lst)) + +(defun mm/msg-recipients-to-string (lst) + "Convert a recipient list (of form '( (\"A\" +. \"a@example.com\") (\"B\" . \"B@example.com\") (nil +. \"c@example.com\")) into a string of form \"A <@aexample.com>, B +, c@example.com\." + (mapconcat + (lambda (recip) + (let ((name (car recip)) (email (cdr recip))) + (if name + (format "%s <%s>" name email) + (format "%s" email)))) lst ", ")) + +(defun mm/msg-hidden-header (hdr val) + "Return user-invisible header to the message (HDR: VAL\n)." + ;; (format "%s: %s\n" hdr val)) + (propertize (format "%s: %s\n" hdr val) 'invisible t)) + +(defun mm/msg-header (hdr val) + "Return a header line of the form HDR: VAL\n. If VAL is nil, +return nil." + (when val (format "%s: %s\n" hdr val))) + +(defun mm/msg-references-create (msg) + "Construct the value of the References: header based on MSG as a +comma-separated string. Normally, this the concatenation of the +existing References (which may be empty) and the message-id. If the +message-id is empty, returns the old References. If both are empty, +return nil." + (let ((refs (plist-get msg :references)) + (msgid (plist-get msg :message-id))) + (if msgid ;; every received message should have one... + (mapconcat 'identity (append refs (list msgid)) ",") + (mapconcat 'identity refs ",")))) + +(defun mm/msg-to-create (msg reply-all) + "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." + (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)))))) + + +(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))))) + +(defun mm/msg-from-create () + "Construct a value for the From:-field of the reply to MSG, +based on `user-full-name' and `user-mail-address'; if the latter is +nil, function returns nil." + (when user-mail-address + (if user-full-name + (format "%s <%s>" user-full-name user-mail-address) + (format "%s" user-mail-address)))) + +(defun mm/msg-create-reply (msg reply-all) + "Create a draft message as a reply to MSG; if REPLY-ALL is +non-nil, reply to all recipients. + +A reply message has fields: + From: - see `mu-msg-from-create' + To: - see `mm/msg-to-create' + Cc: - see `mm/msg-cc-create' + Subject: - `mm/msg-reply-prefix' + subject of MSG + + then, the following fields, normally hidden from user: + Reply-To: - if `mail-reply-to' has been set + References: - see `mm/msg-references-create' + In-Reply-To: - message-id of MSG + User-Agent - see `mm/msg-user-agent' + +Then follows `mm/msg-separator' (for `message-mode' to separate +body from headers) + +And finally, the cited body of MSG, as per `mm/msg-cite-original'." + (concat + (mm/msg-header "From" (or (mm/msg-from-create) "")) + (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 "Cc" (mm/msg-cc-create msg reply-all)) + + (mm/msg-hidden-header "User-agent" (mm/msg-user-agent)) + (mm/msg-hidden-header "References" (mm/msg-references-create msg)) + + (mm/msg-hidden-header "In-reply-to" (plist-get msg :message-id)) + + (mm/msg-header"Subject" + (concat mm/msg-reply-prefix (plist-get msg :subject))) + + mm/msg-separator + + (mm/msg-cite-original msg))) + +;; TODO: attachments +(defun mm/msg-create-forward (msg) + "Create a draft forward message for MSG. + +A forward message has fields: + From: - see `mm/msg-from-create' + To: - empty + Subject: - `mm/msg-forward-prefix' + subject of MSG + +then, the following fields, normally hidden from user: + Reply-To: - if `mail-reply-to' has been set + References: - see `mm/msg-references-create' + User-Agent - see `mm/msg-user-agent' + +Then follows `mm/msg-separator' (for `message-mode' to separate +body from headers) + +And finally, the cited body of MSG, as per `mm/msg-cite-original'." + (concat + (mm/msg-header "From" (or (mm/msg-from-for-new) "")) + (when (boundp 'mail-reply-to) + (mm/msg-header "Reply-To" mail-reply-to)) + + (mm/msg-header "To" "") + (mm/msg-hidden-header "User-agent" (mm/msg-user-agent)) + (mm/msg-hidden-header "References" (mm/msg-references-for-reply msg)) + (mm/msg-header"Subject" + (concat mm/msg-forward-prefix (plist-get msg :subject))) + + mm/msg-separator + + (mm/msg-cite-original msg))) + +(defun mm/msg-create-new () + "Create a new message. + +A new draft message has fields: + From: - see `mu-msg-from-create' + To: - empty + Subject: - empty + +then, the following fields, normally hidden from user: + Reply-To: - if `mail-reply-to' has been set + User-Agent - see `mm/msg-user-agent' + +Then follows `mm/msg-separator' (for `message-mode' to separate +body from headers)." + (concat + (mm/msg-header "From" (or (mm/msg-from-create) "")) + (when (boundp 'mail-reply-to) + (mm/msg-header "Reply-To" mail-reply-to)) + + (mm/msg-header "To" "") + (mm/msg-hidden-header "User-agent" (mm/msg-user-agent)) + (mm/msg-header "Subject" "") + mm/msg-separator)) + +(defconst mm/msg-prefix "mm" "prefix for mm-generated +mail files; we use this to ensure that our hooks don't mess +with non-mm-generated messages") + +(defun mm/msg-draft-file-name () + "Create a Maildir-compatible[1], unique file name for a draft +message. + [1]: see http://cr.yp.to/proto/maildir.html" + (format "%s-%s-%x.%s:2,D" ;; 'D': rarely used, but hey, it's available + mm/msg-prefix + (format-time-string "%Y%m%d" (current-time)) + (emacs-pid) + (random t) + (replace-regexp-in-string "[:/]" "_" (system-name)))) + + +(defvar mm/send-reply-docid nil "Docid of the message this is a reply to.") +(defvar mm/send-forward-docid nil "Docid of the message being forwarded.") + +(defun mm/msg-compose (str &optional parent-docid reply-or-forward) + "Create a new draft message in the drafts folder with STR as +its contents, and open this message file for editing. + +For replies/forewards, you can specify PARENT-DOCID so the +corresponding message can get its Passed or Replied flag set when +this one is sent. If PARENT-DOCID is specified, also +reply-or-forward should be specified, which is a symbol, either +'reply or 'forward. + +The name of the draft folder is constructed from the concatenation of + `mm/maildir' and `mm/drafts-folder' (therefore, these must be set). + +The message file name is a unique name determined by +`mm/msg-draft-file-name'. + +The initial STR would be created from either `mm/msg-create-reply', +`mm/msg-create-forward' or `mm/msg-create-new'. The editing buffer is +using Gnus' `message-mode'." + (unless mm/maildir (error "mm/maildir not set")) + (unless mm/drafts-folder (error "mm/drafts-folder not set")) + + ;; write our draft message to the the drafts folder + (let ((draftfile (concat mm/maildir "/" mm/drafts-folder "/cur/" + (mm/msg-draft-file-name)))) + (with-temp-file draftfile (insert str)) + (find-file draftfile) (rename-buffer mm/msg-draft-name t) + + (message-mode) + + (make-local-variable 'mm/send-reply-docid) + (make-local-variable 'mm/send-forward-docid) + + (if (eq reply-or-forward 'reply) + (setq mm/send-reply-docid parent-docid) + (setq mm/send-forward-docid parent-docid)) + + (message-goto-body))) + + +(defun mm/send-compose-handler (msg reply-or-forward) + "This function is registered as the compose handler in +`mm/proc-compose-func', and will be called when a new message is to +be composed, based on some existing one. MSG is a message sexp, +while REPLY-OR-FORWARD is a symbol, either 'reply or 'forward. + +In case of 'forward, create a draft forward for MSG, and switch to +an edit buffer with the draft message. + +In case of 'reply, create a draft reply to MSG, and swith to an +edit buffer with the draft message" + + (unless (member reply-or-forward '(reply forward)) + (error "unexpected type in compose handler")) + (let ((parent-docid (plist-get msg :docid))) + + (if (eq reply-or-forward 'forward) + + ;; forward + (when (mm/msg-compose (mm/msg-create-forward msg) parent-docid 'forward) + (message-goto-to)) + + ;; reply + (let* ((recipnum (+ (length (plist-get msg :to)) + (length (plist-get msg :cc)))) + (replyall (when (> recipnum 1) + (yes-or-no-p + (format "Reply to all ~%d recipients (y) or only the sender (n)? " + (+ recipnum)))))) + ;; exact num depends on some more things + (when (mm/msg-compose (mm/msg-create-reply msg replyall) parent-docid 'reply) + (message-goto-body)))))) + + + +(defun mm/msg-save-to-sent () + "Move the message in this buffer to the sent folder. This is + meant to be called from message mode's `message-sent-hook'." + (when (mm/msg-is-mm-message) ;; only if we are mm + (unless mm/sent-folder (error "mm/sent-folder not set")) + ;; we don't know the draft message is already in the database... + ;; + ;; ;; TODO: remove duplicate flags + ;; ((newflags ;; remove Draft; maybe set 'Seen' as well? + ;; (delq 'draft (mm/msg-flags-from-path (buffer-file-name)))) + ;; ;; so, we register path => uid, then we move uid, then check the name + ;; ;; uid is referring to + ;; (uid (mm/msg-register (buffer-file-name))) + ;; (if (mm/msg-move uid + ;; (concat mm/maildir mm/sent-folder) + ;; (mm/msg-flags-to-string newflags)) + ;; (set-visited-file-name (mm/msg-get-path uid) t t) + ;; (error "Failed to save message to the Sent-folder")))))) +)) + +(defun mm/send-set-parent-flag () + "Set the 'replied' flag on messages we replied to, and the +'passed' flag on message we have forwarded. + +NOTE: This does not handle the case yet of message which are +edited from drafts. That case could be solved by searching for +the In-Reply-To message-id for replies. + +This is meant to be called from message mode's +`message-sent-hook'." + ;; handle the replied-to message + (when mm/send-reply-docid (mm/proc-flag-msg mm/send-reply-docid "+R")) + (when mm/send-forward-docid (mm/proc-flag-msg mm/send-forward-docid "+P"))) + + +;; hook our functions up with sending of the message +;;(add-hook 'message-sent-hook 'mm/msg-save-to-sent) +(add-hook 'message-sent-hook 'mm/send-set-parent-flag) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; some interactive function + +(defun mm/compose-new () + "Create a draft message, and switch to an edit buffer with the +draft message." + (interactive) + (when (mm/msg-compose (mm/msg-create-new)) + (message-goto-to))) + + +(provide 'mm-send) + + + diff --git a/toys/mm/mm-view.el b/toys/mm/mm-view.el new file mode 100644 index 00000000..89045dff --- /dev/null +++ b/toys/mm/mm-view.el @@ -0,0 +1,253 @@ +;; mm-view.el -- part of mm, the mu mail user agent +;; +;; Copyright (C) 2011 Dirk-Jan C. Binnema + +;; Author: Dirk-Jan C. Binnema +;; Maintainer: Dirk-Jan C. Binnema +;; 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 . + +;;; Commentary: + +;; In this file are function related to creating the list of one-line +;; descriptions of emails, aka 'headers' (not to be confused with headers like +;; 'To:' or 'Subject:') + +;; mm + +;;; Code: +(eval-when-compile (require 'cl)) +(require 'mm-common) +(require 'html2text) + +(defconst mm/view-buffer-name "*mm-view*" + "*internal* Name for the message view buffer") + +;; some buffer-local variables +(defvar mm/hdrs-buffer nil + "*internal* Headers buffer connected to this view.") + +(defvar mm/current-msg nil + "*internal* The plist describing the current message.") + +(defun mm/view (msg hdrsbuf) + "Display the message MSG in a new buffer, and keep in sync with HDRSBUF. +'In sync' here means that moving to the next/previous message in +the the message view affects HDRSBUF, as does marking etc. + +As a side-effect, a message that is being viewed loses its 'unread' +marking if it still had that." + (let ((buf (get-buffer-create mm/view-buffer-name)) (inhibit-read-only t)) + (with-current-buffer buf + (erase-buffer) + (insert + (mapconcat + (lambda (field) + (case field + (:subject (mm/view-header "Subject" (plist-get msg :subject))) + (:path (mm/view-header "Path" (plist-get msg :path))) + (:to (mm/view-contacts msg field)) + (:from (mm/view-contacts msg field)) + (:cc (mm/view-contacts msg field)) + (:bcc (mm/view-contacts msg field)) + (:date + (let* ((date (plist-get msg :date)) + (datestr (when date (format-time-string "%c" date)))) + (if datestr (mm/view-header "Date" datestr) ""))) + + (:flags "") ;; TODO + (:maildir (mm/view-header "Maildir" (plist-get msg :maildir))) + (:size (mm/view-size msg) + (let* ((size (plist-get msg :size)) + (sizestr (when size (format "%d bytes")))) + (if sizestr (mm/view-header "Size" sizestr)))) + + (:attachments "") ;; TODO + (t (error "Unsupported field: %S" field)))) + mm/view-headers "") + "\n" + (mm/view-body msg)) + (mm/view-mode) + (setq + mode-name (format "%s" mm/view-buffer-name (plist-get msg :docid)) + ;; these are buffer-local + mm/current-msg msg + mm/hdrs-buffer hdrsbuf) + (switch-to-buffer buf) + (goto-char (point-min))))) + + +(defun mm/view-body (msg) + "Get the body for this message, which is either :body-txt, +or if not available, :body-html converted to text)." + (or (plist-get msg :body-txt) + (with-temp-buffer + (plist-get msg :body-html) + (html2text) + (buffer-string)) + "No body found")) + + +(defun mm/view-header (key val) + "Show header FIELD for MSG with KEY. ie. : value-of-FIELD\n." + (if val + (concat + (propertize key 'face 'mm/view-header-key-face) ": " + (propertize val 'face 'mm/view-header-value-face) "\n") + "")) + + +(defun mm/view-contacts (msg field) + (unless (member field '(:to :from :bcc :cc)) (error "Wrong type")) + (let* ((lst (plist-get msg field)) + (contacts + (when lst + (mapconcat + (lambda(c) + (let ((name (car c)) (email (cdr c))) + (if name + (format "%s <%s>" name email) + (format "%s" email)))) lst ", ")))) + (if contacts + (mm/view-header + (case field (:to "To") (:from "From") (:bcc "Bcc") (:cc "Cc")) + contacts) + ""))) + + +(defvar mm/view-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "q" 'mm/view-quit-buffer) + + (define-key map "s" 'mm/search) + (define-key map "j" 'mm/jump-to-maildir) + + ;; (define-key map "f" 'mua/view-forward) + ;; (define-key map "r" 'mua/view-reply) + ;; (define-key map "c" 'mua/view-compose) + + ;; navigation between messages + (define-key map "n" 'mm/view-next) + (define-key map "p" 'mm/view-prev) + + ;; marking/unmarking + (define-key map "d" 'mm/view-mark-for-trash) + (define-key map "D" 'mm/view-mark-for-delete) + (define-key map "m" 'mm/view-mark-for-move) + + ;; next two only warn user + (define-key map "u" 'mm/view-unmark) + (define-key map "U" 'mm/view-unmark) + + (define-key map "x" 'mm/view-marked-execute) + map) + "Keymap for \"*mm-view*\" buffers.") +(fset 'mm/view-mode-map mm/view-mode-map) + + +(defun mm/view-mode () + "Major mode for viewing an e-mail message." + (interactive) + (kill-all-local-variables) + (use-local-map mm/view-mode-map) + + (make-local-variable 'mm/hdrs-buffer) + (make-local-variable 'mm/current-msg) + + (setq major-mode 'mm/view-mode mode-name mm/view-buffer-name) + (setq truncate-lines t buffer-read-only t)) + + +;;;;;; + + +;; we mark messages are as read when we leave the message; ie., when skipping to +;; the next/previous one, or leaving the view buffer altogether. + +(defun mm/view-mark-as-read-maybe () + "Clear the current message's New/Unread status and set it to +Seen; if the message is not New/Unread, do nothing." + (when mm/current-msg + (let ((flags (plist-get mm/current-msg :flags)) + (docid (plist-get mm/current-msg :docid))) + ;; is it a new message? + (when (or (member 'unread flags) (member 'new flags)) + ;; if so, mark it as non-new and read + (mm/proc-flag-msg docid "+S-u-N"))))) + +;; Interactive functions + +(defun mm/view-quit-buffer () + "Quit the message view and return to the headers." + (interactive) + (mm/view-mark-as-read-maybe) + (let ((inhibit-read-only t)) + (kill-buffer) + (switch-to-buffer mm/hdrs-buffer))) + +(defun mm/view-next () + "View the next message." + (interactive) + (mm/view-mark-as-read-maybe) + (with-current-buffer mm/hdrs-buffer + (when (mm/next-header) + (mm/hdrs-view)))) + +(defun mm/view-prev () + "View the previous message." + (interactive) + (mm/view-mark-as-read-maybe) + (with-current-buffer mm/hdrs-buffer + (when (mm/prev-header) + (mm/hdrs-view)))) + +(defun mm/view-mark-for-trash () + "Mark the viewed message to be moved to the trash folder." + (interactive) + (with-current-buffer mm/hdrs-buffer + (when (mm/mark-for-trash) + (mm/hdrs-view)))) + +(defun mm/view-mark-for-delete () + "Mark the viewed message to be deleted." + (interactive) + (with-current-buffer mm/hdrs-buffer + (when (mm/mark-for-trash) + (mm/hdrs-view)))) + +(defun mm/view-mark-for-move () + "Mark the viewed message to be moved to some folder." + (interactive) + (with-current-buffer mm/hdrs-buffer + (when (mm/mark-for-move) + (mm/view-next)))) + +(defun mm/view-unmark () + "Warn user that unmarking only works in the header list." + (interactive) + (message "Unmarking needs to be done in the header list view")) + + +(defun mm/view-marked-execute () + "Warn user that execution can only take place in n the header +list." + (interactive) + (message "Execution needs to be done in the header list view")) + + +(provide 'mm-view) diff --git a/toys/mm/mm.el b/toys/mm/mm.el index c76557d6..6e6c0535 100644 --- a/toys/mm/mm.el +++ b/toys/mm/mm.el @@ -1,4 +1,4 @@ -;;; mm.el -- part of mm, the mu mail user agent + ;; ;; Copyright (C) 2011 Dirk-Jan C. Binnema @@ -28,9 +28,9 @@ (eval-when-compile (require 'cl)) -(add-to-list 'load-path "/home/djcb/Sources/mu/toys/mm") - (require 'mm-hdrs) +(require 'mm-view) +(require 'mm-send) (require 'mm-common) (require 'mm-proc) @@ -60,6 +60,15 @@ PATH, you can specifiy the full path." :group 'mm) +(defcustom mm/get-mail-command nil + "Shell command to run to retrieve new mail; e.g. 'offlineimap' or +'fetchmail'." + :type 'string + :group 'mm + :safe 'stringp) + + + ;; Folders (defgroup mm/folders nil @@ -97,6 +106,47 @@ PATH, you can specifiy the full path." :safe 'stringp :group 'mm/folders) + +(defgroup mm/view nil + "Settings for the message view." + :group 'mm) + +;; the message view + +(defcustom mm/view-headers + '(:from :to :cc :subject :flags :date :maildir :path :attachments) + "Header fields to display in the message view buffer." + :type (list 'symbol) + :group 'mm/view) + + +;; Composing / Sending messages +(defgroup mm/compose nil + "Customizations for composing/sending messages." + :group 'mm) + +(defcustom mm/msg-citation-prefix "> " + "String to prefix cited message parts with." + :type 'string + :group 'mm/compose) + +(defcustom mm/msg-reply-prefix "Re: " + "String to prefix the subject of replied messages with." + :type 'string + :group 'mm/compose) + +(defcustom mm/msg-forward-prefix "Fwd: " + "String to prefix the subject of forwarded messages with." + :type 'string + :group 'mm/compose) + +(defcustom mm/user-agent nil + "The user-agent string; leave at `nil' for the default." + :type 'string + :group 'mm/compose) + + + ;; Faces (defgroup mm/faces nil @@ -110,43 +160,170 @@ PATH, you can specifiy the full path." :group 'mm/faces) (defface mm/moved-face - '((t :inherit font-lock-comment-face :italic t)) - "Face for an mm message header that has been moved from the -search results." + '((t :inherit font-lock-comment-face :slant italic)) + "Face for an mm message header that has been moved to some +folder (it's still visible in the search results, since we cannot +be sure it no longer matches)." + :group 'mm/faces) + +(defface mm/trashed-face + '((t :inherit font-lock-comment-face :strike-though t)) + "Face for an message header in the trash folder." :group 'mm/faces) (defface mm/header-face '((t :inherit default)) "Face for an mm header without any special flags." - :group 'deft-faces) + :group 'mm/faces) + +(defface mm/title-face + '((t :inherit font-lock-type-face)) + "Face for an mm title." + :group 'mm/faces) + +(defface mm/view-header-key-face + '((t :inherit font-lock-builtin-face)) + "Face for the header title (such as \"Subject\" in the message view)." + :group 'mm/faces) + +(defface mm/view-header-value-face + '((t :inherit font-lock-doc-face)) + "Face for the header value (such as \"Re: Hello!\" in the message view)." + :group 'mm/faces) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; FIXME -(setq - mm/maildir "/home/djcb/Maildir" - mm/inbox-folder "/inbox" - mm/outbox-folder "/outbox" - mm/sent-folder "/sent" - mm/drafts-folder "/drafts" - mm/trash-folder "/trash") -(defvar mm/working-folders nil) -(setq mm/working-folders - '("/bulk" "/archive" "/bulkarchive" "/todo")) -(setq mm/header-fields - '( (:date . 25) - (:flags . 6) - (:from . 22) - (:subject . 40))) -;;; my stuff -(setq mm/mu-binary "/home/djcb/Sources/mu/src/mu") -(setq mm/mu-home "/home/djcb/.mu") -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; internal variables / constant +(defconst mm/mm-buffer-name "*mm*" + "*internal* Name of the mm main buffer.") + +(defvar mm/mu-version nil + "*interal* version of the mu binary") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; mm mode + keybindings +(defvar mm/mm-mode-map + (let ((map (make-sparse-keymap))) + + (define-key map "I" 'mm/jump-to-inbox) + (define-key map "S" 'mm/search-today) + (define-key map "W" 'mm/search-last-7-days) + (define-key map "U" 'mm/search-unread) + + (define-key map "s" 'mm/search) + (define-key map "q" 'mm/quit-mm) + (define-key map "j" 'mm/jump-to-maildir) + (define-key map "c" 'mm/compose-new) + + (define-key map "r" 'mm/retrieve-mail) + (define-key map "u" 'mm/update-database) + + map) + "Keymap for the *mm* buffer.") +(fset 'mm/mm-mode-map mm/mm-mode-map) + +(defun mm/mm-mode () + "Major mode for the mm main screen." + (interactive) + + (kill-all-local-variables) + (use-local-map mm/mm-mode-map) + + (setq + mm/marks-map (make-hash-table :size 16 :rehash-size 2) + major-mode 'mm/mm-mode + mode-name "*mm*" + truncate-lines t + buffer-read-only t + overwrite-mode 'overwrite-mode-binary)) + +(defun mm() + "Start mm." + (interactive) + (let ((buf (get-buffer-create mm/mm-buffer-name)) + (inhibit-read-only t)) + (with-current-buffer buf + (erase-buffer) + (insert + "* " + (propertize "mm - mail for emacs\n" 'face 'mm/title-face) + "\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" + " - 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" + "\n" + " * " (propertize "r" 'face 'highlight) "etrieve new mail\n" + " * " (propertize "u" 'face 'highlight) "update the message database\n" + "\n" + " * " (propertize "q" 'face 'highlight) "uit mm\n") + + (mm/mm-mode) + (switch-to-buffer buf)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; interactive functions + +(defun mm/jump-to-inbox () + "Jump to your Inbox folder (as specified in `mm/inbox-folder')." + (interactive) + (mm/hdrs-search (concat "maildir:" mm/inbox-folder))) + +(defun mm/search-unread () + "List all your unread messages." + (interactive) + (mm/hdrs-search "flag:unread AND NOT flag:trashed")) + +(defun mm/search-today () + "List messages received today." + (interactive) + (mm/hdrs-search "date:today..now")) + +(defun mm/search-last-7-days () + "List messages received in the last 7 days." + (interactive) + (mm/hdrs-search "flag:7d..now")) + +(defun mm/retrieve-mail () + "Get new mail." + (interactive) + (unless mm/get-mail-command + (error "`mm/get-mail-command' is not set")) + (when (y-or-n-p "Sure you want to retrieve new mail?") + (shell-command mm/get-mail-command))) + +(defun mm/update-database () + "Update the database (ie., 'mu index')." + (interactive) + (unless mm/maildir (error "`mm/maildir' not set")) + (when (y-or-n-p "Sure you want to update the database?") + (mm/proc-index mm/maildir))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + +(defun mm/quit-mm() + "Quit the mm session." + (interactive) + (when (y-or-n-p "Are you sure you want to quit mm? ") + (message nil) + (mm/kill-proc) + (kill-buffer))) (provide 'mm)