lisp/mail/rmailedit.el

   1 ;;; rmailedit.el --- "RMAIL edit mode"  Edit the current message
   2
   3 ;; Copyright (C) 1985, 1994, 2001, 2002, 2003, 2004, 2005, 2006,
   4 ;;   2007, 2008, 2009 Free Software Foundation, Inc.
   5
   6 ;; Maintainer: FSF
   7 ;; Keywords: mail
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile
  29   (require 'rmail)
  30   (require 'rmailsum))
  31
  32 (defcustom rmail-edit-mode-hook nil
  33   "List of functions to call when editing an RMAIL message."
  34   :type 'hook
  35   :version "21.1"
  36   :group 'rmail-edit)
  37
  38 (defvar rmail-old-text)
  39
  40 (defvar rmail-edit-map nil)
  41 (if rmail-edit-map
  42     nil
  43   ;; Make a keymap that inherits text-mode-map.
  44   (setq rmail-edit-map (make-sparse-keymap))
  45   (set-keymap-parent rmail-edit-map text-mode-map)
  46   (define-key rmail-edit-map "\C-c\C-c" 'rmail-cease-edit)
  47   (define-key rmail-edit-map "\C-c\C-]" 'rmail-abort-edit))
  48
  49 ;; Rmail Edit mode is suitable only for specially formatted data.
  50 (put 'rmail-edit-mode 'mode-class 'special)
  51
  52 (declare-function rmail-summary-disable "" ())
  53 (declare-function rmail-summary-enable "rmailsum" ())
  54
  55 (defun rmail-edit-mode ()
  56   "Major mode for editing the contents of an RMAIL message.
  57 The editing commands are the same as in Text mode, together with two commands
  58 to return to regular RMAIL:
  59   *  \\[rmail-abort-edit] cancels the changes
  60      you have made and returns to RMAIL
  61   *  \\[rmail-cease-edit] makes them permanent.
  62 This functions runs the normal hook `rmail-edit-mode-hook'.
  63 \\{rmail-edit-map}"
  64   (if (rmail-summary-exists)
  65       (save-excursion
  66         (set-buffer rmail-summary-buffer)
  67         (rmail-summary-disable)))
  68   (let (rmail-buffer-swapped)
  69     ;; Prevent change-major-mode-hook from unswapping the buffers.
  70     (delay-mode-hooks (text-mode))
  71     (use-local-map rmail-edit-map)
  72     (setq major-mode 'rmail-edit-mode)
  73     (setq mode-name "RMAIL Edit")
  74     (if (boundp 'mode-line-modified)
  75         (setq mode-line-modified (default-value 'mode-line-modified))
  76       (setq mode-line-format (default-value 'mode-line-format)))
  77     (run-mode-hooks 'rmail-edit-mode-hook)))
  78
  79 (defvar rmail-old-pruned nil)
  80 (put 'rmail-old-pruned 'permanent-local t)
  81
  82 ;;;###autoload
  83 (defun rmail-edit-current-message ()
  84   "Edit the contents of this message."
  85   (interactive)
  86   (if (= rmail-total-messages 0)
  87       (error "No messages in this buffer"))
  88   (make-local-variable 'rmail-old-pruned)
  89   (setq rmail-old-pruned (eq rmail-header-style 'normal))
  90   (rmail-edit-mode)
  91   (make-local-variable 'rmail-old-text)
  92   (save-restriction
  93     (widen)
  94     (setq rmail-old-text (buffer-substring (point-min) (point-max))))
  95   (setq buffer-read-only nil)
  96   (setq buffer-undo-list nil)
  97   (force-mode-line-update)
  98   (if (and (eq (key-binding "\C-c\C-c") 'rmail-cease-edit)
  99            (eq (key-binding "\C-c\C-]") 'rmail-abort-edit))
 100       (message "Editing: Type C-c C-c to return to Rmail, C-c C-] to abort")
 101     (message "%s" (substitute-command-keys
 102                    "Editing: Type \\[rmail-cease-edit] to return to Rmail, \\[rmail-abort-edit] to abort"))))
 103
 104 (defun rmail-cease-edit ()
 105   "Finish editing message; switch back to Rmail proper."
 106   (interactive)
 107   (if (rmail-summary-exists)
 108       (save-excursion
 109         (set-buffer rmail-summary-buffer)
 110         (rmail-summary-enable)))
 111   (widen)
 112   ;; Disguise any "From " lines so they don't start a new message.
 113   (save-excursion
 114     (goto-char (point-min))
 115     (while (search-forward "\nFrom " nil t)
 116       (beginning-of-line)
 117       (insert ">")))
 118   ;; Make sure buffer ends with a blank line
 119   ;; so as not to run this message together with the following one.
 120   (save-excursion
 121     (goto-char (point-max))
 122     (if (/= (preceding-char) ?\n)
 123         (insert "\n"))
 124     (unless (looking-back "\n\n")
 125       (insert "\n")))
 126   (let ((old rmail-old-text)
 127         character-coding is-text-message coding-system
 128         headers-end)
 129     ;; Go back to Rmail mode, but carefully.
 130     (force-mode-line-update)
 131     (let (rmail-buffer-swapped)
 132       (kill-all-local-variables)
 133       (rmail-mode-1)
 134       (if (boundp 'tool-bar-map)
 135           (set (make-local-variable 'tool-bar-map) rmail-tool-bar-map))
 136       (setq buffer-undo-list t)
 137       (rmail-variables))
 138     ;; If text has really changed, mark message as edited.
 139     (unless (and (= (length old) (- (point-max) (point-min)))
 140                  (string= old (buffer-substring (point-min) (point-max))))
 141       (setq old nil)
 142       (goto-char (point-min))
 143       (search-forward "\n\n")
 144       (setq headers-end (point))
 145
 146       (rmail-swap-buffers-maybe)
 147
 148       (setq character-coding (mail-fetch-field "content-transfer-encoding")
 149             is-text-message (rmail-is-text-p)
 150             coding-system (rmail-get-coding-system))
 151       (if character-coding
 152           (setq character-coding (downcase character-coding)))
 153
 154       (narrow-to-region (rmail-msgbeg rmail-current-message)
 155                         (rmail-msgend rmail-current-message))
 156       (goto-char (point-min))
 157       (search-forward "\n\n")
 158       (let ((inhibit-read-only t)
 159             (headers-end-1 (point)))
 160         (insert-buffer-substring rmail-view-buffer headers-end)
 161         (delete-region (point) (point-max))
 162
 163         ;; Re-encode the message body in whatever
 164         ;; way it was decoded.
 165         (cond
 166          ((string= character-coding "quoted-printable")
 167           (mail-quote-printable-region headers-end-1 (point-max)))
 168          ((and (string= character-coding "base64") is-text-message)
 169           (base64-encode-region headers-end-1 (point-max)))
 170          ((eq character-coding 'uuencode)
 171           (error "Not supported yet."))
 172          (t
 173           (if (or (not coding-system) (not (coding-system-p coding-system)))
 174               (setq coding-system 'undecided))
 175           (encode-coding-region headers-end-1 (point-max) coding-system)))
 176         ))
 177
 178     (rmail-set-attribute rmail-edited-attr-index t)
 179
 180     ;;??? BROKEN perhaps.
 181     ;; I think that the Summary-Line header may not be kept there any more.
 182 ;;;       (if (boundp 'rmail-summary-vector)
 183 ;;;       (progn
 184 ;;;         (aset rmail-summary-vector (1- rmail-current-message) nil)
 185 ;;;         (save-excursion
 186 ;;;           (rmail-widen-to-current-msgbeg
 187 ;;;             (function (lambda ()
 188 ;;;                         (forward-line 2)
 189 ;;;                         (if (looking-at "Summary-line: ")
 190 ;;;                             (let ((buffer-read-only nil))
 191 ;;;                               (delete-region (point)
 192 ;;;                                              (progn (forward-line 1)
 193 ;;;                                                     (point)))))))))))
 194     )
 195
 196   (save-excursion
 197     (rmail-show-message)
 198     (rmail-toggle-header (if rmail-old-pruned 1 0)))
 199   (run-hooks 'rmail-mode-hook))
 200
 201 (defun rmail-abort-edit ()
 202   "Abort edit of current message; restore original contents."
 203   (interactive)
 204   (widen)
 205   (delete-region (point-min) (point-max))
 206   (insert rmail-old-text)
 207   (rmail-cease-edit)
 208   (rmail-highlight-headers))
 209
 210 (provide 'rmailedit)
 211
 212 ;; arch-tag: 9524f335-12cc-4e95-9e9b-3208dc30550b
 213 ;;; rmailedit.el ends here