+;;; Start of functions adopted from `message-utils.el'.
+
+(defun message-strip-subject-trailing-was (subject)
+ "Remove trailing \"(Was: <old subject>)\" from SUBJECT lines.
+Leading \"Re: \" is not stripped by this function. Use the function
+`message-strip-subject-re' for this."
+ (let* ((query message-subject-trailing-was-query)
+ (new) (found))
+ (setq found
+ (string-match
+ (if (eq query 'ask)
+ message-subject-trailing-was-ask-regexp
+ message-subject-trailing-was-regexp)
+ subject))
+ (if found
+ (setq new (substring subject 0 (match-beginning 0))))
+ (if (or (not found) (eq query nil))
+ subject
+ (if (eq query 'ask)
+ (if (message-y-or-n-p
+ "Strip `(was: <old subject>)' in subject? " t
+ (concat
+ "Strip `(was: <old subject>)' in subject "
+ "and use the new one instead?\n\n"
+ "Current subject is: \""
+ subject "\"\n\n"
+ "New subject would be: \""
+ new "\"\n\n"
+ "See the variable `message-subject-trailing-was-query' "
+ "to get rid of this query."
+ ))
+ new subject)
+ new))))
+
+;;; 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>)."
+ ;; <URL:http://www.landfield.com/usefor/drafts/draft-ietf-usefor-useage--1.02.unpaged>
+ (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
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-fetch-field "Subject"))))
+ (cond ((not old-subject)
+ (error "No current subject"))
+ ((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")))))))))
+
+;;;###autoload
+(defun message-mark-inserted-region (beg end)
+ "Mark some region in the current article with enclosing tags.
+See `message-mark-insert-begin' and `message-mark-insert-end'."
+ (interactive "r")
+ (save-excursion
+ ;; add to the end of the region first, otherwise end would be invalid
+ (goto-char end)
+ (insert message-mark-insert-end)
+ (goto-char beg)
+ (insert message-mark-insert-begin)))
+
+;;;###autoload
+(defun message-mark-insert-file (file)
+ "Insert FILE at point, marking it with enclosing tags.
+See `message-mark-insert-begin' and `message-mark-insert-end'."
+ (interactive "fFile to insert: ")
+ ;; reverse insertion to get correct result.
+ (let ((p (point)))
+ (insert message-mark-insert-end)
+ (goto-char p)
+ (insert-file-contents file)
+ (goto-char p)
+ (insert message-mark-insert-begin)))
+
+;;;###autoload
+(defun message-add-archive-header ()
+ "Insert \"X-No-Archive: Yes\" in the header and a note in the body.
+The note can be customized using `message-archive-note'. When called with a
+prefix argument, ask for a text to insert. If you don't want the note in the
+body, set `message-archive-note' to nil."
+ (interactive)
+ (if current-prefix-arg
+ (setq message-archive-note
+ (read-from-minibuffer "Reason for No-Archive: "
+ (cons message-archive-note 0))))
+ (save-excursion
+ (if (message-goto-signature)
+ (re-search-backward message-signature-separator))
+ (when message-archive-note
+ (insert message-archive-note)
+ (newline))
+ (message-add-header message-archive-header)
+ (message-sort-headers)))
+
+;;;###autoload
+(defun message-cross-post-followup-to-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 "Followup 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-cross-post-old-target
+ (re-search-forward
+ (regexp-quote (concat "," message-cross-post-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
+ ;; def: cross-post, req:no
+ (and message-cross-post-default (not current-prefix-arg))
+ ;; def: no-cross-post, req:yes
+ (and (not message-cross-post-default) current-prefix-arg))
+ (not (string-match "poster" target-group))
+ (not (string-match (regexp-quote target-group)
+ (message-fetch-field "Newsgroups"))))
+ (end-of-line)
+ (insert (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-cross-post-old-target target-group))
+
+;;;###autoload
+(defun message-cross-post-insert-note (target-group cross-post 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 CROSS-POST 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-cross-post-note) ".*")
+ head t)
+ (message-delete-line))
+ (message-goto-signature)
+ (while (re-search-backward
+ (concat "^" (regexp-quote message-followup-to-note) ".*")
+ head t)
+ (message-delete-line))
+ ;; insert new note
+ (if (message-goto-signature)
+ (re-search-backward message-signature-separator))
+ (if (or in-old
+ (not cross-post)
+ (string-match "^[ \t]*poster[ \t]*$" target-group))
+ (insert (concat message-followup-to-note target-group "\n"))
+ (insert (concat message-cross-post-note target-group "\n")))))
+
+;;;###autoload
+(defun message-cross-post-followup-to (target-group)
+ "Crossposts message and set Followup-To to TARGET-GROUP.
+With prefix-argument just set Follow-Up, don't cross-post."
+ (interactive
+ (list ; Completion based on Gnus
+ (completing-read "Followup 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)
+ (or old-groups ""))))
+ ;; check whether target exactly matches old Newsgroups
+ (cond ((not old-groups)
+ (error "No current newsgroup"))
+ ((or (not in-old)
+ (not (string-match
+ (concat "^[ \t]*"
+ (regexp-quote target-group)
+ "[ \t]*$")
+ old-groups)))
+ ;; yes, Newsgroups line must change
+ (message-cross-post-followup-to-header target-group)
+ ;; insert note whether we do cross-post or followup-to
+ (funcall message-cross-post-note-function
+ target-group
+ (if (or (and message-cross-post-default
+ (not current-prefix-arg))
+ (and (not message-cross-post-default)
+ current-prefix-arg)) t)
+ in-old old-groups))))))))
+
+;;; Reduce To: to Cc: or Bcc: header
+
+;;;###autoload
+(defun message-reduce-to-to-cc ()
+ "Replace contents of To: header with contents of Cc: or Bcc: header."
+ (interactive)
+ (let ((cc-content
+ (save-restriction (message-narrow-to-headers)
+ (message-fetch-field "cc")))
+ (bcc nil))
+ (if (and (not cc-content)
+ (setq cc-content
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-fetch-field "bcc"))))
+ (setq bcc t))
+ (cond (cc-content
+ (save-excursion
+ (message-goto-to)
+ (message-delete-line)
+ (insert (concat "To: " cc-content "\n"))
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-remove-header (if bcc
+ "bcc"
+ "cc"))))))))
+
+;;; End of functions adopted from `message-utils.el'.
+