(gnus-article-refer-article): Be more permissive.

[gnus] / lisp / message.el

diff --git a/lisp/message.el b/lisp/message.el
index 9ea1ef6..a9faf5e 100644 (file)
--- a/lisp/message.el
+++ b/lisp/message.el
@@ -194,9 +194,9 @@ Checks include `subject-cmsg', `multiple-headers', `sendsys',
   :type '(repeat sexp))                        ; Fixme: improve this
 
 (defcustom message-required-headers '((optional . References) From)
   :type '(repeat sexp))                        ; Fixme: improve this
 
 (defcustom message-required-headers '((optional . References) From)

-  "*Headers to be generated or promted for when sending a message.
+  "*Headers to be generated or prompted for when sending a message.

 Also see `message-required-news-headers' and
 Also see `message-required-news-headers' and

-1message-required-mail-headers'."
+`message-required-mail-headers'."

   :group 'message-news
   :group 'message-headers
   :type '(repeat sexp))
   :group 'message-news
   :group 'message-headers
   :type '(repeat sexp))


@@ -636,6 +636,15 @@ Doing so would be even more evil than leaving it out."
   :group 'message-sending
   :type 'boolean)
 
   :group 'message-sending
   :type 'boolean)
 

+(defcustom message-sendmail-envelope-from nil
+  "*Envelope-from when sending mail with sendmail.
+If this is nil, use `user-mail-address'.  If it is the symbol
+`header', use the From: header of the message."
+  :type '(choice (string :tag "From name")
+                (const :tag "Use From: header from message" header)
+                (const :tag "Use `user-mail-address'" nil))
+  :group 'message-sending)
+

 ;; qmail-related stuff
 (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject"
   "Location of the qmail-inject program."
 ;; qmail-related stuff
 (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject"
   "Location of the qmail-inject program."


@@ -1178,18 +1187,23 @@ candidates:
 The cdr of each entry is a function for applying the face to a region.")
 
 (defcustom message-send-hook nil
 The cdr of each entry is a function for applying the face to a region.")
 
 (defcustom message-send-hook nil

-  "Hook run before sending messages."
+  "Hook run before sending messages.
+This hook is run quite early when sending."

   :group 'message-various
   :options '(ispell-message)
   :type 'hook)
 
 (defcustom message-send-mail-hook nil
   :group 'message-various
   :options '(ispell-message)
   :type 'hook)
 
 (defcustom message-send-mail-hook nil

-  "Hook run before sending mail messages."
+  "Hook run before sending mail messages.
+This hook is run very late -- just before the message is sent as
+mail."

   :group 'message-various
   :type 'hook)
 
 (defcustom message-send-news-hook nil
   :group 'message-various
   :type 'hook)
 
 (defcustom message-send-news-hook nil

-  "Hook run before sending news messages."
+  "Hook run before sending news messages.
+This hook is run very late -- just before the message is sent as
+news."

   :group 'message-various
   :type 'hook)
 
   :group 'message-various
   :type 'hook)
 


@@ -1268,6 +1282,12 @@ no, only reply back to the author."
   :group 'message-headers
   :type 'boolean)
 
   :group 'message-headers
   :type 'boolean)
 

+(defcustom message-user-fqdn nil
+  "*Domain part of Messsage-Ids."
+  :group 'message-headers
+  :link '(custom-manual "(message)News Headers")
+  :type 'string)
+

 ;;; Internal variables.
 
 (defvar message-sending-message "Sending...")
 ;;; Internal variables.
 
 (defvar message-sending-message "Sending...")


@@ -1314,7 +1334,7 @@ no, only reply back to the author."
      ;; We want to match the results of any of these manglings.
      ;; The following regexp rejects names whose first characters are
      ;; obviously bogus, but after that anything goes.
      ;; We want to match the results of any of these manglings.
      ;; The following regexp rejects names whose first characters are
      ;; obviously bogus, but after that anything goes.

-     "\\([^\0-\b\n-\r\^?].*\\)? "
+     "\\([^\0-\b\n-\r\^?].*\\)?"

 
      ;; The time the message was sent.
      "\\([^\0-\r \^?]+\\) +"           ; day of the week
 
      ;; The time the message was sent.
      "\\([^\0-\r \^?]+\\) +"           ; day of the week


@@ -1376,6 +1396,19 @@ no, only reply back to the author."
 (defvar message-bogus-system-names "^localhost\\."
   "The regexp of bogus system names.")
 
 (defvar message-bogus-system-names "^localhost\\."
   "The regexp of bogus system names.")
 

+(defcustom message-valid-fqdn-regexp
+  (concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain.
+         ;; valid TLDs:
+         "\\([a-z][a-z]" ;; two letter country TDLs
+         "\\|biz\\|com\\|edu\\|gov\\|int\\|mil\\|net\\|org"
+         "\\|aero\\|coop\\|info\\|name\\|museum"
+         "\\|arpa\\|pro\\|uucp\\|bitnet\\|bofh" ;; old style?
+         "\\)")
+  "Regular expression that matches a valid FQDN."
+  ;; see also: gnus-button-valid-fqdn-regexp
+  :group 'message-headers
+  :type 'regexp)
+

 (eval-and-compile
   (autoload 'message-setup-toolbar "messagexmas")
   (autoload 'mh-new-draft-name "mh-comp")
 (eval-and-compile
   (autoload 'message-setup-toolbar "messagexmas")
   (autoload 'mh-new-draft-name "mh-comp")


@@ -1411,6 +1444,10 @@ no, only reply back to the author."
   `(delete-region (progn (beginning-of-line) (point))
                  (progn (forward-line ,(or n 1)) (point))))
 
   `(delete-region (progn (beginning-of-line) (point))
                  (progn (forward-line ,(or n 1)) (point))))
 

+(defun message-mark-active-p ()
+  "Non-nil means the mark and region are currently active in this buffer."
+  mark-active)
+

 (defun message-unquote-tokens (elems)
   "Remove double quotes (\") from strings in list ELEMS."
   (mapcar (lambda (item)
 (defun message-unquote-tokens (elems)
   "Remove double quotes (\") from strings in list ELEMS."
   (mapcar (lambda (item)


@@ -1520,7 +1557,9 @@ is used by default."
 (defun message-fetch-reply-field (header)
   "Fetch field HEADER from the message we're replying to."
   (message-with-reply-buffer
 (defun message-fetch-reply-field (header)
   "Fetch field HEADER from the message we're replying to."
   (message-with-reply-buffer

-    (message-fetch-field header)))
+    (save-restriction
+      (mail-narrow-to-head)
+      (message-fetch-field header))))

 
 (defun message-set-work-buffer ()
   (if (get-buffer " *message work*")
 
 (defun message-set-work-buffer ()
   (if (get-buffer " *message work*")


@@ -1700,7 +1739,7 @@ With prefix-argument just set Follow-Up, don't cross-post."
              (not (string-match (regexp-quote target-group)
                                 (message-fetch-field "Newsgroups"))))
         (end-of-line)
              (not (string-match (regexp-quote target-group)
                                 (message-fetch-field "Newsgroups"))))
         (end-of-line)

-        (insert-string (concat "," target-group))))
+        (insert (concat "," target-group))))

   (end-of-line) ; ensure Followup: comes after Newsgroups:
   ;; unless new followup would be identical to Newsgroups line
   ;; make a new Followup-To line
   (end-of-line) ; ensure Followup: comes after Newsgroups:
   ;; unless new followup would be identical to Newsgroups line
   ;; make a new Followup-To line


@@ -2051,13 +2090,19 @@ Point is left at the beginning of the narrowed-to region."
 (easy-menu-define
   message-mode-menu message-mode-map "Message Menu."
   `("Message"
 (easy-menu-define
   message-mode-menu message-mode-map "Message Menu."
   `("Message"

-    ["Yank Original" message-yank-original t]
+    ["Yank Original" message-yank-original message-reply-buffer]

     ["Fill Yanked Message" message-fill-yanked-message t]
     ["Insert Signature" message-insert-signature t]
     ["Caesar (rot13) Message" message-caesar-buffer-body t]
     ["Fill Yanked Message" message-fill-yanked-message t]
     ["Insert Signature" message-insert-signature t]
     ["Caesar (rot13) Message" message-caesar-buffer-body t]

-    ["Caesar (rot13) Region" message-caesar-region (mark t)]
-    ["Elide Region" message-elide-region (mark t)]
-    ["Delete Outside Region" message-delete-not-region (mark t)]
+    ["Caesar (rot13) Region" message-caesar-region (message-mark-active-p)]
+    ["Elide Region" message-elide-region 
+     :active (message-mark-active-p)
+     ,@(if (featurep 'xemacs) nil
+        '(:help "Replace text in region with an ellipsis"))]
+    ["Delete Outside Region" message-delete-not-region 
+     :active (message-mark-active-p)
+     ,@(if (featurep 'xemacs) nil
+        '(:help "Delete all quoted text outside region"))]

     ["Kill To Signature" message-kill-to-signature t]
     ["Newline and Reformat" message-newline-and-reformat t]
     ["Rename buffer" message-rename-buffer t]
     ["Kill To Signature" message-kill-to-signature t]
     ["Newline and Reformat" message-newline-and-reformat t]
     ["Rename buffer" message-rename-buffer t]


@@ -2066,7 +2111,8 @@ Point is left at the beginning of the narrowed-to region."
         '(:help "Spellcheck this message"))]
     "----"
     ["Insert Region Marked" message-mark-inserted-region
         '(:help "Spellcheck this message"))]
     "----"
     ["Insert Region Marked" message-mark-inserted-region

-     ,@(if (featurep 'xemacs) '(t)
+     :active (message-mark-active-p)
+     ,@(if (featurep 'xemacs) nil

         '(:help "Mark region with enclosing tags"))]
     ["Insert File Marked..." message-mark-insert-file
      ,@(if (featurep 'xemacs) '(t)
         '(:help "Mark region with enclosing tags"))]
     ["Insert File Marked..." message-mark-insert-file
      ,@(if (featurep 'xemacs) '(t)


@@ -2252,6 +2298,11 @@ M-RET    `message-newline-and-reformat' (break the line and reformat)."
   (set (make-local-variable 'message-checksum) nil)
   (set (make-local-variable 'message-mime-part) 0)
   (message-setup-fill-variables)
   (set (make-local-variable 'message-checksum) nil)
   (set (make-local-variable 'message-mime-part) 0)
   (message-setup-fill-variables)

+  (set
+   (make-local-variable 'paragraph-separate)
+   (format "\\(%s\\)\\|\\(%s\\)"
+          paragraph-separate
+          "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)"))

   ;; Allow using comment commands to add/remove quoting.
   (set (make-local-variable 'comment-start) message-yank-prefix)
   (if (featurep 'xemacs)
   ;; Allow using comment commands to add/remove quoting.
   (set (make-local-variable 'comment-start) message-yank-prefix)
   (if (featurep 'xemacs)


@@ -3134,6 +3185,7 @@ It should typically alter the sending method in some way or other."
       (when (funcall (cadr elem))
        (when (and (or (not (memq (car elem)
                                  message-sent-message-via))
       (when (funcall (cadr elem))
        (when (and (or (not (memq (car elem)
                                  message-sent-message-via))

+                      (not (message-fetch-field "supersedes"))

                       (if (or (message-gnksa-enable-p 'multiple-copies)
                               (not (eq (car elem) 'news)))
                           (y-or-n-p
                       (if (or (message-gnksa-enable-p 'multiple-copies)
                               (not (eq (car elem) 'news)))
                           (y-or-n-p


@@ -3214,7 +3266,8 @@ It should typically alter the sending method in some way or other."
        (goto-char (car points))
        (dolist (point points)
          (add-text-properties point (1+ point)
        (goto-char (car points))
        (dolist (point points)
          (add-text-properties point (1+ point)

-                              '(invisible nil highlight t)))
+                              '(invisible nil face highlight
+                                          font-lock-face highlight)))

        (unless (yes-or-no-p
                 "Invisible text found and made visible; continue posting? ")
          (error "Invisible text found and made visible")))))
        (unless (yes-or-no-p
                 "Invisible text found and made visible; continue posting? ")
          (error "Invisible text found and made visible")))))


@@ -3229,14 +3282,15 @@ It should typically alter the sending method in some way or other."
                         (memq (char-charset char)
                               '(eight-bit-control eight-bit-graphic
                                                   control-1)))))
                         (memq (char-charset char)
                               '(eight-bit-control eight-bit-graphic
                                                   control-1)))))

-         (add-text-properties (point) (1+ (point)) '(highlight t))
+         (add-text-properties (point) (1+ (point))
+                              '(font-lock-face highlight face highlight))

          (setq found t))
        (forward-char)
        (skip-chars-forward mm-7bit-chars))
       (when found
        (setq choice
              (gnus-multiple-choice
          (setq found t))
        (forward-char)
        (skip-chars-forward mm-7bit-chars))
       (when found
        (setq choice
              (gnus-multiple-choice

-              "Illegible text found. Continue posting? "
+              "Illegible text found.  Continue posting?"

               '((?d "Remove and continue posting")
                 (?r "Replace with dots and continue posting")
                 (?i "Ignore and continue posting")
               '((?d "Remove and continue posting")
                 (?r "Replace with dots and continue posting")
                 (?i "Ignore and continue posting")


@@ -3253,10 +3307,11 @@ It should typically alter the sending method in some way or other."
                                 '(eight-bit-control eight-bit-graphic
                                                     control-1)))))
            (if (eq choice ?i)
                                 '(eight-bit-control eight-bit-graphic
                                                     control-1)))))
            (if (eq choice ?i)

-               (remove-text-properties (point) (1+ (point)) '(highlight t))
+               (remove-text-properties (point) (1+ (point))
+                                       '(font-lock-face highlight face highlight))

              (delete-char 1)
              (delete-char 1)

-             (if (eq choice ?r)
-                 (insert "."))))
+             (when (eq choice ?r)
+               (insert "."))))

          (forward-char)
          (skip-chars-forward mm-7bit-chars))))))
 
          (forward-char)
          (skip-chars-forward mm-7bit-chars))))))
 


@@ -3448,7 +3503,7 @@ sent in one piece.
 
 The size limit is controlled by `message-send-mail-partially-limit'.
 If you always want Gnus to send messages in one piece, set
 
 The size limit is controlled by `message-send-mail-partially-limit'.
 If you always want Gnus to send messages in one piece, set

-`message-send-mail-partially-limit' to `nil'.
+`message-send-mail-partially-limit' to nil.

 ")))
              (mm-with-unibyte-current-buffer
                (message "Sending via mail...")
 ")))
              (mm-with-unibyte-current-buffer
                (message "Sending via mail...")


@@ -3504,7 +3559,7 @@ If you always want Gnus to send messages in one piece, set
                        ;; But some systems are more broken with -f, so
                        ;; we'll let users override this.
                        (if (null message-sendmail-f-is-evil)
                        ;; 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)))
+                           (list "-f" (message-sendmail-envelope-from)))

                        ;; These mean "report errors by mail"
                        ;; and "deliver in background".
                        (if (null message-interactive) '("-oem" "-odb"))
                        ;; These mean "report errors by mail"
                        ;; and "deliver in background".
                        (if (null message-interactive) '("-oem" "-odb"))


@@ -4454,30 +4509,53 @@ give as trustworthy answer as possible."
 
 (defun message-user-mail-address ()
   "Return the pertinent part of `user-mail-address'."
 
 (defun message-user-mail-address ()
   "Return the pertinent part of `user-mail-address'."

-  (when user-mail-address
+  (when (and user-mail-address
+            (string-match "@.*\\." user-mail-address))

     (if (string-match " " user-mail-address)
        (nth 1 (mail-extract-address-components user-mail-address))
       user-mail-address)))
 
     (if (string-match " " user-mail-address)
        (nth 1 (mail-extract-address-components user-mail-address))
       user-mail-address)))
 

+(defun message-sendmail-envelope-from ()
+  "Return the envelope from."
+  (cond ((eq message-sendmail-envelope-from 'header)
+        (nth 1 (mail-extract-address-components
+                (message-fetch-field "from"))))
+       ((stringp message-sendmail-envelope-from)
+        message-sendmail-envelope-from)
+       (t
+        (message-make-address))))
+

 (defun message-make-fqdn ()
   "Return user's fully qualified domain name."
 (defun message-make-fqdn ()
   "Return user's fully qualified domain name."

-  (let ((system-name (system-name))
-       (user-mail (message-user-mail-address)))
+  (let* ((system-name (system-name))
+        (user-mail (message-user-mail-address))
+        (user-domain
+         (if (and user-mail
+                  (string-match "@\\(.*\\)\\'" user-mail))
+             (match-string 1 user-mail))))

     (cond
     (cond

-     ((and (string-match "[^.]\\.[^.]" system-name)
+     ((and message-user-fqdn
+          (stringp message-user-fqdn)
+          (string-match message-valid-fqdn-regexp message-user-fqdn)
+          (not (string-match message-bogus-system-names message-user-fqdn)))
+      message-user-fqdn)
+     ;; `message-user-fqdn' seems to be valid
+     ((and (string-match message-valid-fqdn-regexp system-name)

           (not (string-match message-bogus-system-names system-name)))
       ;; `system-name' returned the right result.
       system-name)
      ;; Try `mail-host-address'.
      ((and (boundp 'mail-host-address)
           (stringp mail-host-address)
           (not (string-match message-bogus-system-names system-name)))
       ;; `system-name' returned the right result.
       system-name)
      ;; Try `mail-host-address'.
      ((and (boundp 'mail-host-address)
           (stringp mail-host-address)

-          (string-match "\\." mail-host-address))
+          (string-match message-valid-fqdn-regexp mail-host-address)
+          (not (string-match message-bogus-system-names mail-host-address)))

       mail-host-address)
      ;; We try `user-mail-address' as a backup.
       mail-host-address)
      ;; We try `user-mail-address' as a backup.

-     ((and user-mail
-          (string-match "\\." user-mail)
-          (string-match "@\\(.*\\)\\'" user-mail))
-      (match-string 1 user-mail))
+     ((and user-domain
+          (stringp user-domain)
+          (string-match message-valid-fqdn-regexp user-domain)
+          (not (string-match message-bogus-system-names user-domain)))
+      user-domain)

      ;; Default to this bogus thing.
      (t
       (concat system-name ".i-did-not-set--mail-host-address--so-tickle-me")))))
      ;; Default to this bogus thing.
      (t
       (concat system-name ".i-did-not-set--mail-host-address--so-tickle-me")))))


@@ -5736,7 +5814,7 @@ Optional DIGEST will use digest to forward."
             (mm-disable-multibyte-mule4)
             (insert
              (with-current-buffer forward-buffer
             (mm-disable-multibyte-mule4)
             (insert
              (with-current-buffer forward-buffer

-               (mm-string-as-unibyte (buffer-string))))
+               (mm-with-unibyte-current-buffer-mule4 (buffer-string))))

             (mm-enable-multibyte-mule4)
             (mime-to-mml)
             (goto-char (point-min))
             (mm-enable-multibyte-mule4)
             (mime-to-mml)
             (goto-char (point-min))


@@ -5808,12 +5886,16 @@ Optional DIGEST will use digest to forward."
       (unless (message-mail-user-agent)
        (set-buffer (get-buffer-create " *message resend*"))
        (erase-buffer))
       (unless (message-mail-user-agent)
        (set-buffer (get-buffer-create " *message resend*"))
        (erase-buffer))

-      (let ((message-this-is-mail t))
+      (let ((message-this-is-mail t)
+           message-setup-hook)

        (message-setup `((To . ,address))))
       ;; Insert our usual headers.
       (message-generate-headers '(From Date To))
       (message-narrow-to-headers)
        (message-setup `((To . ,address))))
       ;; Insert our usual headers.
       (message-generate-headers '(From Date To))
       (message-narrow-to-headers)

+      ;; Remove X-Draft-From header etc.
+      (message-remove-header message-ignored-mail-headers t)

       ;; Rename them all to "Resent-*".
       ;; Rename them all to "Resent-*".

+      (goto-char (point-min))

       (while (re-search-forward "^[A-Za-z]" nil t)
        (forward-char -1)
        (insert "Resent-"))
       (while (re-search-forward "^[A-Za-z]" nil t)
        (forward-char -1)
        (insert "Resent-"))