cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-edit.el

   1 ;;; vm-edit.el --- Editing VM messages
   2 ;;
   3 ;; Copyright (C) 1990, 1991, 1993, 1994, 1997, 2001 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;;
   6 ;; This program is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2 of the License, or
   9 ;; (at your option) any later version.
  10 ;;
  11 ;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License along
  17 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  18 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 ;;; Code:
  21
  22 ;;;###autoload
  23 (defun vm-edit-message (&optional prefix-argument)
  24   "Edit the current message.  Prefix arg means mark as unedited instead.
  25 If editing, the current message is copied into a temporary buffer, and
  26 this buffer is selected for editing.  The major mode of this buffer is
  27 controlled by the variable vm-edit-message-mode.  The hooks specified
  28 in vm-edit-message-hook are run just prior to returning control to the user
  29 for editing.
  30
  31 Use C-c ESC when you have finished editing the message.  The message
  32 will be inserted into its folder replacing the old version of the
  33 message.  If you don't want your edited version of the message to
  34 replace the original, use C-c C-] and the edit will be aborted."
  35   (interactive "P")
  36   (vm-follow-summary-cursor)
  37   (vm-select-folder-buffer)
  38   (vm-check-for-killed-summary)
  39   (vm-check-for-killed-presentation)
  40   (vm-error-if-folder-read-only)
  41   (vm-error-if-folder-empty)
  42   (if (and (vm-virtual-message-p (car vm-message-pointer))
  43            (null (vm-virtual-messages-of (car vm-message-pointer))))
  44       (error "Can't edit unmirrored virtual messages."))
  45   (if prefix-argument
  46       (if (vm-edited-flag (car vm-message-pointer))
  47           (progn
  48             (vm-set-edited-flag-of (car vm-message-pointer) nil)
  49             (vm-update-summary-and-mode-line)))
  50     (let ((mp vm-message-pointer)
  51           (offset (save-excursion
  52                     (if vm-presentation-buffer
  53                         (set-buffer vm-presentation-buffer))
  54                     (- (point) (vm-headers-of (car vm-message-pointer)))))
  55           (edit-buf (vm-edit-buffer-of (car vm-message-pointer)))
  56           (folder-buffer (current-buffer)))
  57       (if (not (and edit-buf (buffer-name edit-buf)))
  58           (progn
  59             (vm-save-restriction
  60               (widen)
  61               (setq edit-buf
  62                     (generate-new-buffer
  63                      (format "edit of %s's note re: %s"
  64                              (vm-su-full-name (car vm-message-pointer))
  65                              (vm-su-subject (car vm-message-pointer)))))
  66               (if vm-fsfemacs-mule-p
  67                   (set-buffer-multibyte nil))
  68               (vm-set-edit-buffer-of (car mp) edit-buf)
  69               (copy-to-buffer edit-buf
  70                               (vm-headers-of (car mp))
  71                               (vm-text-end-of (car mp))))
  72             (set-buffer edit-buf)
  73             (set-buffer-modified-p nil)
  74             (goto-char (point-min))
  75             (if (< offset 0)
  76                 (search-forward "\n\n" nil t)
  77               (forward-char offset))
  78             (funcall (or vm-edit-message-mode 'text-mode))
  79             (set-keymap-parent vm-edit-message-map (current-local-map))
  80             (use-local-map vm-edit-message-map)
  81             ;; (list (car mp)) because a different message may
  82             ;; later be stuffed into a cons linked that is linked
  83             ;; into the folder's message list.
  84             (setq vm-message-pointer (list (car mp))
  85                   vm-mail-buffer folder-buffer
  86                   vm-system-state 'editing
  87                   buffer-offer-save t)
  88             (run-hooks 'vm-edit-message-hook)
  89             (message
  90              (substitute-command-keys
  91               "Type \\[vm-edit-message-end] to end edit, \\[vm-edit-message-abort] to abort with no change.")))
  92         (set-buffer edit-buf))
  93       (if (and vm-mutable-frames vm-frame-per-edit
  94                (vm-multiple-frames-possible-p))
  95           (let ((w (vm-get-buffer-window edit-buf)))
  96             (if (null w)
  97                 (progn
  98                   (vm-goto-new-frame 'edit)
  99                   (vm-set-hooks-for-frame-deletion))
 100               (save-excursion
 101                 (select-window w)
 102                 (and vm-warp-mouse-to-new-frame
 103                      (vm-warp-mouse-to-frame-maybe (vm-window-frame w)))))))
 104       (vm-display edit-buf t '(vm-edit-message vm-edit-message-other-frame)
 105                   (list this-command 'editing-message)))))
 106
 107 ;;;###autoload
 108 (defun vm-edit-message-other-frame (&optional prefix)
 109   "Like vm-edit-message, but run in a newly created frame."
 110   (interactive "P")
 111   (if (vm-multiple-frames-possible-p)
 112       (vm-goto-new-frame 'edit))
 113   (let ((vm-search-other-frames nil)
 114         (vm-frame-per-edit nil))
 115     (vm-edit-message prefix))
 116   (if (vm-multiple-frames-possible-p)
 117       (vm-set-hooks-for-frame-deletion)))
 118
 119 ;;;###autoload
 120 (defun vm-discard-cached-data (&optional count)
 121   "Discard cached information about the current message.
 122 When VM gathers information from the headers of a message, it stores it
 123 internally for future reference.  This command causes VM to forget this
 124 information, and VM will be forced to search the headers of the message
 125 again for these data.  VM will also have to decide again which headers
 126 should be displayed and which should not.  Therefore this command is
 127 useful if you change the value of vm-visible-headers or
 128 vm-invisible-header-regexp in the midst of a VM session.
 129
 130 Numeric prefix argument N means to discard data from the current message
 131 plus the next N-1 messages.  A negative N means discard data from the
 132 current message and the previous N-1 messages.
 133
 134 When invoked on marked messages (via vm-next-command-uses-marks),
 135 data is discarded only from the marked messages in the current folder."
 136   (interactive "p")
 137   (or count (setq count 1))
 138   (vm-follow-summary-cursor)
 139   (vm-select-folder-buffer)
 140   (vm-check-for-killed-summary)
 141   (vm-check-for-killed-presentation)
 142   (vm-error-if-folder-empty)
 143   (let ((mlist (vm-select-marked-or-prefixed-messages count)))
 144     (vm-discard-cached-data-internal mlist))
 145   (vm-display nil nil '(vm-discard-cached-data) '(vm-discard-cached-data))
 146   (vm-update-summary-and-mode-line))
 147
 148 (defun vm-discard-cached-data-internal (mlist)
 149   (let ((buffers-needing-thread-sort (make-vector 29 0))
 150         m)
 151     (while mlist
 152       (setq m (vm-real-message-of (car mlist)))
 153       (vm-garbage-collect-message)
 154       (if (vectorp vm-thread-obarray)
 155           (vm-unthread-message m t))
 156       ;; It was a mistake to store the POP UIDL data here but
 157       ;; it's too late to change it now.  So keep the data from
 158       ;; getting wiped.
 159       (let ((uidl (vm-pop-uidl-of m)))
 160         (fillarray (vm-cache-of m) nil)
 161         (vm-set-pop-uidl-of m uidl))
 162       (vm-set-vheaders-of m nil)
 163       (vm-set-vheaders-regexp-of m nil)
 164       (vm-set-text-of m nil)
 165       (vm-set-mime-layout-of m nil)
 166       (vm-set-mime-encoded-header-flag-of m nil)
 167       (if (and vm-presentation-buffer (eq (car vm-message-pointer) m))
 168           (save-excursion (vm-preview-current-message)))
 169       (if (vectorp vm-thread-obarray)
 170           (vm-build-threads (list m)))
 171       (if vm-summary-show-threads
 172           (intern (buffer-name) buffers-needing-thread-sort))
 173       (let ((v-list (vm-virtual-messages-of m)))
 174         (save-excursion
 175           (while v-list
 176             (vm-set-mime-layout-of (car v-list) nil)
 177             (vm-set-mime-encoded-header-flag-of (car v-list) nil)
 178             (set-buffer (vm-buffer-of (car v-list)))
 179             (if (and vm-presentation-buffer
 180                      (eq (car vm-message-pointer) (car v-list)))
 181                 (save-excursion (vm-preview-current-message)))
 182             (if (vectorp vm-thread-obarray)
 183                 (vm-build-threads (list (car v-list))))
 184             (if vm-summary-show-threads
 185                 (intern (buffer-name) buffers-needing-thread-sort))
 186             (setq v-list (cdr v-list)))))
 187       (vm-mark-for-summary-update m)
 188       (setq mlist (cdr mlist)))
 189     (save-excursion
 190       (mapatoms (function (lambda (s)
 191                             (set-buffer (get-buffer (symbol-name s)))
 192                             (vm-sort-messages "thread")))
 193                 buffers-needing-thread-sort))))
 194
 195 ;;;###autoload
 196 (defun vm-edit-message-end ()
 197   "End the edit of a message and copy the result to its folder."
 198   (interactive)
 199   (if (null vm-message-pointer)
 200       (error "This is not a VM message edit buffer."))
 201   (if (null (buffer-name (vm-buffer-of (car vm-message-pointer))))
 202       (error "The folder buffer for this message has been killed."))
 203   (let ((pos-offset (- (point) (point-min))))
 204     ;; make sure the message ends with a newline
 205     (goto-char (point-max))
 206     (and (/= (preceding-char) ?\n) (insert ?\n))
 207     ;; munge message separators found in the edited message to
 208     ;; prevent message from being split into several messages.
 209     (vm-munge-message-separators (vm-message-type-of (car vm-message-pointer))
 210                                  (point-min) (point-max))
 211     ;; for From_-with-Content-Length recompute the Content-Length header
 212     (if (eq (vm-message-type-of (car vm-message-pointer))
 213             'From_-with-Content-Length)
 214         (let ((buffer-read-only nil)
 215               length)
 216           (goto-char (point-min))
 217           ;; first delete all copies of Content-Length
 218           (while (and (re-search-forward vm-content-length-search-regexp nil t)
 219                       (null (match-beginning 1))
 220                       (progn (goto-char (match-beginning 0))
 221                              (vm-match-header vm-content-length-header)))
 222             (delete-region (vm-matched-header-start) (vm-matched-header-end)))
 223           ;; now compute the message body length
 224           (goto-char (point-min))
 225           (search-forward "\n\n" nil 0)
 226           (setq length (- (point-max) (point)))
 227           ;; insert the header
 228           (goto-char (point-min))
 229           (insert vm-content-length-header " " (int-to-string length) "\n")))
 230     (let ((edit-buf (current-buffer))
 231           (mp vm-message-pointer))
 232       (if (buffer-modified-p)
 233           (progn
 234             (widen)
 235             (save-excursion
 236               (set-buffer (vm-buffer-of (vm-real-message-of (car mp))))
 237               (if (not (memq (vm-real-message-of (car mp)) vm-message-list))
 238                   (error "The original copy of this message has been expunged."))
 239               (vm-save-restriction
 240                (widen)
 241                (goto-char (vm-headers-of (vm-real-message-of (car mp))))
 242                (let ((vm-message-pointer mp)
 243                      opoint
 244                      (buffer-read-only nil))
 245                  (setq opoint (point))
 246                  (insert-buffer-substring edit-buf)
 247                  (delete-region
 248                   (point) (vm-text-end-of (vm-real-message-of (car mp))))
 249                  (vm-discard-cached-data))
 250                (vm-set-edited-flag-of (car mp) t)
 251                (vm-set-edit-buffer-of (car mp) nil))
 252               (set-buffer (vm-buffer-of (car mp)))
 253               (if (eq (vm-real-message-of (car mp))
 254                       (vm-real-message-of (car vm-message-pointer)))
 255                   (progn
 256                     (vm-preview-current-message)
 257                     ;; Try to position the cursor in the message
 258                     ;; window close to where it was in the edit
 259                     ;; window.  This works well for non MIME
 260                     ;; messages, but the cursor drifts badly for
 261                     ;; MIME and for refilled messages.
 262                     (vm-save-buffer-excursion
 263                      (and vm-presentation-buffer
 264                           (set-buffer vm-presentation-buffer))
 265                      (vm-save-restriction
 266                       (vm-save-buffer-excursion
 267                        (widen)
 268                        (let ((osw (selected-window))
 269                              (new-win (vm-get-visible-buffer-window
 270                                        (current-buffer))))
 271                          (unwind-protect
 272                              (if new-win
 273                                  (progn
 274                                    (select-window new-win)
 275                                    (goto-char (vm-headers-of
 276                                                (car vm-message-pointer)))
 277                                    (condition-case nil
 278                                        (forward-char pos-offset)
 279                                      (error nil))))
 280                            (if (not (eq osw (selected-window)))
 281                                (select-window osw))))))))
 282                 (vm-update-summary-and-mode-line))))
 283         (message "No change."))
 284       (vm-display edit-buf nil '(vm-edit-message-end)
 285                   '(vm-edit-message-end reading-message startup))
 286       (set-buffer-modified-p nil)
 287       (kill-buffer edit-buf))))
 288
 289 (defun vm-edit-message-abort ()
 290   "Abort the edit of a message, forgetting changes to the message."
 291   (interactive)
 292   (if (null vm-message-pointer)
 293       (error "This is not a VM message edit buffer."))
 294   (if (null (buffer-name (vm-buffer-of (vm-real-message-of (car vm-message-pointer)))))
 295       (error "The folder buffer for this message has been killed."))
 296   (vm-set-edit-buffer-of (car vm-message-pointer) nil)
 297   (vm-display (current-buffer) nil
 298               '(vm-edit-message-abort)
 299               '(vm-edit-message-abort reading-message startup))
 300   (set-buffer-modified-p nil)
 301   (kill-buffer (current-buffer))
 302   (message "Aborted, no change."))
 303
 304 (provide 'vm-edit)
 305
 306 ;;; vm-edit.el ends here