From 6b417bc94705509545c4c8d613fce16bebcaed12 Mon Sep 17 00:00:00 2001 From: djcb Date: Thu, 1 Dec 2011 21:18:11 +0200 Subject: [PATCH] * remove the mua toy emacs ui -- the action now happens in 'mm' --- toys/mua/Makefile | 41 ---- toys/mua/TODO | 32 --- toys/mua/mua-common.el | 88 ------- toys/mua/mua-hdrs.el | 491 --------------------------------------- toys/mua/mua-msg-file.el | 227 ------------------ toys/mua/mua-msg.el | 455 ------------------------------------ toys/mua/mua-mu.el | 144 ------------ toys/mua/mua-view.el | 255 -------------------- toys/mua/mua.el | 177 -------------- 9 files changed, 1910 deletions(-) delete mode 100644 toys/mua/Makefile delete mode 100644 toys/mua/TODO delete mode 100644 toys/mua/mua-common.el delete mode 100644 toys/mua/mua-hdrs.el delete mode 100644 toys/mua/mua-msg-file.el delete mode 100644 toys/mua/mua-msg.el delete mode 100644 toys/mua/mua-mu.el delete mode 100644 toys/mua/mua-view.el delete mode 100644 toys/mua/mua.el diff --git a/toys/mua/Makefile b/toys/mua/Makefile deleted file mode 100644 index d03fcd2e..00000000 --- a/toys/mua/Makefile +++ /dev/null @@ -1,41 +0,0 @@ -EMACS=emacs -PREFIX=/usr/local -ELS=mua.el mua-common.el mua-view.el mua-hdrs.el mua-msg.el -ELCS=$(ELS:.el=.elc) - -.PHONY=install - -top_srcdir=/home/djcb/src/mu/ - - -BATCH=$(EMACS) -batch -q -no-site-file -eval \ - "(setq load-path (cons (expand-file-name \".\") load-path))" - -%.elc: %.el - $(BATCH) --eval '(byte-compile-file "$<")' - -all: $(ELCS) - -BUILT_SOURCES=mu-errors.el - -mu-errors.el: ${top_srcdir}/src/mu-util.h - @cat ${top_srcdir}/src/mu-util.h \ - - - - -docs: mua.info - -install_lisp: - mkdir -p $(DESTDIR)/$(PREFIX)/share/emacs/site-lisp - install -m 644 $(ELS) $(ELCS) $(DESTDIR)/$(PREFIX)/share/emacs/site-lisp - -install_docs: docs - mkdir -p $(DESTDIR)/$(PREFIX)/share/info - install -m 644 mu.info $(DESTDIR)/$(PREFIX)/share/info - install-info --info-dir=$(DESTDIR)/$(PREFIX)/share/info $(DESTDIR)/$(PREFIX)/share/info/mu.info - -install: install_lisp install_docs - -clean: - rm -fr mua.info $(ELCS) diff --git a/toys/mua/TODO b/toys/mua/TODO deleted file mode 100644 index c1a35dfa..00000000 --- a/toys/mua/TODO +++ /dev/null @@ -1,32 +0,0 @@ -* TODO - - [ ] message un-new in find/view - [ ] set 'Replied' flag on source when message is replied - [ ] save message to draft, sent items - [ ] attachment handling (open, play) in view - - [ ] fix flags in src/ - [ ] version check - - [ ] make add, remove async (use async buffer) - - [ ] 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 deleted file mode 100644 index ee2a1824..00000000 --- a/toys/mua/mua-common.el +++ /dev/null @@ -1,88 +0,0 @@ -;;; 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)) - -(require 'ido) - -(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 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 - (append (list mua/inbox-folder mua/drafts-folder mua/sent-folder) - mua/working-folders)) - (chosen (ido-completing-read prompt showfolders))) - (concat (if fullpath mua/maildir "") chosen))) - - -(provide 'mua-common) diff --git a/toys/mua/mua-hdrs.el b/toys/mua/mua-hdrs.el deleted file mode 100644 index d69c35b9..00000000 --- a/toys/mua/mua-hdrs.el +++ /dev/null @@ -1,491 +0,0 @@ -;;; 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: - -;; In this file are function related to creating the list of one-line -;; descriptions of emails, aka 'headers' (not to be confused with headers like -;; 'To:' or 'Subject:') - -;; 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 - "*internal* Field to sort headers by") -(defvar mua/hdrs-sort-descending nil - "*internal Whether to sort in descending order") - -(defvar mua/hdrs-fields - '( (:date . 25) - (:from-or-to . 22) - (:subject . 40)) - "A list of header fields and their character widths") - -;; internal stuff -(defvar mua/buf "" - "*internal* Buffer for results data.") -(defvar mua/last-expression nil - "*internal* The most recent search expression.") -(defvar mua/hdrs-proc nil - "*internal* The mu-find process.") - -(defconst mua/eom-mark "\n;;eom\n" - "*internal* Marker for the end of message in the mu find - output.") -(defconst mua/hdrs-buffer-name "*mua-headers*" - "*internal* Name of the mua headers buffer.") - -(defun mua/hdrs-proc-filter (proc str) - "A 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." - (setq mua/buf (concat mua/buf str)) ;; update our buffer - (let ((buf (process-buffer proc))) ;; check the buffer - (unless (buffer-live-p buf) - (error "No live buffer for process filter")) - (while ;; for-each-sex - ;; Process the sexp in `mua/buf', and remove it if it worked and return - ;; t. If no complete sexp is found, return nil." - (let ((eom (string-match mua/eom-mark mua/buf)) - (after-eom (match-end 0)) (inhibit-read-only t)) - (when (numberp eom) ;; was the marker found? - (with-current-buffer buf - (mua/hdrs-append-message (mua/msg-from-string - (substring mua/buf 0 eom)))) - (setq mua/buf (substring mua/buf after-eom)) t))))) - - -(defun mua/hdrs-proc-sentinel (proc msg) - "Sentinel funtion for the mu-find process -- ie., will be called upon its ." - (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 - (if (= 0 exit-status) - "End of search results" - (mua/mu-error exit-status)))))) - (with-current-buffer procbuf - (save-excursion - (goto-char (point-max)) - (mua/message "%s" msg))))))) - -(defun mua/hdrs-search-execute (expr) - "Search in the mu database, and output the results in the current -buffer." - (let* ((argl - (remove-if 'not - (list "find" "--format=sexp" "--threads" - (when mua/mu-home (concat "--muhome=" mua/mu-home)) - (when mua/hdrs-sortfield - (concat "--sortfield=" mua/hdrs-sortfield)) - (when mua/hdrs-sort-descending "--descending") - expr))) - (mua/buf "") - ;; start the process - (proc (apply 'start-process - mua/hdrs-buffer-name (current-buffer) mua/mu-binary argl))) - (setq mua/hdrs-proc proc) - (set-process-filter proc 'mua/hdrs-proc-filter) - (set-process-sentinel proc 'mua/hdrs-proc-sentinel) - (mua/log (concat mua/mu-binary " " (mapconcat 'identity argl " "))))) - -;; 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 for EXPR, and switch to the output -buffer for the results." - (interactive "s[mu] search for: ") - ;; kill a running process if needed - (when (and mua/hdrs-proc (eq (process-status mua/hdrs-proc) 'run)) - (kill-process mua/hdrs-proc)) - (let ((buf (mua/new-buffer mua/hdrs-buffer-name))) - (switch-to-buffer buf) - (mua/hdrs-mode) - (mua/hdrs-search-execute expr))) - - -(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-proc) - (make-local-variable 'mua/hdrs-hash) - (make-local-variable 'mua/hdrs-marks-hash) - - (setq - mua/last-expression expr - mua/hdrs-marks-hash (make-hash-table :size 16 :rehash-size 2) - major-mode 'mua/mua/hdrs-mode mode-name "*mua-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)." - (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 " ")) - -;; -;; 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-get-uid () - "Get the uid for the message header at point." - (get-text-property (point) 'uid)) - -(defun mua/hdrs-get-path () - "Get the current path for the header at point." - (mua/msg-map-get-path (mua/hdrs-get-uid))) - -(defun mua/hdrs-append-message (msg) - "Append a one-line description of MSG to the buffer, and register -it with `mua/msg-map-add' to `mua/msg-map'; add the uid for this -message as a text-property `uid'." - (let* ((uid (mua/msg-map-add (mua/msg-field msg :path))) - (line (propertize (concat " " (mua/hdrs-line msg) "\n") 'uid uid)) - (inhibit-read-only t)) - (save-excursion - (goto-char (point-max)) - (insert line)))) - - - -;; 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) - "Return a string describing the flags of MSG at WIDTH." - (let ((flagstr (mua/msg-flags-to-string (mua/msg-field msg :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") - t)) - -(defun mua/hdrs-prev () - "Go to the previous line; t if it worked, nil otherwise." - (when (buffer-live-p mua/hdrs-buffer) - (with-current-buffer mua/hdrs-buffer - (if (or (/= 0 (forward-line -1)) (not (mua/hdrs-get-uid))) - (mua/warn "No message before this one"))) - (when mua/view-uid ;; are we in view buffer? - (mua/view (mua/hdrs-get-uid) mua/hdrs-buffer)))) - -(defun mua/hdrs-view () - (interactive) - (let ((uid (mua/hdrs-get-uid))) - (if uid - (mua/view uid (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 dirtrection." - (interactive) - (and (call-interactively 'mua/hdrs-change-sort-order) - (call-interactively 'mua/hdrs-change-sort-direction))) - - - -;;; functions for marking - -(defvar mua/hdrs-marks-hash nil - "*internal* The hash for marked messages. The hash maps - bol (beginning-of-line) to a 3-tuple: [UID TARGET FLAGS], where UID is the - the UID of the message file (see `mua/msg-map'), TARGET is the - target maildir (ie., \"/inbox\", but can also be nil (for 'delete); - and finally FLAGS is the flags to set when the message is moved.") - -(defun mua/hdrs-set-mark-ui (bol action) - "Display (or undisplay) the mark for BOL for action ACTION." - (unless (member action '(delete trash move unmark)) - (error "Invalid action %S" action)) - (save-excursion - (let ((inhibit-read-only t)) - (delete-char 2) - (insert - (case action - (delete "d ") - (trash "D ") - (move "m ") - (unmark " ")))))) - -(defun mua/hdrs-set-mark (bol uid &optional target flags) - "Add a mark to `mua/hdrs-marks-hash', with BOL being the beginning of the line -of the marked message and (optionally) TARGET the target for the trash or move, -and FLAGS the flags to set for the message, either as a string or as a list (see -`mua/msg-move' for a discussion of the format)." - (if (gethash bol mua/hdrs-marks-hash) - (mua/warn "Message is already marked") - (let ((tuple `[,uid ,target ,flags])) - (puthash bol tuple mua/hdrs-marks-hash) ;; add to the hash... - (mua/hdrs-set-mark-ui bol action)))) - -(defun mua/hdrs-remove-mark (bol) - "Remove the mark for the message at BOL from the markings -hash. BOL must be the point at the beginning of the line." - (if (not (gethash bol mua/hdrs-marks-hash)) - (mua/warn "Message is not marked") - (progn - (remhash bol mua/hdrs-marks-hash) ;; remove from the hash... - (mua/hdrs-set-mark-ui bol 'unmark)))) - -(defun mua/hdrs-marks-execute () - "Execute the corresponding actions for all marked messages in -`mua/hdrs-marks-hash'." - (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 tuple) - (let* ((uid (aref tuple 0)) (target (aref tuple 1)) - (flags (aref tuple 2)) (inhibit-read-only t)) - (when (mua/msg-move uid target flags) - ;; remember the updated path -- for now not too useful - ;; as we're hiding the header, but... - (save-excursion - (mua/hdrs-remove-mark bol) - (goto-char bol) - ;; when it succeedes, hide msg..) - (put-text-property (line-beginning-position 1) - (line-beginning-position 2) 'invisible t))))) - mua/hdrs-marks-hash)))))) - -(defun mua/hdrs-mark (action) - "Mark the message at point BOL (the beginning of the line) with -one of the symbols: move, delete, trash, unmark, unmark-all; the -latter two are pseudo-markings." - (let* ((bol (line-beginning-position 1)) (uid (mua/hdrs-get-uid))) - (when uid - (case action - (move - (mua/hdrs-set-mark bol uid (mua/ask-maildir "Target maildir: " t))) - (trash - (if (member 'trashed (mua/msg-flags-from-path (mua/hdrs-get-path))) - (mua/warn "Message is already trashed") - (mua/hdrs-set-mark bol uid (concat mua/maildir mua/trash-folder) "+T"))) - (delete - (mua/hdrs-set-mark bol action uid "/dev/null")) - (unmark - (mua/hdrs-remove-mark bol)) - (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)))) - - - -;; functions for creating new message -- reply, forward, and new -(defun mua/hdrs-reply () - "Reply to message at point." - (interactive) - (let* ((uid (mua/hdrs-get-uid)) - (path (mua/hdrs-get-path)) - (str (when path (mua/mu-view-sexp path))) - (msg (and str (mua/msg-from-string str)))) - (if msg - (mua/msg-reply msg uid) - (mua/warn "No message at point")))) - -(defun mua/hdrs-for-reply () - "Forward the message at point." - (interactive) - (let* ((uid (mua/hdrs-get-uid)) - (path (mua/hdrs-get-path)) - (str (when path (mua/mu-view-sexp path))) - (msg (and str (mua/msg-from-string str)))) - (if msg - (mua/msg-reply msg uid) - (mua/warn "No message at point")))) - -(defun mua/hdrs-compose () - "Create a new message." - (interactive) - (mua/msg-compose-new)) - - -(provide 'mua-hdrs) diff --git a/toys/mua/mua-msg-file.el b/toys/mua/mua-msg-file.el deleted file mode 100644 index b0c79dcf..00000000 --- a/toys/mua/mua-msg-file.el +++ /dev/null @@ -1,227 +0,0 @@ -;;; 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)) - - -(defvar mua/msg-map nil - "*internal* a map of uid->message. - -This map adds a level of indirection for message files; many -actions (such moving, responding to or even reading a message) -cause the file names to change. Here we map the initial file to a -uid, the latter which stays constant over the lifetime of a -message in the system (in practice, the lifetime of a particular -headers buffer). - -When creating the headers buffer, the file names are registered -with `mua/msg-map-add'. - -All operation that change file names ultimately (should) end up -in `mua/msg-move', which will update the map after the -moving (using `mua/msg-map-update') - -Other places of the code can use the uid to get the *current* -path of the file using `mua/msg-map-get-path'. -") - -(defun mua/msg-map-add (path) - "Add a message PATH to the `mua/msg-map', and return the uid - for it." - (unless mua/msg-map - (setq mua/msg-map (make-hash-table :size 256 :rehash-size 2 :weakness t))) - (let ((uid (sha1 path))) - (puthash uid path mua/msg-map) - uid)) - -(defun mua/msg-map-update (uid path) - "Set the new path for the message identified by UID to PATH." - (if (gethash uid mua/msg-map) - (puthash uid path mua/msg-map) - (mua/warn "No message file registered for uid"))) - -(defun mua/msg-map-get-path (uid) - "Get the current path for the message identified by UID." - (gethash uid mua/msg-map)) - -(defun mua/msg-move (uid &optional targetdir flags ignore-already) - "Move message identified by UID to TARGETDIR using 'mu mv', and -update the database with the new situation. 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. See -`mua/msg-map' for a discussion about UID. - -After the file system move (rename) has been done, 'mu remove' -and/or 'mu add' are invoked asynchronously to update the database -with the changes. - -Optionally, you can specify the FLAGS for the new file. The FLAGS -parameter can have the following forms: - 1. a list of flags such as '(passed replied seen) - 2. a string containing the one-char versions of the flags, e.g. \"PRS\" - 3. a delta-string specifying the changes with +/- and the one-char flags, - e.g. \"+S-N\" to set Seen and remove New. - -The flags are any of `deleted', `flagged', `new', `passed', `replied' `seen' or -`trashed', or the corresponding \"DFNPRST\" as defined in [1]. See -`mua/msg-string-to-flags' and `mua/msg-flags-to-string'. - -If TARGETDIR is '/dev/null', remove SRC. After the file system -move, the database will be updated as well, using the 'mu add' -and 'mu remove' commands. - -If IGNORE-ALREADY is non-nil, don't consider it an error when the target file is -the same as the source file. - -Function returns t the move succeeds, in other cases, it returns -nil. - -\[1\] URL `http://cr.yp.to/proto/maildir.html'." - (condition-case err - (let ((src (mua/msg-map-get-path uid))) - (unless src (error "Source path not registered for %S" uid)) - (unless (or targetdir src) (error "Either targetdir or flags required")) - (unless (file-readable-p src) (error "Source is unreadable (%S)" src)) - (let* ((flagstr - (if (stringp flags) flags (mua/msg-flags-to-string flags))) - (argl (append ;; build-up the command line - '("mv" "--print-target" "--ignore-dups") - (when flagstr (list (concat "--flags=" flagstr))) - (list src) - (when targetdir (list targetdir)))) - ;; execute it, and get the results - (rv (apply 'mua/mu-run argl)) - (code (car rv)) (output (cdr rv))) - (unless (= 0 code) - (error "Moving message failed: %S" output)) - - ;; success! - (let ((targetpath (substring output 0 -1))) - - (when (and targetpath (not (string= src targetpath))) - ;; update the UID-map - (mua/msg-map-update uid targetpath) - ;; remove the src file - (mua/mu-remove-async src) - ;; and add the target file, unless it's dead now - (unless (string= targetdir "/dev/null") - (mua/mu-add-async targetpath))) - t))) - - (error (mua/warn "error: %s" (error-message-string err))))) - - -(defun mua/msg-flags-from-path (path) - "Get the flags for the message at PATH, which does not have to exist. -The flags are returned as a list consisting of one or more of -DFNPRST, mean resp. Deleted, Flagged, New, Passed Replied, Seen -and Trash, as defined in [1]. See `mua/msg-string-to-flags' -and `mua/msg-flags-to-string'. -\[1\] http://cr.yp.to/proto/maildir.html." - (when (string-match ",\\(\[A-Z\]*\\)$" path) - (mua/msg-string-to-flags (match-string 1 path)))) - - -(defun mua/msg-maildir-from-path (path &optional dont-strip-prefix) - "Get the maildir from PATH; in this context, 'maildir' is the -part between the `mua/maildir' and the /cur or /new; so -e.g. \"/home/user/Maildir/foo/bar/cur/12345:2,S\" would have -\"/foo/bar\" as its maildir. If DONT-STRIP-PREFIX is non-nil, -function will instead _not_ remove the `mua/maildir' from the -front - so in that case, the example would return -\"/home/user/Maildir/foo/bar/\". If the maildir cannot be -determined, return `nil'." - (when (and (string-match "^\\(.*\\)/\\(cur\\|new\\)/\[^/\]*$" path)) - (let ((mdir (match-string 1 path))) - (when (and (< (length mua/maildir) (length mdir)) - (string= (substring mdir 0 (length mua/maildir)) mua/maildir)) - (if dont-strip-prefix - mdir - (substring mdir (length mua/maildir))))))) - -(defun mua/msg-flags-to-string (flags) - "Remove duplicates and sort the output of `mua/msg-flags-to-string-1'." - (concat - (sort (remove-duplicates - (append (mua/msg-flags-to-string-1 flags) nil)) '>))) - -(defun mua/msg-flags-to-string-1 (flags) - "Convert a list of flags into a string as seen in Maildir -message files; flags are symbols draft, flagged, new, passed, -replied, seen, trashed and the string is the concatenation of the -uppercased first letters of these flags, as per [1]. Other flags -than the ones listed here are ignored. - -Also see `mua/msg-string-to-flags'. - -\[1\]: http://cr.yp.to/proto/maildir.html" - (when flags - (let ((kar (case (car flags) - ('draft ?D) - ('flagged ?F) - ('new ?N) - ('passed ?P) - ('replied ?R) - ('seen ?S) - ('trashed ?T) - ('encrypted ?x) - ('signed ?s) - ('unread ?u)))) - (concat (and kar (string kar)) - (mua/msg-flags-to-string-1 (cdr flags)))))) - - -(defun mua/msg-string-to-flags (str) - "Remove duplicates from the output of `mua/msg-string-to-flags-1'" - (remove-duplicates (mua/msg-string-to-flags-1 str))) - -(defun mua/msg-string-to-flags-1 (str) - "Convert a string with message flags as seen in Maildir -messages into a list of flags in; flags are symbols draft, -flagged, new, passed, replied, seen, trashed and the string is -the concatenation of the uppercased first letters of these flags, -as per [1]. Other letters than the ones listed here are ignored. -Also see `mua/msg-flags-to-string'. - -\[1\]: http://cr.yp.to/proto/maildir.html" - (when (/= 0 (length str)) - (let ((flag - (case (string-to-char str) - (?D 'draft) - (?F 'flagged) - (?P 'passed) - (?R 'replied) - (?S 'seen) - (?T 'trashed)))) - (append (when flag (list flag)) - (mua/msg-string-to-flags-1 (substring str 1)))))) - -(provide 'mua-msg-file) diff --git a/toys/mua/mua-msg.el b/toys/mua/mua-msg.el deleted file mode 100644 index ffdaf73a..00000000 --- a/toys/mua/mua-msg.el +++ /dev/null @@ -1,455 +0,0 @@ -;;; 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 STR containing -a message sexp. - - a 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\" - :maildir: \"/archive\" - :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-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)) - (:maildir ;; messages gotten from mu-view don't have their maildir set... - (or (plist-get msg :maildir) - (mua/msg-maildir-from-path (mua/msg-field msg :path)))) - (t (plist-get msg field)))) - - -;; 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. If there is - no body in MSG, return nil." - (let* ((from (mua/msg-field msg :from)) - (body (mua/msg-body-txt-or-html msg))) - (when body - (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 "^" " > " body))))) - - -(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))) - -(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) - (mua/msg-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-create) "")) - (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-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-%s-%x.%s:2,D" ;; 'D': rarely used, but hey, it's available - mua/msg-prefix - (format-time-string "%Y%m%d" (current-time)) - (emacs-pid) - (random t) - (replace-regexp-in-string "[:/]" "_" (system-name)))) - -(defvar mua/msg-reply-uid nil "UID of the message this is a reply to.") -(defvar mua/msg-forward-uid nil "UID of the message being forwarded.") - -(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. Optionally -specify PARENT-UID, - -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) - (make-local-variable 'mua/msg-forward-uid) - - (message-goto-body))) - -(defun mua/msg-reply (msg &optional reply-uid) - "Create a draft reply to MSG, and swith to an edit buffer with -the draft message. PARENT-UID refers to the UID of the message wer" - (let* ((recipnum (+ (length (mua/msg-field msg :to)) - (length (mua/msg-field msg :cc)))) - (replyall (when (> recipnum 1) - (yes-or-no-p (format "Reply to all ~%d recipients? " - (+ recipnum)))))) - ;; exact num depends on some more things - (when (mua/msg-compose (mua/msg-create-reply msg replyall)) - (when reply-uid (setq mua/msg-reply-uid reply-uid)) - (message-goto-body)))) - -(defun mua/msg-forward (msg &optional forward-uid) - "Create a draft forward for MSG, and swith to an edit buffer with -the draft message." - (when (mua/msg-compose (mua/msg-create-forward msg)) - (when forward-uid (setq mua/msg-forward-uid forward-uid)) - (message-goto-to))) - -(defun mua/msg-compose-new () - "Create a draft message, and swith to an edit buffer with the -draft message." - (when (mua/msg-compose (mua/msg-create-new)) - (message-goto-to))) - - - -(defun mua/msg-save-to-sent () - "Move the message in this buffer to the sent folder. This is -meant to be called from message mode's `message-sent-hook'." - (if (mua/msg-is-mua-message) ;; only if we are mua - (unless mua/sent-folder (error "mua/sent-folder not set")) - (let* ;; TODO: remove duplicate flags - ((newflags ;; remove Draft; maybe set 'Seen' as well? - (delq 'draft (mua/msg-flags-from-path (buffer-file-name)))) - ;; so, we register path => uid, then we move uid, then check the name - ;; uid is referring to - (uid (mua/msg-register (buffer-file-name))) - (if (mua/msg-move uid - (concat mua/maildir mua/sent-folder) - (mua/msg-flags-to-string newflags)) - (set-visited-file-name (mua/msg-get-path uid) t t) - (mua/warn "Failed to save message to the Sent-folder")))))) - - -(defun mua/msg-set-replied-or-passed-flag () - "Set the 'replied' flag on messages we replied to, and the -'passed' flag on message we have forwarded. This uses -`mua/msg-reply-uid' and `mua/msg-forward-uid', repectively. - -NOTE: This does not handle the case yet of message which are -edited from drafts. That case could be solved by searching for -the In-Reply-To message-id for replies. - -This is meant to be called from message mode's -`message-sent-hook'." - ;; handle the replied-to message - (when mua/msg-reply-uid - (unless (mua/msg-move mua/msg-reply-uid nil "+R") - (mua/warn "Failed to marked parent message as 'Replied'"))) - - ;; handle the forwarded message - (when mua/msg-forward-uid - (unless (mua/msg-move mua/msg-forward-uid nil "+P") - (mua/warn "Failed to marked parent message as 'Passed'")))) - - -;; hook our functions up with sending of the message -(add-hook 'message-sent-hook 'mua/msg-save-to-sent) -(add-hook 'message-sent-hook 'mua/msg-set-replied-or-passed-flag) - - -(provide 'mua-msg) diff --git a/toys/mua/mua-mu.el b/toys/mua/mua-mu.el deleted file mode 100644 index bad3f1b8..00000000 --- a/toys/mua/mua-mu.el +++ /dev/null @@ -1,144 +0,0 @@ -;;; mua-mu.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-mu contains common functions that interact with the mu program - -;;; Code: -(eval-when-compile (require 'cl)) - - -(defun mua/mu-run (&rest args) - "Run 'mu' synchronously with ARGS as command-line argument;, -where is the exit code of the program, or 1 if the -process was killed. contains whatever the command wrote on -standard output/error, or nil if there was none or in case of -error. Basically, `mua/mu-run' is like `shell-command-to-string', -but with better possibilities for error handling. The --muhome= -parameter is added automatically if `mua/mu-home' is non-nil." - (let* ((rv) - (args (append args (when mua/mu-home - (list (concat "--muhome=" mua/mu-home))))) - (cmdstr (concat mua/mu-binary " " (mapconcat 'identity args " "))) - (str (with-output-to-string - (with-current-buffer standard-output ;; but we also get stderr... - (setq rv (apply 'call-process mua/mu-binary nil t nil - args)))))) - (when (and (numberp rv) (/= 0 rv)) - (mua/log "mua error: %s" (mua/mu-error rv))) - (mua/log "%s => %S" cmdstr rv) - `(,(if (numberp rv) rv 1) . ,str))) - -(defun mua/mu-binary-version () - "Get the version string of the mu binary, or nil if we failed -to get it" - (let ((rv (mua/mu-run "--version"))) - (if (and (= (car rv) 0) (string-match "version \\(.*\\)$" (cdr rv))) - (match-string 1 (cdr rv)) - (mua/warn "Failed to get version string")))) - - -(defun mua/mu-view-sexp (path) - "Return a string with an s-expression representing the message -at PATH; the format is described in `mua/msg-from-string', and -that function converts the string into a Lisp object (plist)" - (if (not (file-readable-p path)) - (mua/warn "Cannot view unreadable file %s" path) - (let* ((rv (mua/mu-run "view" "--format=sexp" path)) - (code (car rv)) (str (cdr rv))) - (if (= code 0) - str - (mua/warn "mu view failed (%d): %s" - code (if str str "error")))))) - - -(defvar mua/db-update-proc nil "*internal* process for db updates") -(defvar mua/db-update-name "*mua-db-update*" - "*internal* name of the db-update process") -(defvar mua/db-add-paths nil "list of paths to add to database") -(defvar mua/db-remove-paths nil "list of paths to remove from database") - -(defun mua/db-update-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))) - (case status - ('signal (mua/warn "Process killed")) - ('exit - (case exit-status - (mua/warn "Result: %s" (mua/mu-log exit-status)))))) - (mua/mu-db-update-execute))) - -(defun mua/mu-db-update-execute () - "Update the database; remove paths in `mua/db-remove-paths', -and add paths in `mua/db-add-paths'. Updating is ansynchronous." - - ;; when it's already running, do nothing - (unless (and mua/db-update-proc (eq (process-status mua/db-update-proc) 'run)) - (when mua/db-remove-paths - (let ((remove-paths (copy-list mua/db-remove-paths))) - (mua/log (concat mua/mu-binary " remove " - (mapconcat 'identity remove-paths " "))) - (setq mua/db-remove-paths nil) ;; clear the old list - (setq mua/db-update-proc - (apply 'start-process mua/db-update-name mua/db-update-name mua/mu-binary - "remove" remove-paths)) - (set-process-sentinel mua/db-update-proc 'mua/db-update-proc-sentinel)))) - - ;; when it's already running, do nothing - (unless (and mua/db-update-proc - (eq (process-status mua/db-update-proc) 'run)) - (when mua/db-add-paths - (let ((add-paths (copy-list mua/db-add-paths))) - (mua/log (concat mua/mu-binary " add " (mapconcat 'identity add-paths " "))) - (setq mua/db-add-paths nil) ;; clear the old list - (setq mua/db-update-proc - (apply 'start-process mua/db-update-name mua/db-update-name mua/mu-binary - "add" add-paths)) - (set-process-sentinel mua/db-update-proc 'mua/db-update-proc-sentinel))))) - - -(defun mua/mu-add-async (path-or-paths) - "Asynchronously add msg at PATH-OR-PATHS to -database. PATH-OR-PATHS is either a single path or a list of -them." - (setq mua/db-add-paths - (append mua/db-add-paths - (if (listp path-or-paths) path-or-paths `(,path-or-paths)))) - (mua/mu-db-update-execute)) - -(defun mua/mu-remove-async (path-or-paths) - "Asynchronously remove msg at PATH-OR-PATHS from -database. PATH-OR-PATHS is either a single path or a list of -them." - (setq mua/db-remove-paths - (append mua/db-remove-paths - (if (listp path-or-paths) path-or-paths `(,path-or-paths)))) - (mua/mu-db-update-execute)) - - -(provide 'mua-mu) diff --git a/toys/mua/mua-view.el b/toys/mua/mua-view.el deleted file mode 100644 index ccde57ca..00000000 --- a/toys/mua/mua-view.el +++ /dev/null @@ -1,255 +0,0 @@ -;;; 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 :maildir :path :attachments) - "Fields to display in the message view buffer.") - -(defvar mua/hdrs-buffer nil - "*internal* Headers buffer for the view in this buffer.") - -(defvar mua/view-uid nil - "*internal* The UID for the message being viewed in this buffer.") - - -(defun mua/view (uid hdrsbuf) - "Display the message identified by UID in a new buffer, and mark -is as no longer unread, -- 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. - -For the reasoning to use UID here instead of just the path, see -`mua/msg-map'." - (condition-case err - (let* ((path (mua/msg-map-get-path uid)) - (sexp (mua/mu-view-sexp path)) - (msg (and sexp (mua/msg-from-string sexp)))) - (unless (buffer-live-p hdrsbuf) (error "Headers buffer is dead")) - (unless msg (error "Cannot view message %S" path)) - (let ((buf (get-buffer-create mua/view-buffer-name)) - (inhibit-read-only t)) - ;; fill buffer with the message - (erase-buffer) - (insert (mua/view-message msg)) - (mua/view-mode) - (goto-char (point-min)) - - (setq ;; these are buffer-local - mua/view-uid uid - mua/hdrs-buffer hdrsbuf - mua/parent-buffer hdrsbuf) - - (unless (mua/msg-move uid nil "+S-N" t) ;; mark as read - (error "Failed to mark message as read")))) - (debug (error))));; (mua/warn "error: %s" (error-message-string err))))) - - - -(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)) - (:maildir (mua/view-header msg "Maildir" :maildir)) - (: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()(interactive)(mua/view-mark 'trash))) - (define-key map "D" '(lambda()(interactive)(mua/view-mark 'delete))) - (define-key map "m" '(lambda()(interactive)(mua/view-mark 'move))) - (define-key map "u" '(lambda()(interactive)(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/view-uid) - - (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-mark (action) - "Set/unset marks for the current message." - (interactive) - (mua/with-hdrs-buffer (mua/hdrs-mark action))) - -(defun mua/view-marked-execute () - "Warn user that marks cannot be executed from here (for his/her -own safety)." - (interactive) - (mua/warn "You cannot execute marks from here")) - - -(defun mua/view-search() - "Start a new search." - (interactive) - (mua/with-hdrs-buffer - (call-interactively 'mua/hdrs-search))) - -(defun mua/view-next () - "move to the next message; note, this will replace the current -buffer" - (interactive) - (with-current-buffer mua/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) diff --git a/toys/mua/mua.el b/toys/mua/mua.el deleted file mode 100644 index fd64eae1..00000000 --- a/toys/mua/mua.el +++ /dev/null @@ -1,177 +0,0 @@ -;;; mua.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-mu) -(require 'mua-msg) -(require 'mua-hdrs) -(require 'mua-view) -(require 'mua-msg-file) - - -(defvar mua/mu-home nil "location of the mu homedir, or nil for -the default") -(defvar mua/mu-binary "mu" "name/path of the mu binary") -(setq mua/mu-binary "/home/djcb/src/mu/src/mu") - -(defvar mua/user-agent nil "User-specified User-Agent string") - -(defvar mua/parent-buffer nil "parent buffer; if a buffer is -quitted, it switches back to its parent buffer") - -(defvar mua/maildir nil "our maildir") - -(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") -(defvar mu/drafts-folder nil "location of your drafts folder") - -(setq - mua/maildir "/home/djcb/Maildir" - mua/inbox-folder "/inbox" - mua/outbox-folder "/outbox" - mua/sent-folder "/sent" - mua/drafts-folder "/drafts" - mua/trash-folder "/trash") - -(defvar mua/working-folders nil) - -(setq mua/working-folders - '("/bulk" "/archive" "/bulkarchive" "/todo")) - -(setq mua/header-fields - '( (:date . 25) - (:flags . 6) - (:from . 22) - (:subject . 40))) - - -(defface mua/date-face '((t (:foreground "#8c5353"))) "") -(defface mua/header-title-face '((t (:foreground "#df558f"))) "") -(defface mua/header-face '((t (:foreground "#dfaf8f"))) "") -(defface mua/contacts-face '((t (:foreground "#7f9f7f"))) "") -(defface mua/body-face '((t (:foreground "#8cd0d3"))) "") - - - -(setq 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 (kbd "") 'mua/hdrs-next) - (define-key map (kbd "") 'mua/hdrs-prev) - - (define-key map (kbd "") 'scroll-up) - - (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)) -(fset 'mua/hdrs-mode-map mua/hdrs-mode-map) - -(defconst mua/buffer-name "*mua*" - "Name of the top-level mua buffer") - -(defun mua() - "Start mua, the mu e-mail client with an impressive dashboard." - (interactive) - (let ((buf (mua/new-buffer mua/buffer-name))) - (with-current-buffer buf - (insert (propertize "mua" 'face 'highlight) - (propertize " version: " 'face 'mua/header-title-face) - (propertize (mua/mu-binary-version) 'face 'mua/header-face) - (propertize " maildir: " 'face 'mua/header-title-face) - (propertize mua/maildir 'face 'mua/header-face) - "\n\n\n" - (propertize "* quick jump folders" 'face 'mua/header-title-face) - " (use " (propertize "j" 'face 'highlight) ")\n" - " " (mapconcat 'identity - (append (list mua/inbox-folder mua/sent-folder mua/drafts-folder) - mua/working-folders) " ") "\n\n" - - (propertize "* search" 'face 'mua/header-title-face) - " (use " (propertize "s" 'face 'highlight) ")\n\n" - - (propertize "* compose a new message" 'face 'mua/header-title-face) - " (use " (propertize "c" 'face 'highlight) ")\n\n" - )) - (switch-to-buffer buf) - (mua/mua-mode))) - -(defvar mua/mua-mode-map - (let ((map (make-sparse-keymap))) - - (define-key map "s" 'mua/hdrs-search) - (define-key map "q" 'mua/quit-buffer) - (define-key map "j" 'mua/hdrs-jump-to-maildir) - (define-key map "c" 'mua/hdrs-compose) - - map) - "Keymap for *mua-headers* buffers.") -(fset 'mua/mua-mode-map mua/mua-mode-map) - -(defun mua/mua-mode () - "Major mode for the mua dashboard screen." - (interactive) - (kill-all-local-variables) - (use-local-map mua/mua-mode-map) - (make-local-variable 'mua/buf) - - (setq - major-mode 'mua/mua-mode mode-name "*mua*" - truncate-lines t buffer-read-only t - overwrite-mode 'overwrite-mode-binary)) - - -(provide 'mua)