Import Oort Gnus v0.09.

[elisp/gnus.git-] / lisp / gnus-msg.el

diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el
index 13a2e2c..d3238d4 100644 (file)
--- a/lisp/gnus-msg.el
+++ b/lisp/gnus-msg.el
@@ -115,6 +115,7 @@ the second with the current group name."
   "*Alist of styles to use when posting.
 See Info node `(gnus)Posting Styles'."
   :group 'gnus-message
   "*Alist of styles to use when posting.
 See Info node `(gnus)Posting Styles'."
   :group 'gnus-message

+  :link '(custom-manual "(gnus)Posting Styles")

   :type '(repeat (cons (choice (regexp)
                               (variable)
                               (list (const header)
   :type '(repeat (cons (choice (regexp)
                               (variable)
                               (list (const header)

@@ -153,18 +154,25 @@ See Info node `(gnus)Posting Styles'."
   "Should local-file attachments be included as external parts in Gcc copies?
 If it is `all', attach files as external parts;
 if a regexp and matches the Gcc group name, attach files as external parts;
   "Should local-file attachments be included as external parts in Gcc copies?
 If it is `all', attach files as external parts;
 if a regexp and matches the Gcc group name, attach files as external parts;

-If nil, attach files as normal parts."
+if nil, attach files as normal parts."

   :version "21.1"
   :group 'gnus-message
   :type '(choice (const nil :tag "None")
                 (const all :tag "Any")
                 (string :tag "Regexp")))
 
   :version "21.1"
   :group 'gnus-message
   :type '(choice (const nil :tag "None")
                 (const all :tag "Any")
                 (string :tag "Regexp")))
 

-(defcustom gnus-group-posting-charset-alist
+(gnus-define-group-parameter
+ posting-charset-alist
+ :type list
+ :function-document
+ "Return the permitted unencoded charsets for posting of GROUP."
+ :variable gnus-group-posting-charset-alist
+ :variable-default

   '(("^\\(no\\|fr\\)\\.[^,]*\\(,[ \t\n]*\\(no\\|fr\\)\\.[^,]*\\)*$" iso-8859-1 (iso-8859-1))
     ("^\\(fido7\\|relcom\\)\\.[^,]*\\(,[ \t\n]*\\(fido7\\|relcom\\)\\.[^,]*\\)*$" koi8-r (koi8-r))
     (message-this-is-mail nil nil)
     (message-this-is-news nil t))
   '(("^\\(no\\|fr\\)\\.[^,]*\\(,[ \t\n]*\\(no\\|fr\\)\\.[^,]*\\)*$" iso-8859-1 (iso-8859-1))
     ("^\\(fido7\\|relcom\\)\\.[^,]*\\(,[ \t\n]*\\(fido7\\|relcom\\)\\.[^,]*\\)*$" koi8-r (koi8-r))
     (message-this-is-mail nil nil)
     (message-this-is-news nil t))

+ :variable-document

   "Alist of regexps and permitted unencoded charsets for posting.
 Each element of the alist has the form (TEST HEADER BODY-LIST), where
 TEST is either a regular expression matching the newsgroup header or a
   "Alist of regexps and permitted unencoded charsets for posting.
 Each element of the alist has the form (TEST HEADER BODY-LIST), where
 TEST is either a regular expression matching the newsgroup header or a

@@ -177,20 +185,26 @@ nil (always encode using quoted-printable) or t (always use 8bit).
 
 Note that any value other than nil for HEADER infringes some RFCs, so
 use this option with care."
 
 Note that any value other than nil for HEADER infringes some RFCs, so
 use this option with care."

-  :type '(repeat (list :tag "Permitted unencoded charsets"
-                 (choice :tag "Where"
-                  (regexp :tag "Group")
-                  (const :tag "Mail message" :value message-this-is-mail)
-                  (const :tag "News article" :value message-this-is-news))
-                 (choice :tag "Header"
-                  (const :tag "None" nil)
-                  (symbol :tag "Charset"))
-                 (choice :tag "Body"
-                         (const :tag "Any" :value t)
-                         (const :tag "None" :value nil)
-                         (repeat :tag "Charsets"
-                                 (symbol :tag "Charset")))))
-  :group 'gnus-charset)
+ :variable-group gnus-charset
+ :variable-type
+ '(repeat (list :tag "Permitted unencoded charsets"
+               (choice :tag "Where"
+                       (regexp :tag "Group")
+                       (const :tag "Mail message" :value message-this-is-mail)
+                       (const :tag "News article" :value message-this-is-news))
+               (choice :tag "Header"
+                       (const :tag "None" nil)
+                       (symbol :tag "Charset"))
+               (choice :tag "Body"
+                       (const :tag "Any" :value t)
+                       (const :tag "None" :value nil)
+                       (repeat :tag "Charsets"
+                               (symbol :tag "Charset")))))
+ :parameter-type '(choice :tag "Permitted unencoded charsets"
+                         :value nil
+                         (repeat (symbol)))
+ :parameter-document       "\
+List of charsets that are permitted to be unencoded.")

 
 (defcustom gnus-debug-files
   '("gnus.el" "gnus-sum.el" "gnus-group.el"
 
 (defcustom gnus-debug-files
   '("gnus.el" "gnus-sum.el" "gnus-group.el"

@@ -258,6 +272,7 @@ If nil, the address field will always be empty after invoking
 (defvar gnus-inhibit-posting-styles nil
   "Inhibit the use of posting styles.")
 
 (defvar gnus-inhibit-posting-styles nil
   "Inhibit the use of posting styles.")
 

+(defvar gnus-article-yanked-articles nil)

 (defvar gnus-message-buffer "*Mail Gnus*")
 (defvar gnus-article-copy nil)
 (defvar gnus-check-before-posting nil)
 (defvar gnus-message-buffer "*Mail Gnus*")
 (defvar gnus-article-copy nil)
 (defvar gnus-check-before-posting nil)

@@ -333,15 +348,22 @@ Thank you for your help in stamping out bugs.
 
 ;;; Internal functions.
 
 
 ;;; Internal functions.
 

+(defun gnus-inews-make-draft ()
+  `(lambda ()
+     (gnus-inews-make-draft-meta-information
+      ,gnus-newsgroup-name ,gnus-article-reply)))
+

 (defvar gnus-article-reply nil)
 (defmacro gnus-setup-message (config &rest forms)
   (let ((winconf (make-symbol "gnus-setup-message-winconf"))
        (buffer (make-symbol "gnus-setup-message-buffer"))
        (article (make-symbol "gnus-setup-message-article"))
 (defvar gnus-article-reply nil)
 (defmacro gnus-setup-message (config &rest forms)
   (let ((winconf (make-symbol "gnus-setup-message-winconf"))
        (buffer (make-symbol "gnus-setup-message-buffer"))
        (article (make-symbol "gnus-setup-message-article"))

+       (yanked (make-symbol "gnus-setup-yanked-articles"))

        (group (make-symbol "gnus-setup-message-group")))
     `(let ((,winconf (current-window-configuration))
           (,buffer (buffer-name (current-buffer)))
           (,article gnus-article-reply)
        (group (make-symbol "gnus-setup-message-group")))
     `(let ((,winconf (current-window-configuration))
           (,buffer (buffer-name (current-buffer)))
           (,article gnus-article-reply)

+          (,yanked gnus-article-yanked-articles)

           (,group gnus-newsgroup-name)
           (message-header-setup-hook
            (copy-sequence message-header-setup-hook))
           (,group gnus-newsgroup-name)
           (message-header-setup-hook
            (copy-sequence message-header-setup-hook))

@@ -360,11 +382,19 @@ Thank you for your help in stamping out bugs.
        (add-hook 'message-mode-hook
                 (lambda ()
                   (gnus-configure-posting-styles ,group)))
        (add-hook 'message-mode-hook
                 (lambda ()
                   (gnus-configure-posting-styles ,group)))

+       (gnus-pull ',(intern gnus-draft-meta-information-header)
+                 message-required-headers)
+       (when (and ,group
+                 (not (string= ,group "")))
+        (push (cons
+               (intern gnus-draft-meta-information-header)
+               (gnus-inews-make-draft))
+              message-required-headers))

        (unwind-protect
           (progn
             ,@forms)
        (unwind-protect
           (progn
             ,@forms)

-        (gnus-inews-add-send-actions ,winconf ,buffer ,article ,config)
-        (gnus-inews-insert-draft-meta-information ,group ,article)
+        (gnus-inews-add-send-actions ,winconf ,buffer ,article ,config
+                                     ,yanked)

         (setq gnus-message-buffer (current-buffer))
         (set (make-local-variable 'gnus-message-group-art)
              (cons ,group ,article))
         (setq gnus-message-buffer (current-buffer))
         (set (make-local-variable 'gnus-message-group-art)
              (cons ,group ,article))

@@ -387,18 +417,13 @@ Thank you for your help in stamping out bugs.
        (run-hooks 'post-command-hook)
        (set-buffer-modified-p nil))))
 
        (run-hooks 'post-command-hook)
        (set-buffer-modified-p nil))))
 

-(defun gnus-inews-insert-draft-meta-information (group article)
-  (save-excursion
-    (when (and group
-              (not (string= group ""))
-              (not (message-fetch-field gnus-draft-meta-information-header)))
-      (goto-char (point-min))
-      (insert gnus-draft-meta-information-header ": (\"" group "\" "
-             (if article (number-to-string
-                          (if (listp article)
-                              (car article)
-                            article)) "\"\"")
-             ")\n"))))
+(defun gnus-inews-make-draft-meta-information (group article)
+  (concat "(\"" group "\" "
+         (if article (number-to-string
+                      (if (listp article)
+                          (car article)
+                        article)) "\"\"")
+         ")"))

 
 ;;;###autoload
 (defun gnus-msg-mail (&optional to subject other-headers continue
 
 ;;;###autoload
 (defun gnus-msg-mail (&optional to subject other-headers continue

@@ -461,7 +486,8 @@ Gcc: header for archiving purposes."
                         (symbol-value (car elem))))
            (throw 'found (cons (cadr elem) (caddr elem)))))))))
 
                         (symbol-value (car elem))))
            (throw 'found (cons (cadr elem) (caddr elem)))))))))
 

-(defun gnus-inews-add-send-actions (winconf buffer article &optional config)
+(defun gnus-inews-add-send-actions (winconf buffer article
+                                           &optional config yanked)

   (make-local-hook 'message-sent-hook)
   (add-hook 'message-sent-hook (if gnus-agent 'gnus-agent-possibly-do-gcc
                                 'gnus-inews-do-gcc) nil t)
   (make-local-hook 'message-sent-hook)
   (add-hook 'message-sent-hook (if gnus-agent 'gnus-agent-possibly-do-gcc
                                 'gnus-inews-do-gcc) nil t)

@@ -480,8 +506,8 @@ Gcc: header for archiving purposes."
        (set-buffer ,buffer)
        ,(when article
           (if (eq config 'forward)
        (set-buffer ,buffer)
        ,(when article
           (if (eq config 'forward)

-              `(gnus-summary-mark-article-as-forwarded ',article)
-            `(gnus-summary-mark-article-as-replied ',article)))))
+              `(gnus-summary-mark-article-as-forwarded ',yanked)
+            `(gnus-summary-mark-article-as-replied ',yanked)))))

    'send))
 
 (put 'gnus-setup-message 'lisp-indent-function 1)
    'send))
 
 (put 'gnus-setup-message 'lisp-indent-function 1)

@@ -705,8 +731,7 @@ yanked."
             (with-current-buffer gnus-article-copy
               (save-restriction
                 (nnheader-narrow-to-headers)
             (with-current-buffer gnus-article-copy
               (save-restriction
                 (nnheader-narrow-to-headers)

-                (ietf-drums-unfold-fws)
-                (nnheader-parse-head t)))))
+                (nnheader-parse-naked-head)))))

        (message-yank-original)
        (setq beg (or beg (mark t))))
       (when articles
        (message-yank-original)
        (setq beg (or beg (mark t))))
       (when articles

@@ -799,12 +824,14 @@ header line with the old Message-ID."
            (goto-char (point-min))
            (while (looking-at message-unix-mail-delimiter)
              (forward-line 1))
            (goto-char (point-min))
            (while (looking-at message-unix-mail-delimiter)
              (forward-line 1))

-           (setq beg (point)
-                 end (or (message-goto-body) beg))
+           (let ((mail-header-separator ""))
+             (setq beg (point)
+                   end (or (message-goto-body) beg)))

            ;; Delete the headers from the displayed articles.
            (set-buffer gnus-article-copy)
            ;; Delete the headers from the displayed articles.
            (set-buffer gnus-article-copy)

-           (delete-region (goto-char (point-min))
-                          (or (message-goto-body) (point-max)))
+           (let ((mail-header-separator ""))
+             (delete-region (goto-char (point-min))
+                            (or (message-goto-body) (point-max))))

            ;; Insert the original article headers.
            (insert-buffer-substring gnus-original-article-buffer beg end)
            ;; Decode charsets.
            ;; Insert the original article headers.
            (insert-buffer-substring gnus-original-article-buffer beg end)
            ;; Decode charsets.

@@ -819,6 +846,7 @@ header line with the old Message-ID."
   (when article-buffer
     (gnus-copy-article-buffer))
   (let ((gnus-article-reply (and article-buffer (gnus-summary-article-number)))
   (when article-buffer
     (gnus-copy-article-buffer))
   (let ((gnus-article-reply (and article-buffer (gnus-summary-article-number)))

+       (gnus-article-yanked-articles yank)

        (add-to-list gnus-add-to-list))
     (gnus-setup-message (cond (yank 'reply-yank)
                              (article-buffer 'reply)
        (add-to-list gnus-add-to-list))
     (gnus-setup-message (cond (yank 'reply-yank)
                              (article-buffer 'reply)

@@ -877,7 +905,7 @@ header line with the old Message-ID."
          (gnus-inews-yank-articles yank))))))
 
 (defun gnus-msg-treat-broken-reply-to (&optional force)
          (gnus-inews-yank-articles yank))))))
 
 (defun gnus-msg-treat-broken-reply-to (&optional force)

-  "Remove the Reply-to header iff broken-reply-to."
+  "Remove the Reply-to header if broken-reply-to."

   (when (or force
            (gnus-group-find-parameter
             gnus-newsgroup-name 'broken-reply-to))
   (when (or force
            (gnus-group-find-parameter
             gnus-newsgroup-name 'broken-reply-to))

@@ -1018,6 +1046,7 @@ If VERY-WIDE, make a very wide reply."
                (caar yank)
              (car yank)))
           (gnus-article-reply (or article (gnus-summary-article-number)))
                (caar yank)
              (car yank)))
           (gnus-article-reply (or article (gnus-summary-article-number)))

+          (gnus-article-yanked-articles yank)

           (headers ""))
       ;; Stripping headers should be specified with mail-yank-ignored-headers.
       (when yank
           (headers ""))
       ;; Stripping headers should be specified with mail-yank-ignored-headers.
       (when yank

@@ -1055,13 +1084,13 @@ If VERY-WIDE, make a very wide reply."
        (set-buffer gnus-article-buffer)
        (setq signed (memq 'signed gnus-article-wash-types))
        (setq encrypted (memq 'encrypted gnus-article-wash-types)))
        (set-buffer gnus-article-buffer)
        (setq signed (memq 'signed gnus-article-wash-types))
        (setq encrypted (memq 'encrypted gnus-article-wash-types)))

-      (cond ((and gnus-message-replysign signed)
-            (mml-secure-message mml-default-sign-method 'sign))
-           ((and gnus-message-replyencrypt encrypted)
+      (cond ((and gnus-message-replyencrypt encrypted)

             (mml-secure-message mml-default-encrypt-method
                                 (if gnus-message-replysignencrypted
                                     'signencrypt
             (mml-secure-message mml-default-encrypt-method
                                 (if gnus-message-replysignencrypted
                                     'signencrypt

-                                  'encrypt)))))))
+                                  'encrypt)))
+           ((and gnus-message-replysign signed)
+            (mml-secure-message mml-default-sign-method 'sign))))))

 
 (defun gnus-summary-reply-with-original (n &optional wide)
   "Start composing a reply mail to the current message.
 
 (defun gnus-summary-reply-with-original (n &optional wide)
   "Start composing a reply mail to the current message.

@@ -1131,37 +1160,41 @@ If POST, post instead of mail.
 For the `inline' alternatives, also see the variable
 `message-forward-ignored-headers'."
   (interactive "P")
 For the `inline' alternatives, also see the variable
 `message-forward-ignored-headers'."
   (interactive "P")

-  (if (null (cdr (gnus-summary-work-articles nil)))
-      (let ((message-forward-as-mime message-forward-as-mime)
-           (message-forward-show-mml message-forward-show-mml))
-       (cond
-        ((null arg))
-        ((eq arg 1)
-         (setq message-forward-as-mime nil
-               message-forward-show-mml t))
-        ((eq arg 2)
-         (setq message-forward-as-mime t
-               message-forward-show-mml nil))
-        ((eq arg 3)
-         (setq message-forward-as-mime t
-               message-forward-show-mml t))
-        ((eq arg 4)
-         (setq message-forward-as-mime nil
-               message-forward-show-mml nil))
-        (t
-         (setq message-forward-as-mime (not message-forward-as-mime))))
-       (let ((gnus-article-reply (gnus-summary-article-number)))
-         (gnus-setup-message 'forward
-           (gnus-summary-select-article)
-           (let ((mail-parse-charset
-                  (or (and (gnus-buffer-live-p gnus-article-buffer)
-                           (with-current-buffer gnus-article-buffer
-                             gnus-article-charset))
-                      gnus-newsgroup-charset))
-                 (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets))
-             (set-buffer gnus-original-article-buffer)
-             (message-forward post)))))
-    (gnus-uu-digest-mail-forward arg post)))
+  (if (cdr (gnus-summary-work-articles nil))
+      ;; Process marks are given.
+      (gnus-uu-digest-mail-forward arg post)
+    ;; No process marks.
+    (let ((message-forward-as-mime message-forward-as-mime)
+         (message-forward-show-mml message-forward-show-mml))
+      (cond
+       ((null arg))
+       ((eq arg 1)
+       (setq message-forward-as-mime nil
+             message-forward-show-mml t))
+       ((eq arg 2)
+       (setq message-forward-as-mime t
+             message-forward-show-mml nil))
+       ((eq arg 3)
+       (setq message-forward-as-mime t
+             message-forward-show-mml t))
+       ((eq arg 4)
+       (setq message-forward-as-mime nil
+             message-forward-show-mml nil))
+       (t
+       (setq message-forward-as-mime (not message-forward-as-mime))))
+      (let* ((gnus-article-reply (gnus-summary-article-number))
+            (gnus-article-yanked-articles (list gnus-article-reply)))
+       (gnus-setup-message 'forward
+         (gnus-summary-select-article)
+         (let ((mail-parse-charset
+                (or (and (gnus-buffer-live-p gnus-article-buffer)
+                         (with-current-buffer gnus-article-buffer
+                           gnus-article-charset))
+                    gnus-newsgroup-charset))
+               (mail-parse-ignored-charsets
+                gnus-newsgroup-ignored-charsets))
+           (set-buffer gnus-original-article-buffer)
+           (message-forward post)))))))

 
 (defun gnus-summary-resend-message (address n)
   "Resend the current article to ADDRESS."
 
 (defun gnus-summary-resend-message (address n)
   "Resend the current article to ADDRESS."

@@ -1332,7 +1365,9 @@ The current group name will be inserted at \"%s\".")
               message-required-news-headers
             message-required-mail-headers)))
        (goto-char (point-max))
               message-required-news-headers
             message-required-mail-headers)))
        (goto-char (point-max))

-       (insert "Gcc: " group "\n")
+       (if (string-match " " group)
+           (insert "Gcc: \"" group "\"\n")
+         (insert "Gcc: " group "\n"))

        (widen)))
     (gnus-inews-do-gcc)
     (when (and (get-buffer gnus-group-buffer)
        (widen)))
     (gnus-inews-do-gcc)
     (when (and (get-buffer gnus-group-buffer)

@@ -1596,8 +1631,15 @@ this is a reply."
                    group))))
        (when gcc
          (insert "Gcc: "
                    group))))
        (when gcc
          (insert "Gcc: "

-                 (if (stringp gcc) gcc
-                   (mapconcat 'identity gcc " "))
+                 (if (stringp gcc)
+                     (if (string-match " " gcc)
+                         (concat "\"" gcc "\"")
+                       gcc)
+                   (mapconcat (lambda (group)
+                                (if (string-match " " group)
+                                    (concat "\"" group "\"")
+                                  group))
+                              gcc " "))

                  "\n"))))))
 
 (defun gnus-inews-insert-archive-gcc (&optional group)
                  "\n"))))))
 
 (defun gnus-inews-insert-archive-gcc (&optional group)

@@ -1658,8 +1700,12 @@ this is a reply."
              (progn
                (insert
                 (if (stringp gcc-self-val)
              (progn
                (insert
                 (if (stringp gcc-self-val)

-                    gcc-self-val
-                  group))
+                    (if (string-match " " gcc-self-val)
+                        (concat "\"" gcc-self-val "\"")
+                      gcc-self-val)
+                  (if (string-match " " group)
+                      (concat "\"" group "\"")
+                    group)))

                (if (not (eq gcc-self-val 'none))
                    (insert "\n")
                  (progn
                (if (not (eq gcc-self-val 'none))
                    (insert "\n")
                  (progn

@@ -1667,10 +1713,13 @@ this is a reply."
                    (kill-line))))
            ;; Use the list of groups.
            (while (setq name (pop groups))
                    (kill-line))))
            ;; Use the list of groups.
            (while (setq name (pop groups))

-             (insert (if (string-match ":" name)
-                         name
-                       (gnus-group-prefixed-name
-                        name gnus-message-archive-method)))
+             (let ((str (if (string-match ":" name)
+                            name
+                          (gnus-group-prefixed-name
+                           name gnus-message-archive-method))))
+               (insert (if (string-match " " str)
+                           (concat "\"" str "\"")
+                         str)))

              (when groups
                (insert " ")))
            (insert "\n")))))))
              (when groups
                (insert " ")))
            (insert "\n")))))))

@@ -1778,6 +1827,8 @@ this is a reply."
       (setq results (delq name (delq address results)))
       ;; make-local-hook is not obsolete in Emacs 20 or XEmacs.
       (make-local-hook 'message-setup-hook)
       (setq results (delq name (delq address results)))
       ;; make-local-hook is not obsolete in Emacs 20 or XEmacs.
       (make-local-hook 'message-setup-hook)

+      (setq results (sort results (lambda (x y)
+                                   (string-lessp (car x) (car y)))))

       (dolist (result results)
        (add-hook 'message-setup-hook
                  (cond
       (dolist (result results)
        (add-hook 'message-setup-hook
                  (cond