git.chise.org Git - elisp/gnus.git-/blob - lisp/message-utils.el

   1 ;;; message-utils.el -- utils for message-mode
   2
   3 ;; Copyright (C) 2002 Free Software Foundation, Inc.
   4
   5 ;; Author: Holger Schauer <Holger.Schauer@gmx.de>
   6 ;; Keywords: utils message
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2 of the License, or
  13 ;; (at your option) any later version.
  14 ;;
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This file contains some small additions to message mode:
  28 ;;    * inserting files in a message and explicit marking it
  29 ;;      as something somebody else has created,
  30 ;;    * change Subject: header and add (was: <old subject>)
  31 ;;    * strip (was: <old subject>) from Subject: headers
  32 ;;    * add a X-No-Archieve: Yes header and a note in the body
  33 ;;    * a function for cross-post and followup-to messages
  34 ;;    * replace To: header with contents of Cc: or Bcc: header.
  35 ;;
  36
  37 ;; This file is adopt from the link below when the revision is 0.8.
  38 ;;  http://www.coling.uni-freiburg.de/~schauer/resources/emacs/message-utils.el.gz
  39
  40 ;;; Installation: (TODO: merge into message.el)
  41
  42 ;; .. is easy as in most cases. Add
  43 ;; (autoload 'message-mark-inserted-region "message-utils" nil t)
  44 ;; (autoload 'message-mark-insert-file "message-utils" nil t)
  45 ;; (autoload 'message-strip-subject-was "message-utils" nil t)
  46 ;; (autoload 'message-change-subject "message-utils" nil t)
  47 ;; (autoload 'message-xpost-fup2 "message-utils" nil t)
  48 ;; (autoload 'message-add-archive-header "message-utils" nil t)
  49 ;; (autoload 'message-reduce-to-to-cc "message-utils" nil t)
  50 ;; as well as some keybindings like
  51 ;; (define-key message-mode-map '[(control c) m] 'message-mark-inserted-region)
  52 ;; (define-key message-mode-map '[(control c) f] 'message-mark-insert-file)
  53 ;; (define-key message-mode-map '[(control c) x] 'message-xpost-fup2)
  54 ;; (define-key message-mode-map '[(control c) s] 'message-change-subject)
  55 ;; (define-key message-mode-map '[(control c) a] 'message-add-archive-header)
  56 ;; (define-key message-mode-map '[(control c) t] 'message-reduce-to-to-cc)
  57 ;; (add-hook 'message-header-setup-hook 'message-strip-subject-was)
  58 ;; to your .gnus or to your .emacs.
  59 ;; You might also want to add something along the following lines:
  60 ;; (defun message-utils-setup ()
  61 ;;  "Add menu-entries for message-utils."
  62 ;;  (easy-menu-add-item nil '("Message")
  63 ;;   ["Insert Region Marked" message-mark-inserted-region t] "Spellcheck")
  64 ;;  (easy-menu-add-item nil '("Message")
  65 ;;   ["Insert File Marked" message-mark-insert-file t] "Spellcheck")
  66 ;;  (easy-menu-add-item nil '("Field")
  67 ;;   ["Crosspost / Followup" message-xpost-fup2 t] "----")
  68 ;;  (easy-menu-add-item nil '("Field")
  69 ;;   ["New Subject" message-change-subject t] "----")
  70 ;;  (easy-menu-add-item nil '("Field")
  71 ;;   ["Reduce To: to Cc:" message-reduce-to-to-cc t] "----")
  72 ;;  (easy-menu-add-item nil '("Field")
  73 ;;   [ "X-No-Archive:" message-add-archive-header t ]))
  74 ;; (add-hook 'message-mode-hook 'message-utils-setup)
  75
  76 ;;; Code:
  77
  78 (require 'message)
  79
  80 ;;; **************
  81 ;;; Inserting and marking ...
  82
  83 ; We try to hook the vars into the message customize group
  84
  85 (defcustom message-begin-inserted-text-mark
  86 "--8<------------------------schnipp------------------------->8---\n"
  87 "How to mark the beginning of some inserted text."
  88  :type 'string
  89  :group 'message-various)
  90
  91 (defcustom message-end-inserted-text-mark
  92 "--8<------------------------schnapp------------------------->8---\n"
  93 "How to mark the end of some inserted text."
  94  :type 'string
  95  :group 'message-various)
  96
  97 ;;;###autoload
  98 (defun message-mark-inserted-region (beg end)
  99   "Mark some region in the current article with enclosing tags.
 100 See `message-begin-inserted-text-mark' and `message-end-inserted-text-mark'."
 101   (interactive "r")
 102   (save-excursion
 103     ; add to the end of the region first, otherwise end would be invalid
 104     (goto-char end)
 105     (insert message-end-inserted-text-mark)
 106     (goto-char beg)
 107     (insert message-begin-inserted-text-mark)))
 108
 109 ;;;###autoload
 110 (defun message-mark-insert-file (file)
 111   "Inserts FILE at point, marking it with enclosing tags.
 112 See `message-begin-inserted-text-mark' and `message-end-inserted-text-mark'."
 113   (interactive "fFile to insert: ")
 114     ;; reverse insertion to get correct result.
 115   (let ((p (point)))
 116     (insert message-end-inserted-text-mark)
 117     (goto-char p)
 118     (insert-file-contents file)
 119     (goto-char p)
 120     (insert message-begin-inserted-text-mark)))
 121
 122 ;;; **************
 123 ;;; Subject mangling
 124
 125 (defcustom message-subject-was-regexp
 126   "[ \t]*\\((*[Ww][Aa][SsRr]:[ \t]*.*)\\)"
 127   "*Regexp matching \"(was: <old subject>)\" in the subject line."
 128   :group 'message-various
 129   :type 'regexp)
 130
 131 ;;;###autoload
 132 (defun message-strip-subject-was ()
 133   "Remove trailing \"(Was: <old subject>)\" from subject lines."
 134   (message-narrow-to-head)
 135   (let* ((subject (message-fetch-field "Subject"))
 136          (pos))
 137     (cond (subject
 138            (setq pos (or (string-match message-subject-was-regexp subject) 0))
 139            (cond ((> pos 0)
 140                   (message-goto-subject)
 141                   (message-delete-line)
 142                   (insert (concat "Subject: "
 143                                   (substring subject 0 pos) "\n")))))))
 144     (widen))
 145
 146 ;;; Suggested by Jonas Steverud  @  www.dtek.chalmers.se/~d4jonas/
 147 ;;;###autoload
 148 (defun message-change-subject (new-subject)
 149   "Ask for new Subject: header, append (was: <Old Subject>)."
 150   (interactive
 151    (list
 152     (read-from-minibuffer "New subject: ")))
 153   (cond ((and (not (or (null new-subject) ; new subject not empty
 154                        (zerop (string-width new-subject))
 155                        (string-match "^[ \t]*$" new-subject))))
 156          (save-excursion
 157            (let ((old-subject (message-fetch-field "Subject")))
 158              (cond ((not (string-match
 159                           (concat "^[ \t]*"
 160                                   (regexp-quote new-subject)
 161                                   " \t]*$")
 162                           old-subject))  ; yes, it really is a new subject
 163                     ;; delete eventual Re: prefix
 164                     (setq old-subject
 165                           (message-strip-subject-re old-subject))
 166                     (message-goto-subject)
 167                     (message-delete-line)
 168                     (insert (concat "Subject: "
 169                                     new-subject
 170                                     " (was: "
 171                                     old-subject ")\n")))))))))
 172
 173
 174 ;;; **************
 175 ;;; X-Archive-Header: No
 176
 177 (defcustom message-archive-header
 178   "X-No-Archive: Yes\n"
 179   "Header to insert when you don't want your article to be archived by deja.com."
 180   :type 'string
 181   :group 'message-various)
 182
 183 (defcustom message-archive-note
 184   "X-No-Archive: Yes - save http://deja.com/"
 185   "Note to insert why you wouldn't want this posting archived."
 186   :type 'string
 187   :group 'message-various)
 188
 189 (defun message-add-archive-header ()
 190   "Insert \"X-No-Archive: Yes\" in the header and a note in the body.
 191 When called with a prefix argument, ask for a text to insert."
 192   (interactive)
 193   (if current-prefix-arg
 194       (setq message-archive-note
 195             (read-from-minibuffer "Reason for No-Archive: "
 196                                   (cons message-archive-note 0))))
 197   (save-excursion
 198     (insert message-archive-note)
 199     (newline)
 200     (message-add-header message-archive-header)
 201     (message-sort-headers)))
 202
 203 ;;; **************
 204 ;;; Crossposts and Followups
 205
 206 ; inspired by JoH-followup-to by Jochem Huhman <joh  at gmx.de>
 207 ; new suggestions by R. Weikusat <rw at another.de>
 208
 209 (defvar message-xpost-old-target nil
 210   "Old target for cross-posts or follow-ups.")
 211 (make-variable-buffer-local 'message-xpost-old-target)
 212
 213 (defcustom message-xpost-default t
 214   "When non-nil `mesage-xpost-fup2' will normally perform a crosspost.
 215 If nil, `message-xpost-fup2' will only do a followup. Note that you
 216 can explicitly override this setting by calling `message-xpost-fup2'
 217 with a prefix."
 218   :type 'boolean
 219   :group 'message-various)
 220
 221 (defun message-xpost-fup2-header (target-group)
 222   "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP.
 223 With prefix-argument just set Follow-Up, don't cross-post."
 224   (interactive
 225    (list ; Completion based on Gnus
 226     (completing-read "Follwup To: "
 227                      (if (boundp 'gnus-newsrc-alist)
 228                          gnus-newsrc-alist)
 229                      nil nil '("poster" . 0)
 230                      (if (boundp 'gnus-group-history)
 231                          'gnus-group-history))))
 232   (message-remove-header "Follow[Uu]p-[Tt]o" t)
 233   (message-goto-newsgroups)
 234   (beginning-of-line)
 235   ;; if we already did a crosspost before, kill old target
 236   (if (and message-xpost-old-target
 237            (re-search-forward
 238             (regexp-quote (concat "," message-xpost-old-target))
 239             nil t))
 240       (replace-match ""))
 241   ;; unless (followup is to poster or user explicitly asked not
 242   ;; to cross-post, or target-group is already in Newsgroups)
 243   ;; add target-group to Newsgroups line.
 244   (cond ((and (or (and message-xpost-default (not current-prefix-arg))  ; def: xpost, req:no
 245                   (and (not message-xpost-default) current-prefix-arg)) ; def: no-xpost, req:yes
 246               (not (string-match "poster" target-group))
 247               (not (string-match (regexp-quote target-group)
 248                                  (message-fetch-field "Newsgroups"))))
 249          (end-of-line)
 250          (insert-string (concat "," target-group))))
 251   (end-of-line) ; ensure Followup: comes after Newsgroups:
 252   ;; unless new followup would be identical to Newsgroups line
 253   ;; make a new Followup-To line
 254   (if (not (string-match (concat "^[ \t]*"
 255                                  target-group
 256                                  "[ \t]*$")
 257                          (message-fetch-field "Newsgroups")))
 258       (insert (concat "\nFollowup-To: " target-group)))
 259   (setq message-xpost-old-target target-group))
 260
 261
 262 (defcustom message-xpost-note
 263   "Crosspost & Followup-To: "
 264   "Note to insert before signature to notify of xpost and follow-up."
 265  :type 'string
 266  :group 'message-various)
 267
 268 (defcustom message-fup2-note
 269   "Followup-To: "
 270   "Note to insert before signature to notify of follow-up only."
 271  :type 'string
 272  :group 'message-various)
 273
 274 (defun message-xpost-insert-note (target-group xpost in-old old-groups)
 275   "Insert a in message body note about a set Followup or Crosspost.
 276 If there have been previous notes, delete them. TARGET-GROUP specifies the
 277 group to Followup-To. When XPOST is t, insert note about
 278 crossposting. IN-OLD specifies whether TARGET-GROUP is a member of
 279 OLD-GROUPS. OLD-GROUPS lists the old-groups the posting would have
 280 been made to before the user asked for a Crosspost."
 281   ;; start scanning body for previous uses
 282   (message-goto-signature)
 283   (let ((head (re-search-backward
 284                (concat "^" mail-header-separator)
 285                nil t))) ; just search in body
 286     (message-goto-signature)
 287     (while (re-search-backward
 288             (concat "^" (regexp-quote message-xpost-note) ".*")
 289             head t)
 290       (message-delete-line))
 291     (message-goto-signature)
 292     (while (re-search-backward
 293             (concat "^" (regexp-quote message-fup2-note) ".*")
 294             head t)
 295       (message-delete-line))
 296   ;; insert new note
 297   (message-goto-signature)
 298   (previous-line 2)
 299   (open-line 1)
 300   (if (or in-old
 301           (not xpost)
 302           (string-match "^[ \t]*poster[ \t]*$" target-group))
 303       (insert (concat message-fup2-note target-group "\n"))
 304     (insert (concat message-xpost-note target-group "\n")))))
 305
 306 (defcustom message-xpost-note-function
 307   'message-xpost-insert-note
 308   "Function to use to insert note about Crosspost or Followup-To.
 309 The function will be called with four arguments. The function should not
 310 only insert a note, but also ensure old notes are deleted. See the
 311 documentation for `message-xpost-insert-note'. "
 312   :type 'function
 313   :group 'message-various)
 314
 315 ;;;###autoload
 316 (defun message-xpost-fup2 (target-group)
 317   "Crossposts message and sets Followup-To to TARGET-GROUP.
 318 With prefix-argument just set Follow-Up, don't cross-post."
 319   (interactive
 320    (list ; Completion based on Gnus
 321     (completing-read "Follwup To: "
 322                      (if (boundp 'gnus-newsrc-alist)
 323                          gnus-newsrc-alist)
 324                      nil nil '("poster" . 0)
 325                      (if (boundp 'gnus-group-history)
 326                          'gnus-group-history))))
 327   (cond ((not (or (null target-group) ; new subject not empty
 328                   (zerop (string-width target-group))
 329                   (string-match "^[ \t]*$" target-group)))
 330          (save-excursion
 331            (let* ((old-groups (message-fetch-field "Newsgroups"))
 332                   (in-old (string-match
 333                            (regexp-quote target-group) old-groups)))
 334              ;; check whether target exactly matches old Newsgroups
 335              (cond ((or (not in-old)
 336                         (not (string-match
 337                               (concat "^[ \t]*"
 338                                       (regexp-quote target-group)
 339                                       "[ \t]*$")
 340                               old-groups)))
 341                     ;; yes, Newsgroups line must change
 342                     (message-xpost-fup2-header target-group)
 343                     ;; insert note whether we do xpost or fup2
 344                     (funcall message-xpost-note-function
 345                              target-group
 346                              (if (or (and message-xpost-default (not current-prefix-arg))
 347                                      (and (not message-xpost-default) current-prefix-arg))
 348                                  t)
 349                              in-old old-groups))))))))
 350
 351
 352 ;;; **************
 353 ;;; Reduce To: to Cc: or Bcc: header
 354
 355 (defun message-reduce-to-to-cc ()
 356  "Replace contents of To: header with contents of Cc: or Bcc: header."
 357  (interactive)
 358  (let ((cc-content (message-fetch-field "cc"))
 359        (bcc nil))
 360    (if (and (not cc-content)
 361             (setq cc-content (message-fetch-field "bcc")))
 362        (setq bcc t))
 363    (cond (cc-content
 364           (save-excursion
 365             (message-goto-to)
 366             (message-delete-line)
 367             (insert (concat "To: " cc-content "\n"))
 368             (message-remove-header (if bcc
 369                                        "bcc"
 370                                      "cc")))))))
 371
 372 ;;; provide ourself
 373 (provide 'message-utils)
 374
 375 ;;; message-utils.el ends here