* mm updates (WIP)

2011-09-22 21:01:35 +03:00
parent 406aeb6e29
commit f3264affba
5 changed files with 171 additions and 79 deletions
--- 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)
--- 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)
--- 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

--- 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 "
+    (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))))
+	(add-text-properties p (point-max) '(face mm/view-footer-face))))

    ;; this is fairly simplistic...
-    (goto-char (point-min))
+    (goto-char (point-min))
    (while (re-search-forward "\\(https?://.*\\)\\>" nil t)
      (let ((subst (propertize (match-string-no-properties 0)
 		     'face 'mm/view-link-face)))
@ -254,10 +263,30 @@ removing '^M' etc."
 	(puthash num (match-string-no-properties 0) mm/link-map)
 	(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."
@ -265,7 +294,6 @@ removing '^M' etc."
  (let ((inhibit-read-only t))
    (kill-buffer)
    (switch-to-buffer mm/hdrs-buffer)))
-

 (defun mm/view-next-header ()
  "View the next header."
--- 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))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;