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

* mm: some more updates (WIP)

Browse Source
This commit is contained in:
Dirk-Jan C. Binnema
2011-09-20 23:59:20 +03:00
parent 5866220781
commit 3d41a0fe3d
6 changed files with 305 additions and 312 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@ -96,65 +96,6 @@ Also see `mu/flags-to-string'.
;;; moving message files, changing flags ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mm/move-msg (uid &optional targetdir flags ignore-already)
"Move message identified by UID to TARGETDIR using 'mu mv', and
update the database with the new situation. TARGETDIR must be a
maildir - that is, the part _without_ cur/ or new/. 'mu mv' will
calculate the target directory and the exact file name. See
`mm/msg-map' for a discussion about UID.
After the file system move (rename) has been done, 'mu remove'
and/or 'mu add' are invoked asynchronously to update the database
with the changes.
Optionally, you can specify the FLAGS for the new file. The FLAGS
parameter can have the following forms:
1. a list of flags such as '(passed replied seen)
2. a string containing the one-char versions of the flags, e.g. \"PRS\"
3. a delta-string specifying the changes with +/- and the one-char flags,
e.g. \"+S-N\" to set Seen and remove New.
The flags are any of `deleted', `flagged', `new', `passed', `replied' `seen' or
`trashed', or the corresponding \"DFNPRST\" as defined in [1]. See
`mm/string-to-flags' and `mm/flags-to-string'.
If TARGETDIR is '/dev/null', remove SRC. After the file system
move, the database will be updated as well, using the 'mu add'
and 'mu remove' commands.
If IGNORE-ALREADY is non-nil, don't consider it an error when the target file is
the same as the source file.
Function returns t the move succeeds, in other cases, it returns
nil.
\[1\] URL `http://cr.yp.to/proto/maildir.html'."
(let* ((src (mm/msg-map-get-path uid)))
(unless src (error "Source path not registered for %S" uid))
(unless (or targetdir src) (error "Either targetdir or flags required"))
(unless (file-readable-p src) (error "Source is unreadable (%S)" src))
(let* ((flagstr (if (stringp flags) flags (mm/flags-to-string flags)))
(argl (remove-if 'not ;; build up the arg list
(list "mv" "--print-target" "--ignore-dups"
(when flagstr (concat "--flags=" flagstr))
src targetdir)))
;; execute it, and get the results
(rv (apply 'mm/mu-run argl))
(code (car rv)) (output (cdr rv)))
(unless (= 0 code) (error "Moving message failed: %S" output))
;; success!
(let ((targetpath (substring output 0 -1)))
(when (and targetpath (not (string= src targetpath)))
(mm/msg-map-update uid targetpath) ;; update the UID-map
(mm/db-remove-async src) ;; remove the src from the db
(unless (string= targetdir "/dev/null")
(mm/db-add-async targetpath))) ;; add the target to the db
(mm/db-update-execute)
t))))

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

@ -37,12 +37,6 @@
(require 'mm-common) (require 'mm-common)
(require 'mm-proc) (require 'mm-proc)
(defvar mm/header-fields
'( (:date . 25)
(:from-or-to . 22)
(:subject . 40))
"A list of header fields and their character widths.")
;;;; internal variables/constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; internal variables/constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar mm/last-expr nil (defvar mm/last-expr nil
@ -68,9 +62,9 @@ buffer for the results."
(with-current-buffer buf (with-current-buffer buf
(erase-buffer) (erase-buffer)
(mm/hdrs-mode) (mm/hdrs-mode)
(setq mm/msg-map nil mm/mm/marks-map nil)
(mm/msg-map-init)
(setq (setq
mm/mm/marks-map nil
mm/msg-map (make-hash-table :size 1024 :rehash-size 2 :weakness nil)
mode-name expr mode-name expr
mm/last-expr expr mm/last-expr expr
mm/hdrs-buffer buf))) mm/hdrs-buffer buf)))
@ -103,107 +97,75 @@ headers."
(when (buffer-live-p mm/hdrs-buffer) (when (buffer-live-p mm/hdrs-buffer)
(with-current-buffer mm/hdrs-buffer (with-current-buffer mm/hdrs-buffer
(let* ((docid (plist-get msg :docid)) (let* ((docid (plist-get msg :docid))
(marker (mm/msg-map-get-marker docid))) (marker (gethash docid mm/msg-map)))
(unless docid (error "Invalid update %S" update)) (unless docid (error "Invalid update %S" update))
(unless marker (error "Message %d not found" docid)) (when marker ;; is the message present in this list?
(save-excursion (save-excursion
(goto-char (marker-position marker)) (goto-char (marker-position marker))
;; sanity check ;; sanity check
(unless (eq docid (get-text-property (point) 'docid)) (unless (eq docid (mm/hdrs-get-docid)) (error "Unexpected docid"))
(error "Unexpected docid")) ;; if it's marked, unmark it now
;; if it's marked, unmark it now (when (mm/hdrs-docid-is-marked docid)
(when (mm/hdrs-docid-is-marked docid) (mm/hdrs-mark 'unmark))
(mm/hdrs-mark 'unmark)) (mm/hdrs-remove-header docid)
(let ((inhibit-read-only t) (bol (line-beginning-position)) ;; now, if this update was about *moving* a message, we don't show it
(eol (line-beginning-position 2))) ;; anymore (of course, we cannot be sure if the message really no
;; hide the old line (removing it causes some problems) ;; longer matches the query, but this seem a good heuristic.
(put-text-property bol eol 'invisible t) ;; if it was only a flag-change, show the message with its updated flags.
;; now, if this update was about *moving* a message, we don't show it (unless is-move
;; anymore (of course, we cannot be sure if the message really no (mm/hdrs-header-handler msg (beginning-of-line)))))))))
;; 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) (defun mm/hdrs-remove-handler (docid)
"Remove handler, will be called when a message has been removed "Remove handler, will be called when a message has been removed
from the database. This function will hide the remove message in from the database. This function will hide the remove message in
the current list of headers." the current list of headers."
(with-current-buffer mm/hdrs-buffer (with-current-buffer mm/hdrs-buffer
(let ((marker (mm/msg-map-get-marker docid))) (let ((marker (gethash docid mm/msg-map)))
(unless marker (error "Message %d not found" docid)) (unless marker (error "Message %d not found" docid))
(save-excursion (mm/hdrs-remove-header docid))))
(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 message
(set-text-properties bol eol '(invisible t)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mm/hdrs-header-handler (msg &optional point) (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. 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
;; 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))))))
(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)))
(cond
((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 "Create a one line description of MSG in this buffer at
point. Line does not include a newline or any text-properties." point. Line does not include a newline or any text-properties."
(mapconcat (let* ((line (mapconcat
(lambda (f-w) (lambda (f-w)
(let* ((field (car f-w)) (width (cdr f-w)) (let* ((field (car f-w)) (width (cdr f-w))
(val (plist-get msg field)) (val (plist-get msg field))
(str (str
(case field (case field
(:subject val) (:subject val)
((:to :from :cc :bcc) ((:to :from :cc :bcc)
(mapconcat (mapconcat
(lambda (ct) (lambda (ct)
(let ((name (car ct)) (email (cdr ct))) (let ((name (car ct)) (email (cdr ct)))
(or name email "?"))) val ", ")) (or name email "?"))) val ", "))
(:date (format-time-string "%x %X" val)) (:date (format-time-string "%x %X" val))
(:flags (mm/flags-to-string val)) (:flags (mm/flags-to-string val))
(:size (:size
(cond (cond
((>= val 1000000) (format "%2.1fM" (/ val 1000000.0))) ((>= val 1000000) (format "%2.1fM" (/ val 1000000.0)))
((and (>= val 1000) (< val 1000000)) ((and (>= val 1000) (< val 1000000))
(format "%2.1fK" (/ val 1000.0))) (format "%2.1fK" (/ val 1000.0)))
((< val 1000) (format "%d" val)))) ((< val 1000) (format "%d" val))))
(t (error "Unsupported header field (%S)" field))))) (t (error "Unsupported header field (%S)" field)))))
(when str (truncate-string-to-width str width 0 ?\s t)))) (when str
mm/header-fields " ")) (if (not width)
str
(truncate-string-to-width str width 0 ?\s t)))))
mm/header-fields " "))
(flags (plist-get msg :flags))
(line (cond
((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)))))
(mm/hdrs-add-header line (plist-get msg :docid) point)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; hdrs-mode and mode-map ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; hdrs-mode and mode-map ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar mm/hdrs-mode-map (defvar mm/hdrs-mode-map
@ -268,7 +230,9 @@ point. Line does not include a newline or any text-properties."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; the message map ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; headers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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
@ -278,32 +242,55 @@ Using this map, we can update message headers which are currently
on the screen, when we receive (:update ) notices from the mu on the screen, when we receive (:update ) notices from the mu
server.") server.")
(defun mm/msg-map-add (msg marker) (defun mm/hdrs-add-header (str docid point)
"Update `mm/msg-map' with MSG, and MARKER pointing to the buffer "Add header STR with DOCID to the buffer. If POINT is not
position for the message header." provided, put it at the end of the buffer."
(let ((docid (plist-get msg :docid))) (unless docid (error "Invalid message"))
(unless docid (error "Invalid message")) (when (buffer-live-p mm/hdrs-buffer)
(puthash docid marker mm/msg-map))) (with-current-buffer mm/hdrs-buffer
(let ((inhibit-read-only t)
(defun mm/msg-map-get-marker (docid) (bol (line-beginning-position))
"Get the marker for the message identified by DOCID." (eol (line-beginning-position 2))
(gethash docid mm/msg-map)) (point (if point point (point-max))))
(save-excursion
(defun mm/msg-map-init() (goto-char point)
"(Re)initialize the msg map for use -- re-create the hash table, ;; Update `mm/msg-map' with MSG, and MARKER pointing to the buffer
and reset the last-uid to 0." ;; position for the message header."
(setq mm/msg-map (puthash docid (point-marker) mm/msg-map)
(make-hash-table :size 256 :rehash-size 2 :weakness nil))) (insert " " (propertize str 'docid docid) "\n"))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mm/hdrs-remove-header (docid)
"Add header STR with DOCID to the buffer. If POINT is not
provided, put it at the end of the buffer."
(unless docid (error "No docid found"))
(let ((marker (gethash docid mm/msg-map)))
(unless marker (error "Unregistered message"))
(remhash docid mm/msg-map)
(with-current-buffer mm/hdrs-buffer
(save-excursion
(goto-char (marker-position marker))
(let ((inhibit-read-only t))
(delete-region (line-beginning-position) (line-beginning-position 2)))))))
(defun mm/hdrs-mark-header (docid mark)
"(Visually) mark the header for DOCID with character MARK."
(let ((marker (gethash docid mm/msg-map)))
(unless marker (error "Unregistered message"))
(with-current-buffer mm/hdrs-buffer
(save-excursion
(let ((inhibit-read-only t))
(goto-char (marker-position marker))
(move-beginning-of-line 1)
(delete-char 2)
(insert mark " "))))))
(defun mm/hdrs-get-docid ()
"Get the docid for the message at point, or nil if there is none"
(with-current-buffer mm/hdrs-buffer
(when (> (- (line-end-position) (line-beginning-position)) 2)
(get-text-property (+ 2 (line-beginning-position)) 'docid))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; marks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; marks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar mm/marks-map nil (defvar mm/marks-map nil
@ -330,7 +317,7 @@ The following marks are available, and the corresponding props:
`trash' n move the message to `mm/trash-folder' `trash' n move the message to `mm/trash-folder'
`delete' n remove the message `delete' n remove the message
`unmark' n unmark this message" `unmark' n unmark this message"
(let* ((docid (get-text-property (point) 'docid)) (let* ((docid (mm/hdrs-get-docid))
(markkar (markkar
(case mark ;; the visual mark (case mark ;; the visual mark
('move "m") ('move "m")
@ -340,51 +327,39 @@ The following marks are available, and the corresponding props:
(t (error "Invalid mark %S" mark))))) (t (error "Invalid mark %S" mark)))))
(unless docid (error "No message on this line")) (unless docid (error "No message on this line"))
(save-excursion (save-excursion
(move-beginning-of-line 1) (when (mm/hdrs-mark-header docid markkar))
;; is there anything to mark/unmark?
(when (and (looking-at " ") (eql mark 'unmark))
(error "Not marked"))
(when (not (or (looking-at " ") (eql mark 'unmark)))
(error "Already marked"))
;; update the hash ;; update the hash
(if (eql mark 'unmark) (if (eql mark 'unmark)
(remhash docid mm/marks-map) (remhash docid mm/marks-map)
(puthash docid (list (point-marker) mark target) mm/marks-map)) (puthash docid (list (point-marker) mark target) mm/marks-map)))))
;; now, update the visual mark..;
(let ((inhibit-read-only t))
(delete-char 2)
(insert (propertize (concat markkar " ") 'docid docid))))))
(defun mm/hdrs-marks-execute () (defun mm/hdrs-marks-execute ()
"Execute the actions for all marked messages in this "Execute the actions for all marked messages in this
buffer. buffer. After the actions have been executed succesfully, the
affected messages are *hidden* from the current header list. Since
After the actions have been executed succesfully, the affected the headers are the result of a search, we cannot be certain that
messages are *hidden* from the current header list. Since the the messages no longer matches the current one - to get that
headers are the result of a search, we cannot be certain that the certainty, we need to rerun the search, but we don't want to do
messages no longer matches the current one - to get that certainty, that automatically, as it may be too slow and/or break the users
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 flow. Therefore, we hide the message, which in practice seems to
work well." work well."
(if (= 0 (hash-table-count mm/marks-map)) (if (= 0 (hash-table-count mm/marks-map))
(message "Nothing is marked") (message "Nothing is marked")
(maphash (maphash
(lambda (docid val) (lambda (docid val)
(let* (let ((marker (nth 0 val)) (mark (nth 1 val)) (target (nth 2 val)))
((marker (nth 0 val)) (mark (nth 1 val)) (target (nth 2 val)) (case mark
(ok (case mark (move
(move (mm/proc-move-msg docid target))
(mm/proc-move-msg docid target)) (trash
(trash (unless mm/trash-folder
(unless mm/trash-folder "`mm/trash-folder' not set") (error "`mm/trash-folder' not set"))
(mm/proc-move-msg docid mm/trash-folder "+T")) (mm/proc-move-msg docid mm/trash-folder "+T"))
(delete (delete
(mm/proc-remove-msg docid))))))) (mm/proc-remove-msg docid)))))
mm/marks-map)) ) mm/marks-map)
(mm/hdrs-unmark-all)))
(defun mm/hdrs-unmark-all () (defun mm/hdrs-unmark-all ()
"Unmark all marked messages." "Unmark all marked messages."
@ -399,14 +374,14 @@ work well."
(defun mm/hdrs-view () (defun mm/hdrs-view ()
"View message at point." "View message at point."
(let ((docid (get-text-property (point) 'docid))) (let ((docid (mm/hdrs-get-docid)))
(unless docid (error "No message at point.")) (unless docid (error "No message at point."))
(mm/proc-view-msg docid))) (mm/proc-view-msg docid)))
(defun mm/hdrs-compose (reply-or-forward) (defun mm/hdrs-compose (reply-or-forward)
"Compose either a reply or a forward based on the message at "Compose either a reply or a forward based on the message at
point." point."
(let ((docid (get-text-property (point) 'docid))) (let ((docid (mm/hdrs-get-docid)))
(unless docid (error "No message at point.")) (unless docid (error "No message at point."))
(mm/proc-compose-msg docid reply-or-forward))) (mm/proc-compose-msg docid reply-or-forward)))
@ -469,24 +444,19 @@ do a new search."
"Move point to the next message header. If this succeeds, return "Move point to the next message header. If this succeeds, return
the new docid. Otherwise, return nil." the new docid. Otherwise, return nil."
(interactive) (interactive)
(if (= 0 (forward-line 1)) (with-current-buffer mm/hdrs-buffer
(let ((docid (get-text-property (point) 'docid))) (if (= 0 (forward-line 1))
(if docid (let ((docid (mm/hdrs-get-docid)))
docid (if docid docid (mm/next-header)))))) ;; skip non-headers
(mm/next-header))) ;; skip non-headers
(progn (message "No next message available") nil)))
(defun mm/prev-header () (defun mm/prev-header ()
"Move point to the previous message header. If this succeeds, "Move point to the previous message header. If this succeeds,
return the new docid. Otherwise, return nil." return the new docid. Otherwise, return nil."
(interactive) (interactive)
(if (= 0 (forward-line -1)) (with-current-buffer mm/hdrs-buffer
(let ((docid (get-text-property (point) 'docid))) (if (= 0 (forward-line -1))
(if docid (let ((docid (mm/hdrs-get-docid)))
docid (if docid docid (mm/prev-header)))))) ;; skip non-headers
(mm/prev-header))) ;; skip non-headers
(progn (message "No previous message available") nil)))
(defun mm/jump-to-maildir () (defun mm/jump-to-maildir ()
@ -499,64 +469,71 @@ return the new docid. Otherwise, return nil."
(defun mm/mark-for-move () (defun mm/mark-for-move ()
"Mark message at point for moving to a maildir." "Mark message at point for moving to a maildir."
(interactive) (interactive)
(let* ((target (mm/ask-maildir "Target maildir for move: ")) (with-current-buffer mm/hdrs-buffer
(fulltarget (concat mm/maildir target))) (let* ((target (mm/ask-maildir "Target maildir for move: "))
(when (or (file-directory-p fulltarget) (fulltarget (concat mm/maildir target)))
(and (yes-or-no-p (when (or (file-directory-p fulltarget)
(format "%s does not exist. Create now?" fulltarget)) (and (yes-or-no-p
(mm/proc-mkdir fulltarget))) (format "%s does not exist. Create now?" fulltarget))
(mm/proc-mkdir fulltarget)))
(mm/hdrs-mark 'move target) (mm/hdrs-mark 'move target)
(mm/next-header)))) (mm/next-header)))))
(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')."
(interactive) (interactive)
(unless mm/trash-folder (unless mm/trash-folder
(error "`mm/trash-folder' is not set")) (error "`mm/trash-folder' is not set"))
(mm/hdrs-mark 'trash) (with-current-buffer mm/hdrs-buffer
(mm/next-header)) (mm/hdrs-mark 'trash)
(mm/next-header)))
(defun mm/mark-for-delete () (defun mm/mark-for-delete ()
"Mark message at point for direct deletion." "Mark message at point for direct deletion."
(interactive) (interactive)
(mm/hdrs-mark 'delete) (with-current-buffer mm/hdrs-buffer
(mm/next-header)) (mm/hdrs-mark 'delete)
(mm/next-header)))
(defun mm/unmark () (defun mm/unmark ()
"Unmark message at point." "Unmark message at point."
(interactive) (interactive)
(mm/hdrs-mark 'unmark) (with-current-buffer mm/hdrs-buffer
(mm/next-header)) (mm/hdrs-mark 'unmark)
(mm/next-header)))
(defun mm/unmark-all () (defun mm/unmark-all ()
"Unmark all messages." "Unmark all messages."
(interactive) (interactive)
(if (= 0 (hash-table-count mm/marks-map)) (with-current-buffer mm/hdrs-buffer
(message "Nothing is marked") (if (= 0 (hash-table-count mm/marks-map))
(when (mm/ignore-marks) (message "Nothing is marked")
(mm/hdrs-unmark-all)))) (when (mm/ignore-marks)
(mm/hdrs-unmark-all)))))
(defun mm/execute-marks () (defun mm/execute-marks ()
"Execute the actions for the marked messages." "Execute the actions for the marked messages."
(interactive) (interactive)
(if (= 0 (hash-table-count mm/marks-map)) (with-current-buffer mm/hdrs-buffer
(message "Nothing is marked") (if (= 0 (hash-table-count mm/marks-map))
(when (y-or-n-p (format "Sure you want to execute marks on %d message(s)?" (message "Nothing is marked")
(hash-table-count mm/marks-map))) (when (y-or-n-p (format "Sure you want to execute marks on %d message(s)?"
(mm/hdrs-marks-execute) (hash-table-count mm/marks-map)))
(message nil)))) (mm/hdrs-marks-execute)
(message nil)))))
(defun mm/compose-reply () (defun mm/compose-reply ()
"Start composing a reply to the current message." "Start composing a reply to the current message."
(interactive) (interactive)
(mm/hdrs-compose 'reply)) (with-current-buffer mm/hdrs-buffer
(mm/hdrs-compose 'reply)))
(defun mm/compose-forward () (defun mm/compose-forward ()
"Start composing a forward to the current message." "Start composing a forward to the current message."
(interactive) (interactive)
(mm/hdrs-compose 'forward)) (with-current-buffer mm/hdrs-buffer
(mm/hdrs-compose 'forward)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

@ -207,7 +207,7 @@ updated as well, with all processed sexp data removed."
(setq mm/buf (concat mm/buf str)) ;; update our buffer (setq mm/buf (concat mm/buf str)) ;; update our buffer
(let ((sexp (mm/proc-eat-sexp-from-buf))) (let ((sexp (mm/proc-eat-sexp-from-buf)))
(while sexp (while sexp
(mm/proc-log "%S" sexp) (mm/proc-log "<- %S" sexp)
(cond (cond
;; a header plist can be recognized by the existence of a :date field ;; a header plist can be recognized by the existence of a :date field
((plist-get sexp :date) ((plist-get sexp :date)
@ -244,7 +244,10 @@ 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 11) (message "Database is locked by another process")) ((eq code 11)
(message "Database is locked by another process"))
((eq code 19)
(message "Database is empty; try indexing some messages"))
(t (message (format "mu server process ended with exit code %d" code))))) (t (message (format "mu server process ended with exit code %d" code)))))
(t (t
(message "something bad happened to the mu server process"))))) (message "something bad happened to the mu server process")))))
@ -266,7 +269,7 @@ terminates."
(unless (mm/proc-is-running) (unless (mm/proc-is-running)
(mm/start-proc)) (mm/start-proc))
(let ((cmd (apply 'format frm args))) (let ((cmd (apply 'format frm args)))
(mm/proc-log cmd) (mm/proc-log (concat "-> " cmd))
(process-send-string mm/mu-proc (concat cmd "\n")))) (process-send-string mm/mu-proc (concat cmd "\n"))))

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

@ -225,7 +225,6 @@ And finally, the cited body of MSG, as per `mm/msg-cite-original'."
(concat mm/msg-reply-prefix (plist-get msg :subject))) (concat mm/msg-reply-prefix (plist-get msg :subject)))
mm/msg-separator mm/msg-separator
(mm/msg-cite-original msg))) (mm/msg-cite-original msg)))
;; TODO: attachments ;; TODO: attachments
@ -247,7 +246,7 @@ body from headers)
And finally, the cited body of MSG, as per `mm/msg-cite-original'." And finally, the cited body of MSG, as per `mm/msg-cite-original'."
(concat (concat
(mm/msg-header "From" (or (mm/msg-from-for-new) "")) (mm/msg-header "From" (or (mm/msg-from-create) ""))
(when (boundp 'mail-reply-to) (when (boundp 'mail-reply-to)
(mm/msg-header "Reply-To" mail-reply-to)) (mm/msg-header "Reply-To" mail-reply-to))
@ -404,7 +403,9 @@ edit buffer with the draft message"
;; mark the buffer as read-only, as its pointing at a non-existing file ;; mark the buffer as read-only, as its pointing at a non-existing file
;; now... ;; now...
(message "Message has been sent") (message "Message has been sent")
(setq buffer-read-only t)))) (setq buffer-read-only t)
)))
(defun mm/send-set-parent-flag () (defun mm/send-set-parent-flag ()
"Set the 'replied' flag on messages we replied to, and the "Set the 'replied' flag on messages we replied to, and the

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

@ -82,14 +82,19 @@ marking if it still had that."
mm/view-headers "") mm/view-headers "")
"\n" "\n"
(mm/view-body msg)) (mm/view-body msg))
;; initialize view-mode
(mm/view-mode) (mm/view-mode)
(setq (setq ;; these are buffer-local
mode-name (format "%s" mm/view-buffer-name (plist-get msg :docid)) mode-name (format "%s" mm/view-buffer-name (plist-get msg :docid))
;; these are buffer-local
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))
(switch-to-buffer buf) (switch-to-buffer buf)
(goto-char (point-min))))) (goto-char (point-min))
(mm/view-beautify)
(mm/view-mark-as-read-maybe))))
(defun mm/view-body (msg) (defun mm/view-body (msg)
@ -146,7 +151,9 @@ or if not available, :body-html converted to text)."
(lambda (att) (lambda (att)
(incf id) (incf id)
(puthash id att mm/attach-map) (puthash id att mm/attach-map)
(format "[%d]%s" id (nth 1 att))) (concat
(propertize (nth 1 att) 'face 'mm/view-link-face)
(propertize (format "[%d]" id) 'face 'mm/view-attach-number-face)))
atts ", "))) atts ", ")))
(mm/view-header (format "Attachments(%d):" id) vals))))) (mm/view-header (format "Attachments(%d):" id) vals)))))
@ -158,13 +165,15 @@ or if not available, :body-html converted to text)."
(define-key map "s" 'mm/search) (define-key map "s" 'mm/search)
(define-key map "j" 'mm/jump-to-maildir) (define-key map "j" 'mm/jump-to-maildir)
;; (define-key map "f" 'mua/view-forward) (define-key map "g" 'mm/view-go-to-url)
;; (define-key map "r" 'mua/view-reply)
;; (define-key map "c" 'mua/view-compose) (define-key map "f" 'mm/compose-forward)
(define-key map "r" 'mm/compose-reply)
(define-key map "c" 'mm/compose-new)
;; navigation between messages ;; navigation between messages
(define-key map "n" 'mm/view-next) (define-key map "n" 'mm/view-next-header)
(define-key map "p" 'mm/view-prev) (define-key map "p" 'mm/view-prev-header)
;; attachments ;; attachments
(define-key map "e" 'mm/view-extract-attachment) (define-key map "e" 'mm/view-extract-attachment)
@ -192,6 +201,7 @@ or if not available, :body-html converted to text)."
(make-local-variable 'mm/hdrs-buffer) (make-local-variable 'mm/hdrs-buffer)
(make-local-variable 'mm/current-msg) (make-local-variable 'mm/current-msg)
(make-local-variable 'mm/link-map)
(setq major-mode 'mm/view-mode mode-name mm/view-buffer-name) (setq major-mode 'mm/view-mode mode-name mm/view-buffer-name)
(setq truncate-lines t buffer-read-only t)) (setq truncate-lines t buffer-read-only t))
@ -214,32 +224,77 @@ Seen; if the message is not New/Unread, do nothing."
;; if so, mark it as non-new and read ;; if so, mark it as non-new and read
(mm/proc-flag-msg docid "+S-u-N"))))) (mm/proc-flag-msg docid "+S-u-N")))))
(defvar mm/link-map nil
"*internal* A map of some number->url so we can jump to url by number.")
(defun mm/view-beautify ()
"Improve the message view a bit, by making URLs clickable,
removing '^M' etc."
(let ((num 0))
(save-excursion
(goto-char (point-min))
;; remove the stupid CRs
(while (search-forward "
" nil t)
(replace-match "" nil t))
;; give the footer a different color...
(let ((p (search-forward "\n-- \n" nil t)))
(when p
(add-text-properties p (point-max) '(face mm/view-footer-face))))
;; this is fairly simplistic...
(goto-char (point-min))
(while (re-search-forward "\\(https?://.*\\)\\b" nil t)
(let ((subst (propertize (match-string-no-properties 0)
'face 'mm/view-link-face)))
(incf num)
(puthash num (match-string-no-properties 0) mm/link-map)
(replace-match (concat subst
(propertize (format "[%d]" num)
'face 'mm/view-url-number-face))))))))
;; Interactive functions ;; Interactive functions
(defun mm/view-quit-buffer () (defun mm/view-quit-buffer ()
"Quit the message view and return to the headers." "Quit the message view and return to the headers."
(mm/view-mark-as-read-maybe)
(interactive) (interactive)
(let ((inhibit-read-only t)) (let ((inhibit-read-only t))
(kill-buffer) (kill-buffer)
(switch-to-buffer mm/hdrs-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." (defun mm/view-next-header ()
"View the next header." "View the next header."
(mm/view-mark-as-read-maybe) (interactive)
(with-current-buffer mm/hdrs-buffer (when (mm/next-header)
(when (mm/prev-header)
(mm/hdrs-view))))
(mm/view-message))) (mm/view-message)))
(defun mm/view-prev-header ()
"View the previous header."
(interactive)
(when (mm/prev-header)
(mm/view-message)))
(defun mm/view-mark-for-move ()
"Mark the current message for moving."
(interactive)
(when (mm/mark-for-move)
(mm/view-message)))
(defun mm/view-mark-for-trash ()
"Mark the current message for moving to the trash folder."
(interactive)
(when (mm/mark-for-trash)
(mm/view-message)))
(defun mm/view-mark-for-delete ()
"Mark the current message for deletion."
(interactive)
(when (mm/mark-for-delete)
(mm/view-message))) (mm/view-message)))
(defun mm/view-extract-attachment (attnum) (defun mm/view-extract-attachment (attnum)
@ -268,27 +323,6 @@ Seen; if the message is not New/Unread, do nothing."
(unless att (error "Not a valid attachment number")) (unless att (error "Not a valid attachment number"))
(mm/proc-open (plist-get mm/current-msg :docid) (car att)))) (mm/proc-open (plist-get mm/current-msg :docid) (car att))))
(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 () (defun mm/view-unmark ()
"Warn user that unmarking only works in the header list." "Warn user that unmarking only works in the header list."
@ -301,5 +335,12 @@ list."
list." list."
(interactive) (interactive)
(message "Execution needs to be done in the header list view")) (message "Execution needs to be done in the header list view"))
(defun mm/view-go-to-url (num)
"Go to a numbered url."
(interactive "nGo to url with number: ")
(let ((url (gethash num mm/link-map)))
(unless url (error "Invalid number for URL"))
(browse-url url)))

54
toys/mm/mm.el
View File

@ -85,42 +85,54 @@ PATH, you can specifiy the full path."
(defcustom mm/inbox-folder nil (defcustom mm/inbox-folder nil
"Your Inbox folder, relative to `mm/maildir'." "Your Inbox folder, relative to `mm/maildir', e.g. \"/Inbox\"."
:type 'string
:safe 'stringp
:group 'mm/folders)
(defcustom mm/outbox-folder nil
"Your Outbox folder, relative to `mm/maildir'."
:type 'string :type 'string
:safe 'stringp :safe 'stringp
:group 'mm/folders) :group 'mm/folders)
(defcustom mm/sent-folder nil (defcustom mm/sent-folder nil
"Your folder for sent messages, relative to `mm/maildir'." "Your folder for sent messages, relative to `mm/maildir',
e.g. \"/Sent Items\"."
:type 'string :type 'string
:safe 'stringp :safe 'stringp
:group 'mm/folders) :group 'mm/folders)
(defcustom mm/draft-folder nil (defcustom mm/draft-folder nil
"Your folder for draft messages, relative to `mm/maildir'." "Your folder for draft messages, relative to `mm/maildir',
e.g. \"/drafts\""
:type 'string :type 'string
:safe 'stringp :safe 'stringp
:group 'mm/folders) :group 'mm/folders)
(defcustom mm/trash-folder nil (defcustom mm/trash-folder nil
"Your folder for trashed messages, relative to `mm/maildir'." "Your folder for trashed messages, relative to `mm/maildir',
e.g. \"/trash\"."
:type 'string :type 'string
:safe 'stringp :safe 'stringp
:group 'mm/folders) :group 'mm/folders)
;; the headers view
(defgroup mm/headers nil
"Settings for the headers view."
:group 'mm)
(defcustom mm/header-fields
'( (:date . 25)
(:flags . 6)
(:from . 22)
(:subject . 40))
"A list of header fields to show in the headers buffer, and their
respective widths in characters. A width of `nil' means
'unrestricted', and this is best reserved fo the rightmost (last)
field.")
;; 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)
;; the message view
(defcustom mm/view-headers (defcustom mm/view-headers
'(: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."
@ -199,7 +211,25 @@ be sure it no longer matches)."
"Face for the header value (such as \"Re: Hello!\" in the message view)." "Face for the header value (such as \"Re: Hello!\" in the message view)."
:group 'mm/faces) :group 'mm/faces)
(defface mm/view-link-face
'((t :inherit font-lock-type-face :underline t))
"Face for showing URLs and attachments in the message view."
:group 'mm/faces)
(defface mm/view-url-number-face
'((t :inherit font-lock-reference-face :bold t))
"Face for the number tags for URLs."
:group 'mm/faces)
(defface mm/view-attach-number-face
'((t :inherit font-lock-builtin-face :bold t))
"Face for the number tags for attachments."
:group 'mm/faces)
(defface mm/view-footer-face
'((t :inherit font-lock-comment-face))
"Face for message footers (signatures)."
:group 'mm/faces)