Synch with Oort Gnus.
[elisp/gnus.git-] / lisp / message.el
index 42a281a..42d8616 100644 (file)
@@ -350,7 +350,7 @@ value may go against RFC-1036 and draft-ietf-usefor-article-05.txt. "
   :type 'string
   :group 'message-various)
 
   :type 'string
   :group 'message-various)
 
-(defcustom message-interactive nil
+(defcustom message-interactive t
   "Non-nil means when sending a message wait for and display errors.
 nil means let mailer mail back a message to report errors."
   :group 'message-sending
   "Non-nil means when sending a message wait for and display errors.
 nil means let mailer mail back a message to report errors."
   :group 'message-sending
@@ -1167,27 +1167,51 @@ candidates:
   "Face used for displaying MML."
   :group 'message-faces)
 
   "Face used for displaying MML."
   :group 'message-faces)
 
+(defun message-font-lock-make-header-matcher (regexp)
+  (let ((form
+        `(lambda (limit)
+           (let ((start (point)))
+             (save-restriction
+               (widen)
+               (goto-char (point-min))
+               (if (re-search-forward
+                    (concat "^" (regexp-quote mail-header-separator) "$")
+                    nil t)
+                   (setq limit (min limit (match-beginning 0))))
+               (goto-char start))
+             (and (< start limit)
+                  (re-search-forward ,regexp limit t))))))
+    (if (featurep 'bytecomp)
+       (byte-compile form)
+      form)))
+
 (defvar message-font-lock-keywords
   (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))
 (defvar message-font-lock-keywords
   (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))
-    `((,(concat "^\\([Tt]o:\\)" content)
+    `((,(message-font-lock-make-header-matcher
+        (concat "^\\([Tt]o:\\)" content))
        (1 'message-header-name-face)
        (2 'message-header-to-face nil t))
        (1 'message-header-name-face)
        (2 'message-header-to-face nil t))
-      (,(concat "^\\([GBF]?[Cc][Cc]:\\|[Rr]eply-[Tt]o:\\|"
-               "[Mm]ail-[Cc]opies-[Tt]o:\\|"
-               "[Mm]ail-[Rr]eply-[Tt]o:\\|"
-               "[Mm]ail-[Ff]ollowup-[Tt]o:\\)" content)
+      (,(message-font-lock-make-header-matcher
+        (concat "^\\([GBF]?[Cc][Cc]:\\|[Rr]eply-[Tt]o:\\|"
+                "[Mm]ail-[Cc]opies-[Tt]o:\\|"
+                "[Mm]ail-[Rr]eply-[Tt]o:\\|"
+                "[Mm]ail-[Ff]ollowup-[Tt]o:\\)" content))
        (1 'message-header-name-face)
        (2 'message-header-cc-face nil t))
        (1 'message-header-name-face)
        (2 'message-header-cc-face nil t))
-      (,(concat "^\\([Ss]ubject:\\)" content)
+      (,(message-font-lock-make-header-matcher
+        (concat "^\\([Ss]ubject:\\)" content))
        (1 'message-header-name-face)
        (2 'message-header-subject-face nil t))
        (1 'message-header-name-face)
        (2 'message-header-subject-face nil t))
-      (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)
+      (,(message-font-lock-make-header-matcher
+        (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content))
        (1 'message-header-name-face)
        (2 'message-header-newsgroups-face nil t))
        (1 'message-header-name-face)
        (2 'message-header-newsgroups-face nil t))
-      (,(concat "^\\([A-Z][^: \n\t]+:\\)" content)
+      (,(message-font-lock-make-header-matcher
+        (concat "^\\([A-Z][^: \n\t]+:\\)" content))
        (1 'message-header-name-face)
        (2 'message-header-other-face nil t))
        (1 'message-header-name-face)
        (2 'message-header-other-face nil t))
-      (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content)
+      (,(message-font-lock-make-header-matcher
+        (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content))
        (1 'message-header-name-face)
        (2 'message-header-name-face))
       ,@(if (and mail-header-separator
        (1 'message-header-name-face)
        (2 'message-header-name-face))
       ,@(if (and mail-header-separator
@@ -1195,7 +1219,11 @@ candidates:
            `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
               1 'message-separator-face))
          nil)
            `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
               1 'message-separator-face))
          nil)
-      (,(concat "^\\(" message-cite-prefix-regexp "\\).*")
+      ((lambda (limit)
+        (re-search-forward (concat "^\\("
+                                   message-cite-prefix-regexp
+                                   "\\).*")
+                           limit t))
        (0 'message-cited-text-face))
       (,mime-edit-tag-regexp
        (0 'message-mml-face))))
        (0 'message-cited-text-face))
       (,mime-edit-tag-regexp
        (0 'message-mml-face))))
@@ -3052,36 +3080,41 @@ It should typically alter the sending method in some way or other."
          (success t)
          elem sent dont-barf-on-no-method
          (message-options message-options))
          (success t)
          elem sent dont-barf-on-no-method
          (message-options message-options))
-      (message-options-set-recipient)
-      (save-excursion
-       (set-buffer message-encoding-buffer)
-       (erase-buffer)
-       ;; ;; Avoid copying text props (except hard newlines).
-       ;; T-gnus change: copy all text props from the editing buffer
-       ;; into the encoding buffer.
-       (insert-buffer-substring message-edit-buffer)
-       (funcall message-encode-function)
-       (while (and success
-                   (setq elem (pop alist)))
-         (when (funcall (cadr elem))
-           (when (and (or (not (memq (car elem)
-                                     message-sent-message-via))
-                          (if (or (message-gnksa-enable-p 'multiple-copies)
-                                  (not (eq (car elem) 'news)))
-                              (y-or-n-p
-                               (format
-                                "Already sent message via %s; resend? "
-                                (car elem)))
-                            (error "Denied posting -- multiple copies")))
-                      (setq success (funcall (caddr elem) arg)))
-             (setq sent t)))))
-      (unless
-         (or sent
-             (not success)
-             (let ((fcc (message-fetch-field "Fcc"))
-                   (gcc (message-fetch-field "Gcc")))
-               (when (or fcc gcc)
-                 (or (eq message-allow-no-recipients 'always)
+      (unwind-protect
+         (progn
+           (message-options-set-recipient)
+           (save-excursion
+             (set-buffer message-encoding-buffer)
+             (erase-buffer)
+             ;; ;; Avoid copying text props (except hard newlines).
+             ;; T-gnus change: copy all text props from the editing buffer
+             ;; into the encoding buffer.
+             (insert-buffer-substring message-edit-buffer)
+             (funcall message-encode-function)
+             (while (and success
+                         (setq elem (pop alist)))
+               (when (funcall (cadr elem))
+                 (when (and
+                        (or (not (memq (car elem)
+                                       message-sent-message-via))
+                            (if (or (message-gnksa-enable-p 'multiple-copies)
+                                    (not (eq (car elem) 'news)))
+                                (y-or-n-p
+                                 (format
+                                  "Already sent message via %s; resend? "
+                                  (car elem)))
+                              (error "Denied posting -- multiple copies")))
+                        (setq success (funcall (caddr elem) arg)))
+                   (setq sent t)))))
+           (unless
+               (or
+                sent
+                (not success)
+                (let ((fcc (message-fetch-field "Fcc"))
+                      (gcc (message-fetch-field "Gcc")))
+                  (when (or fcc gcc)
+                    (or
+                     (eq message-allow-no-recipients 'always)
                      (and (not (eq message-allow-no-recipients 'never))
                           (setq dont-barf-on-no-method
                                 (gnus-y-or-n-p
                      (and (not (eq message-allow-no-recipients 'never))
                           (setq dont-barf-on-no-method
                                 (gnus-y-or-n-p
@@ -3089,23 +3122,22 @@ It should typically alter the sending method in some way or other."
                                          (cond ((and fcc gcc) "Fcc and Gcc")
                                                (fcc "Fcc")
                                                (t "Gcc"))))))))))
                                          (cond ((and fcc gcc) "Fcc and Gcc")
                                                (fcc "Fcc")
                                                (t "Gcc"))))))))))
-       (error "No methods specified to send by"))
-      (prog1
-         (when (or dont-barf-on-no-method
-                   (and success sent))
-           (message-do-fcc)
-           (save-excursion
-             (run-hooks 'message-sent-hook))
-           (message "Sending...done")
-           ;; Mark the buffer as unmodified and delete auto-save.
-           (set-buffer-modified-p nil)
-           (delete-auto-save-file-if-necessary t)
-           (message-disassociate-draft)
-           ;; Delete other mail buffers and stuff.
-           (message-do-send-housekeeping)
-           (message-do-actions message-send-actions)
-           ;; Return success.
-           t)
+             (error "No methods specified to send by"))
+           (when (or dont-barf-on-no-method
+                     (and success sent))
+             (message-do-fcc)
+             (save-excursion
+               (run-hooks 'message-sent-hook))
+             (message "Sending...done")
+             ;; Mark the buffer as unmodified and delete auto-save.
+             (set-buffer-modified-p nil)
+             (delete-auto-save-file-if-necessary t)
+             (message-disassociate-draft)
+             ;; Delete other mail buffers and stuff.
+             (message-do-send-housekeeping)
+             (message-do-actions message-send-actions)
+             ;; Return success.
+             t))
        (kill-buffer message-encoding-buffer)))))
 
 (defun message-send-via-mail (arg)
        (kill-buffer message-encoding-buffer)))))
 
 (defun message-send-via-mail (arg)
@@ -3457,61 +3489,67 @@ This sub function is for exclusive use of `message-send-mail'."
                     " sendmail errors")
                  0))
        resend-to-addresses delimline)
                     " sendmail errors")
                  0))
        resend-to-addresses delimline)
