Readd missing el
authorJoerg Jaspert <joerg@debian.org>
Sat, 1 Oct 2016 11:36:49 +0000 (13:36 +0200)
committerJoerg Jaspert <joerg@debian.org>
Sat, 1 Oct 2016 11:36:49 +0000 (13:36 +0200)
.emacs.d/elisp/local/message-utils.el [new file with mode: 0644]

diff --git a/.emacs.d/elisp/local/message-utils.el b/.emacs.d/elisp/local/message-utils.el
new file mode 100644 (file)
index 0000000..a32f7a1
--- /dev/null
@@ -0,0 +1,393 @@
+;;; -*- Mode: Emacs-Lisp -*- 
+;;; message-utils.el -- Utils for message-mode
+;;; Revision: 0.8
+;;; $Id: message-utils.el,v 1.17 2000/06/19 10:29:25 schauer Exp $
+
+;; Author: Holger Schauer <Holger.Schauer@gmx.de>
+;; Keywords: utils message 
+
+;;; This program 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 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program 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 this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Summary:
+
+;; This file contains some small additions to message mode:
+;;    * inserting files in a message and explicit marking it 
+;;      as something somebody else has created,
+;;    * change Subject: header and add (was: <old subject>)
+;;    * strip (was: <old subject>) from Subject: headers
+;;    * add a X-No-Archieve: Yes header and a note in the body
+;;    * a function for cross-post and followup-to messages
+;;    * replace To: header with contents of Cc: or Bcc: header.
+;;
+;; Where to get this file: 
+;;  http://www.coling.uni-freiburg.de/~schauer/resources/emacs/message-utils.el.gz
+
+;;; Installation:
+
+;; .. is easy as in most cases. Add this file to where your
+;; Emacs can find it and add
+;; (autoload 'message-mark-inserted-region "message-utils" nil t)
+;; (autoload 'message-mark-insert-file "message-utils" nil t)
+;; (autoload 'message-strip-subject-was "message-utils" nil t)
+;; (autoload 'message-change-subject "message-utils" nil t)
+;; (autoload 'message-xpost-fup2 "message-utils" nil t)
+;; (autoload 'message-add-archive-header "message-utils" nil t)
+;; (autoload 'message-reduce-to-to-cc "message-utils" nil t)
+;; as well as some keybindings like
+;; (define-key message-mode-map '[(control c) m] 'message-mark-inserted-region)
+;; (define-key message-mode-map '[(control c) f] 'message-mark-insert-file) 
+;; (define-key message-mode-map '[(control c) x] 'message-xpost-fup2)
+;; (define-key message-mode-map '[(control c) s] 'message-change-subject)
+;; (define-key message-mode-map '[(control c) a] 'message-add-archive-header)
+;; (define-key message-mode-map '[(control c) t] 'message-reduce-to-to-cc)
+;; (add-hook 'message-header-setup-hook 'message-strip-subject-was)
+;; to your .gnus or to your .emacs.
+;; You might also want to add something along the following lines:
+;; (defun message-utils-setup ()
+;;  "Add menu-entries for message-utils."
+;;  (easy-menu-add-item nil '("Message")
+;;   ["Insert Region Marked" message-mark-inserted-region t] "Spellcheck")
+;;  (easy-menu-add-item nil '("Message")
+;;   ["Insert File Marked" message-mark-insert-file t] "Spellcheck")
+;;  (easy-menu-add-item nil '("Field")  
+;;   ["Crosspost / Followup" message-xpost-fup2 t] "----")
+;;  (easy-menu-add-item nil '("Field")
+;;   ["New Subject" message-change-subject t] "----")
+;;  (easy-menu-add-item nil '("Field")
+;;   ["Reduce To: to Cc:" message-reduce-to-to-cc t] "----")
+;;  (easy-menu-add-item nil '("Field") 
+;;   [ "X-No-Archive:" message-add-archive-header t ]))
+;;
+;;  You may then use it like this:
+;; (add-hook 'message-mode-hook 'message-utils-setup)
+
+
+
+(require 'message)
+
+;;; **************
+;;; Preliminaries
+
+;; Incantations to make custom stuff work without customize, e.g. on
+;; XEmacs 19.14 or GNU Emacs 19.34. Stolen from htmlize.el by Hrovje Niksic.
+(eval-and-compile
+  (condition-case ()
+      (require 'custom)
+    (error nil))
+  (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
+      nil ;; We've got what we needed
+    ;; We have the old custom-library, hack around it!
+    (defmacro defgroup (&rest args)
+      nil)
+    (defmacro defcustom (var value doc &rest args) 
+      (` (defvar (, var) (, value) (, doc))))
+    (defmacro defface (face value doc &rest stuff)
+      `(make-face ,face))))
+
+;;; **************
+;;; Inserting and marking ...
+
+; We try to hook the vars into the message customize group
+
+(defcustom message-begin-inserted-text-mark
+"--8<------------------------schnipp------------------------->8---\n"
+"How to mark the beginning of some inserted text."
+ :type 'string
+ :group 'message-various)
+
+(defcustom message-end-inserted-text-mark
+"--8<------------------------schnapp------------------------->8---\n"
+"How to mark the end of some inserted text."
+ :type 'string
+ :group 'message-various)
+
+;;;###autoload
+(defun message-mark-inserted-region (beg end)
+  "Mark some region in the current article with enclosing tags.
+See `message-begin-inserted-text-mark' and `message-end-inserted-text-mark'."
+  (interactive "r")
+  (save-excursion
+    ; add to the end of the region first, otherwise end would be invalid
+    (goto-char end)
+    (insert message-end-inserted-text-mark)
+    (goto-char beg)
+    (insert message-begin-inserted-text-mark)))
+
+;;;###autoload
+(defun message-mark-insert-file (file)
+  "Inserts FILE at point, marking it with enclosing tags.
+See `message-begin-inserted-text-mark' and `message-end-inserted-text-mark'."
+  (interactive "fFile to insert: ")
+    ;; reverse insertion to get correct result.
+  (let ((p (point)))
+    (insert message-end-inserted-text-mark)
+    (goto-char p)
+    (insert-file-contents file)
+    (goto-char p)
+    (insert message-begin-inserted-text-mark)))
+
+;;; **************
+;;; Subject mangling
+
+(defcustom message-subject-was-regexp 
+  "[ \t]*\\((*[Ww][Aa][SsRr]:[ \t]*.*)\\)"
+  "*Regexp matching \"(was: <old subject>)\" in the subject line."
+  :group 'message-various
+  :type 'regexp)
+  
+;;;###autoload
+(defun message-strip-subject-was ()
+  "Remove trailing \"(Was: <old subject>)\" from subject lines."
+  (message-narrow-to-head)
+  (let* ((subject (message-fetch-field "Subject"))
+        (pos))
+    (cond (subject
+          (setq pos (or (string-match message-subject-was-regexp subject) 0))
+          (cond ((> pos 0)
+                 (message-goto-subject)
+                 (message-delete-line)
+                 (insert (concat "Subject: " 
+                                 (substring subject 0 pos) "\n")))))))
+    (widen))
+
+;;; Suggested by Jonas Steverud  @  www.dtek.chalmers.se/~d4jonas/
+;;;###autoload
+(defun message-change-subject (new-subject)
+  "Ask for new Subject: header, append (was: <Old Subject>)."
+  (interactive
+   (list 
+    (read-from-minibuffer "New subject: ")))
+  (cond ((and (not (or (null new-subject) ; new subject not empty
+                      (zerop (string-width new-subject))
+                      (string-match "^[ \t]*$" new-subject))))
+        (save-excursion
+          (let ((old-subject (message-fetch-field "Subject")))
+            (cond ((not (string-match 
+                         (concat "^[ \t]*" 
+                                 (regexp-quote new-subject) 
+                                 " \t]*$")
+                         old-subject))  ; yes, it really is a new subject
+                   ;; delete eventual Re: prefix
+                   (setq old-subject 
+                         (message-strip-subject-re old-subject))
+                   (message-goto-subject)
+                   (message-delete-line)
+                   (insert (concat "Subject: " 
+                                   new-subject
+                                   " (was: "
+                                   old-subject ")\n")))))))))
+
+
+;;; **************
+;;; X-Archive-Header: No
+
+(defcustom message-archive-header
+  "X-No-Archive: Yes\n"
+  "Header to insert when you don't want your article to be archived by deja.com."
+  :type 'string
+  :group 'message-various)
+
+(defcustom message-archive-note
+  "X-No-Archive: Yes - save http://deja.com/"
+  "Note to insert why you wouldn't want this posting archived."
+  :type 'string
+  :group 'message-various)
+
+(defun message-add-archive-header ()
+  "Insert \"X-No-Archive: Yes\" in the header and a note in the body.
+When called with a prefix argument, ask for a text to insert."
+  (interactive)
+  (if current-prefix-arg
+      (setq message-archive-note
+           (read-from-minibuffer "Reason for No-Archive: "
+                                 (cons message-archive-note 0))))
+  (save-excursion
+    (insert message-archive-note)
+    (newline)
+    (message-add-header message-archive-header)
+    (message-sort-headers)))
+
+;;; **************
+;;; Crossposts and Followups      
+
+; inspired by JoH-followup-to by Jochem Huhman <joh  at gmx.de>
+; new suggestions by R. Weikusat <rw at another.de>
+
+(defvar message-xpost-old-target nil
+  "Old target for cross-posts or follow-ups.")
+(make-variable-buffer-local 'message-xpost-old-target)
+
+(defcustom message-xpost-default t
+  "When non-nil `mesage-xpost-fup2' will normally perform a crosspost.
+If nil, `message-xpost-fup2' will only do a followup. Note that you
+can explicitly override this setting by calling `message-xpost-fup2'
+with a prefix."
+  :type 'boolean
+  :group 'message-various)
+
+(defun message-xpost-fup2-header (target-group)
+  "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP.
+With prefix-argument just set Follow-Up, don't cross-post."
+  (interactive
+   (list ; Completion based on Gnus
+    (completing-read "Follwup To: "
+                    (if (boundp 'gnus-newsrc-alist)
+                        gnus-newsrc-alist)
+                    nil nil '("poster" . 0) 
+                    (if (boundp 'gnus-group-history)
+                        'gnus-group-history))))
+  (message-remove-header "Follow[Uu]p-[Tt]o" t)
+  (message-goto-newsgroups)
+  (beginning-of-line)
+  ;; if we already did a crosspost before, kill old target
+  (if (and message-xpost-old-target
+          (re-search-forward 
+           (regexp-quote (concat "," message-xpost-old-target))
+           nil t))
+      (replace-match ""))
+  ;; unless (followup is to poster or user explicitly asked not
+  ;; to cross-post, or target-group is already in Newsgroups)
+  ;; add target-group to Newsgroups line.
+  (cond ((and (or (and message-xpost-default (not current-prefix-arg))  ; def: xpost, req:no
+                 (and (not message-xpost-default) current-prefix-arg)) ; def: no-xpost, req:yes
+             (not (string-match "poster" target-group))
+             (not (string-match (regexp-quote target-group) 
+                                (message-fetch-field "Newsgroups"))))
+        (end-of-line)
+        (insert-string (concat "," target-group))))
+  (end-of-line) ; ensure Followup: comes after Newsgroups:
+  ;; unless new followup would be identical to Newsgroups line
+  ;; make a new Followup-To line
+  (if (not (string-match (concat "^[ \t]*" 
+                                target-group 
+                                "[ \t]*$")
+                        (message-fetch-field "Newsgroups")))
+      (insert (concat "\nFollowup-To: " target-group)))
+  (setq message-xpost-old-target target-group))
+
+
+(defcustom message-xpost-note
+  "Crosspost & Followup-To: "
+  "Note to insert before signature to notify of xpost and follow-up."
+ :type 'string
+ :group 'message-various)
+
+(defcustom message-fup2-note
+  "Followup-To: "
+  "Note to insert before signature to notify of follow-up only."
+ :type 'string
+ :group 'message-various)
+
+(defun message-xpost-insert-note (target-group xpost in-old old-groups)
+  "Insert a in message body note about a set Followup or Crosspost.
+If there have been previous notes, delete them. TARGET-GROUP specifies the
+group to Followup-To. When XPOST is t, insert note about
+crossposting. IN-OLD specifies whether TARGET-GROUP is a member of
+OLD-GROUPS. OLD-GROUPS lists the old-groups the posting would have
+been made to before the user asked for a Crosspost."
+  ;; start scanning body for previous uses
+  (message-goto-signature)
+  (let ((head (re-search-backward 
+              (concat "^" mail-header-separator) 
+              nil t))) ; just search in body
+    (message-goto-signature)
+    (while (re-search-backward 
+           (concat "^" (regexp-quote message-xpost-note) ".*")
+           head t)
+      (message-delete-line))
+    (message-goto-signature)
+    (while (re-search-backward 
+           (concat "^" (regexp-quote message-fup2-note) ".*")
+           head t)
+      (message-delete-line))
+  ;; insert new note
+  (message-goto-signature)
+  (previous-line 2)
+  (open-line 1)
+  (if (or in-old
+         (not xpost)
+         (string-match "^[ \t]*poster[ \t]*$" target-group))
+      (insert (concat message-fup2-note target-group "\n"))
+    (insert (concat message-xpost-note target-group "\n")))))
+
+(defcustom message-xpost-note-function
+  'message-xpost-insert-note
+  "Function to use to insert note about Crosspost or Followup-To.
+The function will be called with four arguments. The function should not 
+only insert a note, but also ensure old notes are deleted. See the 
+documentation for `message-xpost-insert-note'. "
+  :type 'function
+  :group 'message-various)
+
+;;;###autoload
+(defun message-xpost-fup2 (target-group)
+  "Crossposts message and sets Followup-To to TARGET-GROUP.
+With prefix-argument just set Follow-Up, don't cross-post."
+  (interactive
+   (list ; Completion based on Gnus
+    (completing-read "Follwup To: "
+                    (if (boundp 'gnus-newsrc-alist)
+                        gnus-newsrc-alist)
+                    nil nil '("poster" . 0) 
+                    (if (boundp 'gnus-group-history)
+                        'gnus-group-history))))
+  (cond ((not (or (null target-group) ; new subject not empty
+                 (zerop (string-width target-group))
+                 (string-match "^[ \t]*$" target-group)))
+        (save-excursion
+          (let* ((old-groups (message-fetch-field "Newsgroups"))
+                 (in-old (string-match 
+                          (regexp-quote target-group) old-groups)))
+            ;; check whether target exactly matches old Newsgroups
+            (cond ((or (not in-old)       
+                       (not (string-match 
+                             (concat "^[ \t]*"
+                                     (regexp-quote target-group)
+                                     "[ \t]*$")
+                             old-groups)))
+                   ;; yes, Newsgroups line must change
+                   (message-xpost-fup2-header target-group)
+                   ;; insert note whether we do xpost or fup2
+                   (funcall message-xpost-note-function
+                            target-group 
+                            (if (or (and message-xpost-default (not current-prefix-arg))
+                                    (and (not message-xpost-default) current-prefix-arg))
+                                t)
+                            in-old old-groups))))))))
+
+
+;;; **************
+;;; Reduce To: to Cc: or Bcc: header
+
+(defun message-reduce-to-to-cc ()
+ "Replace contents of To: header with contents of Cc: or Bcc: header."
+ (interactive)
+ (let ((cc-content (message-fetch-field "cc"))
+       (bcc nil))
+   (if (and (not cc-content)
+           (setq cc-content (message-fetch-field "bcc")))
+       (setq bcc t))
+   (cond (cc-content
+         (save-excursion
+           (message-goto-to)
+           (message-delete-line)
+           (insert (concat "To: " cc-content "\n"))
+           (message-remove-header (if bcc 
+                                      "bcc"
+                                    "cc")))))))
+;;; provide ourself
+(provide 'message-utils)
+