gnus-msg.el (gnus-setup-message): Fix last commit

[gnus] / lisp / gnus-msg.el

diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el
index aa4ed4b..87eb6af 100644 (file)
--- a/lisp/gnus-msg.el
+++ b/lisp/gnus-msg.el
@@ -1,6 +1,6 @@
 ;;; gnus-msg.el --- mail and post interface for Gnus
 
 ;;; gnus-msg.el --- mail and post interface for Gnus
 

-;; Copyright (C) 1995-2012  Free Software Foundation, Inc.
+;; Copyright (C) 1995-2013 Free Software Foundation, Inc.

 
 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
 ;;     Lars Magne Ingebrigtsen <larsi@gnus.org>
 
 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
 ;;     Lars Magne Ingebrigtsen <larsi@gnus.org>


@@ -174,7 +174,7 @@ specifies a group to which resent messages will be Gcc'd.  If this is
 nil, Gcc will be done according to existing Gcc header(s), if any.
 If this is `no-gcc-self', resent messages will be Gcc'd to groups that
 existing Gcc header specifies, except for the current group."
 nil, Gcc will be done according to existing Gcc header(s), if any.
 If this is `no-gcc-self', resent messages will be Gcc'd to groups that
 existing Gcc header specifies, except for the current group."

-  :version "24.2"
+  :version "24.3"

   :group 'gnus-message
   :type '(choice (const none) (const t) string (const nil)
                 (const no-gcc-self)))
   :group 'gnus-message
   :type '(choice (const none) (const t) string (const nil)
                 (const no-gcc-self)))


@@ -313,6 +313,24 @@ If nil, the address field will always be empty after invoking
   :group 'gnus-message
   :type 'boolean)
 
   :group 'gnus-message
   :type 'boolean)
 

