From 74d00e26d4b908571324caaa379f844a365ccf8c Mon Sep 17 00:00:00 2001 From: "Dirk-Jan C. Binnema" Date: Mon, 8 Aug 2011 21:55:59 +0300 Subject: [PATCH] * move emacs/ code to toys/mua; rename mu=>mua, many updates --- emacs/mu-common.el | 227 ---------------- emacs/mu-headers.el | 464 --------------------------------- emacs/mu-message.el | 165 ------------ emacs/mu-view.el | 221 ---------------- emacs/mu.el | 68 ----- {emacs => toys/mua}/Makefile | 0 toys/mua/TODO | 28 ++ toys/mua/mua-common.el | 94 +++++++ toys/mua/mua-hdrs.el | 480 ++++++++++++++++++++++++++++++++++ toys/mua/mua-msg.el | 483 +++++++++++++++++++++++++++++++++++ toys/mua/mua-view.el | 221 ++++++++++++++++ 11 files changed, 1306 insertions(+), 1145 deletions(-) delete mode 100644 emacs/mu-common.el delete mode 100644 emacs/mu-headers.el delete mode 100644 emacs/mu-message.el delete mode 100644 emacs/mu-view.el delete mode 100644 emacs/mu.el rename {emacs => toys/mua}/Makefile (100%) create mode 100644 toys/mua/TODO create mode 100644 toys/mua/mua-common.el create mode 100644 toys/mua/mua-hdrs.el create mode 100644 toys/mua/mua-msg.el create mode 100644 toys/mua/mua-view.el diff --git a/emacs/mu-common.el b/emacs/mu-common.el deleted file mode 100644 index 43082aab..00000000 --- a/emacs/mu-common.el +++ /dev/null @@ -1,227 +0,0 @@ -;;; mu-common.el -- part of mu -;; -;; Copyright (C) 2011 Dirk-Jan C. Binnema - -;; Author: Dirk-Jan C. Binnema -;; Maintainer: Dirk-Jan C. Binnema -;; Keywords: email -;; Version: 0.0 - -;; This file is not part of GNU Emacs. -;; -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;; mu message has functions to display a message - -;;; Code: - -(require 'cl) - -(defvar mu-binary "/home/djcb/src/mu/src/mu" "name/path of the mu executable") -(defvar mu-muile-binary "/home/djcb/src/mu/toys/muile/muile" - "name/path of the muile executable") -(defvar mu-home nil - "path where mu stores it's data or nil for the defaults (typically, ~/.mu)") - -(defvar mu-date-format-short "%x %X" "date format (in strftime(2) -notation) e.g. for mail headers") - -(defvar mu-date-format-long "%c" "date format (in strftime(2) -notation) for the mail view and in replied/forwarded message quotations") - -(defvar mu-folder-draft "/home/djcb/Maildir/") - -(defface mu-date-face '((t (:foreground "#8c5353"))) "") -(defface mu-subject-face '((t (:foreground "#dfaf8f"))) "") -(defface mu-from-face '((t (:foreground "#7f9f7f"))) "") -(defface mu-to-face '((t (:foreground "#7f6655"))) "") -(defface mu-cc-face '((t (:foreground "#7f6666"))) "") -(defface mu-bcc-face '((t (:foreground "#7f6677"))) "") -(defface mu-body-face '((t (:foreground "#8cd0d3"))) "") -(defface mu-header-face '((t (:foreground "#7f9f7f"))) "") -(defface mu-size-face '((t (:foreground "#889f7f"))) "") -(defface mu-flag-face '((t (:foreground "#dc56cc"))) "") -(defface mu-path-face '((t (:foreground "#dc56cc"))) "") - -(defface mu-unread-face '((t (:bold t))) "") -(defface mu-face '((t (:foreground "Gray" :italic t))) "") - -(defvar mu-own-address "djcb" "regexp matching my own address") - -;;; internal stuff -(defvar mu-parent-buffer nil "the parent buffer for a -buffer (buffer-local), i.e., the buffer we'll return to when this -buffer is killed") - - -(defun mu-binary-version () - "get the version of the mu binary" - (let ((cmd (concat mu-binary - " --version | head -1 | sed 's/.*version //'"))) - (substring (shell-command-to-string cmd) 0 -1))) - -(defun mu-inspect (path) - "inspect message in a guile environment" - (let ((cmd (concat mu-muile-binary " --msg='" path "'"))) - (ansi-term cmd "*mu-inspect"))) - -;; (defalias mu-find mu-headers-find) -;; (defalias mu-display mu-message-display) - -(defun mu-str (str) - "return STR propertized as a mu string (for info, warnings -etc.)" - (propertize str 'face 'mu-face 'intangible t)) - -(setq mu-headers-fields - '( - (:date . 20) - (:flags . 4) - (:from-or-to . 22) - (:size . 8) - (:subject . 40))) -(setq mu-headers-date-format "%x %X") - -(setq mu-header-fields - '( :from - :to - :subject - :date - :path)) - -(setq mu-own-address-regexp "djcb\\|diggler\\|bulkmeel") - -(defvar mu-maildir nil "our maildir") -(defvar mu-folder nil "our list of special folders for jumping, -moving") - - -(defvar mu-maildir nil "location of your maildir, typically ~/Maildir") -(defvar mu-inbox-folder nil "location of your inbox folder") -(defvar mu-outbox-folder nil "location of your outbox folder") -(defvar mu-sent-folder nil "location of your sent folder") -(defvar mu-trash-folder nil "location of your trash-folder folder") - -(setq - mu-maildir "/home/djcb/Maildir" - mu-inbox-folder "/inbox" - mu-outbox-folder "/outbox" - mu-sent-folder "/sent" - mu-trash-folder "/trash") - -(defvar mu-quick-folders nil) - -(setq mu-quick-folders - '("/archive" "/bulkarchive" "/todo")) - -(defun mu-ask-maildir (prompt &optional fullpath) - "ask user with PROMPT for a maildir name, if fullpath is -non-nill, return the fulpath (ie, mu-maildir prepended to the -maildir" - (interactive) - (let* - ((showfolders - (delete-dups - (append (list mu-inbox-folder mu-sent-folder) mu-quick-folders))) - (chosen (ido-completing-read prompt showfolders))) - (concat (if fullpath mu-maildir "") chosen))) - -(defun mu-ask-key (prompt) - "Get a char from user, only accepting characters marked with [x] in prompt, -e.g. 'Reply to [a]ll or [s]ender only; returns the character chosen" - (let ((match 0) (kars '())) - (while match - (setq match (string-match "\\[\\(.\\)\\]" prompt match)) - (when match - (setq kars (cons (match-string 1 prompt) kars)) - (setq match (+ 1 match)))) - (let ((kar) - (prompt (replace-regexp-in-string - "\\[\\(.\\)\\]" - (lambda(s) - (concat "[" (propertize (substring s 1 -1) 'face 'highlight) "]")) - prompt))) - (while (not kar) - (setq kar (read-char-exclusive prompt)) - (unless (member (string kar) kars) - (setq kar nil))) - kar))) - - -;; both in mu-find.el and mu-view.el we have the path as a text property; in the -;; latter case we could have use a buffer-local variable, but using a -;; text-property makes this function work for both -(defun mu-get-path () - "get the path (a string) of the message at point or nil if it -is not found; this works both for the header list and when -viewing a message" - (let ((path (get-text-property (point) 'path))) - (unless path (message "No message at point")) - path)) - - -;; The message sexp looks something like: -;; ( -;; :from (("Donald Duck" . "donald@example.com")) -;; :to (("Mickey Mouse" . "mickey@example.com")) -;; :subject "Wicked stuff" -;; :date (20023 26572 0) -;; :size 15165 -;; :msgid "foobar32423847ef23@pluto.net" -;; :path "/home/mickey/Maildir/inbox/cur/1312254065_3.32282.pluto,4cd5bd4e9:2," -;; :priority high -;; :flags (new unread) -;; :body-txt " " -;; ) -(defun mu-get-message (path) - "use 'mu view --format=sexp' to get the message at PATH in the -form of an s-expression; parse this s-expression and return the -Lisp data as a plist. Returns nil in case of error" - (if (not (file-readable-p path)) - (progn (message "Message is not readable") nil) - (let* ((cmd (concat mu-binary " view --format=sexp " path)) - (str (shell-command-to-string cmd)) - (msglst (read-from-string str))) - (if msglst - (car msglst) - (progn (message "Failed to parse message") nil))))) - - -(defun mu-quit-buffer () - "kill this buffer, and switch to it's parentbuf if it is alive" - (interactive) - (let ((parentbuf mu-parent-buffer)) - (kill-buffer) - (when (and parentbuf (buffer-live-p parentbuf)) - (switch-to-buffer parentbuf)))) - -(defun mu-get-new-buffer (bufname) - "return a new buffer BUFNAME; if such already exists, kill the -old one first" - (when (get-buffer bufname) - (kill-buffer bufname)) - (get-buffer-create bufname)) - -(defun mu-log (frm &rest args) - (with-current-buffer (get-buffer-create "*mu-log*") - (goto-char (point-max)) - (insert (apply 'format - (concat - (format-time-string "%x %X " (current-time)) - frm "\n") args)))) - - -(provide 'mu-common) diff --git a/emacs/mu-headers.el b/emacs/mu-headers.el deleted file mode 100644 index 7b890ee4..00000000 --- a/emacs/mu-headers.el +++ /dev/null @@ -1,464 +0,0 @@ -;;; mu-headers.el -- use `mu' from emacs -;; Copyright (C) 2011 Dirk-Jan C. Binnema - -;; Author: Dirk-Jan C. Binnema -;; Maintainer: Dirk-Jan C. Binnema -;; Keywords: email -;; Version: 0.0 - -;; This file is not part of GNU Emacs. -;; -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;;; Code: - -(require 'mu-common) - - -;;; mu-headers has functions for displaying/manipulating a list of headers (ie., -;;; one line descriptions of an e-mail message), based on the output of 'mu -;;; find'. - -;; data is stored like the following: for each header-line, we take the (point) -;; at beginning-of-line (bol) and use that as the key in the mu-headers-hash -;; hash, which does -;; -;; point-of-bol -> path -;; -;; then, marks are stored in a seperate hash 'mu-headers-marks-hash, using -;; -;; point-of-bol -> (src . target) -;; -;; and note both 'delete' (target=/dev/null), trash (target=trash-folder), and -;; move can be expressed by that -;; -;; after the marks have been 'executed', the lines will be marked a *invisible* -;; instead of deleting them; that way, the 'point-of-bol' stays valid. - -(defvar mu-headers-hash nil "internal: buffer-local hash table -which maps bol->path") -(defvar mu-headers-marks-hash nil "internal: buffer-local hash table -which maps bol->(src . target) for marked lines") - -(defun mu-headers-set-path (path) - "map the bol of the current header to a path" - (puthash (line-beginning-position 1) path mu-headers-hash)) - -(defun mu-headers-get-path () - "get the path for the header at point" - (gethash (line-beginning-position 1) mu-headers-hash)) - -(defvar mu-headers-fields - '( (:date . 25) - (:from-or-to . 22) - (:subject . 40)) - "a list of fields and their widths") - -(defvar mu-headers-sort-field "date" - "shortcut of the field to sort on (see mu-headers (1))") -(defvar mu-headers-sort-descending nil - "whether to sort in descending order") - -;; internal stuff -(defconst mu-headers-buffer-name " *mu-headers*" "name of the mu -results buffer; name should start with a space") - -(defvar mu-headers-process nil "the possibly running find process") - -(defconst mu-eom "\n;;eom\n" "marker for the end of message in -the mu find output") - -(defvar mu-headers-expression nil - "search expression for the current find buffer") - -(defvar mu-buf "" "internal: buffer for results data") -(defun mu-headers-process-filter (proc str) - "process-filter for the 'mu find --format=sexp output; it - accumulates the strings into valid sexps by checking of the - ';;eom' end-of-msg marker, and then evaluating them" - (when (buffer-live-p (process-buffer proc)) - (with-current-buffer (process-buffer proc) - (save-excursion - (setq mu-buf (concat mu-buf str)) - (let ((eom (string-match mu-eom mu-buf))) - (while (numberp eom) - (let* ((msg (car (read-from-string (substring mu-buf 0 eom)))) - (inhibit-read-only t)) - (goto-char (point-max)) - (mu-headers-set-path (plist-get msg :path)) - (save-match-data (insert (mu-headers-header msg) ?\n))) - (setq mu-buf (substring mu-buf (match-end 0))) - (setq eom (string-match mu-eom mu-buf)))))))) - -(defun mu-headers-process-sentinel (proc msg) - "Check the mu-headers process upon completion" - (when (buffer-live-p (process-buffer proc)) - (with-current-buffer (process-buffer proc) - (let ((status (process-status proc)) - (exit-status (process-exit-status proc))) - (if (memq status '(exit signal)) - (let ((inhibit-read-only t) - (text - (cond - ((eq status 'signal) - "Search process killed (results incomplete)") - ((eq status 'exit) - (cond - ((= 0 exit-status) "End of search results") - ((= 2 exit-status) "No matches found") - ((= 4 exit-status) "Database problem; try running 'mu index'") - (t (format "Some error occured; mu-headers returned %d" - exit-status)))) - (t "Unknown status")))) ;; shouldn't happen - (save-excursion - (goto-char (point-max)) - (insert (mu-str text))))))))) - - -;; Note, the 'mu find --format=sexp' sexp is almost the same as the ones that -;; 'mu view --format=sexp' produces (see mu-get-message), with the difference -;; that former may give more than one result, and that mu-headers output comes -;; from the database rather than file, and does _not_ contain the message body -(defun mu-headers-search (expr) - "search in the mu database" - (interactive "s[mu] search for: ") - (let* ((buf (mu-get-new-buffer mu-headers-buffer-name)) - (dummy-arg "--fields=\"dummy\"") ;; ignored - (proc (start-process mu-headers-buffer-name buf - mu-binary - "find" - (if mu-home - (concat "--muhome=" mu-home) dummy-arg) - (if mu-headers-sort-field - (concat "--sortfield=" mu-headers-sort-field) dummy-arg) - (if mu-headers-sort-descending "--descending" dummy-arg) - "--format=sexp" - "--quiet" - expr))) - (mu-log "search: '%s'" expr) - (switch-to-buffer buf) - (mu-headers-mode) - - (setq - mu-buf "" ;; if the last query went wrong... - mu-headers-expression expr - mu-headers-process proc - - mu-headers-hash (make-hash-table :size 256 :rehash-size 2) - mu-headers-marks-hash (make-hash-table :size 16 :rehash-size 2)) - - (set-process-filter proc 'mu-headers-process-filter) - (set-process-sentinel proc 'mu-headers-process-sentinel))) - -(defun mu-headers-field-contact (lst width face) - "display a list of contacts, truncated for fitting in WIDTH" - (if lst - (let* ((len (length lst)) - (str (if (= len 0) "" - ;; try name -> email -> ? - (or (car(car lst)) (cdr(car lst)) "?"))) - (others (if (> len 1) (mu-str (format " [+%d]" (- len 1))) ""))) - (truncate-string-to-width - (concat(propertize (truncate-string-to-width str - (- width (length others)) 0 ?\s "...") 'face face) others) - width 0 ?\s)) - (make-string width ?\s))) - - -(defun mu-headers-field-from-or-to (fromlst tolst width from-face to-face) - "return a propertized string for FROM unless TO matches - mu-own-address, in which case it returns TO, prefixed with To:" - (if (and fromlst tolst) - (let ((fromaddr (cdr(car fromlst)))) - (if (and fromaddr (string-match mu-own-address fromaddr)) - (concat (mu-str "To ") (mu-headers-field-contact tolst (- width 3) to-face)) - (mu-headers-field-contact fromlst width from-face))) - (make-string width ?\s))) - -(defun mu-headers-field-size (size width face) - "return a string for SIZE of WIDTH with FACE" - (let* ((str - (cond - ((>= size 1000000) (format "%2.1fM" (/ size 1000000.0))) - ((and (>= size 1000) (< size 1000000)) (format "%2.1fK" (/ size 1000.0))) - ((< size 1000) (format "%d" size))))) - (propertize (truncate-string-to-width str width 0 ?\s) 'face face))) - -(defun mu-headers-field-str (str width face) - "print a STR, at WIDTH (truncate or ' '-pad) with FACE" - (let ((str (if str str ""))) - (propertize (truncate-string-to-width str width 0 ?\s t) 'face face))) - -(defun mu-headers-field-flags (flags width face) - (let ((str - (mapconcat - (lambda(flag) - (let ((flagname (symbol-name flag))) - (cond - ((string= flagname "unread") "U") - ((string= flagname "seen") "S") - ((string= flagname "replied") "R") - ((string= flagname "attach") "a") - ((string= flagname "encrypted") "x") - ((string= flagname "signed") "s")))) flags ""))) - (propertize (truncate-string-to-width str width 0 ?\s) 'face face))) - -(defun mu-headers-field (msg fieldinfo) - "determine a field based on FIELDINFO in the header for MSG" - (let* ((field (car fieldinfo)) - (width (cdr fieldinfo)) - (val (plist-get msg field)) ;; note: header-field maps msg-field in - (str (case field ;; most cases.. - (:date (mu-headers-field-str (format-time-string mu-date-format-short - val) width 'mu-date-face)) - (:from (mu-headers-field-contact val width 'mu-from-face)) - (:to (mu-headers-field-contact val width 'mu-to-face)) - (:cc (mu-headers-field-contact val width 'mu-cc-face)) - (:bcc (mu-headers-field-contact val width 'mu-bcc-face)) - (:flags (mu-headers-field-flags val width 'mu-flag-face)) - (:size (mu-headers-field-size val width 'mu-size-face)) - (:subject (mu-headers-field-str val width 'mu-subject-face)) - (:from-or-to ;; this one is special - (mu-headers-field-from-or-to (plist-get msg :from) - (plist-get msg :to) width 'mu-from-face 'mu-to-face))))) - str)) - -(defun mu-headers-header (msg) - "convert a message s-expression into a header for display, and -set text property 'path" - (concat " " - (mapconcat - (lambda (fieldinfo) - (mu-headers-field msg fieldinfo)) mu-headers-fields " "))) - - -(defun mu-headers-mode () - "major mode for displaying search results" - (interactive) - (kill-all-local-variables) - (use-local-map mu-headers-mode-map) - - (make-local-variable 'mu-buf) - (make-local-variable 'mu-parent-buffer) - (make-local-variable 'mu-headers-expression) - (make-local-variable 'mu-headers-process) - (make-local-variable 'mu-headers-hash) - (make-local-variable 'mu-headers-marks-hash) - - (setq - major-mode 'mu-headers-mode mode-name "*headers*" - mu-buf "" - truncate-lines t buffer-read-only t - overwrite-mode 'overwrite-mode-binary)) - -(defvar mu-headers-mode-map - (let ((map (make-sparse-keymap))) - - (define-key map "s" 'mu-headers-search) - (define-key map "q" 'mu-quit-buffer) - (define-key map "s" 'mu-headers-change-sort) - (define-key map "g" 'mu-headers-refresh) - - ;; navigation - (define-key map "n" 'mu-headers-next) - (define-key map "p" 'mu-headers-previous) - (define-key map "j" 'mu-headers-jump-to-maildir) - - ;; marking/unmarking/executing - (define-key map "m" 'mu-headers-mark-for-move) - (define-key map "d" 'mu-headers-mark-for-trash) - (define-key map "D" 'mu-headers-mark-for-deletion) - (define-key map "u" 'mu-headers-unmark) - (define-key map "U" 'mu-headers-unmark-all) - (define-key map "x" 'mu-headers-marked-execute) - - ;; message composition - (define-key map "r" 'mu-reply) - (define-key map "f" 'mu-forward) - (define-key map (kbd "RET") 'mu-headers-view) - map) - "Keymap for \"mu-headers\" buffers.") -(fset 'mu-headers-mode-map mu-headers-mode-map) - -(defun mu-headers-view () - "display the message at the current line" - (interactive) - (let ((path (mu-headers-get-path))) - (when path (mu-view path (current-buffer))))) - -(defun mu-headers-next () - "go to the next line; t if it worked, nil otherwise" - (interactive) - (if (or (/= 0 (forward-line 1)) (not (mu-headers-get-path))) - (progn (message "No message after this one") nil) - t)) - -(defun mu-headers-prev () - "go to the next line; t if it worked, nil otherwise" - (interactive) - (if (/= 0 (forward-line -1)) - (progn (message "No message before this one") nil) - t)) - -(defun mu-headers-jump-to-maildir () - "show the messages in one of the standard folders" - (interactive) - (let ((fld (mu-ask-maildir "Jump to maildir: "))) - (mu-headers-search (concat "maildir:" fld)))) - -(defun mu-headers-refresh () - "re-run the query for the current search expression, but only -if the search process is not already running" - (interactive) - (message "REFRESH %s" mu-headers-expression) - (if (and mu-headers-process (eq (process-status mu-headers-process) 'run)) - (message "Can't refresh while running") - (when mu-headers-expression (mu-headers mu-headers-expression)))) - -;; create a new query based on the old one, but with a changed sort order - -(defun mu-headers-change-sort-order (fieldchar) - "change the sortfield to FIELDCHAR" - (interactive"cField to sort by ('d', 's', etc.; see mu-headers(1)):\n") - (let - ((field - (case fieldchar - (?b "bcc") - (?c "cc") - (?d "date") - (?f "from") - (?i "msgid") - (?m "maildir") - (?p "prio") - (?s "subject") - (?t "to") - (?z "size")))) - (if field - (setq mu-headers-sort-field field) - (message "Invalid sort-field; use one of bcdfimpstz (see mu-headers(1)")) - field)) - -(defun mu-headers-change-sort-direction (dirchar) - "change the sort direction, either [a]scending or [d]escending" - (interactive - "cSorting direction ([a]scending or [d]escending):") - (cond - (?d (setq mu-headers-sort-descending t) t) - (?a (setq mu-headers-sort-descending nil) t) - (t (message - "Invalid sort-direction; choose either [a]scending or [d]escending") nil))) - -(defun mu-headers-change-sort () - "change sort field and direction" - (interactive) - (and (call-interactively 'mu-headers-change-sort-order) - (call-interactively 'mu-headers-change-sort-direction))) - -(defun mu-headers-add-marked (src &optional dst) - (let ((bol (line-beginning-position 1))) - (if (gethash bol mu-headers-marks-hash) - (progn (message "Message is already marked") nil) - (progn (puthash bol (cons src dst) mu-headers-marks-hash) t)))) - -(defun mu-headers-remove-marked () - (let ((bol (line-beginning-position 1))) - (if (not (gethash bol mu-headers-marks-hash)) - (progn (message "Message is not marked") nil) - (progn (remhash bol mu-headers-marks-hash) t)))) - -(defun mu-headers-set-marker (kar) - "set the marker at the beginning of this line" - (beginning-of-line 1) - (let ((inhibit-read-only t)) - (delete-char 2) - (insert (if kar kar " ") " "))) - -(defun mu-headers-mark (action) - "mark the current msg for something: move, delete, trash, unmark" - (let ((target) (src (mu-headers-get-path))) - (when src - (case action - (move - (when (mu-headers-add-marked src - (mu-ask-maildir "Target maildir: " t)) - (mu-headers-set-marker ?m))) - (trash - (when (mu-headers-add-marked src - (concat mu-maildir mu-trash-folder)) - (mu-headers-set-marker ?d))) - (delete - (when (mu-headers-add-marked src "/dev/null") - (mu-headers-set-marker ?D))) - (unmark - (when (mu-headers-remove-marked) - (mu-headers-set-marker nil))) - (unmark-all - (when (y-or-n-p (format "Sure you want to remove all (%d) marks? " - (hash-table-count mu-headers-marks-hash))) - (save-excursion - (maphash (lambda (k v) (goto-char k) (mu-headers-mark 'unmark)) - mu-headers-marks-hash))) - (t (message "Unsupported mark type")))) - (move-beginning-of-line 2)))) - -(defun mu-headers-marks-execute () - "execute the actions for all marked messages" - (interactive) - (let ((n-marked (hash-table-count mu-headers-marks-hash))) - (if (= 0 n-marked) - (message "No marked messages") - (when (y-or-n-p - (format "Execute actions for %d marked message(s)? " n-marked)) - (save-excursion - (maphash - (lambda(bol v) - (let ((src (car v)) (target (cdr v)) (inhibit-read-only t)) - (when (mu-message-move src target) - (goto-char bol) - (mu-headers-remove-marked) - (put-text-property (line-beginning-position 1) - (line-beginning-position 2) - 'invisible t)))) ;; when it succeedes, hide msg..) - mu-headers-marks-hash)) - (message "Done") -)))) - -(defun mu-headers-mark-for-move () (interactive) (mu-headers-mark 'move)) -(defun mu-headers-mark-for-trash () (interactive) (mu-headers-mark 'trash)) -(defun mu-headers-mark-for-delete () (interactive) (mu-headers-mark 'delete)) -(defun mu-headers-mark-for-deletion () (interactive) (mu-headers-mark 'delete)) -(defun mu-headers-unmark () (interactive) (mu-headers-mark 'unmark)) -(defun mu-headers-unmark-all () (interactive) (mu-headers-mark 'unmark-all)) - -(defun mu-headers-reply () - "Reply to the message at point" - (interactive) - (let ((path (mu-headers-get-path))) - (if path - (mu-message-reply path) - (message "No message at point")))) - -(defun mu-headers-forward () - "Reply to the message at point" - (interactive) - (let ((path (mu-headers-get-path))) - (if path - (mu-message-forward path) - (message "No message at point")))) - - -(provide 'mu-headers) - diff --git a/emacs/mu-message.el b/emacs/mu-message.el deleted file mode 100644 index 54f273c3..00000000 --- a/emacs/mu-message.el +++ /dev/null @@ -1,165 +0,0 @@ -;;; mu-message.el -- use `mu' from emacs -;; Copyright (C) 2011 Dirk-Jan C. Binnema - -;; Author: Dirk-Jan C. Binnema -;; Maintainer: Dirk-Jan C. Binnema -;; Keywords: email -;; Version: 0.0 - -;; This file is not part of GNU Emacs. -;; -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;; mu-message contains code to generate a message for composing, replying or -;; forwarding - -;;; Code: -(require 'mu-common) - -(defvar mu-message-citation-prefix "> " - "string to prefix cited message parts with") - -(defvar mu-message-reply-prefix "Re:" - "string to prefix the subject of replied messages with") - -(defvar mu-message-forward-prefix "Fwd:" - "string to prefix the subject of forwarded messages with") - -(defun mu-message-user-agent () - (format "mu %s; emacs %s" (mu-binary-version) emacs-version)) - -(defun mu-message-attribution (msg) - "get an attribution line for a quoted message" - (format "On %s, %s wrote:\n" - (format-time-string mu-date-format-long (plist-get msg :date)) - (cdr (car (plist-get msg :from))))) - -(defun mu-message-cite (msg) - "cite an existing message" - (let ((body - (or (plist-get msg :body-txt) - (let ((html (plist-get msg :body-html))) - (when html - (with-temp-buffer (insert html) (html2text) (buffer-string)))) - ""))) - (replace-regexp-in-string "^" " > " body))) - -(defun mu-message-recipients-remove (lst email-to-remove) - "remove the recipient with EMAIL from the recipient list (of -form '( (\"A\" . \"a@example.com\") (\"B\" . \"B@example.com\"))" - (remove-if (lambda (name-email) - (string= email-to-remove (downcase (cdr name-email)))) - lst)) - -(defun mu-message-recipients-to-string (lst) - "convert a recipient list (of form '( (\"A\" -. \"a@example.com\") (\"B\" . \"B@example.com\") into a string -useful for from/to headers" - (message "recips: %S" lst) - (mapconcat - (lambda (recip) - (let ((name (car recip)) (email (cdr recip))) - (format "%s <%s>" (or name "") email))) lst ", ")) - -(defun mu-message-hidden-header (hdr val) - "return user-invisible header to the message (HDR: VAL\n)" - (propertize (format "%s: %s\n" hdr val) 'invisible t)) - -(defun mu-message-reply (path) - "create a reply to the message at PATH. After creation, switch -to the message editor" - (let* ((cmd (concat mu-binary " view --format=sexp " path)) - (str (shell-command-to-string cmd)) - (msg (car (read-from-string str))) - (buf (get-buffer-create - (generate-new-buffer-name "*mu-draft*"))) - (to-lst (mu-message-recipients-remove - (append (plist-get msg :from) (plist-get msg :to)) - user-mail-address)) - (cc-lst (mu-message-recipients-remove (plist-get msg :cc) - user-mail-address))) - - (with-current-buffer buf - (insert - (format "From: %s <%s>\n" user-full-name user-mail-address) - (mu-message-hidden-header "User-agent" (mu-message-user-agent)) - (if (boundp 'mail-reply-to) (insert (format "Reply-To: %s\n" - mail-reply-to)) "") - (format "To: %s\n" (if to-lst (mu-message-recipients-to-string to-lst) "")) - (if cc-lst - (format "Cc: %s\n" (mu-message-recipients-to-string cc-lst))) - "Subject: " mu-message-reply-prefix (plist-get msg :subject) "\n" - "--text follows this line--\n\n" - - (mu-message-attribution msg) - (mu-message-cite msg))) - - (switch-to-buffer buf) - (message-mode) - (message-goto-body))) - - -(defun mu-message-forward (path) - "create a forward to the message at PATH. After creation, switch -to the message editor" - (let* ((cmd (concat mu-binary " view --format=sexp " path)) - (str (shell-command-to-string cmd)) - (msg (car (read-from-string str))) - (buf (get-buffer-create - (generate-new-buffer-name "*mu-draft*")))) - - (with-current-buffer buf - (insert - (format "From: %s <%s>\n" user-full-name user-mail-address) - (mu-message-hidden-header "User-agent" (mu-message-user-agent)) - "To: \n" - "Subject: " mu-message-forward-prefix (plist-get msg :subject) "\n" - "--text follows this line--\n\n" - - (mu-message-attribution msg) - (mu-message-cite msg))) - - (switch-to-buffer buf) - (message-mode) - (message-goto-to))) - -(defun mu-message-move (src targetdir) - "move message at PATH using 'mu mv'; if targetdir is -'/dev/null', move immediately. Return t if succeeded, nil -otherwise" - (let* ((cmd (concat - mu-binary " mv --printtarget " - (shell-quote-argument src) " " - (shell-quote-argument targetdir))) - (fulltarget (shell-command-to-string cmd))) - (mu-log cmd) - - (mu-log - (if fulltarget (concat "Message has been moved to " fulltarget) - "Message moving failed")) - ;; now, if saving worked, anynchronously try to update the database - (when fulltarget - (mu-log "Removing from database: %s" src) - (start-process " *mu-remove*" nil mu-binary "remove" src) - - (if (string= targetdir "/dev/null") - t - (mu-log "Adding to database: %s" fulltarget) - (start-process " *mu-add*" nil mu-binary "add" fulltarget) t)))) - -;; note, we don't check the result of the db output - -(provide 'mu-message) diff --git a/emacs/mu-view.el b/emacs/mu-view.el deleted file mode 100644 index 483d74f1..00000000 --- a/emacs/mu-view.el +++ /dev/null @@ -1,221 +0,0 @@ -;;; mu-view.el -- use `mu' from emacs -;; Copyright (C) 2011 Dirk-Jan C. Binnema - -;; Author: Dirk-Jan C. Binnema -;; Maintainer: Dirk-Jan C. Binnema -;; Keywords: email -;; Version: 0.0 - -;; This file is not part of GNU Emacs. -;; -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See theq -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;; mu message has functions to display a single message - -;;; Code: - -(require 'mu-common) - -(defvar mu-view-header-fields - '( :from - :to - :subject - :date - :attachments - :path) - "list of header fields to display in the message view") - -(defconst mu-view-buffer-name " *mu-view*") -(defvar mu-view-headers-buffer nil "the headers buffer (if any) -from which this buffer was invoked (buffer local)") - -(defun mu-view-header (field val val-face) - "get a header string (like 'Subject: foo')" - (when val - (concat (propertize field 'face 'mu-header-face) ": " - (propertize val 'face val-face) "\n"))) - -(defun mu-view-header-contact (field lst face) - (when lst - (let* ((header (concat (propertize field 'face 'mu-header-face) ": ")) - (val (mapconcat (lambda(c) - (propertize (or (car c) (cdr c) "?") 'face face)) - lst ","))) - (concat header val "\n")))) - - -(defun mu-view-header-contact (field lst face) - (when lst - (let* ((header (concat (propertize field 'face 'mu-header-face) ": ")) - (val (mapconcat (lambda(c) - (propertize (or (car c) (cdr c) "?") 'face face)) - lst ", "))) - (concat header val "\n")))) - -(defun mu-view-header-attachments (field lst face) - (when lst - (let* ((header (concat (propertize field 'face 'mu-header-face) ": ")) - (val (mapconcat - (lambda(att) - (let ((idx (nth 0 att)) (fname (nth 1 att)) (ctype (nth 2 att))) - (propertize fname 'face face))) - lst ", "))) - (concat header val "\n")))) - -(defun mu-view-body (msg face) - "view the body; try text first, if that does not work, try html" - (cond - ((plist-get msg :body-txt) (propertize (plist-get msg :body-txt) 'face face)) - ((plist-get msg :body-html) - (propertize - (with-temp-buffer - (insert (plist-get msg :body-html)) - (html2text) - (buffer-string)) 'face face)) - (t ""))) - -(defun mu-view-message (path) - "display the email message at PATH" - (let ((msg (mu-get-message path))) - (when msg - (concat - (mapconcat - (lambda (field) - (case field - (:from (mu-view-header-contact "From" - (plist-get msg :from) 'mu-from-face)) - (:to - (mu-view-header-contact "To" (plist-get msg :to) 'mu-to-face)) - (:cc - (mu-view-header-contact "Cc" (plist-get msg :cc) 'mu-to-face)) - (:bcc - (mu-view-header-contact "Bcc" (plist-get msg :bcc) 'mu-to-face)) - (:subject - (mu-view-header "Subject" (plist-get msg :subject) 'mu-subject-face)) - (:path - (mu-view-header "Path" (plist-get msg :path) 'mu-path-face)) - (:date - (mu-view-header "Date" - (format-time-string mu-date-format-long - (plist-get msg :date)) 'mu-date-face)) - (:attachments - (mu-view-header-attachments "Attachments" (plist-get msg :attachments) - 'mu-path-face) - ))) - mu-view-header-fields "") - "\n" - (mu-view-body msg 'mu-body-face) - )))) - -;; note: mu-view sets path as a text-property ('path) for the whole buffer, just -;; like mu-headers does it per-header -(defun mu-view (path parentbuf) - "display message at PATH in a new buffer; note that the action -of viewing a message may cause it to be moved/renamed; this -function returns the resulting name. PARENTBUF refers to the -buffer who invoked this view; this allows us to return there when -we quit from this view. Also, if PARENTBUF is a find buffer (ie., -has mu-headers-mode as its major mode), this allows various -commands (navigation, marking etc.) to be applied to this -buffer." - (let ((str (mu-view-message path)) - (buf (mu-get-new-buffer mu-view-buffer-name))) - (when str - (switch-to-buffer buf) - (insert str)) - (mu-view-mode) - - (setq ;; these are buffer-local - mu-parent-buffer parentbuf - mu-view-headers-buffer parentbuf - mu-path path) - - (goto-char (point-min)))) - -(defvar mu-view-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "q" 'mu-quit-buffer) - (define-key map "s" 'mu-headers) - (define-key map "f" 'mu-forward) - (define-key map "r" 'mu-reply) - - ;; navigation between messages - (define-key map "n" 'mu-view-next) - (define-key map "p" 'mu-view-prev) - - ;; marking/unmarking - (define-key map "d" '(lambda (mu-view-mark 'trash))) - (define-key map "D" '(lambda (mu-view-mark 'delete))) - (define-key map "m" '(lambda (mu-view-mark 'move))) - (define-key map "u" '(lambda (mu-view-mark 'unmark))) - (define-key map "x" 'mu-view-marked-execute) - - map) - "Keymap for \"mu-view\" buffers.") -(fset 'mu-view-mode-map mu-view-mode-map) - -(defun mu-view-mode () - "major mode for viewing an e-mail message" - (interactive) - (kill-all-local-variables) - (use-local-map mu-view-mode-map) - - (make-local-variable 'mu-parent-buffer) - (make-local-variable 'mu-headers-buffer) - (make-local-variable 'mu-path) - - (setq major-mode 'mu-view-mode mode-name "*mu-view*") - (setq truncate-lines t buffer-read-only t)) - -(defmacro with-current-headers-buffer (&rest body) - "Execute the forms in BODY with BUFFER-OR-NAME temporarily current. -BUFFER-OR-NAME must be a buffer or the name of an existing buffer. -The value returned is the value of the last form in BODY. See -also `with-temp-buffer'." - (declare (indent 1) (debug t)) - `(if (and mu-view-headers-buffer (buffer-live-p mu-view-headers-buffer)) - (save-current-buffer - (set-buffer mu-view-headers-buffer) - ,@body) - (message "No headers-buffer connected"))) - -(defun mu-view-next () - "move to the next message" - (interactive) - (with-current-headers-buffer - (when (mu-headers-next) - (mu-view (mu-headers-get-path) (current-buffer))))) - -(defun mu-view-prev () - "move to the previous message" - (interactive) - (with-current-headers-buffer - (when (mu-headers-prev) - (mu-view (mu-headers-get-path) (current-buffer))))) - -(defun mu-view-mark (mark) - "mark for MARK" - (interactive) - (with-current-headers-buffer (mu-headers-mark mark))) - -;; we don't allow executing marks from the view buffer, to protect user from -;; accidentally deleting stuff... -(defun mu-view-marked-execute () - "give user a warning" - (interactive) - (message "Please go back to the headers list to execute your marks")) - -(provide 'mu-view) diff --git a/emacs/mu.el b/emacs/mu.el deleted file mode 100644 index b220ebd7..00000000 --- a/emacs/mu.el +++ /dev/null @@ -1,68 +0,0 @@ -;;; mu.el -- use `mu' from emacs -;; Copyright (C) 2011 Dirk-Jan C. Binnema - -;; Author: Dirk-Jan C. Binnema -;; Maintainer: Dirk-Jan C. Binnema -;; Keywords: email -;; Version: 0.0 - -;; This file is not part of GNU Emacs. -;; -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;;; Code: -(require 'mu-view) -(require 'mu-headers) -(require 'mu-message) - -(define-key mu-headers-mode-map "q" 'mu-quit-buffer) -(define-key mu-headers-mode-map "f" 'mu-headers) -(define-key mu-headers-mode-map (kbd "") 'mu-headers-prev) -(define-key mu-headers-mode-map (kbd "") 'mu-headers-next) -(define-key mu-headers-mode-map (kbd "RET") 'mu-headers-view) -(define-key mu-headers-mode-map "n" 'mu-headers-next) -(define-key mu-headers-mode-map "p" 'mu-headers-prev) -(define-key mu-headers-mode-map "o" 'mu-headers-change-sort) -(define-key mu-headers-mode-map "g" 'mu-headers-refresh) -(define-key mu-headers-mode-map "m" 'mu-headers-mark-for-move) -(define-key mu-headers-mode-map "d" 'mu-headers-mark-for-trash) -(define-key mu-headers-mode-map "D" 'mu-headers-mark-for-deletion) -(define-key mu-headers-mode-map "u" 'mu-headers-unmark) -(define-key mu-headers-mode-map "U" 'mu-headers-unmark-all) -(define-key mu-headers-mode-map "r" 'mu-headers-reply) -(define-key mu-headers-mode-map "f" 'mu-headers-forward) -(define-key mu-headers-mode-map "x" 'mu-headers-marks-execute) - - -(define-key mu-view-mode-map "q" 'mu-quit-buffer) -(define-key mu-view-mode-map "f" 'mu-view-find) -(define-key mu-view-mode-map "n" 'mu-view-next) -(define-key mu-view-mode-map "p" 'mu-view-prev) -(define-key mu-view-mode-map "r" 'mu-reply) -(define-key mu-view-mode-map "f" 'mu-forward) -(define-key mu-view-mode-map "x" 'mu-execute) -(define-key mu-view-mode-map "m" 'mu-view-mark-for-move) -(define-key mu-view-mode-map "d" 'mu-view-mark-for-trash) -(define-key mu-view-mode-map "D" 'mu-view-mark-for-deletion) -(define-key mu-view-mode-map "u" 'mu-view-unmark) -(define-key mu-view-mode-map "U" 'mu-view-unmark-all) -(define-key mu-view-mode-map "r" 'mu-view-reply) -(define-key mu-view-mode-map "f" 'mu-view-forward) -(define-key mu-view-mode-map "x" 'mu-view-marked-execute) - - -(provide 'mu) - diff --git a/emacs/Makefile b/toys/mua/Makefile similarity index 100% rename from emacs/Makefile rename to toys/mua/Makefile diff --git a/toys/mua/TODO b/toys/mua/TODO new file mode 100644 index 00000000..fd6444e2 --- /dev/null +++ b/toys/mua/TODO @@ -0,0 +1,28 @@ +* TODO + + [ ] message un-new in find/view + [ ] set 'Replied' flag on source when message is replied + [ ] update database after changes (CHECK) + [ ] save message to draft, sent items + [ ] attachment handling (open, play) in view + + [ ] abstract away mu/binary, shell-command-to-string + [ ] make flag handling a bit more lispy + + [ ] threads support + [ ] expandable recipients list in view + [ ] additive font props in mu find + [ ] fix headers/view interaction + + [ ] region commands + [ ] menu + [ ] mua-dashboard + + +# Local Variables: +# mode: org; org-startup-folded: nil +# End: + + + + diff --git a/toys/mua/mua-common.el b/toys/mua/mua-common.el new file mode 100644 index 00000000..9317b8a5 --- /dev/null +++ b/toys/mua/mua-common.el @@ -0,0 +1,94 @@ +;;; mua-common.el -- part of mua, the mu mail user agent +;; +;; Copyright (C) 2011 Dirk-Jan C. Binnema + +;; Author: Dirk-Jan C. Binnema +;; Maintainer: Dirk-Jan C. Binnema +;; Keywords: email +;; Version: 0.0 + +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; mua-common contains common utility functions for mua + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defconst mua/log-buffer-name "*mua-log*" "name of the logging buffer") + +(defun mua/warn (frm &rest args) + "warn user in echo-area, return nil" + (let ((str (apply 'format frm args))) + (message str) + nil)) + +(defun mua/log (frm &rest args) + "write something in the *mua-log* buffer - mainly useful for debugging" + (with-current-buffer (get-buffer-create mua/log-buffer-name) + (goto-char (point-max)) + (insert (apply 'format (concat (format-time-string "%x %X " (current-time)) + frm "\n") args)))) + +(defun mua/warn-and-log (frm &rest args) + "log and warn (ie., mua/warn + mua/log); return nil" + (apply 'mua/log frm args) + (apply 'mua/warn frm args) + nil) + +(defun mua/new-buffer (bufname) + "return a new buffer BUFNAME; if such already exists, kill the +old one first" + (when (get-buffer bufname) + (kill-buffer bufname)) + (get-buffer-create bufname)) + +(defun mua/message (frm &rest args) + "print a mua message at point" + (let ((str (apply 'format frm args)) (inhibit-read-only t)) + (insert (propertize str 'face 'italic)))) + +(defun mua/quit-buffer () + "kill this buffer, and switch to it's parentbuf if it is alive" + (interactive) + (let ((parentbuf mua/parent-buffer)) + (kill-buffer) + (when (and parentbuf (buffer-live-p parentbuf)) + (switch-to-buffer parentbuf)))) + +(defun mua/ask-maildir (prompt &optional fullpath) + "ask user with PROMPT for a maildir name, if fullpath is +non-nill, return the fulpath (ie, mu-maildir prepended to the +maildir" + (interactive) + (let* ((showfolders + (delete-dups + (append (list mua/inbox-folder mua/sent-folder) + mua/working-folders))) + (chosen (ido-completing-read prompt showfolders))) + (concat (if fullpath mua/maildir "") chosen))) + +(defun mua/mu-binary-version () + "Get the version of the mu binary." + (let ((cmd (concat mua/mu-binary + " --version | head -1 | sed 's/.*version //'"))) + (substring (shell-command-to-string cmd) 0 -1))) + + + +(provide 'mua-common) diff --git a/toys/mua/mua-hdrs.el b/toys/mua/mua-hdrs.el new file mode 100644 index 00000000..5bcff09e --- /dev/null +++ b/toys/mua/mua-hdrs.el @@ -0,0 +1,480 @@ +;;; mua-hdrs.el -- part of mua, the mu mail user agent +;; +;; Copyright (C) 2011 Dirk-Jan C. Binnema + +;; Author: Dirk-Jan C. Binnema +;; Maintainer: Dirk-Jan C. Binnema +;; Keywords: email +;; Version: 0.0 + +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; mu + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'mua-common) +(require 'mua-msg) + +;; note: these next two are *not* buffer-local, so they persist during a session +(defvar mua/hdrs-sortfield nil "field to sort headers by") +(defvar mua/hdrs-sort-descending nil "whether to sort in descending order") + +(defvar mua/header-fields + '( (:date . 25) + (:from-or-to . 22) + (:subject . 40)) + "a list of fields and their widths") + + +;; internal stuff +(defvar mua/buf "" "buffer for results data") +(defvar mua/last-expression "the last search expression") +(defvar mua/hdrs-process "the mu-find process") +(defvar mua/hdrs-hash nil "the bol->path hash") +(defvar mua/hdrs-marks-hash nil "the hash for marked messages") + +(defconst mua/eom "\n;;eom\n" "marker for the end of message in +the mu find output") +(defconst mua/hdrs-buffer-name "*mua-headers*" + "name of the mua headers buffer") + +(defun mua/hdrs-proc-filter (proc str) + "process-filter for the 'mu find --format=sexp output; it + accumulates the strings into valid sexps by checking of the + ';;eom' end-of-msg marker, and then evaluating them" + (let ((procbuf (process-buffer proc))) + (when (buffer-live-p procbuf) + (with-current-buffer procbuf + (save-excursion + (setq mua/buf (concat mua/buf str)) + (let ((eom (string-match mua/eom mua/buf))) + (while (numberp eom) + (let* ((msg (mua/msg-from-string(substring mua/buf 0 eom)))) + (save-match-data (mua/hdrs-append-message msg)) + (setq mua/buf (substring mua/buf (match-end 0))) + (setq eom (string-match mua/eom mua/buf)))))))))) + + +(defun mua/hdrs-proc-sentinel (proc msg) + "Check the process upon completion" + (let ((procbuf (process-buffer proc)) + (status (process-status proc)) + (exit-status (process-exit-status proc))) + (when (and (buffer-live-p procbuf) (memq status '(exit signal))) + (let ((msg + (case status + ('signal "Search process killed (results incomplete)") + ('exit + (case exit-status + (0 "End of search results") + (1 "mu find error") + (2 "No matches found") + (4 "Database problem; try running 'mu index'") + (t (format "Some error occured; mu find returned %d" + exit-status))))))) + (with-current-buffer procbuf + (save-excursion + (goto-char (point-max)) + (mua/message msg))) + + (unless (= exit-status 0) + (mua/log "mu find exit with %d" exit-status)))))) + +(defun mua/hdrs-search-execute (expr buf) + "search in the mu database; output the results in buffer BUF" + (let ((args `("find" "--format=sexp" ,expr))) + (when mua/mu-home + (add-to-list args (concat "--muhome=" mua/mu-home))) + (when mua/hdrs-sortfield + (add-to-list args (concat "--sortfield=" mua/hdrs-sortfield))) + (when mua/hdrs-sort-descending + (add-to-list args "--descending")) + (mua/log "Searching for %s with %S" expr args) + + ;; now, do it! + (let ((proc (apply 'start-process "*mua-headers*" buf mua/mu-binary args))) + (setq + mua/buf "" + mua/hdrs-process proc) + (set-process-filter proc 'mua/hdrs-proc-filter) + (set-process-sentinel proc 'mua/hdrs-proc-sentinel)))) + +;; Note, the 'mu find --format=sexp' sexp is almost the same as the ones that +;; 'mu view --format=sexp' produces (see mu-get-message), with the difference +;; that former may give more than one result, and that mu-headers output comes +;; from the database rather than file, and does _not_ contain the message body +(defun mua/hdrs-search (expr) + "search in the mu database" + (interactive "s[mu] search for: ") + (setq debug-on-error t) + + ;; kill running process if needed + (when (and mua/hdrs-process + (eq (process-status mua/hdrs-process) 'run)) + (kill-process mua/hdrs-process)) + + (let ((buf (mua/new-buffer mua/hdrs-buffer-name))) + (switch-to-buffer buf) + (mua/hdrs-mode) + (setq + mua/last-expression expr + mua/hdrs-hash (make-hash-table :size 256 :rehash-size 2) + mua/hdrs-marks-hash (make-hash-table :size 16 :rehash-size 2)) + (mua/log "searching for %S" expr) + (mua/hdrs-search-execute expr buf))) + + +(defun mua/hdrs-mode () + "major mode for displaying mua search results" + (interactive) + (kill-all-local-variables) + (use-local-map mua/hdrs-mode-map) + + (make-local-variable 'mua/buf) + (make-local-variable 'mua/last-expression) + (make-local-variable 'mua/hdrs-process) + (make-local-variable 'mua/hdrs-hash) + (make-local-variable 'mua/hdrs-marks-hash) + + (setq + major-mode 'mu-headers-mode mode-name "*headers*" + truncate-lines t buffer-read-only t + overwrite-mode 'overwrite-mode-binary)) + +(defun mua/hdrs-line (msg) + "return line describing a message (ie., a header line)" + (let + ((hdr + (mapconcat + (lambda(fieldpair) + (let ((field (car fieldpair)) (width (cdr fieldpair))) + (case field + (:subject (mua/hdrs-header msg :subject width)) + (:to (mua/hdrs-contact msg field width)) + (:from (mua/hdrs-contact msg field width)) + ;;(:from-or-to (mua/msg-header-header-from-or-to msg width 'mua/header-face)) + (:cc (mua/hdrs-contact msg field width)) + (:bcc (mua/hdrs-contact msg field width)) + (:date (mua/hdrs-date msg width)) + (:flags (mua/hdrs-flags msg width)) + (:size (mua/hdrs-size msg width)) + (t (error "Unsupported field: %S" field)) + ))) + mua/header-fields " "))) + hdr)) + +;; +;; Note: we maintain a hash table to remember what message-path corresponds to a +;; certain line in the buffer. (mua/hdrs-set-path, mua/hdrs-get-path) +;; +;; data is stored like the following: for each header-line, we +;; take the (point) at beginning-of-line (bol) and use that as the key in the +;; mu-headers-hash hash, which does +;; +;; point-of-bol -> path +;; + +(defun mua/hdrs-set-path (path) + "map the bol of the current header to a path" + (puthash (line-beginning-position 1) path mua/hdrs-hash)) + +(defun mua/hdrs-get-path () + "get the path for the header at point" + (gethash (line-beginning-position 1) mua/hdrs-hash)) + +(defun mua/hdrs-append-message (msg) + "append a message line to the buffer and register the message" + (let ((line (mua/hdrs-line msg)) (inhibit-read-only t)) + (save-excursion + (goto-char (point-max)) + (mua/hdrs-set-path (mua/msg-field msg :path)) + (insert " " line "\n")))) + + +;; Now follow a bunch of function to turn some message field in a +;; string for display + +(defun mua/hdrs-header (msg field width) + "get a string at WIDTH (truncate or ' '-pad) for display as a +header" + (let* ((str (mua/msg-field msg field)) (str (if str str ""))) + (propertize (truncate-string-to-width str width 0 ?\s t) + 'face 'mua/header-face))) + +(defun mua/hdrs-contact (msg field width) + "get display string for a list of contacts in a header, truncated for +fitting in WIDTH" + (unless (member field '(:to :from :bcc :cc)) + (error "Illegal type for contact")) + (let* ((lst (mua/msg-field msg field)) + (str (mapconcat + (lambda (ctc) + (let ((name (car ctc)) (email (cdr ctc))) + (or name email "?"))) lst ","))) + (propertize (truncate-string-to-width str width 0 ?\s t) + 'face 'mua/contacts-face))) + + +(defun mua/hdrs-size (msg width) + "return a string for size of MSG of WIDTH" + (let* ((size (mua/msg-field msg :size)) + ((str + (cond + ((>= size 1000000) (format "%2.1fM" (/ size 1000000.0))) + ((and (>= size 1000) (< size 1000000)) (format "%2.1fK" (/ size 1000.0))) + ((< size 1000) (format "%d" size))))) + (propertize (truncate-string-to-width str width 0 ?\s) + 'face 'mua/header-face)))) + + +(defun mua/hdrs-date (msg width) + "return a string for the date of MSG of WIDTH" + (let* ((date (mua/msg-field msg :date))) + (if date + (propertize (truncate-string-to-width (format-time-string "%x %X" date) + width 0 ?\s) 'face 'mua/date-face)))) + +(defun mua/hdrs-flags (msg width) + (let* ((flags (mua/msg-field msg :flags)) + (flagstr + (mapconcat + (lambda(flag) + (case flag + ('unread "U") + ('seen "S") + ('replied "R") + ('attach "a") + ('encrypted "x") + ('signed "s"))) flags ""))) + (propertize (truncate-string-to-width flagstr width 0 ?\s) + 'face 'mua/header-face))) + + +;; some keybinding / functions for basic navigation + +(defvar mua/hdrs-mode-map + (let ((map (make-sparse-keymap))) + + (define-key map "s" 'mua/hdrs-search) + (define-key map "q" 'mua/quit-buffer) + (define-key map "o" 'mua/hdrs-change-sort) + (define-key map "g" 'mua/hdrs-refresh) + + ;; navigation + (define-key map "n" 'mua/hdrs-next) + (define-key map "p" 'mua/hdrs-prev) + (define-key map "j" 'mua/hdrs-jump-to-maildir) + + ;; marking/unmarking/executing + (define-key map "m" (lambda()(interactive)(mua/hdrs-mark 'move))) + (define-key map "d" (lambda()(interactive)(mua/hdrs-mark 'trash))) + (define-key map "D" (lambda()(interactive)(mua/hdrs-mark 'delete))) + (define-key map "u" (lambda()(interactive)(mua/hdrs-mark 'unmark))) + (define-key map "U" (lambda()(interactive)(mua/hdrs-mark 'unmark-all))) + (define-key map "x" 'mua/hdrs-marks-execute) + + ;; message composition + (define-key map "r" 'mua/hdrs-reply) + (define-key map "f" 'mua/hdrs-forward) + (define-key map "c" 'mua/hdrs-compose) + + + (define-key map (kbd "RET") 'mua/hdrs-view) + map) + "Keymap for *mua-headers* buffers.") +(fset 'mua/hdrs-mode-map mua/hdrs-mode-map) + +(defun mua/hdrs-next () + "go to the next line; t if it worked, nil otherwise" + (interactive) ;; TODO: check if next line has path, if not, don't go there + (if (or (/= 0 (forward-line 1)) (not (mua/hdrs-get-path))) + (mua/warn "No message after this one") + (progn + (mua/log "At: %d [%S]" (point) (mua/hdrs-get-path)) t))) + + +(defun mua/hdrs-prev () + "go to the previous line; t if it worked, nil otherwise" + (interactive) + (if (or (/= 0 (forward-line -1)) (not (mua/hdrs-get-path))) + (mua/warn "No message before this one") + (progn + (mua/log "At: %d [%S]" (point) (mua/hdrs-get-path)) t))) + + +(defun mua/hdrs-view () + (interactive) + (let ((path (mua/hdrs-get-path))) + (if path + (mua/view path (current-buffer)) + (mua/warn "No message at point")))) + +(defun mua/hdrs-jump-to-maildir () + "Show the messages in one of the standard folders." + (interactive) + (let ((fld (mua/ask-maildir "Jump to maildir: "))) + (mua/hdrs-search (concat "maildir:" fld)))) + +(defun mua/hdrs-refresh () + "Re-run the query for the current search expression, but only +if the search process is not already running" + (interactive) + (when mua/last-expression (mua/hdrs-search mua/last-expression))) + + +;;; functions for sorting +(defun mua/hdrs-change-sort-order (fieldchar) + "Change the sortfield to FIELDCHAR." + (interactive "cField to sort by ('d', 's', etc.; see mu-headers(1)):\n") + (let ((field + (case fieldchar + (?b "bcc") + (?c "cc") + (?d "date") + (?f "from") + (?i "msgid") + (?m "maildir") + (?p "prio") + (?s "subject") + (?t "to") + (?z "size")))) + (if field + (setq mua/hdrs-sortfield field) + (mua/warn "Invalid sort-field; use one of bcdfimpstz (see mu-headers(1)")) + field)) + +(defun mua/hdrs-change-sort-direction (dirchar) + "Change the sort direction, either [a]scending or [d]escending." + (interactive) + (setq mua/hdrs-sort-descending + (y-or-n-p "Set sorting direction to descending(y) or ascending(n)"))) + + +(defun mua/hdrs-change-sort () + "Change thee sort field and direction." + (interactive) + (and (call-interactively 'mua/hdrs-change-sort-order) + (call-interactively 'mua/hdrs-change-sort-direction))) + + + +;;; functions for marking + +(defun mua/hdrs-add-marked (src &optional dst) + "Add the message at point to the markings hash" + (let ((bol (line-beginning-position 1))) + (if (gethash bol mua/hdrs-marks-hash) + (mua/warn "Message is already marked") + (progn (puthash bol (cons src dst) mua/hdrs-marks-hash) t)))) + +(defun mua/hdrs-remove-marked () + "Remove the message at point from the markings hash" + (let ((bol (line-beginning-position 1))) + (if (not (gethash bol mua/hdrs-marks-hash)) + (mua/warn "Message is not marked") + (progn (remhash bol mua/hdrs-marks-hash) t)))) + +(defun mua/hdrs-set-marker (kar) + "Set the marker at the beginning of this line." + (beginning-of-line 1) + (let ((inhibit-read-only t)) + (delete-char 2) + (insert (if kar (format "%c " kar) " ")))) + +(defun mua/hdrs-mark (action) + "Mark the message at point with one of the symbols: move, +delete, trash, unmark, unmark-all; the latter two are +pseudo-markings." + (let ((target) (src (mua/hdrs-get-path))) + (when src + (case action + (move + (when (mua/hdrs-add-marked src + (mua/ask-maildir "Target maildir: " t)) ;; t->return fullpath + (mua/hdrs-set-marker ?m))) + (trash + (when (mua/hdrs-add-marked src + (concat mua/maildir mua/trash-folder)) + (mua/hdrs-set-marker ?d))) + (delete + (when (mua/hdrs-add-marked src "/dev/null") + (mua/hdrs-set-marker ?D))) + (unmark + (when (mua/hdrs-remove-marked) + (mua/hdrs-set-marker nil))) + (unmark-all + (when (y-or-n-p (format "Sure you want to remove all (%d) marks? " + (hash-table-count mua/hdrs-marks-hash))) + (save-excursion + (maphash (lambda (k v) (goto-char k) (mua/hdrs-mark 'unmark)) + mua/hdrs-marks-hash)))) + (t (error "Unsupported mark type"))) + (move-beginning-of-line 2)))) + +(defun mua/hdrs-marks-execute () + "execute the actions for all marked messages" + (interactive) + (let ((n-marked (hash-table-count mua/hdrs-marks-hash))) + (if (= 0 n-marked) + (mua/warn "No marked messages") + (when (y-or-n-p + (format "Execute actions for %d marked message(s)? " n-marked)) + (save-excursion + (maphash + (lambda(bol v) + (let ((src (car v)) (target (cdr v)) (inhibit-read-only t)) + (when (mua/msg-move src target) + (goto-char bol) + (mua/hdrs-remove-marked) + (put-text-property (line-beginning-position 1) + (line-beginning-position 2) + 'invisible t)))) ;; when it succeedes, hide msg..) + mua/hdrs-marks-hash)))))) + + + +;; functions for creating new message -- reply, forward, and new +(defun mua/hdrs-reply () + "Reply to message at point." + (interactive) + (let* ((path (mua/hdrs-get-path)) + (msg (when path (mua/msg-from-path path)))) + (if msg + (mua/msg-compose (mua/msg-create-reply msg + (yes-or-no-p "Reply to all? "))) + (mua/warn "No message at point")))) + +(defun mua/hdrs-forward () + "Forward the message at point." + (interactive) + (let* ((path (mua/hdrs-get-path)) + (msg (when path (mua/msg-from-path path)))) + (if msg + (mua/msg-compose (mua/msg-create-forward msg)) + (mua/warn "No message at point")))) + +(defun mua/hdrs-compose () + "Create a new messge." + (interactive) + (mua/msg-compose (mua/msg-create-new))) + + +(provide 'mua-hdrs) diff --git a/toys/mua/mua-msg.el b/toys/mua/mua-msg.el new file mode 100644 index 00000000..975536d0 --- /dev/null +++ b/toys/mua/mua-msg.el @@ -0,0 +1,483 @@ +;;; mua-msg.el -- part of mua, the mu mail user agent +;; +;; Copyright (C) 2011 Dirk-Jan C. Binnema + +;; Author: Dirk-Jan C. Binnema +;; Maintainer: Dirk-Jan C. Binnema +;; Keywords: email +;; Version: 0.0 + +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; mua + +;;; Code: + +(eval-when-compile (require 'cl)) + +;; we use some stuff from gnus... +(require 'message) +(require 'mail-parse) + +(require 'html2text) +(require 'mua-common) + +(defun mua/msg-from-string (str) + "Get the plist describing an email message, from a string +contain a message sexp; a message sexp looks something like: The +message sexp looks something like: + \( + :from ((\"Donald Duck\" . \"donald@example.com\")) + :to ((\"Mickey Mouse\" . \"mickey@example.com\")) + :subject \"Wicked stuff\" + :date (20023 26572 0) + :size 15165 + :references (\"200208121222.g7CCMdb80690@msg.id\") + :in-reply-to \"200208121222.g7CCMdb80690@msg.id\" + :message-id \"foobar32423847ef23@pluto.net\" + :path \"/home/mickey/Maildir/inbox/cur/1312254065_3.32282.pluto,4cd5bd4e9:2,\" + :priority high + :flags (new unread) + :attachments ((2 \"hello.jpg\" \"image/jpeg\") (3 \"laah.mp3\" \"audio/mp3\")) + :body-txt \" \" +\) +other fields are :cc, :bcc, :body-html + +When the s-expression comes from the database ('mu find'), the +fields :attachments, :body-txt, :body-html, :references, :in-reply-to +are missing (because that information is not stored in the +database -- at least not in a usable way." + (condition-case nil + (car (read-from-string str));; read-from-string returns a cons + (error "Failed to parse message"))) + + +(defun mua/msg-from-path (path) + "Get the an s-expression (plist) describing the e-mail message +at path, or nil if it failed. This functions uses 'mu view' to +obtain the s-expression. For the format, see `mua/msg-from-string'" + (if (not (file-readable-p path)) + (progn + (mua/warn "Message is not readable") + (mua/log "not readable: %s" path)) + (condition-case nil + (progn (let* ((cmd (concat mua/mu-binary " view --format=sexp " path)) + (str (shell-command-to-string cmd))) + (mua/msg-from-string str))) + (error "Failed to read/parse message %s" path)))) + + +(defun mua/msg-body-txt-or-html (msg) + "Get :body-txt, or if not available, :body-html converted to +text, using `html2text'." + (let ((body (mua/msg-field msg :body-txt))) + (unless body + (setq body (mua/msg-field msg :body-html)) + (when body + (setq body (with-temp-buffer + (insert body) + (html2text) + (buffer-string))))) + body)) + +(defun mua/msg-field (msg field) + "Get a field from this message, or nil. The fields are the +fields of the message, which are the various items of the plist +as described in `mua/msg-from-string' + +There is also the special field :body (which is either :body-txt, +or if not available, :body-html converted to text)." + (case field + (:body (mua/msg-body-txt-or-html msg)) + (t (plist-get msg field)))) + + +;; TODO: add better error-reporting to mua/msg-move, and make flag handling a +;; bit more lispy + +(defun mua/msg-move (src targetdir &optional flags) + "Move message at SRC to TARGETDIR using 'mu mv'; SRC must be +the full, absolute path to a message file, while 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. + +Optionally, you can specify the FLAGS for the new file; this must +be a string consisting of one or more of DFNPRST, mean +resp. Deleted, Flagged, New, Passed Replied, Seen and Trash, as +defined in [1]. + +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. + +Function returns the target filename if the move succeeds, or +/dev/null if TARGETDIR was /dev/null; in other cases, it returns +`nil'. + +\[1\] http://cr.yp.to/proto/maildir.html." + +;; require the flags to be kosher + (when (and flags (let ((case-fold-search nil)) + (string-match "[^DFNPRST]" flags))) (error Illegal flags)) + + (let* ((cmd (concat + mua/mu-binary " mv --printtarget " + (when flags (concat "--flags=" flags " ")) + (shell-quote-argument src) " " + (shell-quote-argument targetdir))) + (fulltarget (shell-command-to-string cmd))) + (mua/log cmd) + (mua/log + (if fulltarget (concat "Message has been moved to " fulltarget) + "Message moving failed")) + ;; now, if saving worked, anynchronously try to update the database + (when fulltarget ;; note, we don't check the result of the db output + + (mua/log "Removing from database: %s" src) + (start-process " *mu-remove*" nil mua/mu-binary "remove" src) + + (unless (string= targetdir "/dev/null") + (mua/log "Adding to database: %s" fulltarget) + (start-process " *mu-add*" nil mua/mu-binary "add" fulltarget) t) + ) + + fulltarget)) + + +;; functions for composing new messages (forward, reply and new) + +(defvar mua/msg-citation-prefix "> " + "String to prefix cited message parts with.") + +(defvar mua/msg-reply-prefix "Re: " + "String to prefix the subject of replied messages with.") + +(defvar mua/msg-forward-prefix "Fwd: " + "String to prefix the subject of forwarded messages with.") + +(defconst mua/msg-draft-name "*mua-draft*" + "Name for draft messages.") + +(defun mua/msg-user-agent () + "Return the User-Agent string for mua. This is either the value +of `mua/user-agent', or, if not set, a string based on the +version of mua and emacs." + (or mua/user-agent + (format "mu %s; emacs %s" (mua/mu-binary-version) emacs-version))) + +(defun mua/msg-cite-original (msg) + "Cite the body text of MSG, with a \"On %s, %s wrote:\" + line (with the %s's replaced with the date of MSG and the name + or e-mail address of its sender (or 'someone' if nothing + else)), followed of the quoted body of MSG, constructed by by + prepending `mua/msg-citation-prefix' to each line." + (let ((from (mua/msg-field msg :from))) + (concat + (format "On %s, %s wrote:" + (format-time-string "%c" (mua/msg-field msg :date)) + (if (and from (car from)) ;; a list (( . )) + (or (caar from) (cdar from) "someone") + "someone")) + "\n\n" + (replace-regexp-in-string "^" " > " + (mua/msg-body-txt-or-html msg))))) + +(defun mua/msg-recipients-remove (lst email-to-remove) + "Remove the recipient with EMAIL from the recipient list (of +form '( (\"A\" . \"a@example.com\") (\"B\" . \"B@example.com\"))." + (remove-if + (lambda (name-email) + (let ((email (cdr name-email))) + (when email (string= email-to-remove (downcase email))))) lst)) + +(defun mua/msg-recipients-to-string (lst) + "Convert a recipient list (of form '( (\"A\" +. \"a@example.com\") (\"B\" . \"B@example.com\") (nil +. \"c@example.com\")) into a string of form \"A <@aexample.com>, +B , c@example.com\." + (mapconcat + (lambda (recip) + (let ((name (car recip)) (email (cdr recip))) + (if name + (format "%s <%s>" name email) + (format "%s" email)))) lst ", ")) + +(defun mua/msg-hidden-header (hdr val) + "Return user-invisible header to the message (HDR: VAL\n)." + (format "%s: %s\n" hdr val)) + ;;(propertize (format "%s: %s\n" hdr val) 'invisible t)) + +(defun mua/msg-header (hdr val) + "Return a header line of the form HDR: VAL\n. If VAL is nil, +return nil." + (when val (format "%s: %s\n" hdr val))) + ;;(propertize (format "%s: %s\n" hdr val) 'invisible t)) + + +(defun mua/msg-references-create (msg) + "Construct the value of the References: header based on MSG as +a comma-separated string. Normally, this the concatenation of the +existing References (which may be empty) and the message-id. If +the message-id is empty, returns the old References. If both are +empty, return nil." + (let ((refs (mua/msg-field msg :references)) + (msgid (mua/msg-field msg :message-id))) + (if msgid ;; every received message should have one... + (mapconcat 'identity (append refs (list msgid)) ",") + (mapconcat 'identity refs ",")))) + +(defun mua/msg-to-create (msg reply-all) + "Construct the To: header for a reply-message based on some +message MSG. If REPLY-ALL is nil, this the the Reply-To addresss +of MSG if it exist, or the From:-address othewise. If reply-all +is non-nil, the To: is what was in the old To: with either the +Reply-To: or From: appended, and then the +receiver (i.e. `user-mail-address') removed. + +So: + reply-all nil: Reply-To: or From: of MSG + reply-all t : Reply-To: or From: of MSG + To: of MSG - `user-mail-address' + +The result is either nil or a string which can be used for the To:-field." + (let ((to-lst (mua/msg-field msg :to)) + (reply-to (mua/msg-field msg :reply-to)) + (from (mua/msg-field msg :from))) + + (if reply-all + (progn ;; reply-all + (setq to-lst ;; append Reply-To:, or if not set, From: if set + (if reply-to (cons `(nil . ,reply-to) to-lst) + (if from (append to-lst from) + to-lst))) + + ;; and remove myself from To: + (setq to-lst (mua/msg-recipients-remove to-lst user-mail-address)) + (mua/msg-recipients-to-string to-lst)) + + ;; reply single + (progn + (or reply-to (mua/msg-recipients-to-string from)))))) + +(defconst mua/msg-separator "--text follows this line--\n\n" + "separator between headers and body, needed for `message-mode'") + +(defun mua/msg-cc-create (msg reply-all) + "Get the list of Cc-addresses for the reply to MSG. If +REPLY-ALL is nil this is simply empty, otherwise it is the same +list as the one in MSG, minus `user-mail-address'. The result of +this function is either nil or a string to be used for the Cc: +field." + (let ((cc-lst (mua/msg-field msg :cc))) + (when (and reply-all cc-lst) + (mu-message-recipients-to-string + (mua/msg-recipients-remove cc-lst + user-mail-address))))) + +(defun mua/msg-from-create () + "Construct a value for the From:-field of the reply to MSG, +based on `user-full-name' and `user-mail-address'; if the latter +is nil, function returns nil." + (when user-mail-address + (if user-full-name + (format "%s <%s>" user-full-name user-mail-address) + (format "%s" user-mail-address)))) + + +(defun mua/msg-create-reply (msg reply-all) + "Create a draft message as a reply to MSG; if REPLY-ALL is +non-nil, reply to all recipients. + +A reply message has fields: + From: - see `mu-msg-from-create' + To: - see `mua/msg-to-create' + Cc: - see `mua/msg-cc-create' + Subject: - `mua/msg-reply-prefix' + subject of MSG + + then, the following fields, normally hidden from user: + Reply-To: - if `mail-reply-to' has been set + References: - see `mua/msg-references-create' + In-Reply-To: - message-id of MSG + User-Agent - see `mua/msg-user-agent' + +Then follows `mua-msg-separator' (for `message-mode' to separate +body from headers) + +And finally, the cited body of MSG, as per `mua/msg-cite-original'." + (concat + (mua/msg-header "From" (or (mua/msg-from-create) "")) + (when (boundp 'mail-reply-to) + (mua/msg-header "Reply-To" mail-reply-to)) + + (mua/msg-header "To" (or (mua/msg-to-create msg reply-all) "")) + (mua/msg-header "Cc" (mua/msg-cc-create msg reply-all)) + + (mua/msg-hidden-header "User-agent" (mua/msg-user-agent)) + (mua/msg-hidden-header "References" (mua/msg-references-create msg)) + + (mua/msg-hidden-header "In-reply-to" (mua/msg-field msg :message-id)) + + (mua/msg-header"Subject" + (concat mua/msg-reply-prefix (mua/msg-field msg :subject))) + + mua/msg-separator + + (mua/msg-cite-original msg))) + +;; TODO: attachments +(defun mua/msg-create-forward (msg) + "Create a draft forward message for MSG. + +A forward message has fields: + From: - see `mu-msg-from-create' + To: - empty + Subject: - `mua/msg-forward-prefix' + subject of MSG + +then, the following fields, normally hidden from user: + Reply-To: - if `mail-reply-to' has been set + References: - see `mua/msg-references-create' + User-Agent - see `mua/msg-user-agent' + +Then follows `mua-msg-separator' (for `message-mode' to separate +body from headers) + +And finally, the cited body of MSG, as per `mua/msg-cite-original'." + (concat + (mua/msg-header "From" (or (mua/msg-from-for-new) "")) + (when (boundp 'mail-reply-to) + (mua/msg-header "Reply-To" mail-reply-to)) + + (mua/msg-header "To" "") + + (mua/msg-hidden-header "User-agent" (mua/msg-user-agent)) + (mua/msg-hidden-header "References" (mua/msg-references-for-reply msg)) + + (mua/msg-header"Subject" + (concat mua/msg-forward-prefix (mua/msg-field msg :subject))) + + mua/msg-separator + + (mua/msg-cite-original msg))) + +(defun mua/msg-create-new () + "Create a new message. + +A new draft message has fields: + From: - see `mu-msg-from-create' + To: - empty + Subject: - empty + +then, the following fields, normally hidden from user: + Reply-To: - if `mail-reply-to' has been set + User-Agent - see `mua/msg-user-agent' + +Then follows `mua-msg-separator' (for `message-mode' to separate +body from headers)." + (concat + (mua/msg-header "From" (or (mua/msg-from-for-new) "")) + (when (boundp 'mail-reply-to) + (mua/msg-header "Reply-To" mail-reply-to)) + + (mua/msg-header "To" "") + (mua/msg-hidden-header "User-agent" (mua/msg-user-agent)) + (mua/msg-header "Subject" "") + mua/msg-separator)) + +(defconst mua/msg-file-prefix "mua" "prefix for mua-generated +mail files; we use this to ensure that our hooks don't mess +with non-mua-generated messages") + +(defun mua/msg-draft-file-name () + "Create a Maildir-compatible[1], unique file name for a draft +message. + [1]: see http://cr.yp.to/proto/maildir.html" + (format "%s-%x-%x.%s:2,D" ;; 'D': rarely used, but hey, it's available + mua/msg-file-prefix + (format-time-string "%Y%m%d" (current-time)) + (emacs-pid) + (random t) + (replace-regexp-in-string "[:/]" "_" (system-name)))) + + +(defun mua/msg-compose (str) + "Create a new draft message in the drafts folder with STR as +its contents, and open this message file for editing + +The name of the draft folder is constructed from the concatenation of + `mua/maildir' and `mua/drafts-folder' (therefore, these must be set). + +The message file name is a unique name determined by +`mua/msg-draft-file-name'. + +The initial STR would be created from either `mua/msg-create-reply', +`mua/msg-create-forward' or `mua/msg-create-new'. The editing buffer is +using Gnus' `message-mode'." + (unless mua/maildir (error "mua/maildir not set")) + (unless mua/drafts-folder (error "mua/drafts-folder not set")) + + ;; write our draft message to the the drafts folder + (let ((draftfile (concat mua/maildir "/" mua/drafts-folder "/cur/" + (mua/msg-draft-file-name)))) + (with-temp-file draftfile (insert str)) + (find-file draftfile) + (rename-buffer mua/msg-draft-name t) + (message-mode) + (message-goto-body))) + + + +(defun mua/msg-is-mua-message () + "Check whether the current buffer refers a mua-message based on +the buffer file name; this is used in hooks we install on +message-mode to ensure we only do things with mua-generated +messages (mua is not the only user of `message-mode' after all)" + (let* ((fname (buffer-file-name)) + (match (and fname (string-match mua/msg-file-prefix fname)))) + (and (numberp match) (= 0 match)))) +;; we simply check if file starts with `mu-msg-file-prefix' + +(defun mua/msg-save-to-sent () + "function that moves the current message to the sent folder" + (if (mua/msg-is-mua-message) + (unless mua/sent-folder (error "mua/sent-folder not set")) + + (let ((sent-msg ;; note, the "" parameter remove the D 'Draft'-flag + (mua/msg-move (buffer-file-name) mua/sent-folder ""))) + (if (sent-msg) ;; change our buffer file-name + (set-visited-file-name sent-msg t t) + (mua/warn "Failed to save message to the Sent-folder"))))) + +;; (defun mua/msg-set-replied-flag () +;; "find the message we replied to, and set its 'Replied' flag." +;; (if (mua/msg-is-mua-message) + +;; (let ((msgid (mail-header-parse-addresses +;; (message-field-value "In-Reply-To"))) +;; (path (and msgid (shell-command-to-string +;; (concat mua/mu-binary +;; " find msgid:" msgid " --exec=echo | head -1"))))) +;; (if path +;; (mu-mv) + + + + +;; add-hook +;; add-hook + + +(provide 'mua-msg) diff --git a/toys/mua/mua-view.el b/toys/mua/mua-view.el new file mode 100644 index 00000000..7e2287f7 --- /dev/null +++ b/toys/mua/mua-view.el @@ -0,0 +1,221 @@ +;;; mua-view.el -- part of mua, the mu mail user agent +;; +;; Copyright (C) 2011 Dirk-Jan C. Binnema + +;; Author: Dirk-Jan C. Binnema +;; Maintainer: Dirk-Jan C. Binnema +;; Keywords: email +;; Version: 0.0 + +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; mu + +;;; Code: + + +(eval-when-compile (require 'cl)) + +(require 'mua-common) +(require 'mua-msg) + +(defconst mua/view-buffer-name " *mua-view*" + "buffer name for mua/view buffers") + +(defvar mua/view-headers + '(:from :to :cc :subject :flags :date :attachments) + "fields to display in the message view") + +(defvar mua/hdrs-buffer nil + "headers buffer for the view") + +(defun mua/view (path headersbuf) + "display message at PATH in a new buffer; note that the action +of viewing a message may cause it to be moved/renamed; this +function returns the resulting name. PARENTBUF refers to the +buffer who invoked this view; this allows us to return there when +we quit from this view. Also, if PARENTBUF is a find buffer (ie., +has mu-headers-mode as its major mode), this allows various +commands (navigation, marking etc.) to be applied to this +buffer." + (let* ((msg (mua/msg-from-path path)) + (buf (get-buffer-create mua/view-buffer-name)) + (str (mua/view-message msg))) + (when (and msg str) + + (switch-to-buffer buf) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert str)) + + (mua/view-mode) + + (setq ;; these are buffer-local + mua/hdrs-buffer headersbuf + mua/parent-buffer headersbuf) + (goto-char (point-min))))) + +(defun mua/view-message (msg) + "construct a display string for the message" + (let ((hdrs + (mapconcat + (lambda (field) + (case field + (:subject (mua/view-header msg "Subject" :subject)) + (:path (mua/view-header msg "Path" :path)) + (:to (mua/view-contacts msg field)) + (:from (mua/view-contacts msg field)) + (:cc (mua/view-contacts msg field)) + (:bcc (mua/view-contacts msg field)) + (:date (mua/view-date msg)) + (:flags (mua/view-flags msg)) + (:size (mua/view-size msg)) + (:attachments (mua/view-attachments msg)) + (t (error "Unsupported field: %S" field)))) + mua/view-headers "")) + (body (mua/msg-body-txt-or-html msg))) + (concat hdrs "\n" body))) + +(defun mua/view-header-string (key val face) + (if val + (concat + (propertize key 'face 'mua/header-title-face) ": " + (propertize val 'face face) "\n") + "")) + +(defun mua/view-header (msg key field) + "show header FIELD for MSG with KEY. ie. : value-of-FIELD\n" + (mua/view-header-string key (mua/msg-field msg field) 'mua/header-face)) + +(defun mua/view-contacts (msg field) + (unless (member field '(:to :from :bcc :cc)) + (error "Illegal type for contact")) + (let* ((lst (mua/msg-field msg field)) + (contacts + (when lst + (mapconcat + (lambda(c) (let ((name (car c)) (email (cdr c))) + (if name + (format "%s <%s>" name email) + (format "%s" email)))) lst ", ")))) + (if contacts + (mua/view-header-string + (case field (:to "To") (:from "From") (:bcc "Bcc") (:cc "Cc")) + contacts 'mua/contacts-face) + ""))) + +(defun mua/view-date (msg) + (let* ((date (mua/msg-field msg :date)) + (datestr (when date (format-time-string "%c" date)))) + (mua/view-header-string "Date" datestr 'mua/header-face))) + +(defun mua/view-size (msg) + (let* ((size (mua/msg-field msg :size)) + (sizestr (when size (format "%d bytes")))) + (mua/view-header-string "Size" sizestr 'mua-header-face))) + +(defun mua/view-flags (msg) + "" + "" ;; todo +) + +(defun mua/view-attachments (msg) + "" + "" ;; todo +) + + + +(defvar mua/view-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "q" 'mua/quit-buffer) + (define-key map "s" 'mua/view-search) + + (define-key map "f" 'mua/view-forward) + (define-key map "r" 'mua/view-reply) + (define-key map "c" 'mua/view-compose) + + ;; navigation between messages + (define-key map "n" 'mua/view-next) + (define-key map "p" 'mua/view-prev) + + ;; marking/unmarking + (define-key map "d" '(lambda (mua/view-mark 'trash))) + (define-key map "D" '(lambda (mua/view-mark 'delete))) + (define-key map "m" '(lambda (mua/view-mark 'move))) + (define-key map "u" '(lambda (mua/view-mark 'unmark))) + (define-key map "x" 'mua/view-marked-execute) + map) + "Keymap for \"*mua-view*\" buffers.") +(fset 'mua/view-mode-map mua/view-mode-map) + +(defun mua/view-mode () + "major mode for viewing an e-mail message" + (interactive) + (kill-all-local-variables) + (use-local-map mua/view-mode-map) + + (make-local-variable 'mua/parent-buffer) + (make-local-variable 'mua/hdrs-buffer) + (make-local-variable 'mua/path) + + (setq major-mode 'mua/view-mode mode-name "*mu-view*") + (setq truncate-lines t buffer-read-only t)) + + +(defmacro mua/with-hdrs-buffer (&rest body) + "Execute the forms in BODY with the mua/hdrs-buffer temporarily current. +Note that this actually switches the buffer, and changes to point +etc. persist." + (declare (indent 1) (debug t)) + `(let ((oldbuf (current-buffer))) + (if (buffer-live-p mua/hdrs-buffer) + (progn + (set-buffer mua/hdrs-buffer) + (progn ,@body) + (set-buffer oldbuf)) + (mua/warn "hdrs buffer is dead")))) + +(defun mua/view-next () + "move to the next message; note, this will replace the current +buffer" + (interactive) + (mua/with-hdrs-buffer + (when (mua/hdrs-next) (mua/hdrs-view)))) + +(defun mua/view-prev () + "move to the previous message; note, this will replace the +current buffer" + (interactive) + (mua/with-hdrs-buffer + (when (mua/hdrs-prev) (mua/hdrs-view)))) + +(defun mua/view-reply () + "Reply to the current message." + (interactive) (mua/with-hdrs-buffer (mua/hdrs-reply))) + +(defun mua/view-forward () + "Reply to the current message." + (interactive) (mua/with-hdrs-buffer (mua/hdrs-forward))) + +(defun mua/view-compose () + "Write a new message." + (interactive) (mua/with-hdrs-buffer (mua/hdrs-compose))) + + +(provide 'mua-view)