(gnus-article-refer-article): Be more permissive.
[gnus] / lisp / message.el
index cb0e6f2..a9faf5e 100644 (file)
@@ -194,9 +194,9 @@ Checks include `subject-cmsg', `multiple-headers', `sendsys',
   :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
-1message-required-mail-headers'."
+`message-required-mail-headers'."
   :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)
 
+(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."
@@ -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
-  "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
-  "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
-  "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)
 
@@ -1268,6 +1282,12 @@ no, only reply back to the author."
   :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...")
@@ -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.
-     "\\([^\0-\b\n-\r\^?].*\\)? "
+     "\\([^\0-\b\n-\r\^?].*\\)?"
 
      ;; 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.")
 
+(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")
@@ -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))))
 
+(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)
@@ -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
-    (message-fetch-field header)))
+    (save-restriction
+      (mail-narrow-to-head)
+      (message-fetch-field header))))
 
 (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)
-        (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
@@ -2013,7 +2052,7 @@ Point is left at the beginning of the narrowed-to region."
   (define-key message-mode-map "\C-c\C-i" 'message-goto-signature)
 
   (define-key message-mode-map "\C-c\C-t" 'message-insert-to)
-  (define-key message-mode-map "\C-c\M-t" 'message-insert-wide-reply)
+  (define-key message-mode-map "\C-c\C-fw" 'message-insert-wide-reply)
   (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
   (define-key message-mode-map "\C-c\C-l" 'message-to-list-only)
 
@@ -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"
-    ["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]
-    ["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]
@@ -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
-     ,@(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)
@@ -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 '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)
@@ -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))
+                      (not (message-fetch-field "supersedes"))
                       (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)
-                              '(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")))))
@@ -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)))))
-         (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
-              "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")
@@ -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)
-               (remove-text-properties (point) (1+ (point)) '(highlight t))
+               (remove-text-properties (point) (1+ (point))
+                                       '(font-lock-face highlight face highlight))
              (delete-char 1)
-             (if (eq choice ?r)
-                 (insert "."))))
+             (when (eq choice ?r)
+               (insert "."))))
          (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
-`message-send-mail-partially-limit' to `nil'.
+`message-send-mail-partially-limit' to nil.
 ")))
              (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)
-                           (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"))
@@ -4454,30 +4509,53 @@ give as trustworthy answer as possible."
 
 (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)))
 
+(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."
-  (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
-     ((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)
-          (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.
-     ((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")))))
@@ -5736,7 +5814,7 @@ Optional DIGEST will use digest to forward."
             (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))
@@ -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))
-      (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)
+      ;; Remove X-Draft-From header etc.
+      (message-remove-header message-ignored-mail-headers t)
       ;; Rename them all to "Resent-*".
+      (goto-char (point-min))
       (while (re-search-forward "^[A-Za-z]" nil t)
        (forward-char -1)
        (insert "Resent-"))