+(defcustom gnus-gcc-pre-body-encode-hook nil
+  "A hook called before encoding the body of the Gcc copy of a message.
+The current buffer (when the hook is run) contains the message
+including the message header.  Changes made to the message will
+only affect the Gcc copy, but not the original message."
+  :group 'gnus-message
+  :version "24.3"
+  :type 'hook)
+
+(defcustom gnus-gcc-post-body-encode-hook nil
+    "A hook called after encoding the body of the Gcc copy of a message.
+The current buffer (when the hook is run) contains the message
+including the message header.  Changes made to the message will
+only affect the Gcc copy, but not the original message."
+  :group 'gnus-message
+  :version "24.3"
+  :type 'hook)
+

 (autoload 'gnus-message-citation-mode "gnus-cite" nil t)
 
 ;;; Internal variables.
 (autoload 'gnus-message-citation-mode "gnus-cite" nil t)
 
 ;;; Internal variables.


@@ -397,6 +415,11 @@ Thank you for your help in stamping out bugs.
      (gnus-inews-make-draft-meta-information
       ,(gnus-group-decoded-name gnus-newsgroup-name) ',articles)))
 
      (gnus-inews-make-draft-meta-information
       ,(gnus-group-decoded-name gnus-newsgroup-name) ',articles)))
 

+(autoload 'nnir-article-number "nnir" nil nil 'macro)
+(autoload 'nnir-article-group "nnir" nil nil 'macro)
+(autoload 'gnus-nnir-group-p "nnir")
+
+

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


@@ -408,15 +431,24 @@ Thank you for your help in stamping out bugs.
     `(let ((,winconf (current-window-configuration))
           (,winconf-name gnus-current-window-configuration)
           (,buffer (buffer-name (current-buffer)))
     `(let ((,winconf (current-window-configuration))
           (,winconf-name gnus-current-window-configuration)
           (,buffer (buffer-name (current-buffer)))

-          (,article gnus-article-reply)
+          (,article (if (and (gnus-nnir-group-p gnus-newsgroup-name)
+                             gnus-article-reply)
+                        (nnir-article-number (or (car-safe gnus-article-reply)
+                                                 gnus-article-reply))
+                      gnus-article-reply))

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

-          (,group gnus-newsgroup-name)
+          (,group (if (and (gnus-nnir-group-p gnus-newsgroup-name)
+                           gnus-article-reply)
+                      (nnir-article-group (or (car-safe gnus-article-reply)
+                                              gnus-article-reply))
+                    gnus-newsgroup-name))

           (message-header-setup-hook
            (copy-sequence message-header-setup-hook))
           (mbl mml-buffer-list)
           (message-mode-hook (copy-sequence message-mode-hook)))
        (setq mml-buffer-list nil)
           (message-header-setup-hook
            (copy-sequence message-header-setup-hook))
           (mbl mml-buffer-list)
           (message-mode-hook (copy-sequence message-mode-hook)))
        (setq mml-buffer-list nil)

-       (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
+       (add-hook 'message-header-setup-hook (lambda ()
+                                             (gnus-inews-insert-gcc ,group)))

        ;; message-newsreader and message-mailer were formerly set in
        ;; gnus-inews-add-send-actions, but this is too late when
        ;; message-generate-headers-first is used. --ansel
        ;; message-newsreader and message-mailer were formerly set in
        ;; gnus-inews-add-send-actions, but this is too late when
        ;; message-generate-headers-first is used. --ansel


@@ -494,22 +526,32 @@ Thank you for your help in stamping out bugs.
 
 ;;;###autoload
 (defun gnus-msg-mail (&optional to subject other-headers continue
 
 ;;;###autoload
 (defun gnus-msg-mail (&optional to subject other-headers continue

-                     switch-action yank-action send-actions return-action)
+                               switch-action yank-action send-actions
+                               return-action)

   "Start editing a mail message to be sent.
 Like `message-mail', but with Gnus paraphernalia, particularly the
   "Start editing a mail message to be sent.
 Like `message-mail', but with Gnus paraphernalia, particularly the

-Gcc: header for archiving purposes."
+Gcc: header for archiving purposes.
+If Gnus isn't running, a plain `message-mail' setup is used
+instead."

   (interactive)
   (interactive)

-  (let ((buf (current-buffer))
-       mail-buf)
-    (gnus-setup-message 'message
-      (message-mail to subject other-headers continue
-                   nil yank-action send-actions return-action))
-    (when switch-action
-      (setq mail-buf (current-buffer))
-      (switch-to-buffer buf)
-      (apply switch-action mail-buf nil)))
-  ;; COMPOSEFUNC should return t if succeed.  Undocumented ???
-  t)
+  (if (not (gnus-alive-p))
+      (progn
+       (message "Gnus not running; using plain Message mode")
+       (message-mail to subject other-headers continue
+                     nil yank-action send-actions return-action))
+    (let ((buf (current-buffer))
+         ;; Don't use posting styles corresponding to any existing group.
+         (gnus-newsgroup-name "")
+         mail-buf)
+      (gnus-setup-message 'message
+       (message-mail to subject other-headers continue
+                     nil yank-action send-actions return-action))
+      (when switch-action
+       (setq mail-buf (current-buffer))
+       (switch-to-buffer buf)
+       (apply switch-action mail-buf nil))
+      ;; COMPOSEFUNC should return t if succeed.  Undocumented ???
+      t)))

 
 ;;;###autoload
 (defun gnus-button-mailto (address)
 
 ;;;###autoload
 (defun gnus-button-mailto (address)


@@ -652,7 +694,7 @@ a news."
             (if (= 1 (prefix-numeric-value arg))
                 (gnus-group-completing-read "Newsgroup" nil
                                             (gnus-read-active-file-p))
             (if (= 1 (prefix-numeric-value arg))
                 (gnus-group-completing-read "Newsgroup" nil
                                             (gnus-read-active-file-p))

-              (gnus-group-group-name))
+              (or (gnus-group-group-name) ""))

           ""))
        ;; make sure last viewed article doesn't affect posting styles:
        (gnus-article-copy))
           ""))
        ;; make sure last viewed article doesn't affect posting styles:
        (gnus-article-copy))


@@ -819,9 +861,21 @@ post using the current select method."
   (interactive (gnus-interactive "P\ny"))
   (let ((message-post-method
         `(lambda (arg)
   (interactive (gnus-interactive "P\ny"))
   (let ((message-post-method
         `(lambda (arg)

-           (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name))))
+           (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name)))
+       (user-mail-address user-mail-address))

     (dolist (article (gnus-summary-work-articles n))
       (when (gnus-summary-select-article t nil nil article)
     (dolist (article (gnus-summary-work-articles n))
       (when (gnus-summary-select-article t nil nil article)

+       ;; Pretend that we're doing a followup so that we can see what
+       ;; the From header would have ended up being.
+       (save-window-excursion
+         (save-excursion
+           (gnus-summary-followup nil)
+           (let ((from (message-fetch-field "from")))
+             (when from
+               (setq user-mail-address
+                     (car (mail-header-parse-address from)))))
+           (kill-buffer (current-buffer))))
+       ;; Now cancel the article using the From header we got.

        (when (gnus-eval-in-buffer-window gnus-original-article-buffer
                (message-cancel-news))
          (gnus-summary-mark-as-read article gnus-canceled-mark)
        (when (gnus-eval-in-buffer-window gnus-original-article-buffer
                (message-cancel-news))
          (gnus-summary-mark-as-read article gnus-canceled-mark)


@@ -868,6 +922,7 @@ header line with the old Message-ID."
       (with-current-buffer article-buffer
        (let ((gnus-newsgroup-charset (or gnus-article-charset
                                          gnus-newsgroup-charset))
       (with-current-buffer article-buffer
        (let ((gnus-newsgroup-charset (or gnus-article-charset
                                          gnus-newsgroup-charset))

+             (inhibit-read-only t)

              (gnus-newsgroup-ignored-charsets
               (or gnus-article-ignored-charsets
                   gnus-newsgroup-ignored-charsets)))
              (gnus-newsgroup-ignored-charsets
               (or gnus-article-ignored-charsets
                   gnus-newsgroup-ignored-charsets)))


@@ -1079,7 +1134,9 @@ See the variable `gnus-user-agent'."
           (gnus-v
            (when (memq 'gnus gnus-user-agent)
              (concat "Gnus/"
           (gnus-v
            (when (memq 'gnus gnus-user-agent)
              (concat "Gnus/"

-                     (prin1-to-string (gnus-continuum-version gnus-version) t)
+                     (gnus-replace-in-string
+                      (format "%1.8f" (gnus-continuum-version gnus-version))
+                      "0+\\'" "")

                      " (" gnus-version ")")))
           (emacs-v (gnus-emacs-version)))
       (concat gnus-v (when (and gnus-v emacs-v) " ")
                      " (" gnus-version ")")))
           (emacs-v (gnus-emacs-version)))
       (concat gnus-v (when (and gnus-v emacs-v) " ")


@@ -1291,26 +1348,27 @@ For the \"inline\" alternatives, also see the variable
                                          group)))
              (message-unquote-tokens
               (message-tokenize-header (mail-fetch-field "gcc" nil t)
                                          group)))
              (message-unquote-tokens
               (message-tokenize-header (mail-fetch-field "gcc" nil t)

-                                       " ,")))))
+                                       " ,"))))
+       (self (with-current-buffer gnus-summary-buffer
+               gnus-gcc-self-resent-messages)))

     (message-remove-header "gcc")
     (when gcc
       (goto-char (point-max))
     (message-remove-header "gcc")
     (when gcc
       (goto-char (point-max))

-      (cond ((eq gnus-gcc-self-resent-messages  'none))
-           ((eq gnus-gcc-self-resent-messages t)
+      (cond ((eq self 'none))
+           ((eq self t)

             (insert "Gcc: \"" gnus-newsgroup-name "\"\n"))
             (insert "Gcc: \"" gnus-newsgroup-name "\"\n"))

-           ((stringp gnus-gcc-self-resent-messages)
+           ((stringp self)

             (insert "Gcc: "
                     (mm-encode-coding-string
             (insert "Gcc: "
                     (mm-encode-coding-string

-                     (if (string-match " " gnus-gcc-self-resent-messages)
-                         (concat "\"" gnus-gcc-self-resent-messages "\"")
-                       gnus-gcc-self-resent-messages)
-                     (gnus-group-name-charset
-                      (gnus-inews-group-method gnus-gcc-self-resent-messages)
-                      gnus-gcc-self-resent-messages))
+                     (if (string-match " " self)
+                         (concat "\"" self "\"")
+                       self)
+                     (gnus-group-name-charset (gnus-inews-group-method self)
+                                              self))

                     "\n"))
                     "\n"))

-           ((null gnus-gcc-self-resent-messages)
+           ((null self)

             (insert "Gcc: " (mapconcat 'identity gcc ", ") "\n"))
             (insert "Gcc: " (mapconcat 'identity gcc ", ") "\n"))

-           ((eq gnus-gcc-self-resent-messages 'no-gcc-self)
+           ((eq self 'no-gcc-self)

             (when (setq gcc (delete
                              gnus-newsgroup-name
                              (delete (concat "\"" gnus-newsgroup-name "\"")
             (when (setq gcc (delete
                              gnus-newsgroup-name
                              (delete (concat "\"" gnus-newsgroup-name "\"")


@@ -1331,12 +1389,34 @@ For the \"inline\" alternatives, also see the variable
              (nnmail-fetch-field "to"))))
         current-prefix-arg))
   (let ((message-header-setup-hook (copy-sequence message-header-setup-hook))
              (nnmail-fetch-field "to"))))
         current-prefix-arg))
   (let ((message-header-setup-hook (copy-sequence message-header-setup-hook))

-       (message-sent-hook (copy-sequence message-sent-hook)))
+       (message-sent-hook (copy-sequence message-sent-hook))
+       ;; Honor posting-style for `name' and `address' in Resent-From header.
+       (styles (gnus-group-find-parameter gnus-newsgroup-name
+                                          'posting-style t))
+       (user-full-name user-full-name)
+       (user-mail-address user-mail-address)
+       tem)
+    (dolist (style styles)
+      (when (stringp (cadr style))
+       (setcdr style (list (mm-decode-coding-string (cadr style) 'utf-8)))))
+    (dolist (style (if styles
+                      (append gnus-posting-styles (list (cons ".*" styles)))
+                    gnus-posting-styles))
+      (when (and (stringp (car style))
+                (string-match (pop style) gnus-newsgroup-name))
+       (when (setq tem (cadr (assq 'name style)))
+         (setq user-full-name tem))
+       (when (setq tem (cadr (assq 'address style)))
+         (setq user-mail-address tem))))
+    ;; `gnus-summary-resend-message-insert-gcc' must run last.

     (add-hook 'message-header-setup-hook
     (add-hook 'message-header-setup-hook

-             'gnus-summary-resend-message-insert-gcc)
-    (add-hook 'message-sent-hook (if gnus-agent
-                                    'gnus-agent-possibly-do-gcc
-                                  'gnus-inews-do-gcc))
+             'gnus-summary-resend-message-insert-gcc t)
+    (add-hook 'message-sent-hook
+             `(lambda ()
+                (let ((rfc2047-encode-encoded-words nil))
+                  ,(if gnus-agent
+                       '(gnus-agent-possibly-do-gcc)
+                     '(gnus-inews-do-gcc)))))

     (dolist (article (gnus-summary-work-articles n))
       (gnus-summary-select-article nil nil nil article)
       (with-current-buffer gnus-original-article-buffer
     (dolist (article (gnus-summary-work-articles n))
       (gnus-summary-select-article nil nil nil article)
       (with-current-buffer gnus-original-article-buffer


@@ -1415,33 +1495,6 @@ See `gnus-summary-mail-forward' for ARG."
        (when (gnus-y-or-n-p "Send this complaint? ")
          (message-send-and-exit))))))
 
        (when (gnus-y-or-n-p "Send this complaint? ")
          (message-send-and-exit))))))
 

-(defun gnus-mail-parse-comma-list ()
-  (let (accumulated
-       beg)
-    (skip-chars-forward " ")
-    (while (not (eobp))
-      (setq beg (point))
-      (skip-chars-forward "^,")
-      (while (zerop
-             (save-excursion
-               (save-restriction
-                 (let ((i 0))
-                   (narrow-to-region beg (point))
-                   (goto-char beg)
-                   (logand (progn
-                             (while (search-forward "\"" nil t)
-                               (incf i))
-                             (if (zerop i) 2 i))
-                           2)))))
-       (skip-chars-forward ",")
-       (skip-chars-forward "^,"))
-      (skip-chars-backward " ")
-      (push (buffer-substring beg (point))
-           accumulated)
-      (skip-chars-forward "^,")
-      (skip-chars-forward ", "))
-    accumulated))
-

 (defun gnus-inews-add-to-address (group)
   (let ((to-address (mail-fetch-field "to")))
     (when (and to-address
 (defun gnus-inews-add-to-address (group)
   (let ((to-address (mail-fetch-field "to")))
     (when (and to-address


@@ -1452,41 +1505,6 @@ See `gnus-summary-mail-forward' for ARG."
             (format "Do you want to add this as `to-list': %s? " to-address))
        (gnus-group-add-parameter group (cons 'to-list to-address))))))
 
             (format "Do you want to add this as `to-list': %s? " to-address))
        (gnus-group-add-parameter group (cons 'to-list to-address))))))
 

-(defun gnus-put-message ()
-  "Put the current message in some group and return to Gnus."
-  (interactive)
-  (let ((reply gnus-article-reply)
-       (winconf gnus-prev-winconf)
-       (group gnus-newsgroup-name))
-    (unless (and group
-                (not (gnus-group-read-only-p group)))
-      (setq group (read-string "Put in group: " nil (gnus-writable-groups))))
-
-    (when (gnus-group-entry group)
-      (error "No such group: %s" group))
-    (save-excursion
-      (save-restriction
-       (widen)
-       (message-narrow-to-headers)
-       (let ((gnus-deletable-headers nil))
-         (message-generate-headers
-          (if (message-news-p)
-              message-required-news-headers
-            message-required-mail-headers)))
-       (goto-char (point-max))
-       (if (string-match " " group)
-           (insert "Gcc: \"" group "\"\n")
-         (insert "Gcc: " group "\n"))
-       (widen)))
-    (gnus-inews-do-gcc)
-    (when (and (get-buffer gnus-group-buffer)
-              (gnus-buffer-exists-p (car-safe reply))
-              (cdr reply))
-      (set-buffer (car reply))
-      (gnus-summary-mark-article-as-replied (cdr reply)))
-    (when winconf
-      (set-window-configuration winconf))))
-

 (defun gnus-article-mail (yank)
   "Send a reply to the address near point.
 If YANK is non-nil, include the original article."
 (defun gnus-article-mail (yank)
   "Send a reply to the address near point.
 If YANK is non-nil, include the original article."


@@ -1508,7 +1526,6 @@ If YANK is non-nil, include the original article."
     (error "Gnus has been shut down"))
   (gnus-setup-message (if (message-mail-user-agent) 'message 'bug)
     (unless (message-mail-user-agent)
     (error "Gnus has been shut down"))
   (gnus-setup-message (if (message-mail-user-agent) 'message 'bug)
     (unless (message-mail-user-agent)

-      (delete-other-windows)

       (when gnus-bug-create-help-buffer
        (switch-to-buffer "*Gnus Help Bug*")
        (erase-buffer)
       (when gnus-bug-create-help-buffer
        (switch-to-buffer "*Gnus Help Bug*")
        (erase-buffer)


@@ -1636,7 +1653,9 @@ this is a reply."
              (nnheader-set-temp-buffer " *acc*")
              (setq message-options (with-current-buffer cur message-options))
              (insert-buffer-substring cur)
              (nnheader-set-temp-buffer " *acc*")
              (setq message-options (with-current-buffer cur message-options))
              (insert-buffer-substring cur)

+             (run-hooks 'gnus-gcc-pre-body-encode-hook)

              (message-encode-message-body)
              (message-encode-message-body)

+             (run-hooks 'gnus-gcc-post-body-encode-hook)

              (save-restriction
                (message-narrow-to-headers)
                (let* ((mail-parse-charset message-default-charset)
              (save-restriction
                (message-narrow-to-headers)
                (let* ((mail-parse-charset message-default-charset)


@@ -1705,7 +1724,8 @@ this is a reply."
          (group (when group (gnus-group-decoded-name group)))
          (var (or gnus-outgoing-message-group gnus-message-archive-group))
         (gcc-self-val
          (group (when group (gnus-group-decoded-name group)))
          (var (or gnus-outgoing-message-group gnus-message-archive-group))
         (gcc-self-val

-         (and group (gnus-group-find-parameter group 'gcc-self)))
+         (and group (not (gnus-virtual-group-p group))
+              (gnus-group-find-parameter group 'gcc-self)))

         result
         (groups
          (cond
         result
         (groups
          (cond


@@ -1724,17 +1744,19 @@ this is a reply."
           ((functionp var)
            ;; A function.
            (funcall var group))
           ((functionp var)
            ;; A function.
            (funcall var group))

-          (t
+          (group

            ;; An alist of regexps/functions/forms.
            (while (and var
                        (not
                         (setq result
                               (cond
            ;; An alist of regexps/functions/forms.
            (while (and var
                        (not
                         (setq result
                               (cond

-                               ((stringp (caar var))
+                               ((and group
+                                     (stringp (caar var)))

                                 ;; Regexp.
                                 (when (string-match (caar var) group)
                                   (cdar var)))
                                 ;; Regexp.
                                 (when (string-match (caar var) group)
                                   (cdar var)))

-                               ((functionp (car var))
+                               ((and group
+                                     (functionp (car var)))

                                 ;; Function.
                                 (funcall (car var) group))
                                (t
                                 ;; Function.
                                 (funcall (car var) group))
                                (t


@@ -1742,7 +1764,8 @@ this is a reply."
              (setq var (cdr var)))
            result)))
         name)
              (setq var (cdr var)))
            result)))
         name)

-    (when (or groups gcc-self-val)
+    (when (and (or groups gcc-self-val)
+              (gnus-alive-p))

       (when (stringp groups)
        (setq groups (list groups)))
       (save-excursion
       (when (stringp groups)
        (setq groups (list groups)))
       (save-excursion


@@ -1810,6 +1833,10 @@ this is a reply."
       (when gnus-newsgroup-name
        (let ((tmp-style (gnus-group-find-parameter group 'posting-style t)))
          (when tmp-style
       (when gnus-newsgroup-name
        (let ((tmp-style (gnus-group-find-parameter group 'posting-style t)))
          (when tmp-style

+           (dolist (style tmp-style)
+             (when (stringp (cadr style))
+               (setcdr style (list (mm-decode-coding-string (cadr style)
+                                                            'utf-8)))))

            (setq styles (append styles (list (cons ".*" tmp-style)))))))
       ;; Go through all styles and look for matches.
       (dolist (style styles)
            (setq styles (append styles (list (cons ".*" tmp-style)))))))
       ;; Go through all styles and look for matches.
       (dolist (style styles)