* imap.el: Add compiler directives.
[gnus] / lisp / message.el
index 70e56ef..01a16b0 100644 (file)
 (require 'mail-parse)
 (require 'mml)
 (require 'rfc822)
-(eval-and-compile
-  (autoload 'sha1 "sha1-el")
-  (autoload 'gnus-find-method-for-group "gnus")
-  (autoload 'nnvirtual-find-group-art "nnvirtual")
-  (autoload 'gnus-group-decoded-name "gnus-group"))
 
 (defgroup message '((user-mail-address custom-variable)
                    (user-full-name custom-variable))
@@ -729,11 +724,6 @@ might set this variable to '(\"-f\" \"you@some.where\")."
   :type '(choice (function)
                 (repeat string)))
 
-(defvar message-cater-to-broken-inn t
-  "Non-nil means Gnus should not fold the `References' header.
-Folding `References' makes ancient versions of INN create incorrect
-NOV lines.")
-
 (eval-when-compile
   (defvar gnus-post-method)
   (defvar gnus-select-method))
@@ -760,7 +750,7 @@ variable isn't used."
 ;; is nil.  See: http://article.gmane.org/gmane.emacs.gnus.general/51138
 (defcustom message-generate-headers-first '(references)
   "Which headers should be generated before starting to compose a message.
-If `t', generate all required headers.  This can also be a list of headers to
+If t, generate all required headers.  This can also be a list of headers to
 generate.  The variables `message-required-news-headers' and
 `message-required-mail-headers' specify which headers to generate.
 
@@ -1530,24 +1520,34 @@ no, only reply back to the author."
   :type 'regexp)
 
 (eval-and-compile
-  (autoload 'message-setup-toolbar "messagexmas")
-  (autoload 'mh-new-draft-name "mh-comp")
-  (autoload 'mh-send-letter "mh-comp")
-  (autoload 'gnus-output-to-rmail "gnus-util")
-  (autoload 'gnus-output-to-mail "gnus-util")
-  (autoload 'nndraft-request-associate-buffer "nndraft")
-  (autoload 'nndraft-request-expire-articles "nndraft")
-  (autoload 'gnus-open-server "gnus-int")
-  (autoload 'gnus-request-post "gnus-int")
   (autoload 'gnus-alive-p "gnus-util")
-  (autoload 'gnus-server-string "gnus")
+  (autoload 'gnus-delay-article "gnus-delay")
+  (autoload 'gnus-extract-address-components "gnus-util")
+  (autoload 'gnus-find-method-for-group "gnus")
+  (autoload 'gnus-group-decoded-name "gnus-group")
   (autoload 'gnus-group-name-charset "gnus-group")
   (autoload 'gnus-group-name-decode "gnus-group")
   (autoload 'gnus-groups-from-server "gnus")
-  (autoload 'rmail-output "rmailout")
-  (autoload 'gnus-delay-article "gnus-delay")
   (autoload 'gnus-make-local-hook "gnus-util")
-  (autoload 'gnus-extract-address-components "gnus-util"))
+  (autoload 'gnus-open-server "gnus-int")
+  (autoload 'gnus-output-to-mail "gnus-util")
+  (autoload 'gnus-output-to-rmail "gnus-util")
+  (autoload 'gnus-request-post "gnus-int")
+  (autoload 'gnus-server-string "gnus")
+  (autoload 'idna-to-ascii "idna")
+  (autoload 'message-setup-toolbar "messagexmas")
+  (autoload 'mh-new-draft-name "mh-comp")
+  (autoload 'mh-send-letter "mh-comp")
+  (autoload 'nndraft-request-associate-buffer "nndraft")
+  (autoload 'nndraft-request-expire-articles "nndraft")
+  (autoload 'nnvirtual-find-group-art "nnvirtual")
+  (autoload 'rmail-dont-reply-to "mail-utils")
+  (autoload 'rmail-msg-is-pruned "rmail")
+  (autoload 'rmail-msg-restore-non-pruned-header "rmail")
+  (autoload 'rmail-output "rmailout"))
+
+(eval-when-compile
+  (autoload 'sha1 "sha1-el"))
 
 \f
 
@@ -1627,7 +1627,6 @@ is used by default."
 The buffer is expected to be narrowed to just the header of the message;
 see `message-narrow-to-headers-or-head'."
   (let* ((inhibit-point-motion-hooks t)
-        (case-fold-search t)
         (value (mail-fetch-field header nil (not not-all))))
     (when value
       (while (string-match "\n[\t ]+" value)
@@ -1650,9 +1649,7 @@ see `message-narrow-to-headers-or-head'."
    (progn
      (forward-line 1)
      (if (re-search-forward "^[^ \n\t]" nil t)
-        (progn
-          (beginning-of-line)
-          (point))
+        (point-at-bol)
        (point-max))))
   (goto-char (point-min)))
 
@@ -2128,6 +2125,16 @@ Point is left at the beginning of the narrowed-to region."
             (1+ max)))))
       (message-sort-headers-1))))
 
+(defun message-delete-address ()
+  "Delete the address under point."
+  (interactive)
+  (let ((start (point))
+       (quote nil))
+    (message-narrow-to-field)
+    (while (and (not (eobp))
+               (or (not (eq (setq char (following-char)) ?,))
+                   (not quote)))
+      ())))
 
 \f
 
@@ -2440,11 +2447,6 @@ 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)
@@ -2496,7 +2498,9 @@ M-RET    `message-newline-and-reformat' (break the line and reformat)."
           "---+$\\|"              ; delimiters for forwarded messages
           page-delimiter "$\\|"        ; spoiler warnings
           ".*wrote:$\\|"               ; attribution lines
-          quote-prefix-regexp "$"))    ; empty lines in quoted text
+          quote-prefix-regexp "$\\|"   ; empty lines in quoted text
+                                       ; mml tags
+          "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)"))
     (setq paragraph-separate paragraph-start)
     (setq adaptive-fill-regexp
          (concat quote-prefix-regexp "\\|" adaptive-fill-regexp))
@@ -2760,16 +2764,23 @@ or in the synonym headers, defined by `message-header-synonyms'."
   (when (message-goto-signature)
     (forward-line -2)))
 
-(defun message-kill-to-signature ()
-  "Deletes all text up to the signature."
-  (interactive)
-  (let ((point (point)))
-    (message-goto-signature)
-    (unless (eobp)
-      (end-of-line -1))
-    (kill-region point (point))
-    (unless (bolp)
-      (insert "\n"))))
+(defun message-kill-to-signature (&optional arg)
+  "Kill all text up to the signature.
+If a numberic argument or prefix arg is given, leave that number
+of lines before the signature intact."
+  (interactive "p")
+  (save-excursion
+    (save-restriction
+      (let ((point (point)))
+       (narrow-to-region point (point-max))
+       (message-goto-signature)
+       (unless (eobp)
+         (if (and arg (numberp arg))
+             (forward-line (- -1 arg))
+           (end-of-line -1)))
+       (unless (= point (point))
+         (kill-region point (point))
+         (insert "\n"))))))
 
 (defun message-newline-and-reformat (&optional arg not-break)
   "Insert four newlines, and then reformat if inside quoted text.
@@ -3886,14 +3897,15 @@ to find out how to use this."
   "Send the prepared message buffer with `smtpmail-send-it'.
 This only differs from `smtpmail-send-it' that this command evaluates
 `message-send-mail-hook' just before sending a message.  It is useful
-if your ISP requires the POP-before-SMTP authentication.  See the
-documentation for the function `mail-source-touch-pop'."
+if your ISP requires the POP-before-SMTP authentication.  See the Gnus
+manual for details."
   (run-hooks 'message-send-mail-hook)
   (smtpmail-send-it))
 
 (defun message-canlock-generate ()
   "Return a string that is non-trivial to guess.
 Do not use this for anything important, it is cryptographically weak."
+  (require 'sha1-el)
   (let (sha1-maximum-internal-length)
     (sha1 (concat (message-unique-id)
                  (format "%x%x%x" (random) (random t) (random))
@@ -4873,57 +4885,25 @@ subscribed address (and not the additional To and Cc header contents)."
              list
            msg-recipients))))))
 
-(defun message-idna-inside-rhs-p ()
-  "Return t iff point is inside a RHS (heuristically).
-Only works properly if header contains mailbox-list or address-list.
-I.e., calling it on a Subject: header is useless."
-  (save-restriction
-    (narrow-to-region (save-excursion (or (re-search-backward "^[^ \t]" nil t)
-                                         (point-min)))
-                     (save-excursion (or (re-search-forward "^[^ \t]" nil t)
-                                         (point-max))))
-    (if (re-search-backward "[\\\n\r\t ]"
-                           (save-excursion (search-backward "@" nil t)) t)
-       ;; whitespace between @ and point
-       nil
-      (let ((dquote 1) (paren 1))
-       (while (save-excursion (re-search-backward "[^\\]\"" nil t dquote))
-         (incf dquote))
-       (while (save-excursion (re-search-backward "[^\\]\(" nil t paren))
-         (incf paren))
-       (and (= (% dquote 2) 1) (= (% paren 2) 1))))))
-
-(autoload 'idna-to-ascii "idna")
-
 (defun message-idna-to-ascii-rhs-1 (header)
   "Interactively potentially IDNA encode domain names in HEADER."
-  (let (rhs ace start startpos endpos ovl)
-    (goto-char (point-min))
-    (while (re-search-forward (concat "^" header) nil t)
-      (while (re-search-forward "@\\([^ \t\r\n>,]+\\)"
-                               (or (save-excursion
-                                     (re-search-forward "^[^ \t]" nil t))
-                                   (point-max))
-                               t)
-       (setq rhs (match-string-no-properties 1)
-             startpos (match-beginning 1)
-             endpos (match-end 1))
-       (when (save-match-data
-               (and (message-idna-inside-rhs-p)
-                    (setq ace (idna-to-ascii rhs))
-                    (not (string= rhs ace))
-                    (if (eq message-use-idna 'ask)
-                        (unwind-protect
-                            (progn
-                              (setq ovl (message-make-overlay startpos
-                                                              endpos))
-                              (message-overlay-put ovl 'face 'highlight)
-                              (y-or-n-p
-                               (format "Replace with `%s'? " ace)))
-                          (message "")
-                          (message-delete-overlay ovl))
-                      message-use-idna)))
-         (replace-match (concat "@" ace)))))))
+  (let ((field (message-fetch-field header))
+       rhs ace  address)
+    (when field
+      (dolist (address (mail-header-parse-addresses field))
+       (setq address (car address)
+             rhs (cadr (split-string address "@"))
+             ace (idna-to-ascii rhs))
+       (when (and (not (equalp rhs ace))
+                  (or (not (eq message-use-idna 'ask))
+                      (y-or-n-p (format "Replace %s with %s? " rhs ace))))
+         (goto-char (point-min))
+         (while (re-search-forward (concat "^" header ":") nil t)
+           (message-narrow-to-field)
+           (while (search-forward (concat "@" rhs) nil t)
+             (replace-match (concat "@" ace) t t))
+           (goto-char (point-max))
+           (widen)))))))
 
 (defun message-idna-to-ascii-rhs ()
   "Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers.
@@ -5179,8 +5159,9 @@ If the current line has `message-yank-prefix', insert it on the new line."
 
 (defun message-shorten-references (header references)
   "Trim REFERENCES to be 21 Message-ID long or less, and fold them.
-If folding is disallowed, also check that the REFERENCES are less
-than 988 characters long, and if they are not, trim them until they are."
+When sending via news, also check that the REFERENCES are less
+than 988 characters long, and if they are not, trim them until
+they are."
   (let ((maxcount 21)
        (count 0)
        (cut 2)
@@ -5202,33 +5183,25 @@ than 988 characters long, and if they are not, trim them until they are."
        (message-shorten-1 refs cut surplus)
        (decf count surplus)))
 
-    ;; If folding is disallowed, make sure the total length (including
-    ;; the spaces between) will be less than MAXSIZE characters.
+    ;; When sending via news, make sure the total folded length will
+    ;; be less than 998 characters.  This is to cater to broken INN
+    ;; 2.3 which counts the total number of characters in a header
+    ;; rather than the physical line length of each line, as it shuld.
     ;;
-    ;; Only disallow folding for News messages. At this point the headers
-    ;; have not been generated, thus we use message-this-is-news directly.
-    (when (and message-this-is-news message-cater-to-broken-inn)
-      (let ((maxsize 988)
-           (totalsize (+ (apply #'+ (mapcar #'length refs))
-                         (1- count)))
-           (surplus 0)
-           (ptr (nthcdr (1- cut) refs)))
-       ;; Decide how many elements to cut off...
-       (while (> totalsize maxsize)
-         (decf totalsize (1+ (length (car ptr))))
-         (incf surplus)
-         (setq ptr (cdr ptr)))
-       ;; ...and do it.
-       (when (> surplus 0)
-         (message-shorten-1 refs cut surplus))))
-
+    ;; This hack should be removed when it's believed than INN 2.3 is
+    ;; no longer widely used.
+    ;;
+    ;; At this point the headers have not been generated, thus we use
+    ;; message-this-is-news directly.
+    (when message-this-is-news
+      (while (< 998
+               (with-temp-buffer
+                 (message-fill-header header (mapconcat #'identity refs " "))
+                 (buffer-size)))
+       (message-shorten-1 refs cut 1)))
     ;; Finally, collect the references back into a string and insert
     ;; it into the buffer.
-    (let ((refstring (mapconcat #'identity refs " ")))
-      (if (and message-this-is-news message-cater-to-broken-inn)
-         (insert (capitalize (symbol-name header)) ": "
-                 refstring "\n")
-       (message-fill-header header refstring)))))
+    (message-fill-header header (mapconcat #'identity refs " "))))
 
 (defun message-position-point ()
   "Move point to where the user probably wants to find it."
@@ -5456,12 +5429,7 @@ are not included."
   (when message-default-headers
     (insert message-default-headers)
     (or (bolp) (insert ?\n)))
-  (put-text-property
-   (point)
-   (progn
-     (insert mail-header-separator "\n")
-     (1- (point)))
-   'read-only nil)
+  (insert mail-header-separator "\n")
   (forward-line -1)
   (when (message-news-p)
     (when message-default-news-headers
@@ -6272,8 +6240,6 @@ Optional DIGEST will use digest to forward."
 (defun message-forward-rmail-make-body (forward-buffer)
   (save-window-excursion
     (set-buffer forward-buffer)
-    ;; Rmail doesn't have rmail-msg-restore-non-pruned-header in Emacs
-    ;; 20.  FIXIT, or we drop support for rmail in Emacs 20.
     (if (rmail-msg-is-pruned)
        (rmail-msg-restore-non-pruned-header)))
   (message-forward-make-body forward-buffer))
@@ -6482,7 +6448,13 @@ which specify the range to operate on."
        (if (eq (char-after) (char-after (- (point) 2)))
            (delete-char -2))))))
 
-(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
+(defun message-exchange-point-and-mark ()
+  "Exchange point and mark, but don't activate region if it was inactive."
+  (unless (prog1
+             (message-mark-active-p)
+           (exchange-point-and-mark))
+    (setq mark-active nil)))
+
 (defalias 'message-make-overlay 'make-overlay)
 (defalias 'message-delete-overlay 'delete-overlay)
 (defalias 'message-overlay-put 'overlay-put)