-    (let ((case-fold-search t))
-      (save-restriction
-       (message-narrow-to-headers)
-       (setq resend-to-addresses (message-fetch-field "resent-to")))
-      ;; Change header-delimiter to be what sendmail expects.
-      (goto-char (point-min))
-      (re-search-forward
-       (concat "^" (regexp-quote mail-header-separator) "\n"))
-      (replace-match "\n")
-      (backward-char 1)
-      (setq delimline (point-marker))
-      (run-hooks 'message-send-mail-hook)
-      ;; Insert an extra newline if we need it to work around
-      ;; Sun's bug that swallows newlines.
-      (goto-char (1+ delimline))
-      (when (eval message-mailer-swallows-blank-line)
-       (newline))
-      (when message-interactive
-       (save-excursion
-         (set-buffer errbuf)
-         (erase-buffer))))
-    (let ((default-directory "/"))
-      (as-binary-process
-       (apply 'call-process-region
-             (append (list (point-min) (point-max)
-                           (if (boundp 'sendmail-program)
-                               sendmail-program
-                             "/usr/lib/sendmail")
-                           nil errbuf nil "-oi")
-                     ;; Always specify who from,
-                     ;; since some systems have broken sendmails.
-                     ;; But some systems are more broken with -f, so
-                     ;; we'll let users override this.
-                     (if (null message-sendmail-f-is-evil)
-                         (list "-f" (message-make-address)))
-                     ;; These mean "report errors by mail"
-                     ;; and "deliver in background".
-                     (if (null message-interactive) '("-oem" "-odb"))
-                     ;; Get the addresses from the message
-                     ;; unless this is a resend.
-                     ;; We must not do that for a resend
-                     ;; because we would find the original addresses.
-                     ;; For a resend, include the specific addresses.
-                     (if resend-to-addresses
-                         (list resend-to-addresses)
-                       '("-t"))))))
-    (when message-interactive
-      (save-excursion
-       (set-buffer errbuf)
-       (goto-char (point-min))
-       (while (re-search-forward "\n\n* *" nil t)
-         (replace-match "; "))
-       (if (not (zerop (buffer-size)))
-           (error "Sending...failed to %s"
-                  (buffer-substring (point-min) (point-max)))))
+    (unwind-protect
+       (progn
+         (let ((case-fold-search t))
+           (save-restriction
+             (message-narrow-to-headers)
+             (setq resend-to-addresses (message-fetch-field "resent-to")))
+           ;; Change header-delimiter to be what sendmail expects.
+           (goto-char (point-min))
+           (re-search-forward
+            (concat "^" (regexp-quote mail-header-separator) "\n"))
+           (replace-match "\n")
+           (backward-char 1)
+           (setq delimline (point-marker))
+           (run-hooks 'message-send-mail-hook)
+           ;; Insert an extra newline if we need it to work around
+           ;; Sun's bug that swallows newlines.
+           (goto-char (1+ delimline))
+           (when (eval message-mailer-swallows-blank-line)
+             (newline))
+           (when message-interactive
+             (save-excursion
+               (set-buffer errbuf)
+               (erase-buffer))))
+         (let* ((default-directory "/")
+                (cpr (as-binary-process
+                      (apply
+                       'call-process-region
+                       (append
+                        (list (point-min) (point-max)
+                              (if (boundp 'sendmail-program)
+                                  sendmail-program
+                                "/usr/lib/sendmail")
+                              nil errbuf nil "-oi")
+                        ;; Always specify who from,
+                        ;; since some systems have broken sendmails.
+                        ;; But some systems are more broken with -f, so
+                        ;; we'll let users override this.
+                        (if (null message-sendmail-f-is-evil)
+                            (list "-f" (message-make-address)))
+                        ;; These mean "report errors by mail"
+                        ;; and "deliver in background".
+                        (if (null message-interactive) '("-oem" "-odb"))
+                        ;; Get the addresses from the message
+                        ;; unless this is a resend.
+                        ;; We must not do that for a resend
+                        ;; because we would find the original addresses.
+                        ;; For a resend, include the specific addresses.
+                        (if resend-to-addresses
+                            (list resend-to-addresses)
+                          '("-t")))))))
+           (unless (or (null cpr) (zerop cpr))
+             (error "Sending...failed with exit value %d" cpr)))
+         (when message-interactive
+           (save-excursion
+             (set-buffer errbuf)
+             (goto-char (point-min))
+             (while (re-search-forward "\n\n* *" nil t)
+               (replace-match "; "))
+             (if (not (zerop (buffer-size)))
+                 (error "Sending...failed to %s"
+                        (buffer-substring (point-min) (point-max)))))))
       (when (bufferp errbuf)
        (kill-buffer errbuf)))))
 
       (when (bufferp errbuf)
        (kill-buffer errbuf)))))
 
@@ -3653,7 +3691,8 @@ Do not use this for anything important, it is cryptographically weak."
 This is the value of `canlock-password', if that option is non-nil.
 Otherwise, generate and save a value for `canlock-password' first."
   (unless canlock-password
 This is the value of `canlock-password', if that option is non-nil.
 Otherwise, generate and save a value for `canlock-password' first."
   (unless canlock-password
-    (customize-save-variable 'canlock-password (message-canlock-generate)))
+    (customize-save-variable 'canlock-password (message-canlock-generate))
+    (setq canlock-password-for-verify canlock-password))
   canlock-password)
 
 (defun message-insert-canlock ()
   canlock-password)
 
 (defun message-insert-canlock ()
@@ -4612,7 +4651,11 @@ string."
       (goto-char (point-min))
       (let ((case-fold-search t)
            user-agent start p end)
       (goto-char (point-min))
       (let ((case-fold-search t)
            user-agent start p end)
-       (if (re-search-forward "^User-Agent:[\t ]*" nil t)
+       (if (re-search-forward
+            (concat "^User-Agent:[\t ]*\\("
+                    (regexp-quote gnus-product-name)
+                    "/[0-9.]+\\([ \t\r\n]*([^)]+)\\)*\\)?[\t ]*")
+            nil t)
            (progn
              (setq start (match-beginning 0)
                    p (match-end 0)
            (progn
              (setq start (match-beginning 0)
                    p (match-end 0)
@@ -4917,6 +4960,9 @@ than 988 characters long, and if they are not, trim them until they are."
 (defun message-beginning-of-line (&optional n)
   "Move point to beginning of header value or to beginning of line."
   (interactive "p")
 (defun message-beginning-of-line (&optional n)
   "Move point to beginning of header value or to beginning of line."
   (interactive "p")
+  (let ((zrs 'zmacs-region-stays))
+    (when (and (interactive-p) (boundp zrs))
+      (set zrs t)))
   (if (message-point-in-header-p)
       (let* ((here (point))
             (bol (progn (beginning-of-line n) (point)))
   (if (message-point-in-header-p)
       (let* ((here (point))
             (bol (progn (beginning-of-line n) (point)))
@@ -6138,6 +6184,16 @@ which specify the range to operate on."
   :group 'message
   :type '(alist :key-type regexp :value-type function))
 
   :group 'message
   :type '(alist :key-type regexp :value-type function))
 
+(defcustom message-expand-name-function
+  (if (fboundp 'bbdb-complete-name)
+      'bbdb-complete-name
+    (if (fboundp 'lsdb-complete-name)
+       'lsdb-complete-name
+      'expand-abbrev))
+  "*A function called to expand addresses in field body."
+  :group 'message
+  :type 'function)
+
 (defcustom message-tab-body-function nil
   "*Function to execute when `message-tab' (TAB) is executed in the body.
 If nil, the function bound in `text-mode-map' or `global-map' is executed."
 (defcustom message-tab-body-function nil
   "*Function to execute when `message-tab' (TAB) is executed in the body.
 If nil, the function bound in `text-mode-map' or `global-map' is executed."
@@ -6202,9 +6258,7 @@ those headers."
            (delete-region (point) (progn (forward-line 3) (point))))))))))
 
 (defun message-expand-name ()
            (delete-region (point) (progn (forward-line 3) (point))))))))))
 
 (defun message-expand-name ()
-  (if (fboundp 'bbdb-complete-name)
-      (bbdb-complete-name)
-    (expand-abbrev)))
+  (funcall message-expand-name-function))
 
 ;;; Help stuff.
 
 
 ;;; Help stuff.