From f3264affbacdc03d814d18fdcb156f87f9d9737a Mon Sep 17 00:00:00 2001 From: "Dirk-Jan C. Binnema" Date: Thu, 22 Sep 2011 21:01:35 +0300 Subject: [PATCH] * mm updates (WIP) --- toys/mm/mm-hdrs.el | 115 ++++++++++++++++++++++++++++++--------------- toys/mm/mm-proc.el | 42 +++++++++++++++++ toys/mm/mm-send.el | 23 ++++----- toys/mm/mm-view.el | 48 +++++++++++++++---- toys/mm/mm.el | 22 ++------- 5 files changed, 171 insertions(+), 79 deletions(-) diff --git a/toys/mm/mm-hdrs.el b/toys/mm/mm-hdrs.el index fbbee855..cdb07f10 100644 --- a/toys/mm/mm-hdrs.el +++ b/toys/mm/mm-hdrs.el @@ -97,23 +97,30 @@ headers." (when (buffer-live-p mm/hdrs-buffer) (with-current-buffer mm/hdrs-buffer (let* ((docid (plist-get msg :docid)) - (marker (gethash docid mm/msg-map))) + (marker (gethash docid mm/msg-map)) + (point (when marker (marker-position marker)))) (unless docid (error "Invalid update %S" update)) - (when marker ;; is the message present in this list? + (when point ;; is the message present in this list? (save-excursion - (goto-char (marker-position marker)) + (goto-char point) ;; sanity check - (unless (eq docid (mm/hdrs-get-docid)) (error "Unexpected docid")) + (unless (eq docid (mm/hdrs-get-docid)) + (error "Unexpected docid: %S <=> %S" docid (mm/hdrs-get-docid))) + ;; if it's marked, unmark it now (when (mm/hdrs-docid-is-marked docid) (mm/hdrs-mark 'unmark)) - (mm/hdrs-remove-header docid) + + ;; first, remove the old one (otherwise, we'd have to headers with + ;; the same docid... + (mm/hdrs-remove-header docid point) + ;; 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))))))))) + (when (not is-move) + (mm/hdrs-header-handler msg point)))))))) (defun mm/hdrs-remove-handler (docid) "Remove handler, will be called when a message has been removed @@ -122,7 +129,7 @@ the current list of headers." (with-current-buffer mm/hdrs-buffer (let ((marker (gethash docid mm/msg-map))) (unless marker (error "Message %d not found" docid)) - (mm/hdrs-remove-header docid)))) + (mm/hdrs-remove-header docid (marker-position marker))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -181,6 +188,8 @@ point. Line does not include a newline or any text-properties." (define-key map "p" 'mm/prev-header) (define-key map "j" 'mm/jump-to-maildir) + + ;; marking/unmarking/executing (define-key map "m" 'mm/mark-for-move) (define-key map "d" 'mm/mark-for-trash) @@ -189,6 +198,10 @@ point. Line does not include a newline or any text-properties." (define-key map "U" 'mm/unmark-all) (define-key map "x" 'mm/execute-marks) + (define-key map " " 'mm/select) + (define-key map "*" 'mm/select) + + ;; message composition (define-key map "r" 'mm/compose-reply) (define-key map "f" 'mm/compose-forward) @@ -256,39 +269,39 @@ provided, put it at the end of the buffer." (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")))))) + (puthash docid (copy-marker point) mm/msg-map) + (insert (propertize (concat " " str "\n") 'docid docid))))))) -(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-remove-header (docid point) + "Remove header with DOCID at POINT." + (with-current-buffer mm/hdrs-buffer + (save-excursion + (goto-char point) + ;; sanity check + (unless (eq docid (mm/hdrs-get-docid)) (error "Unexpected docid")) + (let ((inhibit-read-only t)) + (delete-region (line-beginning-position) (line-beginning-position 2))) + (remhash docid mm/msg-map)))) (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 " ")))))) - + ;; (unless marker (error "Unregistered message")) + (when marker + (with-current-buffer mm/hdrs-buffer + (save-excursion + (let ((inhibit-read-only t) (pos (marker-position marker))) + (goto-char pos) + (delete-char 2) + (insert mark " ") + (put-text-property pos + (line-beginning-position 2) 'docid docid))))))) + + (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)))) + (get-text-property (point) 'docid))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -323,14 +336,16 @@ The following marks are available, and the corresponding props: ('move "m") ('trash "d") ('delete "D") + ('select "*") ('unmark " ") (t (error "Invalid mark %S" mark))))) (unless docid (error "No message on this line")) (save-excursion (when (mm/hdrs-mark-header docid markkar)) - ;; update the hash - (if (eql mark 'unmark) - (remhash docid mm/marks-map) + ;; update the hash -- remove everything current, and if add the new stuff, + ;; unless we're unmarking + (remhash docid mm/marks-map) + (unless (eql mark 'unmark) (puthash docid (list (point-marker) mark target) mm/marks-map))))) @@ -445,9 +460,10 @@ do a new search." the new docid. Otherwise, return nil." (interactive) (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 + (let ((old (line-number-at-pos))) + (if (= 0 (forward-line 1)) + (let ((docid (mm/hdrs-get-docid))) + (if docid docid (mm/next-header))))))) (defun mm/prev-header () "Move point to the previous message header. If this succeeds, @@ -466,6 +482,27 @@ return the new docid. Otherwise, return nil." (mm/hdrs-search (concat "maildir:" fld)))) +;; (defun mm/select () +;; "Select the current messsage." +;; (interactive) +;; (with-current-buffer mm/hdrs-buffer +;; (mm/hdrs-mark 'select) +;; (mm/next-header))) + +;; (defun mm/mark-selected (marktype) +;; "If any headers have been selected, set the mark for all of them; +;; otherwise, return nil." +;; (let ((selected) (target)) +;; (maphash +;; (lambda (docid val) +;; (when (eq (car val) 'select) +;; (setq selected t) +;; (case marktype + +;; mm/marks-map + + + (defun mm/mark-for-move () "Mark message at point for moving to a maildir." (interactive) diff --git a/toys/mm/mm-proc.el b/toys/mm/mm-proc.el index f2a8fb10..26081c29 100644 --- a/toys/mm/mm-proc.el +++ b/toys/mm/mm-proc.el @@ -110,6 +110,8 @@ process." (unless (file-executable-p mm/mu-binary) (error (format "%S is not executable" mm/mu-binary))) (let* ((process-connection-type nil) ;; use a pipe + (coding-system-for-read 'utf-8) + (coding-system-for-write 'no-conversion) (args '("server")) (args (append args (when mm/mu-home (list (concat "--muhome=" mm/mu-home)))))) @@ -214,17 +216,27 @@ updated as well, with all processed sexp data removed." (funcall mm/proc-header-func sexp)) ((plist-get sexp :view) (funcall mm/proc-view-func (plist-get sexp :view))) + + ;; something got moved/flags changed ((plist-get sexp :update) (funcall mm/proc-update-func (plist-get sexp :update) (plist-get sexp :move))) + + ;; a message got removed ((plist-get sexp :remove) (funcall mm/proc-remove-func (plist-get sexp :remove))) + + ;; start composing a new message ((plist-get sexp :compose) (funcall mm/proc-compose-func (plist-get sexp :compose) (plist-get sexp :action))) + + ;; get some info ((plist-get sexp :info) (funcall mm/proc-info-func sexp)) + + ;; receive an error ((plist-get sexp :error) (funcall mm/proc-error-func sexp)) (t (message "Unexpected data from server [%S]" sexp))) @@ -362,4 +374,34 @@ The result will be delivered to the function registered as (mm/proc-send-command "compose %s %d" action docid))) + +(defun mm/proc-retrieve-mail-update-db () + "Try to retrieve mail (using the user-provided shell command), +and update the database afterwards." + (when mm/get-mail-command + (let ((buf (get-buffer-create "*mm-retrieve*")) + (cmd mm/get-mail-command)) + (message "Retrieving mail...") + (let ((proc (start-process "*mm-retrieve*" buf "sh" "-c" cmd))) + (set-process-sentinel proc 'mm/proc-retrieve-mail-sentinel))))) + + +(defun mm/proc-retrieve-mail-sentinel (proc msg) + "Function that will be called when the mail retrieval process +terminates." + (let ((status (process-status proc)) (code (process-exit-status proc))) + (cond + ((eq status 'signal) + (cond + ((eq code 9) (message "the mail retrieval process has been stopped")) + (t (message (format "mu server process received signal %d" code))))) + ((eq status 'exit) + (if (eq code 0) ;; all went well, it seems + (progn + (message "Updating the database...") + (mm/proc-index mm/maildir)) + (progn + (message "Received code %d from mail retrieval process" code))))))) + + (provide 'mm-proc) diff --git a/toys/mm/mm-send.el b/toys/mm/mm-send.el index 3ba521ee..5068ef93 100644 --- a/toys/mm/mm-send.el +++ b/toys/mm/mm-send.el @@ -252,7 +252,7 @@ And finally, the cited body of MSG, as per `mm/msg-cite-original'." (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-hidden-header "References" (mm/msg-references-create msg)) (mm/msg-header"Subject" (concat mm/msg-forward-prefix (plist-get msg :subject))) @@ -292,12 +292,11 @@ with non-mm-generated messages") "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 "%s-%x%x:2,D" ;; 'D': rarely used, but hey, it's available (format-time-string "%Y%m%d" (current-time)) (emacs-pid) - (random t) - (replace-regexp-in-string "[:/]" "_" (system-name)))) + (random t))) +;;; (replace-regexp-in-string "[:/]" "_" (system-name)))) (defvar mm/send-reply-docid nil "Docid of the message this is a reply to.") @@ -344,7 +343,11 @@ using Gnus' `message-mode'." (make-local-variable 'mm/send-reply-docid) (make-local-variable 'mm/send-forward-docid) (make-local-variable 'mm/mm-msg) - + + ;; hook our functions up with sending of the message + (add-hook 'message-sent-hook 'mm/msg-save-to-sent nil t) + (add-hook 'message-sent-hook 'mm/send-set-parent-flag nil t) + (setq mm/mm-msg t) (if (eq reply-or-forward 'reply) @@ -403,9 +406,8 @@ 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 @@ -422,11 +424,6 @@ This is meant to be called from message mode's (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 diff --git a/toys/mm/mm-view.el b/toys/mm/mm-view.el index 4011759a..41987e9d 100644 --- a/toys/mm/mm-view.el +++ b/toys/mm/mm-view.el @@ -34,6 +34,7 @@ (eval-when-compile (require 'cl)) (require 'mm-common) (require 'html2text) +(require 'filladapt) (defconst mm/view-buffer-name "*mm-view*" "*internal* Name for the message view buffer") @@ -45,10 +46,11 @@ (defvar mm/current-msg nil "*internal* The plist describing the current message.") -(defun mm/view (msg hdrsbuf) +(defun mm/view (msg hdrsbuf &optional update) "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. +the the message view affects HDRSBUF, as does marking etc. If +UPDATE is non-nil, the current message will be (visually) updated. As a side-effect, a message that is being viewed loses its 'unread' marking if it still had that." @@ -86,15 +88,17 @@ marking if it still had that." ;; initialize view-mode (mm/view-mode) (setq ;; these are buffer-local - mode-name (format "%s" mm/view-buffer-name (plist-get msg :docid)) + mode-name (format "%s %d" mm/view-buffer-name (plist-get msg :docid)) mm/current-msg msg 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)) (mm/view-beautify) - (mm/view-mark-as-read-maybe)))) + + (unless update + (mm/view-mark-as-read-maybe))))) (defun mm/view-body (msg) @@ -184,6 +188,9 @@ or if not available, :body-html converted to text)." (define-key map "D" 'mm/view-mark-for-delete) (define-key map "m" 'mm/view-mark-for-move) + ;; misc + (define-key map "w" 'mm/view-toggle-wrap-lines) + ;; next 3 only warn user (define-key map "u" 'mm/view-unmark) (define-key map "U" 'mm/view-unmark) @@ -202,6 +209,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) + (make-local-variable 'mm/wrap-lines) (setq major-mode 'mm/view-mode mode-name mm/view-buffer-name) (setq truncate-lines t buffer-read-only t)) @@ -233,20 +241,21 @@ Seen; if the message is not New/Unread, do nothing." removing '^M' etc." (let ((num 0)) (save-excursion - (goto-char (point-min)) ;; remove the stupid CRs - (while (search-forward " " nil t) + (goto-char (point-min)) + (while (search-forward " \\| " nil t) (replace-match "" nil t)) ;; give the footer a different color... + (goto-char (point-min)) (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) + (while (re-search-forward "\\(https?://.*\\)\\>" nil t) (let ((subst (propertize (match-string-no-properties 0) 'face 'mm/view-link-face))) (incf num) @@ -254,10 +263,30 @@ removing '^M' etc." (replace-match (concat subst (propertize (format "[%d]" num) 'face 'mm/view-url-number-face)))))))) + +(defvar mm/wrap-lines nil + "*internal* Whether to wrap lines or not (variable controlled by + `mm/view-toggle-wrap-lines').") + ;; Interactive functions +(defun mm/view-toggle-wrap-lines () + "Toggle line wrap in the message body." + (interactive) + (save-excursion + (if mm/wrap-lines + (progn + (setq mm/wrap-lines nil) + (mm/view mm/current-msg mm/hdrs-buffer t)) ;; back to normal + (let ((inhibit-read-only t)) + (setq mm/wrap-lines t) + (goto-char (point-min)) + (when (search-forward "\n\n") ;; search for the message body + (fill-region (point) (point-max))))))) + + (defun mm/view-quit-buffer () "Quit the message view and return to the headers." (interactive) @@ -265,7 +294,6 @@ removing '^M' etc." (kill-buffer) (switch-to-buffer mm/hdrs-buffer))) - (defun mm/view-next-header () "View the next header." (interactive) diff --git a/toys/mm/mm.el b/toys/mm/mm.el index df160e77..0cd82cb1 100644 --- a/toys/mm/mm.el +++ b/toys/mm/mm.el @@ -257,7 +257,7 @@ be sure it no longer matches)." (define-key map "c" 'mm/compose-new) (define-key map "r" 'mm/retrieve-mail) - (define-key map "u" 'mm/update-database) + (define-key map "u" 'mm/retrieve-mail-update-db) map) "Keymap for the *mm* buffer.") @@ -301,8 +301,7 @@ be sure it no longer matches)." "\n" " * " (propertize "c" 'face 'highlight) "ompose a new message\n" "\n" - " * " (propertize "r" 'face 'highlight) "etrieve new mail\n" - " * " (propertize "u" 'face 'highlight) "pdate the message database\n" + " * " (propertize "u" 'face 'highlight) "pdate email\n" "\n" " * " (propertize "q" 'face 'highlight) "uit mm\n") @@ -333,21 +332,10 @@ be sure it no longer matches)." (interactive) (mm/hdrs-search "date:7d..now")) -(defun mm/retrieve-mail () - "Get new mail." +(defun mm/retrieve-mail-update-db () + "Get new mail and update the database." (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))) - + (mm/proc-retrieve-mail-update-db)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;