2011-09-18 13:39:36 +02:00
|
|
|
|
;; mm-view.el -- part of mm, the mu mail user agent
|
|
|
|
|
;;
|
|
|
|
|
;; Copyright (C) 2011 Dirk-Jan C. Binnema
|
|
|
|
|
|
|
|
|
|
;; Author: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
|
|
|
|
|
;; Maintainer: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
|
|
|
|
|
;; 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 <http://www.gnu.org/licenses/>.
|
|
|
|
|
|
|
|
|
|
;;; 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:')
|
|
|
|
|
|
|
|
|
|
;; mm
|
|
|
|
|
|
|
|
|
|
;;; Code:
|
|
|
|
|
(eval-when-compile (require 'cl))
|
|
|
|
|
(require 'html2text)
|
2011-09-22 20:01:35 +02:00
|
|
|
|
(require 'filladapt)
|
2011-09-18 13:39:36 +02:00
|
|
|
|
|
|
|
|
|
(defconst mm/view-buffer-name "*mm-view*"
|
|
|
|
|
"*internal* Name for the message view buffer")
|
|
|
|
|
|
2011-11-20 09:31:38 +01:00
|
|
|
|
(defconst mm/view-raw-buffer-name "*mm-view-raw*"
|
|
|
|
|
"*internal* Name for the raw message view buffer")
|
|
|
|
|
|
2011-09-18 13:39:36 +02:00
|
|
|
|
;; some buffer-local variables
|
|
|
|
|
(defvar mm/hdrs-buffer nil
|
|
|
|
|
"*internal* Headers buffer connected to this view.")
|
|
|
|
|
|
|
|
|
|
(defvar mm/current-msg nil
|
|
|
|
|
"*internal* The plist describing the current message.")
|
|
|
|
|
|
2011-09-22 20:01:35 +02:00
|
|
|
|
(defun mm/view (msg hdrsbuf &optional update)
|
2011-09-18 13:39:36 +02:00
|
|
|
|
"Display the message MSG in a new buffer, and keep in sync with HDRSBUF.
|
|
|
|
|
'In sync' here means that moving to the next/previous message in
|
2011-09-22 20:01:35 +02:00
|
|
|
|
the the message view affects HDRSBUF, as does marking etc. If
|
|
|
|
|
UPDATE is non-nil, the current message will be (visually) updated.
|
2011-09-18 13:39:36 +02:00
|
|
|
|
|
|
|
|
|
As a side-effect, a message that is being viewed loses its 'unread'
|
|
|
|
|
marking if it still had that."
|
2011-09-30 07:37:47 +02:00
|
|
|
|
(let ((buf (get-buffer-create mm/view-buffer-name))
|
|
|
|
|
(inhibit-read-only t))
|
2011-09-18 13:39:36 +02:00
|
|
|
|
(with-current-buffer buf
|
|
|
|
|
(erase-buffer)
|
|
|
|
|
(insert
|
|
|
|
|
(mapconcat
|
|
|
|
|
(lambda (field)
|
2011-11-05 09:26:24 +01:00
|
|
|
|
(let ((fieldname (cdr (assoc field mm/header-names)))
|
|
|
|
|
(fieldval (plist-get msg field)))
|
|
|
|
|
(case field
|
2011-11-20 00:18:12 +01:00
|
|
|
|
|
2011-11-05 09:26:24 +01:00
|
|
|
|
(:subject (mm/view-header fieldname fieldval))
|
|
|
|
|
(:path (mm/view-header fieldname fieldval))
|
|
|
|
|
(:maildir (mm/view-header fieldname fieldval))
|
2011-11-20 00:18:12 +01:00
|
|
|
|
(:flags (mm/view-header fieldname (format "%S" fieldval)))
|
|
|
|
|
|
2011-11-05 09:26:24 +01:00
|
|
|
|
;; contact fields
|
|
|
|
|
(:to (mm/view-contacts msg field))
|
|
|
|
|
(:from (mm/view-contacts msg field))
|
|
|
|
|
(:cc (mm/view-contacts msg field))
|
|
|
|
|
(:bcc (mm/view-contacts msg field))
|
|
|
|
|
|
2011-11-09 07:35:24 +01:00
|
|
|
|
;; if we (`user-mail-address' are the From, show To, otherwise,
|
|
|
|
|
;; show From
|
|
|
|
|
(:from-or-to
|
|
|
|
|
(let* ((from (plist-get msg :from))
|
|
|
|
|
(from (and from (cdar from))))
|
|
|
|
|
(if (and from (string-match mm/user-mail-address-regexp from))
|
|
|
|
|
(mm/view-contacts msg :to)
|
|
|
|
|
(mm/view-contacts msg :from))))
|
2011-11-20 00:18:12 +01:00
|
|
|
|
|
2011-11-05 09:26:24 +01:00
|
|
|
|
;; date
|
|
|
|
|
(:date
|
|
|
|
|
(let ((datestr
|
2011-11-09 07:35:24 +01:00
|
|
|
|
(when fieldval (format-time-string mm/view-date-format fieldval))))
|
2011-11-05 09:26:24 +01:00
|
|
|
|
(if datestr (mm/view-header fieldname datestr) "")))
|
|
|
|
|
;; size
|
|
|
|
|
(:size (mm/view-size msg)
|
|
|
|
|
(let ((sizestr (when size (format "%d bytes"))))
|
|
|
|
|
(if sizestr (mm/view-header fieldname sizestr))))
|
|
|
|
|
;; attachments
|
|
|
|
|
(:attachments (mm/view-attachments msg))
|
|
|
|
|
(t (error "Unsupported field: %S" field)))))
|
|
|
|
|
mm/view-fields "")
|
2011-09-18 13:39:36 +02:00
|
|
|
|
"\n"
|
|
|
|
|
(mm/view-body msg))
|
2011-09-20 22:59:20 +02:00
|
|
|
|
|
|
|
|
|
;; initialize view-mode
|
2011-09-18 13:39:36 +02:00
|
|
|
|
(mm/view-mode)
|
2011-09-20 22:59:20 +02:00
|
|
|
|
(setq ;; these are buffer-local
|
2011-09-30 07:37:47 +02:00
|
|
|
|
mode-name (if (plist-get msg :subject)
|
|
|
|
|
(truncate-string-to-width (plist-get msg :subject) 16 0 nil t)
|
2011-11-05 09:26:24 +01:00
|
|
|
|
(propertize "No subject" 'face 'mm/system-face))
|
2011-09-18 13:39:36 +02:00
|
|
|
|
mm/current-msg msg
|
2011-09-20 22:59:20 +02:00
|
|
|
|
mm/hdrs-buffer hdrsbuf
|
|
|
|
|
mm/link-map (make-hash-table :size 32 :rehash-size 2 :weakness nil))
|
2011-09-30 07:37:47 +02:00
|
|
|
|
|
2011-09-18 13:39:36 +02:00
|
|
|
|
(switch-to-buffer buf)
|
2011-09-20 22:59:20 +02:00
|
|
|
|
(goto-char (point-min))
|
|
|
|
|
(mm/view-beautify)
|
2011-09-22 20:01:35 +02:00
|
|
|
|
|
|
|
|
|
(unless update
|
|
|
|
|
(mm/view-mark-as-read-maybe)))))
|
2011-09-18 13:39:36 +02:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(defun mm/view-body (msg)
|
|
|
|
|
"Get the body for this message, which is either :body-txt,
|
|
|
|
|
or if not available, :body-html converted to text)."
|
|
|
|
|
(or (plist-get msg :body-txt)
|
|
|
|
|
(with-temp-buffer
|
|
|
|
|
(plist-get msg :body-html)
|
|
|
|
|
(html2text)
|
|
|
|
|
(buffer-string))
|
|
|
|
|
"No body found"))
|
|
|
|
|
|
|
|
|
|
|
2011-11-20 00:18:12 +01:00
|
|
|
|
(defun mm/view-header (key val &optional dont-propertize-val)
|
2011-11-05 09:26:24 +01:00
|
|
|
|
"Show header FIELD for MSG with KEY. ie. <KEY>: value-of-FIELD."
|
2011-09-18 13:39:36 +02:00
|
|
|
|
(if val
|
|
|
|
|
(concat
|
|
|
|
|
(propertize key 'face 'mm/view-header-key-face) ": "
|
2011-11-20 00:18:12 +01:00
|
|
|
|
(if dont-propertize-val
|
|
|
|
|
val
|
|
|
|
|
(propertize val 'face 'mm/view-header-value-face))
|
|
|
|
|
"\n")
|
2011-09-18 13:39:36 +02:00
|
|
|
|
""))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(defun mm/view-contacts (msg field)
|
2011-11-05 09:26:24 +01:00
|
|
|
|
"Add a header for a contact field (ie., :to, :from, :cc, :bcc)."
|
2011-09-18 13:39:36 +02:00
|
|
|
|
(let* ((lst (plist-get msg field))
|
2011-11-05 09:26:24 +01:00
|
|
|
|
(fieldname (cdr (assoc field mm/header-names)))
|
2011-09-18 13:39:36 +02:00
|
|
|
|
(contacts
|
2011-11-05 09:26:24 +01:00
|
|
|
|
(and lst
|
2011-09-18 13:39:36 +02:00
|
|
|
|
(mapconcat
|
|
|
|
|
(lambda(c)
|
|
|
|
|
(let ((name (car c)) (email (cdr c)))
|
|
|
|
|
(if name
|
|
|
|
|
(format "%s <%s>" name email)
|
|
|
|
|
(format "%s" email)))) lst ", "))))
|
|
|
|
|
(if contacts
|
2011-11-05 09:26:24 +01:00
|
|
|
|
(mm/view-header fieldname contacts)
|
2011-09-18 13:39:36 +02:00
|
|
|
|
"")))
|
|
|
|
|
|
2011-09-19 23:20:59 +02:00
|
|
|
|
(defvar mm/attach-map nil
|
|
|
|
|
"*internal* Hash which maps a number to a (part-id name mime-type).")
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(defun mm/view-attachments (msg)
|
|
|
|
|
"Display attachment information; the field looks like something like:
|
2011-11-20 00:18:12 +01:00
|
|
|
|
:attachments ((:index 4 :name \"test123.doc\"
|
|
|
|
|
:mime-type \"application/msword\" :size 1234))."
|
2011-09-19 23:20:59 +02:00
|
|
|
|
(let ((atts (plist-get msg :attachments)))
|
|
|
|
|
(when atts
|
|
|
|
|
(setq mm/attach-map
|
|
|
|
|
(make-hash-table :size 32 :rehash-size 2 :weakness nil))
|
|
|
|
|
(let* ((id 0)
|
|
|
|
|
(vals
|
|
|
|
|
(mapconcat
|
|
|
|
|
(lambda (att)
|
2011-11-20 00:18:12 +01:00
|
|
|
|
(let ( (index (plist-get att :index))
|
|
|
|
|
(name (plist-get att :name))
|
|
|
|
|
(mime-type (plist-get att :mime-type))
|
|
|
|
|
(size (plist-get att :size)))
|
|
|
|
|
(incf id)
|
|
|
|
|
(puthash id att mm/attach-map)
|
|
|
|
|
(concat
|
|
|
|
|
(propertize (format "[%d]" id) 'face 'mm/view-attach-number-face)
|
|
|
|
|
(propertize name 'face 'mm/view-link-face)
|
|
|
|
|
(if size
|
|
|
|
|
(concat
|
|
|
|
|
"(" (propertize (mm/display-size size) 'face 'mm/view-header-key-face)
|
|
|
|
|
")")
|
|
|
|
|
"")
|
|
|
|
|
)))
|
|
|
|
|
atts ", ")))
|
|
|
|
|
(mm/view-header (format "Attachments(%d)" id) vals t)))))
|
2011-09-19 23:20:59 +02:00
|
|
|
|
|
2011-11-20 09:31:38 +01:00
|
|
|
|
|
2011-10-18 11:39:49 +02:00
|
|
|
|
(defvar mm/view-mode-map nil
|
2011-09-18 13:39:36 +02:00
|
|
|
|
"Keymap for \"*mm-view*\" buffers.")
|
2011-10-18 11:39:49 +02:00
|
|
|
|
(unless mm/view-mode-map
|
|
|
|
|
(setq mm/view-mode-map
|
|
|
|
|
(let ((map (make-sparse-keymap)))
|
|
|
|
|
(define-key map "q" 'mm/view-quit-buffer)
|
|
|
|
|
|
|
|
|
|
(define-key map "s" 'mm/search)
|
|
|
|
|
(define-key map "j" 'mm/jump-to-maildir)
|
2011-11-20 00:18:12 +01:00
|
|
|
|
|
2011-10-18 11:39:49 +02:00
|
|
|
|
(define-key map "g" 'mm/view-go-to-url)
|
|
|
|
|
(define-key map "f" 'mm/compose-forward)
|
|
|
|
|
(define-key map "r" 'mm/compose-reply)
|
|
|
|
|
(define-key map "c" 'mm/compose-new)
|
|
|
|
|
(define-key map "e" 'mm/edit-draft)
|
2011-11-20 00:18:12 +01:00
|
|
|
|
|
2011-11-20 09:31:38 +01:00
|
|
|
|
(define-key map "." 'mm/view-raw)
|
|
|
|
|
|
2011-10-18 11:39:49 +02:00
|
|
|
|
;; intra-message navigation
|
|
|
|
|
(define-key map (kbd "SPC") 'scroll-up)
|
|
|
|
|
(define-key map (kbd "<home>")
|
|
|
|
|
'(lambda () (interactive) (goto-char (point-min))))
|
|
|
|
|
(define-key map (kbd "<end>")
|
|
|
|
|
'(lambda () (interactive) (goto-char (point-max))))
|
|
|
|
|
(define-key map (kbd "RET")
|
|
|
|
|
'(lambda () (interactive) (scroll-up 1)))
|
|
|
|
|
(define-key map (kbd "<backspace>")
|
|
|
|
|
'(lambda () (interactive) (scroll-up -1)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; navigation between messages
|
|
|
|
|
(define-key map "n" 'mm/view-next-header)
|
|
|
|
|
(define-key map "p" 'mm/view-prev-header)
|
2011-11-20 00:18:12 +01:00
|
|
|
|
|
2011-10-18 11:39:49 +02:00
|
|
|
|
;; attachments
|
|
|
|
|
(define-key map "e" 'mm/view-extract-attachment)
|
|
|
|
|
(define-key map "o" 'mm/view-open-attachment)
|
2011-11-20 00:18:12 +01:00
|
|
|
|
|
2011-10-18 11:39:49 +02:00
|
|
|
|
;; marking/unmarking
|
|
|
|
|
(define-key map (kbd "<backspace>") 'mm/mark-for-trash)
|
|
|
|
|
(define-key map "d" 'mm/view-mark-for-trash)
|
2011-11-20 00:18:12 +01:00
|
|
|
|
|
2011-10-18 11:39:49 +02:00
|
|
|
|
(define-key map (kbd "<delete>") 'mm/view-mark-for-delete)
|
|
|
|
|
(define-key map "D" 'mm/view-mark-for-delete)
|
2011-11-05 09:26:24 +01:00
|
|
|
|
(define-key map "a" 'mm/mark-for-move-quick)
|
2011-11-05 11:29:07 +01:00
|
|
|
|
|
2011-10-18 11:39:49 +02:00
|
|
|
|
(define-key map "m" 'mm/view-mark-for-move)
|
2011-11-05 11:29:07 +01:00
|
|
|
|
|
2011-10-18 11:39:49 +02:00
|
|
|
|
;; misc
|
|
|
|
|
(define-key map "w" 'mm/view-toggle-wrap-lines)
|
|
|
|
|
(define-key map "h" 'mm/view-toggle-hide-cited)
|
2011-11-20 00:18:12 +01:00
|
|
|
|
|
2011-10-18 11:39:49 +02:00
|
|
|
|
(define-key map "R" 'mm/view-refresh)
|
2011-11-20 00:18:12 +01:00
|
|
|
|
|
2011-10-18 11:39:49 +02:00
|
|
|
|
;; next 3 only warn user when attempt in the message view
|
|
|
|
|
(define-key map "u" 'mm/view-unmark)
|
|
|
|
|
(define-key map "U" 'mm/view-unmark)
|
|
|
|
|
(define-key map "x" 'mm/view-marked-execute)
|
|
|
|
|
|
|
|
|
|
;; menu
|
|
|
|
|
(define-key map [menu-bar] (make-sparse-keymap))
|
|
|
|
|
(let ((menumap (make-sparse-keymap "View")))
|
|
|
|
|
(define-key map [menu-bar headers] (cons "View" menumap))
|
2011-11-20 00:18:12 +01:00
|
|
|
|
|
2011-11-20 09:31:38 +01:00
|
|
|
|
(define-key menumap [quit-buffer] '("Quit view" . mm/view-quit-buffer))
|
2011-10-18 11:39:49 +02:00
|
|
|
|
|
|
|
|
|
(define-key menumap [sepa0] '("--"))
|
|
|
|
|
(define-key menumap [wrap-lines]
|
|
|
|
|
'("Toggle wrap lines" . mm/view-toggle-wrap-lines))
|
|
|
|
|
(define-key menumap [hide-cited]
|
|
|
|
|
'("Toggle hide cited" . mm/view-toggle-hide-cited))
|
|
|
|
|
|
|
|
|
|
(define-key menumap [sepa8] '("--"))
|
|
|
|
|
(define-key menumap [open-att]
|
|
|
|
|
'("Open attachment" . mm/view-open-attachment))
|
|
|
|
|
(define-key menumap [extract-att]
|
|
|
|
|
'("Extract attachment" . mm/view-extract-attachment))
|
|
|
|
|
(define-key menumap [goto-url]
|
|
|
|
|
'("Visit URL" . mm/view-go-to-url))
|
2011-11-20 00:18:12 +01:00
|
|
|
|
|
2011-10-18 11:39:49 +02:00
|
|
|
|
(define-key menumap [sepa1] '("--"))
|
|
|
|
|
(define-key menumap [mark-delete]
|
|
|
|
|
'("Mark for deletion" . mm/view-mark-for-delete))
|
|
|
|
|
(define-key menumap [mark-trash]
|
|
|
|
|
'("Mark for trash" . mm/view-mark-for-trash))
|
|
|
|
|
(define-key menumap [mark-move]
|
|
|
|
|
'("Mark for move" . mm/view-mark-for-move))
|
2011-11-20 00:18:12 +01:00
|
|
|
|
|
2011-10-18 11:39:49 +02:00
|
|
|
|
(define-key menumap [sepa2] '("--"))
|
|
|
|
|
(define-key menumap [compose-new] '("Compose new" . mm/compose-new))
|
|
|
|
|
(define-key menumap [forward] '("Forward" . mm/compose-forward))
|
|
|
|
|
(define-key menumap [reply] '("Reply" . mm/compose-reply))
|
|
|
|
|
(define-key menumap [sepa3] '("--"))
|
|
|
|
|
|
|
|
|
|
(define-key menumap [search] '("Search" . mm/search))
|
|
|
|
|
(define-key menumap [jump] '("Jump to maildir" . mm/jump-to-maildir))
|
|
|
|
|
|
|
|
|
|
(define-key menumap [sepa4] '("--"))
|
|
|
|
|
(define-key menumap [next] '("Next" . mm/view-next-header))
|
|
|
|
|
(define-key menumap [previous] '("Previous" . mm/view-prev-header)))
|
|
|
|
|
map)))
|
2011-11-20 00:18:12 +01:00
|
|
|
|
|
2011-09-18 13:39:36 +02:00
|
|
|
|
(fset 'mm/view-mode-map mm/view-mode-map)
|
|
|
|
|
|
|
|
|
|
|
2011-09-30 07:37:47 +02:00
|
|
|
|
(defvar mm/wrap-lines nil
|
|
|
|
|
"*internal* Whether to wrap lines or not (variable controlled by
|
|
|
|
|
`mm/view-toggle-wrap-lines').")
|
|
|
|
|
|
|
|
|
|
(defvar mm/hide-cited nil
|
|
|
|
|
"*internal* Whether to hide cited lines or not (the variable can
|
|
|
|
|
be changed with `mm/view-toggle-hide-cited').")
|
|
|
|
|
|
|
|
|
|
|
2011-09-18 13:39:36 +02:00
|
|
|
|
(defun mm/view-mode ()
|
|
|
|
|
"Major mode for viewing an e-mail message."
|
|
|
|
|
(interactive)
|
|
|
|
|
(kill-all-local-variables)
|
|
|
|
|
(use-local-map mm/view-mode-map)
|
|
|
|
|
|
|
|
|
|
(make-local-variable 'mm/hdrs-buffer)
|
|
|
|
|
(make-local-variable 'mm/current-msg)
|
2011-09-20 22:59:20 +02:00
|
|
|
|
(make-local-variable 'mm/link-map)
|
2011-09-30 07:37:47 +02:00
|
|
|
|
|
2011-09-22 20:01:35 +02:00
|
|
|
|
(make-local-variable 'mm/wrap-lines)
|
2011-09-30 07:37:47 +02:00
|
|
|
|
(make-local-variable 'mm/hide-cited)
|
2011-09-18 13:39:36 +02:00
|
|
|
|
|
|
|
|
|
(setq major-mode 'mm/view-mode mode-name mm/view-buffer-name)
|
|
|
|
|
(setq truncate-lines t buffer-read-only t))
|
|
|
|
|
|
|
|
|
|
;;;;;;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; we mark messages are as read when we leave the message; ie., when skipping to
|
|
|
|
|
;; the next/previous one, or leaving the view buffer altogether.
|
|
|
|
|
|
|
|
|
|
(defun mm/view-mark-as-read-maybe ()
|
|
|
|
|
"Clear the current message's New/Unread status and set it to
|
|
|
|
|
Seen; if the message is not New/Unread, do nothing."
|
|
|
|
|
(when mm/current-msg
|
|
|
|
|
(let ((flags (plist-get mm/current-msg :flags))
|
|
|
|
|
(docid (plist-get mm/current-msg :docid)))
|
|
|
|
|
;; is it a new message?
|
|
|
|
|
(when (or (member 'unread flags) (member 'new flags))
|
2011-10-02 20:35:03 +02:00
|
|
|
|
(mm/proc-flag docid "+S-u-N")))))
|
2011-09-18 13:39:36 +02:00
|
|
|
|
|
2011-09-20 22:59:20 +02:00
|
|
|
|
|
|
|
|
|
(defvar mm/link-map nil
|
|
|
|
|
"*internal* A map of some number->url so we can jump to url by number.")
|
|
|
|
|
|
|
|
|
|
(defun mm/view-beautify ()
|
|
|
|
|
"Improve the message view a bit, by making URLs clickable,
|
|
|
|
|
removing '^M' etc."
|
|
|
|
|
(let ((num 0))
|
|
|
|
|
(save-excursion
|
|
|
|
|
;; remove the stupid CRs
|
2011-09-22 20:01:35 +02:00
|
|
|
|
(goto-char (point-min))
|
2011-10-26 21:00:08 +02:00
|
|
|
|
(while (re-search-forward "[\r\240]" nil t)
|
|
|
|
|
(replace-match " " nil t))
|
2011-09-20 22:59:20 +02:00
|
|
|
|
;; give the footer a different color...
|
2011-09-22 20:01:35 +02:00
|
|
|
|
(goto-char (point-min))
|
2011-09-20 22:59:20 +02:00
|
|
|
|
(let ((p (search-forward "\n-- \n" nil t)))
|
|
|
|
|
(when p
|
|
|
|
|
(add-text-properties p (point-max) '(face mm/view-footer-face))))
|
|
|
|
|
;; this is fairly simplistic...
|
|
|
|
|
(goto-char (point-min))
|
2011-11-23 23:15:34 +01:00
|
|
|
|
(while (re-search-forward "\\(https?://[-a-zA-Z0-9?_.$%/=+&#@!~,:]*\\)\\>" nil t)
|
2011-09-20 22:59:20 +02:00
|
|
|
|
(let ((subst (propertize (match-string-no-properties 0)
|
|
|
|
|
'face 'mm/view-link-face)))
|
|
|
|
|
(incf num)
|
|
|
|
|
(puthash num (match-string-no-properties 0) mm/link-map)
|
|
|
|
|
(replace-match (concat subst
|
|
|
|
|
(propertize (format "[%d]" num)
|
|
|
|
|
'face 'mm/view-url-number-face))))))))
|
|
|
|
|
|
|
|
|
|
|
2011-10-10 07:38:14 +02:00
|
|
|
|
|
2011-11-20 09:31:38 +01:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; raw mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
|
|
|
|
(defun mm/view-raw-mode ()
|
|
|
|
|
"Major mode for viewing of raw e-mail message."
|
|
|
|
|
(interactive)
|
|
|
|
|
(kill-all-local-variables)
|
|
|
|
|
(use-local-map mm/view-raw-mode-map)
|
|
|
|
|
|
|
|
|
|
(setq major-mode 'mm/view-raw-mode
|
|
|
|
|
mode-name mm/view-raw-buffer-name)
|
|
|
|
|
(setq truncate-lines t buffer-read-only t))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(defvar mm/view-raw-mode-map nil
|
|
|
|
|
"Keymap for \"*mm-view-raw*\" buffers.")
|
|
|
|
|
|
|
|
|
|
(unless mm/view-raw-mode-map
|
|
|
|
|
(setq mm/view-raw-mode-map
|
|
|
|
|
(let ((map (make-sparse-keymap)))
|
|
|
|
|
|
|
|
|
|
(define-key map "q" 'kill-buffer)
|
|
|
|
|
(define-key map "." 'kill-buffer)
|
|
|
|
|
|
|
|
|
|
;; intra-message navigation
|
|
|
|
|
(define-key map (kbd "SPC") 'scroll-up)
|
|
|
|
|
(define-key map (kbd "<home>")
|
|
|
|
|
'(lambda () (interactive) (goto-char (point-min))))
|
|
|
|
|
(define-key map (kbd "<end>")
|
|
|
|
|
'(lambda () (interactive) (goto-char (point-max))))
|
|
|
|
|
(define-key map (kbd "RET")
|
|
|
|
|
'(lambda () (interactive) (scroll-up 1)))
|
|
|
|
|
(define-key map (kbd "<backspace>")
|
|
|
|
|
'(lambda () (interactive) (scroll-up -1)))
|
|
|
|
|
|
|
|
|
|
;; menu
|
|
|
|
|
(define-key map [menu-bar] (make-sparse-keymap))
|
|
|
|
|
(let ((menumap (make-sparse-keymap "Raw view")))
|
|
|
|
|
(define-key map [menu-bar headers] (cons "Raw view" menumap))
|
|
|
|
|
|
|
|
|
|
(define-key menumap [quit-buffer] '("Quit" . kill-buffer))
|
|
|
|
|
map))))
|
|
|
|
|
|
|
|
|
|
(fset 'mm/view-raw-mode-map mm/view-raw-mode-map)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(defun mm/view-raw-message (msg)
|
|
|
|
|
"Display the raw contents of message MSG in a new buffer."
|
|
|
|
|
(let ((buf (get-buffer-create mm/view-raw-buffer-name))
|
|
|
|
|
(inhibit-read-only t)
|
|
|
|
|
(file (plist-get msg :path)))
|
|
|
|
|
(unless (and file (file-readable-p file))
|
|
|
|
|
(error "Not a readable file: %S" file))
|
|
|
|
|
(with-current-buffer buf
|
|
|
|
|
(erase-buffer)
|
|
|
|
|
(insert-file file)
|
|
|
|
|
;; initialize view-mode
|
|
|
|
|
(mm/view-raw-mode)
|
|
|
|
|
(switch-to-buffer buf)
|
|
|
|
|
(goto-char (point-min)))))
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
|
|
|
|
|
2011-10-10 07:38:14 +02:00
|
|
|
|
|
|
|
|
|
|
2011-09-22 20:01:35 +02:00
|
|
|
|
|
2011-09-18 13:39:36 +02:00
|
|
|
|
;; Interactive functions
|
|
|
|
|
|
2011-09-22 20:01:35 +02:00
|
|
|
|
(defun mm/view-toggle-wrap-lines ()
|
|
|
|
|
"Toggle line wrap in the message body."
|
|
|
|
|
(interactive)
|
2011-09-30 07:37:47 +02:00
|
|
|
|
(if mm/wrap-lines
|
|
|
|
|
(progn
|
|
|
|
|
(setq mm/wrap-lines nil)
|
|
|
|
|
(mm/view-refresh)) ;; back to normal
|
|
|
|
|
(save-excursion
|
2011-09-22 20:01:35 +02:00
|
|
|
|
(let ((inhibit-read-only t))
|
|
|
|
|
(setq mm/wrap-lines t)
|
|
|
|
|
(goto-char (point-min))
|
|
|
|
|
(when (search-forward "\n\n") ;; search for the message body
|
|
|
|
|
(fill-region (point) (point-max)))))))
|
|
|
|
|
|
2011-09-30 07:37:47 +02:00
|
|
|
|
(defun mm/view-toggle-hide-cited ()
|
|
|
|
|
"Toggle hiding of cited lines in the message body."
|
|
|
|
|
(interactive)
|
|
|
|
|
(if mm/hide-cited
|
|
|
|
|
(progn
|
|
|
|
|
(setq mm/hide-cited nil)
|
|
|
|
|
(mm/view-refresh))
|
|
|
|
|
(save-excursion
|
|
|
|
|
(let ((inhibit-read-only t))
|
|
|
|
|
(goto-char (point-min))
|
|
|
|
|
(flush-lines "^[:blank:]*>")
|
|
|
|
|
(setq mm/hide-cited t)))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(defun mm/view-refresh ()
|
|
|
|
|
"Redisplay the current message."
|
|
|
|
|
(interactive)
|
|
|
|
|
(mm/view mm/current-msg mm/hdrs-buffer t))
|
|
|
|
|
|
2011-09-22 20:01:35 +02:00
|
|
|
|
|
2011-09-18 13:39:36 +02:00
|
|
|
|
(defun mm/view-quit-buffer ()
|
|
|
|
|
"Quit the message view and return to the headers."
|
|
|
|
|
(interactive)
|
2011-11-05 11:29:07 +01:00
|
|
|
|
(if (buffer-live-p mm/hdrs-buffer)
|
|
|
|
|
(switch-to-buffer mm/hdrs-buffer)
|
|
|
|
|
(kill-buffer)))
|
2011-09-18 13:39:36 +02:00
|
|
|
|
|
2011-09-20 22:59:20 +02:00
|
|
|
|
(defun mm/view-next-header ()
|
|
|
|
|
"View the next header."
|
2011-09-18 13:39:36 +02:00
|
|
|
|
(interactive)
|
2011-09-20 22:59:20 +02:00
|
|
|
|
(when (mm/next-header)
|
|
|
|
|
(mm/view-message)))
|
2011-09-18 13:39:36 +02:00
|
|
|
|
|
2011-09-20 22:59:20 +02:00
|
|
|
|
(defun mm/view-prev-header ()
|
|
|
|
|
"View the previous header."
|
2011-09-18 13:39:36 +02:00
|
|
|
|
(interactive)
|
2011-09-20 22:59:20 +02:00
|
|
|
|
(when (mm/prev-header)
|
|
|
|
|
(mm/view-message)))
|
2011-09-18 13:39:36 +02:00
|
|
|
|
|
2011-09-20 22:59:20 +02:00
|
|
|
|
(defun mm/view-mark-for-move ()
|
|
|
|
|
"Mark the current message for moving."
|
|
|
|
|
(interactive)
|
|
|
|
|
(when (mm/mark-for-move)
|
|
|
|
|
(mm/view-message)))
|
|
|
|
|
|
|
|
|
|
(defun mm/view-mark-for-trash ()
|
|
|
|
|
"Mark the current message for moving to the trash folder."
|
|
|
|
|
(interactive)
|
|
|
|
|
(when (mm/mark-for-trash)
|
|
|
|
|
(mm/view-message)))
|
|
|
|
|
|
|
|
|
|
(defun mm/view-mark-for-delete ()
|
|
|
|
|
"Mark the current message for deletion."
|
|
|
|
|
(interactive)
|
|
|
|
|
(when (mm/mark-for-delete)
|
|
|
|
|
(mm/view-message)))
|
2011-09-19 23:20:59 +02:00
|
|
|
|
|
|
|
|
|
(defun mm/view-extract-attachment (attnum)
|
|
|
|
|
"Extract the attachment with ATTNUM"
|
|
|
|
|
(unless mm/attachment-dir (error "`mm/attachment-dir' is not set"))
|
2011-11-09 07:35:24 +01:00
|
|
|
|
(when (or (null mm/attach-map) (zerop (hash-table-count mm/attach-map)))
|
2011-09-19 23:20:59 +02:00
|
|
|
|
(error "No attachments for this message"))
|
|
|
|
|
(interactive "nAttachment to extract:")
|
|
|
|
|
(let* ((att (gethash attnum mm/attach-map))
|
|
|
|
|
(path (when att (concat mm/attachment-dir "/" (nth 1 att))))
|
|
|
|
|
(retry t))
|
|
|
|
|
(unless att (error "Not a valid attachment number"))
|
|
|
|
|
(while retry
|
|
|
|
|
(setq path (expand-file-name (read-string "Save as " path)))
|
|
|
|
|
(setq retry
|
|
|
|
|
(and (file-exists-p path)
|
|
|
|
|
(not (y-or-n-p (concat "Overwrite " path "?"))))))
|
|
|
|
|
(mm/proc-save (plist-get mm/current-msg :docid) (car att) path)))
|
|
|
|
|
|
|
|
|
|
(defun mm/view-open-attachment (attnum)
|
|
|
|
|
"Extract the attachment with ATTNUM"
|
|
|
|
|
(when (zerop (hash-table-count mm/attach-map))
|
|
|
|
|
(error "No attachments for this message"))
|
|
|
|
|
(interactive "nAttachment to open:")
|
2011-11-20 00:18:12 +01:00
|
|
|
|
(let* ((att (gethash attnum mm/attach-map))
|
|
|
|
|
(id (and att (plist-get att :index))))
|
|
|
|
|
(unless id (error "Not a valid attachment number"))
|
|
|
|
|
(mm/proc-open (plist-get mm/current-msg :docid) id)))
|
2011-09-19 23:20:59 +02:00
|
|
|
|
|
2011-09-18 13:39:36 +02:00
|
|
|
|
(defun mm/view-unmark ()
|
|
|
|
|
"Warn user that unmarking only works in the header list."
|
|
|
|
|
(interactive)
|
|
|
|
|
(message "Unmarking needs to be done in the header list view"))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(defun mm/view-marked-execute ()
|
|
|
|
|
"Warn user that execution can only take place in n the header
|
|
|
|
|
list."
|
|
|
|
|
(interactive)
|
|
|
|
|
(message "Execution needs to be done in the header list view"))
|
|
|
|
|
|
2011-09-20 22:59:20 +02:00
|
|
|
|
(defun mm/view-go-to-url (num)
|
|
|
|
|
"Go to a numbered url."
|
|
|
|
|
(interactive "nGo to url with number: ")
|
|
|
|
|
(let ((url (gethash num mm/link-map)))
|
|
|
|
|
(unless url (error "Invalid number for URL"))
|
|
|
|
|
(browse-url url)))
|
|
|
|
|
|
2011-11-20 09:31:38 +01:00
|
|
|
|
(defun mm/view-raw ()
|
|
|
|
|
"Show the the raw text of the current message."
|
|
|
|
|
(interactive)
|
|
|
|
|
(unless mm/current-msg
|
|
|
|
|
(error "No current message"))
|
|
|
|
|
(mm/view-raw-message mm/current-msg))
|
|
|
|
|
|
2011-09-18 13:39:36 +02:00
|
|
|
|
|
|
|
|
|
(provide 'mm-view)
|