cgit.sxemacs.org Git - gnus/blob - lisp/message-utils.el

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