Sync up with Semi-gnus 6.8.19
[elisp/gnus.git-] / lisp / message.el
index f761af0..cd6ca1d 100644 (file)
@@ -3,6 +3,7 @@
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;         MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;;         Keiichi Suzuki <kei-suzu@mail.wbs.ne.jp>
 ;; Keywords: mail, news, MIME
 
 ;; This file is part of GNU Emacs.
   :group 'message
   :group 'faces)
 
+(defgroup message-frames nil
+  "Message frames"
+  :group 'message)
+
 (defcustom message-directory "~/Mail/"
   "*Directory from which all other mail file variables are derived."
   :group 'message-various
@@ -220,7 +225,7 @@ included.  Organization, Lines and X-Mailer are optional."
   :group 'message-headers
   :type 'regexp)
 
-(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:"
+(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^X-Trace:\\|^X-Complaints-To:"
   "*Header lines matching this regexp will be deleted before posting.
 It's best to delete old Path and Date headers before posting to avoid
 any confusion."
@@ -291,7 +296,7 @@ If t, use `message-user-organization-file'."
   :type 'string)
 
 (defcustom message-forward-end-separator
-  ""
+  (concat (mime-make-tag "text" "plain") "\n")
   "*Delimiter inserted after forwarded messages."
   :group 'message-forwarding
   :type 'string)
@@ -302,11 +307,32 @@ If t, use `message-user-organization-file'."
   :type 'boolean)
 
 (defcustom message-included-forward-headers
-  "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-Transfer-Encoding:\\|^Content-Type:\\|^Mime-Version:"
+  "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-Transfer-Encoding:\\|^Content-Type:\\|^MIME-Version:"
   "*Regexp matching headers to be included in forwarded messages."
   :group 'message-forwarding
   :type 'regexp)
 
+(defcustom message-make-forward-subject-function 
+  'message-forward-subject-author-subject
+ "*A list of functions that are called to generate a subject header for forwarded messages.
+The subject generated by the previous function is passed into each
+successive function.
+
+The provided functions are:
+
+* message-forward-subject-author-subject (Source of article (author or
+      newsgroup)), in brackets followed by the subject
+* message-forward-subject-fwd (Subject of article with 'Fwd:' prepended
+      to it."
+ :group 'message-forwarding
+ :type '(radio (function-item message-forward-subject-author-subject)
+              (function-item message-forward-subject-fwd)))
+
+(defcustom message-wash-forwarded-subjects nil
+  "*If non-nil, try to remove as much old cruft as possible from the subject of messages before generating the new subject of a forward."
+  :group 'message-forwarding
+  :type 'boolean)
+
 (defcustom message-ignored-resent-headers "^Return-receipt"
   "*All headers that match this regexp will be deleted when resending a message."
   :group 'message-interface
@@ -408,6 +434,7 @@ might set this variable to '(\"-f\" \"you@some.where\")."
 (defvar gnus-select-method)
 (defcustom message-post-method
   (cond ((and (boundp 'gnus-post-method)
+             (listp gnus-post-method)
              gnus-post-method)
         gnus-post-method)
        ((boundp 'gnus-select-method)
@@ -476,16 +503,12 @@ Used by `message-yank-original' via `message-yank-cite'."
   :type 'integer)
 
 ;;;###autoload
-(defcustom message-cite-function
-  (if (and (boundp 'mail-citation-hook)
-          mail-citation-hook)
-      mail-citation-hook
-    'message-cite-original)
+(defcustom message-cite-function 'message-cite-original
   "*Function for citing an original message.
-Pre-defined functions include `message-cite-original' and
-`message-cite-original-without-signature'."
+Predefined functions include `message-cite-original' and
+`message-cite-original-without-signature'.
+Note that `message-cite-original' uses `mail-citation-hook' if that is non-nil."
   :type '(radio (function-item message-cite-original)
-               (function-item message-cite-original-without-signature)
                (function-item sc-cite-original)
                (function :tag "Other"))
   :group 'message-insertion)
@@ -553,6 +576,7 @@ If stringp, use this; if non-nil, use no host name (user name only)."
   "A list of actions to be performed before killing a message buffer.")
 (defvar message-postpone-actions nil
   "A list of actions to be performed after postponing a message.")
+(defvar message-original-frame nil)
 
 (define-widget 'message-header-lines 'text
   "All header lines must be LFD terminated."
@@ -837,6 +861,21 @@ The cdr of ech entry is a function for applying the face to a region.")
   :group 'message-various
   :type 'hook)
 
+(defcustom message-use-multi-frames nil
+  "Make new frame when sending messages."
+  :group 'message-frames
+  :type 'boolean)
+
+(defcustom message-delete-frame-on-exit nil
+  "Delete frame after sending messages."
+  :group 'message-frames
+  :type '(choice (const :tag "off" nil)
+                (const :tag "always" t)
+                (const :tag "ask" ask)))
+
+(defvar message-send-coding-system 'binary
+  "Coding system to encode outgoing mail.")
+
 ;;; Internal variables.
 
 (defvar message-buffer-list nil)
@@ -927,7 +966,7 @@ The cdr of ech entry is a function for applying the face to a region.")
     (Lines)
     (Expires)
     (Message-ID)
-    (References . message-shorten-references)
+    (References . message-fill-references)
     (X-Mailer)
     (X-Newsreader))
   "Alist used for formatting headers.")
@@ -945,6 +984,7 @@ The cdr of ech entry is a function for applying the face to a region.")
   (autoload 'nndraft-request-expire-articles "nndraft")
   (autoload 'gnus-open-server "gnus-int")
   (autoload 'gnus-request-post "gnus-int")
+  (autoload 'gnus-copy-article-buffer "gnus-msg")
   (autoload 'gnus-alive-p "gnus-util")
   (autoload 'rmail-output "rmail"))
 
@@ -1432,13 +1472,22 @@ C-c C-r  message-caesar-buffer-body (rot13 the message body)."
   (goto-char (point-min))
   (search-forward (concat "\n" mail-header-separator "\n") nil t))
 
+(defun message-goto-eoh ()
+  "Move point to the end of the headers."
+  (interactive)
+  (message-goto-body)
+  (forward-line -2))
+
 (defun message-goto-signature ()
-  "Move point to the beginning of the message signature."
+  "Move point to the beginning of the message signature.
+If there is no signature in the article, go to the end and
+return nil."
   (interactive)
   (goto-char (point-min))
   (if (re-search-forward message-signature-separator nil t)
       (forward-line 1)
-    (goto-char (point-max))))
+    (goto-char (point-max))
+    nil))
 
 \f
 
@@ -1478,16 +1527,17 @@ With the prefix argument FORCE, insert the header anyway."
   (interactive "r")
   (save-excursion
     (goto-char end)
-    (delete-region (point) (progn (message-goto-signature)
-                                 (forward-line -2)
-                                 (point)))
+    (delete-region (point) (if (not (message-goto-signature))
+                              (point)
+                            (forward-line -2)
+                            (point)))
     (insert "\n")
     (goto-char beg)
     (delete-region beg (progn (message-goto-body)
                              (forward-line 2)
                              (point))))
-  (message-goto-signature)
-  (forward-line -2))
+  (when (message-goto-signature)
+    (forward-line -2)))
 
 (defun message-kill-to-signature ()
   "Deletes all text up to the signature."
@@ -1711,6 +1761,7 @@ However, if `message-yank-prefix' is non-nil, insert that prefix on each line."
          (forward-line 1))))
     (goto-char start)))
 
+(defvar gnus-article-copy)
 (defun message-yank-original (&optional arg)
   "Insert the message being replied to, if any.
 Puts point before the text and mark after.
@@ -1725,6 +1776,8 @@ prefix, and don't delete any headers."
   (let ((modified (buffer-modified-p)))
     (when (and message-reply-buffer
               message-cite-function)
+      (gnus-copy-article-buffer)
+      (setq message-reply-buffer gnus-article-copy)
       (delete-windows-on message-reply-buffer t)
       (insert-buffer message-reply-buffer)
       (funcall message-cite-function)
@@ -1745,6 +1798,11 @@ prefix, and don't delete any headers."
             (list message-indent-citation-function)))))
     (goto-char end)
     (when (re-search-backward "^-- $" start t)
+      ;; Also peel off any blank lines before the signature.
+      (forward-line -1)
+      (while (looking-at "^[ \t]*$")
+       (forward-line -1))
+      (forward-line 1)
       (delete-region (point) end))
     (goto-char start)
     (while functions
@@ -1754,21 +1812,25 @@ prefix, and don't delete any headers."
        (insert "\n"))
       (funcall message-citation-line-function))))
 
+(defvar mail-citation-hook) ;Compiler directive
 (defun message-cite-original ()
   "Cite function in the standard Message manner."
-  (let ((start (point))
-       (functions
-        (when message-indent-citation-function
-          (if (listp message-indent-citation-function)
-              message-indent-citation-function
-            (list message-indent-citation-function)))))
-    (goto-char start)
-    (while functions
-      (funcall (pop functions)))
-    (when message-citation-line-function
-      (unless (bolp)
-       (insert "\n"))
-      (funcall message-citation-line-function))))
+  (if (and (boundp 'mail-citation-hook)
+          mail-citation-hook)
+      (run-hooks 'mail-citation-hook)
+    (let ((start (point))
+         (functions
+          (when message-indent-citation-function
+            (if (listp message-indent-citation-function)
+                message-indent-citation-function
+              (list message-indent-citation-function)))))
+      (goto-char start)
+      (while functions
+       (funcall (pop functions)))
+      (when message-citation-line-function
+       (unless (bolp)
+         (insert "\n"))
+       (funcall message-citation-line-function)))))
 
 (defun message-insert-citation-line ()
   "Function that inserts a simple citation line."
@@ -1831,11 +1893,18 @@ The text will also be indented the normal way."
 ;;; Sending messages
 ;;;
 
+;; Avoid byte-compile warning.
+(defvar message-encoding-buffer nil)
+(defvar message-edit-buffer nil)
+(defvar message-mime-mode nil)
+
 (defun message-send-and-exit (&optional arg)
   "Send message like `message-send', then, if no errors, exit from mail buffer."
   (interactive "P")
   (let ((buf (current-buffer))
-       (actions message-exit-actions))
+       (actions message-exit-actions)
+       (frame (selected-frame))
+       (org-frame message-original-frame))
     (when (and (message-send arg)
               (buffer-name buf))
       (if message-kill-buffer-on-exit
@@ -1843,7 +1912,9 @@ The text will also be indented the normal way."
        (bury-buffer buf)
        (when (eq buf (current-buffer))
          (message-bury buf)))
-      (message-do-actions actions))))
+      (message-do-actions actions)
+      (message-delete-frame frame org-frame)
+      t)))
 
 (defun message-dont-send ()
   "Don't send the message you have been editing."
@@ -1859,10 +1930,32 @@ The text will also be indented the normal way."
   (interactive)
   (when (or (not (buffer-modified-p))
            (yes-or-no-p "Message modified; kill anyway? "))
-    (let ((actions message-kill-actions))
+    (let ((actions message-kill-actions)
+         (frame (selected-frame))
+         (org-frame message-original-frame))
       (setq buffer-file-name nil)
       (kill-buffer (current-buffer))
-      (message-do-actions actions))))
+      (message-do-actions actions)
+      (message-delete-frame frame org-frame))))
+
+(defun message-delete-frame (frame org-frame)
+  "Delete frame for editing message."
+  (when (and (or (and (featurep 'xemacs)
+                     (not (eq 'tty (device-type))))
+                window-system
+                (>= emacs-major-version 20))
+            (or (and (eq message-delete-frame-on-exit t)
+                     (select-frame frame)
+                     (or (eq frame org-frame)
+                         (prog1
+                             (y-or-n-p "Delete this frame?")
+                           (message ""))))
+                (and (eq message-delete-frame-on-exit 'ask)
+                     (select-frame frame)
+                     (prog1
+                         (y-or-n-p "Delete this frame?")
+                       (message "")))))
+    (delete-frame frame)))
 
 (defun message-bury (buffer)
   "Bury this mail buffer."
@@ -1889,7 +1982,6 @@ the user from the mailer."
     (undo-boundary)
     (let ((inhibit-read-only t))
       (put-text-property (point-min) (point-max) 'read-only nil))
-    (message-fix-before-sending)
     (run-hooks 'message-send-hook)
     (message "Sending...")
     (let ((message-encoding-buffer
@@ -1904,6 +1996,7 @@ the user from the mailer."
        (erase-buffer)
        (insert-buffer message-edit-buffer)
        (funcall message-encode-function)
+       (message-fix-before-sending)
        (while (and success
                    (setq elem (pop alist)))
          (when (and (or (not (funcall (cadr elem)))
@@ -1944,7 +2037,13 @@ the user from the mailer."
   ;; Make sure there's a newline at the end of the message.
   (goto-char (point-max))
   (unless (bolp)
-    (insert "\n")))
+    (insert "\n"))
+  ;; Make all invisible text visible.
+  ;;(when (text-property-any (point-min) (point-max) 'invisible t)
+  ;;  (put-text-property (point-min) (point-max) 'invisible nil)
+  ;;  (unless (yes-or-no-p "Invisible text found and made visible; continue posting?")
+  ;;    (error "Invisible text found and made visible")))
+  )
 
 (defun message-add-action (action &rest types)
   "Add ACTION to be performed when doing an exit of type TYPES."
@@ -2037,7 +2136,7 @@ the user from the mailer."
          (set-buffer errbuf)
          (erase-buffer))))
     (let ((default-directory "/")
-         (coding-system-for-write 'binary))
+         (coding-system-for-write message-send-coding-system))
       (apply 'call-process-region
             (append (list (point-min) (point-max)
                           (if (boundp 'sendmail-program)
@@ -2085,7 +2184,7 @@ to find out how to use this."
   (run-hooks 'message-send-mail-hook)
   ;; send the message
   (case
-      (let ((coding-system-for-write 'binary))
+      (let ((coding-system-for-write message-send-coding-system))
        (apply
         'call-process-region 1 (point-max) message-qmail-inject-program
         nil nil nil
@@ -3023,7 +3122,13 @@ Headers already prepared in the buffer are not modified."
              (setq header (car elem)))
          (setq header elem))
        (when (or (not (re-search-forward
-                       (concat "^" (downcase (symbol-name header)) ":")
+                       (concat "^"
+                               (regexp-quote
+                                (downcase
+                                 (if (stringp header)
+                                     header
+                                   (symbol-name header))))
+                               ":")
                        nil t))
                  (progn
                    ;; The header was found.  We insert a space after the
@@ -3065,7 +3170,8 @@ Headers already prepared in the buffer are not modified."
                  (progn
                    ;; This header didn't exist, so we insert it.
                    (goto-char (point-max))
-                   (insert (symbol-name header) ": " value "\n")
+                   (insert (if (stringp header) header (symbol-name header))
+                           ": " value "\n")
                    (forward-line -1))
                ;; The value of this header was empty, so we clear
                ;; totally and insert the new value.
@@ -3243,7 +3349,24 @@ Headers already prepared in the buffer are not modified."
 
 (defun message-pop-to-buffer (name)
   "Pop to buffer NAME, and warn if it already exists and is modified."
-  (let ((buffer (get-buffer name)))
+  (let ((pop-up-frames pop-up-frames)
+       (special-display-buffer-names special-display-buffer-names)
+       (special-display-regexps special-display-regexps)
+       (same-window-buffer-names same-window-buffer-names)
+       (same-window-regexps same-window-regexps)
+       (buffer (get-buffer name))
+       (cur (current-buffer)))
+    (if (or (and (featurep 'xemacs)
+                (not (eq 'tty (device-type))))
+           window-system
+           (>= emacs-major-version 20))
+       (when message-use-multi-frames
+         (setq pop-up-frames t
+               special-display-buffer-names nil
+               special-display-regexps nil
+               same-window-buffer-names nil
+               same-window-regexps nil))
+      (setq pop-up-frames nil))
     (if (and buffer
             (buffer-name buffer))
        (progn
@@ -3252,9 +3375,12 @@ Headers already prepared in the buffer are not modified."
                     (not (y-or-n-p
                           "Message already being composed; erase? ")))
            (error "Message being composed")))
-      (set-buffer (pop-to-buffer name))))
-  (erase-buffer)
-  (message-mode))
+      (set-buffer (pop-to-buffer name)))
+    (erase-buffer)
+    (message-mode)
+    (when pop-up-frames
+      (make-local-variable 'message-original-frame)
+      (setq message-original-frame (selected-frame)))))
 
 (defun message-do-send-housekeeping ()
   "Kill old message buffers."
@@ -3368,7 +3494,8 @@ Headers already prepared in the buffer are not modified."
 (defun message-mail (&optional to subject
                               other-headers continue switch-function
                               yank-action send-actions)
-  "Start editing a mail message to be sent."
+  "Start editing a mail message to be sent.
+OTHER-HEADERS is an alist of header/value pairs."
   (interactive)
   (let ((message-this-is-mail t))
     (message-pop-to-buffer (message-buffer-name "mail" to))
@@ -3665,13 +3792,18 @@ responses here are directed to other newsgroups."))
 This is done simply by taking the old article and adding a Supersedes
 header line with the old Message-ID."
   (interactive)
-  (let ((cur (current-buffer)))
+  (let ((cur (current-buffer))
+       (sender (message-fetch-field "sender"))
+       (from (message-fetch-field "from")))
     ;; Check whether the user owns the article that is to be superseded.
-    (unless (string-equal
-            (downcase (or (message-fetch-field "sender")
-                          (cadr (mail-extract-address-components
-                                 (message-fetch-field "from")))))
-            (downcase (message-make-sender)))
+    (unless (or (and sender
+                    (string-equal
+                     (downcase sender)
+                     (downcase (message-make-sender))))
+               (string-equal
+                (downcase (cadr (mail-extract-address-components from)))
+                (downcase (cadr (mail-extract-address-components
+                                 (message-make-from))))))
       (error "This article is not yours"))
     ;; Get a normal message buffer.
     (message-pop-to-buffer (message-buffer-name "supersede"))
@@ -3707,19 +3839,81 @@ header line with the old Message-ID."
             (insert-file-contents file-name nil)))
          (t (error "message-recover cancelled")))))
 
+;;; Washing Subject:
+
+(defun message-wash-subject (subject)
+  "Remove junk like \"Re:\", \"(fwd)\", etc. that was added to the subject by previous forwarders, replyers, etc."
+  (nnheader-temp-write nil
+    (insert-string subject)
+    (goto-char (point-min))
+    ;; strip Re/Fwd stuff off the beginning
+    (while (re-search-forward
+           "\\([Rr][Ee]:\\|[Ff][Ww][Dd]\\(\\[[0-9]*\\]\\)?:\\|[Ff][Ww]:\\)" nil t)
+      (replace-match ""))
+
+    ;; and gnus-style forwards [foo@bar.com] subject
+    (goto-char (point-min))
+    (while (re-search-forward "\\[[^ \t]*\\(@\\|\\.\\)[^ \t]*\\]" nil t)
+      (replace-match ""))
+
+    ;; and off the end
+    (goto-char (point-max))
+    (while (re-search-backward "([Ff][Ww][Dd])" nil t)
+      (replace-match ""))
+
+    ;; and finally, any whitespace that was left-over
+    (goto-char (point-min))
+    (while (re-search-forward "^[ \t]+" nil t)
+      (replace-match ""))
+    (goto-char (point-max))
+    (while (re-search-backward "[ \t]+$" nil t)
+      (replace-match ""))
+
+    (buffer-string)))
+    
 ;;; Forwarding messages.
 
+(defun message-forward-subject-author-subject (subject)
+  "Generate a subject for a forwarded message.
+The form is: [Source] Subject, where if the original message was mail,
+Source is the sender, and if the original message was news, Source is
+the list of newsgroups is was posted to."
+  (concat "["
+         (or (message-fetch-field
+              (if (message-news-p) "newsgroups" "from"))
+             "(nowhere)")
+         "] " subject))
+
+(defun message-forward-subject-fwd (subject)
+  "Generate a subject for a forwarded message.
+The form is: Fwd: Subject, where Subject is the original subject of
+the message."
+  (concat "Fwd: " subject))
+
 (defun message-make-forward-subject ()
   "Return a Subject header suitable for the message in the current buffer."
   (save-excursion
     (save-restriction
       (current-buffer)
       (message-narrow-to-head)
-      (concat "[" (or (message-fetch-field
-                      (if (message-news-p) "newsgroups" "from"))
-                     "(nowhere)")
-             "] " (or (eword-decode-unstructured-field-body
-                       (message-fetch-field "Subject") ""))))))
+      (let ((funcs message-make-forward-subject-function)
+           (subject (if message-wash-forwarded-subjects
+                        (message-wash-subject
+                         (or (eword-decode-unstructured-field-body
+                              (message-fetch-field "Subject")) ""))
+                      (or (eword-decode-unstructured-field-body
+                           (message-fetch-field "Subject")) ""))))
+       ;; Make sure funcs is a list.
+       (and funcs
+            (not (listp funcs))
+            (setq funcs (list funcs)))
+       ;; Apply funcs in order, passing subject generated by previous
+       ;; func to the next one.
+       (while funcs
+         (when (message-functionp (car funcs))
+           (setq subject (funcall (car funcs) subject)))
+         (setq funcs (cdr funcs)))
+       subject))))
 
 ;;;###autoload
 (defun message-forward (&optional news)
@@ -3822,7 +4016,7 @@ you."
     (insert-buffer-substring cur)
     (undo-boundary)
     (message-narrow-to-head)
-    (if (and (message-fetch-field "Mime-Version")
+    (if (and (message-fetch-field "MIME-Version")
             (setq boundary (message-fetch-field "Content-Type")))
        (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary)
            (setq boundary (concat (match-string 1 boundary) " *\n"
@@ -3980,7 +4174,6 @@ Do a `tab-to-tab-stop' if not in those headers."
                                            (point))))
         (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
         (completions (all-completions string hashtb))
-        (cur (current-buffer))
         comp)
     (delete-region b (point))
     (cond
@@ -4050,7 +4243,7 @@ regexp varstr."
   (let ((locals (save-excursion
                  (set-buffer buffer)
                  (buffer-local-variables)))
-       (regexp "^gnus\\|^nn\\|^message"))
+       (regexp "^\\(gnus\\|nn\\|message\\|user-\\(mail-address\\|full-name\\)\\)"))
     (mapcar
      (lambda (local)
        (when (and (consp local)