* mm: some more updates (WIP)
This commit is contained in:
Dirk-Jan C. Binnema
@ -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))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -37,12 +37,6 @@
|
||||
(require 'mm-common)
|
||||
(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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defvar mm/last-expr nil
|
||||
@ -68,9 +62,9 @@ buffer for the results."
|
||||
(with-current-buffer buf
|
||||
(erase-buffer)
|
||||
(mm/hdrs-mode)
|
||||
(setq mm/msg-map nil mm/mm/marks-map nil)
|
||||
(mm/msg-map-init)
|
||||
(setq
|
||||
mm/mm/marks-map nil
|
||||
mm/msg-map (make-hash-table :size 1024 :rehash-size 2 :weakness nil)
|
||||
mode-name expr
|
||||
mm/last-expr expr
|
||||
mm/hdrs-buffer buf)))
|
||||
@ -103,107 +97,75 @@ 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)))
|
||||
(marker (gethash docid mm/msg-map)))
|
||||
(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))))))))
|
||||
(when marker ;; is the message present in this list?
|
||||
(save-excursion
|
||||
(goto-char (marker-position marker))
|
||||
;; sanity check
|
||||
(unless (eq docid (mm/hdrs-get-docid)) (error "Unexpected docid"))
|
||||
;; if it's marked, unmark it now
|
||||
(when (mm/hdrs-docid-is-marked docid)
|
||||
(mm/hdrs-mark 'unmark))
|
||||
(mm/hdrs-remove-header docid)
|
||||
;; 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 (beginning-of-line)))))))))
|
||||
|
||||
(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)))
|
||||
(let ((marker (gethash docid mm/msg-map)))
|
||||
(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 message
|
||||
(set-text-properties bol eol '(invisible t)))))))
|
||||
(mm/hdrs-remove-header docid))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(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
|
||||
point. Line does not include a newline or any text-properties."
|
||||
(mapconcat
|
||||
(lambda (f-w)
|
||||
(let* ((field (car f-w)) (width (cdr f-w))
|
||||
(val (plist-get msg field))
|
||||
(str
|
||||
(case field
|
||||
(:subject val)
|
||||
((:to :from :cc :bcc)
|
||||
(mapconcat
|
||||
(lambda (ct)
|
||||
(let ((name (car ct)) (email (cdr ct)))
|
||||
(or name email "?"))) val ", "))
|
||||
(:date (format-time-string "%x %X" val))
|
||||
(:flags (mm/flags-to-string val))
|
||||
(:size
|
||||
(cond
|
||||
((>= val 1000000) (format "%2.1fM" (/ val 1000000.0)))
|
||||
((and (>= val 1000) (< val 1000000))
|
||||
(format "%2.1fK" (/ val 1000.0)))
|
||||
((< val 1000) (format "%d" val))))
|
||||
(t (error "Unsupported header field (%S)" field)))))
|
||||
(when str (truncate-string-to-width str width 0 ?\s t))))
|
||||
mm/header-fields " "))
|
||||
(let* ((line (mapconcat
|
||||
(lambda (f-w)
|
||||
(let* ((field (car f-w)) (width (cdr f-w))
|
||||
(val (plist-get msg field))
|
||||
(str
|
||||
(case field
|
||||
(:subject val)
|
||||
((:to :from :cc :bcc)
|
||||
(mapconcat
|
||||
(lambda (ct)
|
||||
(let ((name (car ct)) (email (cdr ct)))
|
||||
(or name email "?"))) val ", "))
|
||||
(:date (format-time-string "%x %X" val))
|
||||
(:flags (mm/flags-to-string val))
|
||||
(:size
|
||||
(cond
|
||||
((>= val 1000000) (format "%2.1fM" (/ val 1000000.0)))
|
||||
((and (>= val 1000) (< val 1000000))
|
||||
(format "%2.1fK" (/ val 1000.0)))
|
||||
((< val 1000) (format "%d" val))))
|
||||
(t (error "Unsupported header field (%S)" field)))))
|
||||
(when str
|
||||
(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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(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
|
||||
"*internal* A map (hashtable) which maps a database (Xapian)
|
||||
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
|
||||
server.")
|
||||
|
||||
(defun mm/msg-map-add (msg marker)
|
||||
"Update `mm/msg-map' with MSG, and MARKER pointing to the buffer
|
||||
position for the message header."
|
||||
(let ((docid (plist-get msg :docid)))
|
||||
(unless docid (error "Invalid message"))
|
||||
(puthash docid marker mm/msg-map)))
|
||||
|
||||
(defun mm/msg-map-get-marker (docid)
|
||||
"Get the marker for the message identified by DOCID."
|
||||
(gethash docid mm/msg-map))
|
||||
|
||||
(defun mm/msg-map-init()
|
||||
"(Re)initialize the msg map for use -- re-create the hash table,
|
||||
and reset the last-uid to 0."
|
||||
(setq mm/msg-map
|
||||
(make-hash-table :size 256 :rehash-size 2 :weakness nil)))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun mm/hdrs-add-header (str docid point)
|
||||
"Add header STR with DOCID to the buffer. If POINT is not
|
||||
provided, put it at the end of the buffer."
|
||||
(unless docid (error "Invalid message"))
|
||||
(when (buffer-live-p mm/hdrs-buffer)
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(let ((inhibit-read-only t)
|
||||
(bol (line-beginning-position))
|
||||
(eol (line-beginning-position 2))
|
||||
(point (if point point (point-max))))
|
||||
(save-excursion
|
||||
(goto-char point)
|
||||
;; Update `mm/msg-map' with MSG, and MARKER pointing to the buffer
|
||||
;; position for the message header."
|
||||
(puthash docid (point-marker) mm/msg-map)
|
||||
(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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(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'
|
||||
`delete' n remove the message
|
||||
`unmark' n unmark this message"
|
||||
(let* ((docid (get-text-property (point) 'docid))
|
||||
(let* ((docid (mm/hdrs-get-docid))
|
||||
(markkar
|
||||
(case mark ;; the visual mark
|
||||
('move "m")
|
||||
@ -340,51 +327,39 @@ The following marks are available, and the corresponding props:
|
||||
(t (error "Invalid mark %S" mark)))))
|
||||
(unless docid (error "No message on this line"))
|
||||
(save-excursion
|
||||
(move-beginning-of-line 1)
|
||||
|
||||
;; 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"))
|
||||
|
||||
(when (mm/hdrs-mark-header docid markkar))
|
||||
;; update the hash
|
||||
(if (eql mark 'unmark)
|
||||
(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 ()
|
||||
"Execute the actions for all marked messages in this
|
||||
buffer.
|
||||
|
||||
After the actions have been executed succesfully, the affected
|
||||
messages are *hidden* from the current header list. Since the
|
||||
headers are the result of a search, we cannot be certain that the
|
||||
messages no longer matches the current one - to get that certainty,
|
||||
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
|
||||
buffer. After the actions have been executed succesfully, the
|
||||
affected messages are *hidden* from the current header list. Since
|
||||
the headers are the result of a search, we cannot be certain that
|
||||
the messages no longer matches the current one - to get that
|
||||
certainty, 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."
|
||||
(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)) )
|
||||
(let ((marker (nth 0 val)) (mark (nth 1 val)) (target (nth 2 val)))
|
||||
(case mark
|
||||
(move
|
||||
(mm/proc-move-msg docid target))
|
||||
(trash
|
||||
(unless mm/trash-folder
|
||||
(error "`mm/trash-folder' not set"))
|
||||
(mm/proc-move-msg docid mm/trash-folder "+T"))
|
||||
(delete
|
||||
(mm/proc-remove-msg docid)))))
|
||||
mm/marks-map)
|
||||
(mm/hdrs-unmark-all)))
|
||||
|
||||
(defun mm/hdrs-unmark-all ()
|
||||
"Unmark all marked messages."
|
||||
@ -399,14 +374,14 @@ work well."
|
||||
|
||||
(defun mm/hdrs-view ()
|
||||
"View message at point."
|
||||
(let ((docid (get-text-property (point) 'docid)))
|
||||
(let ((docid (mm/hdrs-get-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)))
|
||||
(let ((docid (mm/hdrs-get-docid)))
|
||||
(unless docid (error "No message at point."))
|
||||
(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
|
||||
the new docid. Otherwise, return nil."
|
||||
(interactive)
|
||||
(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)))
|
||||
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(if (= 0 (forward-line 1))
|
||||
(let ((docid (mm/hdrs-get-docid)))
|
||||
(if docid docid (mm/next-header)))))) ;; skip non-headers
|
||||
|
||||
(defun mm/prev-header ()
|
||||
"Move point to the previous message header. If this succeeds,
|
||||
return the new docid. Otherwise, return nil."
|
||||
(interactive)
|
||||
(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)))
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(if (= 0 (forward-line -1))
|
||||
(let ((docid (mm/hdrs-get-docid)))
|
||||
(if docid docid (mm/prev-header)))))) ;; skip non-headers
|
||||
|
||||
|
||||
(defun mm/jump-to-maildir ()
|
||||
@ -499,64 +469,71 @@ return the new docid. Otherwise, return nil."
|
||||
(defun mm/mark-for-move ()
|
||||
"Mark message at point for moving to a maildir."
|
||||
(interactive)
|
||||
(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?" fulltarget))
|
||||
(mm/proc-mkdir fulltarget)))
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(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?" fulltarget))
|
||||
(mm/proc-mkdir fulltarget)))
|
||||
(mm/hdrs-mark 'move target)
|
||||
(mm/next-header))))
|
||||
(mm/next-header)))))
|
||||
|
||||
(defun mm/mark-for-trash ()
|
||||
"Mark message at point for moving to the trash
|
||||
folder (`mm/trash-folder')."
|
||||
(interactive)
|
||||
(unless mm/trash-folder
|
||||
(error "`mm/trash-folder' is not set"))
|
||||
(mm/hdrs-mark 'trash)
|
||||
(mm/next-header))
|
||||
(unless mm/trash-folder
|
||||
(error "`mm/trash-folder' is not set"))
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(mm/hdrs-mark 'trash)
|
||||
(mm/next-header)))
|
||||
|
||||
(defun mm/mark-for-delete ()
|
||||
"Mark message at point for direct deletion."
|
||||
(interactive)
|
||||
(mm/hdrs-mark 'delete)
|
||||
(mm/next-header))
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(mm/hdrs-mark 'delete)
|
||||
(mm/next-header)))
|
||||
|
||||
(defun mm/unmark ()
|
||||
"Unmark message at point."
|
||||
(interactive)
|
||||
(mm/hdrs-mark 'unmark)
|
||||
(mm/next-header))
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(mm/hdrs-mark 'unmark)
|
||||
(mm/next-header)))
|
||||
|
||||
(defun mm/unmark-all ()
|
||||
"Unmark all messages."
|
||||
(interactive)
|
||||
(if (= 0 (hash-table-count mm/marks-map))
|
||||
(message "Nothing is marked")
|
||||
(when (mm/ignore-marks)
|
||||
(mm/hdrs-unmark-all))))
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(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)
|
||||
(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))))
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(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))
|
||||
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(mm/hdrs-compose 'reply)))
|
||||
|
||||
(defun mm/compose-forward ()
|
||||
"Start composing a forward to the current message."
|
||||
(interactive)
|
||||
(mm/hdrs-compose 'forward))
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(mm/hdrs-compose 'forward)))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
@ -207,7 +207,7 @@ updated as well, with all processed sexp data removed."
|
||||
(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)
|
||||
(mm/proc-log "<- %S" sexp)
|
||||
(cond
|
||||
;; a header plist can be recognized by the existence of a :date field
|
||||
((plist-get sexp :date)
|
||||
@ -244,7 +244,10 @@ terminates."
|
||||
(t (message (format "mu server process received signal %d" code)))))
|
||||
((eq status 'exit)
|
||||
(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 "something bad happened to the mu server process")))))
|
||||
@ -266,7 +269,7 @@ terminates."
|
||||
(unless (mm/proc-is-running)
|
||||
(mm/start-proc))
|
||||
(let ((cmd (apply 'format frm args)))
|
||||
(mm/proc-log cmd)
|
||||
(mm/proc-log (concat "-> " cmd))
|
||||
(process-send-string mm/mu-proc (concat cmd "\n"))))
|
||||
|
||||
|
||||
|
||||
@ -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)))
|
||||
|
||||
mm/msg-separator
|
||||
|
||||
(mm/msg-cite-original msg)))
|
||||
|
||||
;; TODO: attachments
|
||||
@ -247,7 +246,7 @@ 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) ""))
|
||||
(mm/msg-header "From" (or (mm/msg-from-create) ""))
|
||||
(when (boundp '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
|
||||
;; now...
|
||||
(message "Message has been sent")
|
||||
(setq buffer-read-only t))))
|
||||
(setq buffer-read-only t)
|
||||
|
||||
)))
|
||||
|
||||
(defun mm/send-set-parent-flag ()
|
||||
"Set the 'replied' flag on messages we replied to, and the
|
||||
|
||||
@ -82,14 +82,19 @@ marking if it still had that."
|
||||
mm/view-headers "")
|
||||
"\n"
|
||||
(mm/view-body msg))
|
||||
|
||||
;; initialize view-mode
|
||||
(mm/view-mode)
|
||||
(setq
|
||||
(setq ;; these are buffer-local
|
||||
mode-name (format "%s" mm/view-buffer-name (plist-get msg :docid))
|
||||
;; these are buffer-local
|
||||
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)
|
||||
(goto-char (point-min)))))
|
||||
(goto-char (point-min))
|
||||
(mm/view-beautify)
|
||||
(mm/view-mark-as-read-maybe))))
|
||||
|
||||
|
||||
(defun mm/view-body (msg)
|
||||
@ -146,7 +151,9 @@ or if not available, :body-html converted to text)."
|
||||
(lambda (att)
|
||||
(incf id)
|
||||
(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 ", ")))
|
||||
(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 "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)
|
||||
(define-key map "g" 'mm/view-go-to-url)
|
||||
|
||||
(define-key map "f" 'mm/compose-forward)
|
||||
(define-key map "r" 'mm/compose-reply)
|
||||
(define-key map "c" 'mm/compose-new)
|
||||
|
||||
;; navigation between messages
|
||||
(define-key map "n" 'mm/view-next)
|
||||
(define-key map "p" 'mm/view-prev)
|
||||
(define-key map "n" 'mm/view-next-header)
|
||||
(define-key map "p" 'mm/view-prev-header)
|
||||
|
||||
;; attachments
|
||||
(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/current-msg)
|
||||
(make-local-variable 'mm/link-map)
|
||||
|
||||
(setq major-mode 'mm/view-mode mode-name mm/view-buffer-name)
|
||||
(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
|
||||
(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
|
||||
|
||||
(defun mm/view-quit-buffer ()
|
||||
"Quit the message view and return to the headers."
|
||||
(mm/view-mark-as-read-maybe)
|
||||
(interactive)
|
||||
(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."
|
||||
|
||||
(defun mm/view-next-header ()
|
||||
"View the next header."
|
||||
(mm/view-mark-as-read-maybe)
|
||||
(with-current-buffer mm/hdrs-buffer
|
||||
(when (mm/prev-header)
|
||||
(mm/hdrs-view))))
|
||||
(interactive)
|
||||
(when (mm/next-header)
|
||||
(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)))
|
||||
|
||||
(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"))
|
||||
(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 ()
|
||||
"Warn user that unmarking only works in the header list."
|
||||
@ -301,5 +335,12 @@ list."
|
||||
list."
|
||||
(interactive)
|
||||
(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)))
|
||||
|
||||
|
||||
|
||||
@ -85,42 +85,54 @@ PATH, you can specifiy the full path."
|
||||
|
||||
|
||||
(defcustom mm/inbox-folder nil
|
||||
"Your Inbox folder, relative to `mm/maildir'."
|
||||
:type 'string
|
||||
:safe 'stringp
|
||||
:group 'mm/folders)
|
||||
|
||||
(defcustom mm/outbox-folder nil
|
||||
"Your Outbox folder, relative to `mm/maildir'."
|
||||
"Your Inbox folder, relative to `mm/maildir', e.g. \"/Inbox\"."
|
||||
:type 'string
|
||||
:safe 'stringp
|
||||
:group 'mm/folders)
|
||||
|
||||
(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
|
||||
:safe 'stringp
|
||||
:group 'mm/folders)
|
||||
|
||||
(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
|
||||
:safe 'stringp
|
||||
:group 'mm/folders)
|
||||
|
||||
(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
|
||||
:safe 'stringp
|
||||
: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
|
||||
"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."
|
||||
@ -199,7 +211,25 @@ be sure it no longer matches)."
|
||||
"Face for the header value (such as \"Re: Hello!\" in the message view)."
|
||||
: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)
|
||||
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user