X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=b53a3f1dd76a4371e9dbafdf0a3b73f3cd1a5be2;hb=c85ff27626350a909ee39474fecac012fec8cd26;hp=d8927ebc59cbe1c9ed092667966266110762b347;hpb=8cbf0038db13f0d2541f885b37fa6e19c6ce90b5;p=gnus

diff --git a/lisp/message.el b/lisp/message.el
index d8927ebc5..b53a3f1dd 100644
--- a/lisp/message.el
+++ b/lisp/message.el
@@ -1,7 +1,6 @@
 ;;; message.el --- composing mail and news messages
 
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: mail, news
@@ -164,8 +163,8 @@ If this variable is nil, no such courtesy message will be added."
   ;; In Emacs 24.1 this defaults to the value of `mail-from-style'
   ;; that defaults to:
   ;; `angles' in Emacs 22.1~23.1, XEmacs 21.4, 21.5, and SXEmacs 22.1;
-  ;; `default' in Emacs 23.2, and 24.1
-  "*Specifies how \"From\" headers look.
+  ;; `system-default' in Emacs 23.2, and 24.1
+  "Specifies how \"From\" headers look.
 
 If nil, they contain just the return address like:
 	king@grassland.com
@@ -281,7 +280,7 @@ This is a list of regexps and regexp matches."
 		 regexp))
 
 (defcustom message-ignored-mail-headers
-  "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:"
+  "^\\([GF]cc\\|Resent-Fcc\\|Xref\\|X-Draft-From\\|X-Gnus-Agent-Meta-Information\\):"
   "*Regexp of headers to be removed unconditionally before mailing."
   :group 'message-mail
   :group 'message-headers
@@ -310,7 +309,7 @@ any confusion."
 
 ;;; Start of variables adopted from `message-utils.el'.
 
-(defcustom message-subject-trailing-was-query 'ask
+(defcustom message-subject-trailing-was-query t
   "*What to do with trailing \"(was: <old subject>)\" in subject lines.
 If nil, leave the subject unchanged.  If it is the symbol `ask', query
 the user what do do.  In this case, the subject is matched against
@@ -318,7 +317,7 @@ the user what do do.  In this case, the subject is matched against
 `message-subject-trailing-was-query' is t, always strip the trailing
 old subject.  In this case, `message-subject-trailing-was-regexp' is
 used."
-  :version "22.1"
+  :version "24.1"
   :type '(choice (const :tag "never" nil)
 		 (const :tag "always strip" t)
 		 (const ask))
@@ -326,7 +325,7 @@ used."
   :group 'message-various)
 
 (defcustom message-subject-trailing-was-ask-regexp
-  "[ \t]*\\([[(]+[Ww][Aa][Ss][ \t]*.*[\])]+\\)"
+  "[ \t]*\\([[(]+[Ww][Aa][Ss]:?[ \t]*.*[])]+\\)"
   "*Regexp matching \"(was: <old subject>)\" in the subject line.
 
 The function `message-strip-subject-trailing-was' uses this regexp if
@@ -515,14 +514,9 @@ This is used by `message-kill-buffer'."
   :group 'message-buffers
   :type 'boolean)
 
-(defvar gnus-local-organization)
 (defcustom message-user-organization
-  (or (and (boundp 'gnus-local-organization)
-	   (stringp gnus-local-organization)
-	   gnus-local-organization)
-      (getenv "ORGANIZATION")
-      t)
-  "*String to be used as an Organization header.
+  (or (getenv "ORGANIZATION") t)
+  "String to be used as an Organization header.
 If t, use `message-user-organization-file'."
   :group 'message-headers
   :type '(choice string
@@ -1169,6 +1163,8 @@ It is a vector of the following headers:
 (defvar message-checksum nil)
 (defvar message-send-actions nil
   "A list of actions to be performed upon successful sending of a message.")
+(defvar message-return-action nil
+  "Action to return to the caller after sending or postphoning a message.")
 (defvar message-exit-actions nil
   "A list of actions to be performed upon exiting after sending a message.")
 (defvar message-kill-actions nil
@@ -1183,13 +1179,17 @@ It is a vector of the following headers:
   :error "All header lines must be newline terminated")
 
 (defcustom message-default-headers ""
-  "*A string containing header lines to be inserted in outgoing messages.
-It is inserted before you edit the message, so you can edit or delete
-these lines."
+  "Header lines to be inserted in outgoing messages.
+This can be set to a string containing or a function returning
+header lines to be inserted before you edit the message, so you
+can edit or delete these lines.  If set to a function, it is
+called and its result is inserted."
   :version "23.2"
   :group 'message-headers
   :link '(custom-manual "(message)Message Headers")
-  :type 'message-header-lines)
+  :type '(choice
+          (message-header-lines :tag "String")
+          (function :tag "Function")))
 
 (defcustom message-default-mail-headers
   ;; Ease the transition from mail-mode to message-mode.  See bugs#4431, 5555.
@@ -1227,14 +1227,11 @@ these lines."
   (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)"
 			 system-configuration)
 	   (file-readable-p "/etc/sendmail.cf")
-	   (let ((buffer (get-buffer-create " *temp*")))
-	     (unwind-protect
-		 (with-current-buffer buffer
-		   (insert-file-contents "/etc/sendmail.cf")
-		   (goto-char (point-min))
-		   (let ((case-fold-search nil))
-		     (re-search-forward "^OR\\>" nil t)))
-	       (kill-buffer buffer))))
+	   (with-temp-buffer
+             (insert-file-contents "/etc/sendmail.cf")
+             (goto-char (point-min))
+             (let ((case-fold-search nil))
+               (re-search-forward "^OR\\>" nil t))))
       ;; According to RFC822, "The field-name must be composed of printable
       ;; ASCII characters (i. e., characters that have decimal values between
       ;; 33 and 126, except colon)", i. e., any chars except ctl chars,
@@ -2683,7 +2680,6 @@ PGG manual, depending on the value of `mml2015-use'."
 
   (define-key message-mode-map "\C-a" 'message-beginning-of-line)
   (define-key message-mode-map "\t" 'message-tab)
-  (define-key message-mode-map "\M-;" 'comment-region)
 
   (define-key message-mode-map "\M-n" 'message-display-abbrev))
 
@@ -2909,6 +2905,7 @@ M-RET    `message-newline-and-reformat' (break the line and reformat)."
   (set (make-local-variable 'message-reply-buffer) nil)
   (set (make-local-variable 'message-inserted-headers) nil)
   (set (make-local-variable 'message-send-actions) nil)
+  (set (make-local-variable 'message-return-action) nil)
   (set (make-local-variable 'message-exit-actions) nil)
   (set (make-local-variable 'message-kill-actions) nil)
   (set (make-local-variable 'message-postpone-actions) nil)
@@ -2960,6 +2957,7 @@ M-RET    `message-newline-and-reformat' (break the line and reformat)."
 	  (mail-aliases-setup))))
    ((message-mail-alias-type-p 'ecomplete)
     (ecomplete-setup)))
+  (add-hook 'completion-at-point-functions 'message-completion-function nil t)
   (unless buffer-file-name
     (message-set-auto-save-file-name))
   (unless (buffer-base-buffer)
@@ -3088,10 +3086,22 @@ M-RET    `message-newline-and-reformat' (break the line and reformat)."
   (interactive)
   (message-position-on-field "Summary" "Subject"))
 
-(defun message-goto-body (&optional interactivep)
+(eval-when-compile
+  (defmacro message-called-interactively-p (kind)
+    (condition-case nil
+	(progn
+	  (eval '(called-interactively-p 'any))
+	  ;; Emacs >=23.2
+	  `(called-interactively-p ,kind))
+      ;; Emacs <23.2
+      (wrong-number-of-arguments '(called-interactively-p))
+      ;; XEmacs
+      (void-function '(interactive-p)))))
+
+(defun message-goto-body ()
   "Move point to the beginning of the message body."
-  (interactive (list t))
-  (when (and interactivep
+  (interactive)
+  (when (and (message-called-interactively-p 'any)
 	     (looking-at "[ \t]*\n"))
     (expand-abbrev))
   (goto-char (point-min))
@@ -3100,7 +3110,7 @@ M-RET    `message-newline-and-reformat' (break the line and reformat)."
 
 (defun message-in-body-p ()
   "Return t if point is in the message body."
-  (let ((body (save-excursion (message-goto-body) (point))))
+  (let ((body (save-excursion (message-goto-body))))
     (>= (point) body)))
 
 (defun message-goto-eoh ()
@@ -3988,11 +3998,9 @@ The text will also be indented the normal way."
 	(actions message-exit-actions))
     (when (and (message-send arg)
 	       (buffer-name buf))
+      (message-bury buf)
       (if message-kill-buffer-on-exit
-	  (kill-buffer buf)
-	(bury-buffer buf)
-	(when (eq buf (current-buffer))
-	  (message-bury buf)))
+	  (kill-buffer buf))
       (message-do-actions actions)
       t)))
 
@@ -4042,9 +4050,8 @@ Instead, just auto-save the buffer and then bury it."
   "Bury this mail BUFFER."
   (let ((newbuf (other-buffer buffer)))
     (bury-buffer buffer)
-    (if (and (window-dedicated-p (selected-window))
-	     (not (null (delq (selected-frame) (visible-frame-list)))))
-	(delete-frame (selected-frame))
+    (if message-return-action
+	(apply (car message-return-action) (cdr message-return-action))
       (switch-to-buffer newbuf))))
 
 (defun message-send (&optional arg)
@@ -4164,7 +4171,6 @@ not have PROP."
     (nreverse regions)))
 
 (defcustom message-bogus-addresses
-  ;; '("noreply" "nospam" "invalid")
   '("noreply" "nospam" "invalid" "@@" "[^[:ascii:]].*@" "[ \t]")
   "List of regexps of potentially bogus mail addresses.
 See `message-check-recipients' how to setup checking.
@@ -4294,9 +4300,10 @@ matching entry in `message-bogus-addresses'."
   ;; FIXME: How about "foo@subdomain", when the MTA adds ".domain.tld"?
   (let (found)
     (mapc (lambda (address)
-	    (setq address (cadr address))
+	    (setq address (or (cadr address) ""))
 	    (when
-		(or (not
+		(or (string= "" address)
+                    (not
 		     (or
 		      (not (string-match "@" address))
 		      (string-match
@@ -4310,7 +4317,7 @@ matching entry in `message-bogus-addresses'."
 					       "\\|")
 				  message-bogus-addresses)))
 			   (string-match re address))))
-			 (push address found)))
+              (push address found)))
 	  ;;
 	  (mail-extract-address-components recipients t))
     found))
@@ -4329,7 +4336,17 @@ This function could be useful in `message-setup-hook'."
 	    (and bog
 		 (not (y-or-n-p
 		       (format
-			"Address `%s' might be bogus.  Continue? " bog)))
+			"Address `%s'%s might be bogus.  Continue? "
+			bog
+			;; If the encoded version of the email address
+			;; is different from the unencoded version,
+			;; then we likely have invisible characters or
+			;; the like.  Display the encoded version,
+			;; too.
+			(let ((encoded (rfc2047-encode-string bog)))
+			  (if (string= encoded bog)
+			      ""
+			    (format " (%s)" encoded))))))
 		 (error "Bogus address"))))))))
 
 (custom-add-option 'message-setup-hook 'message-check-recipients)
@@ -4523,6 +4540,8 @@ This function could be useful in `message-setup-hook'."
 	      (save-restriction
 		(message-narrow-to-headers)
 		(and news
+		     (not (message-fetch-field "List-Post"))
+		     (not (message-fetch-field "List-ID"))
 		     (or (message-fetch-field "cc")
 			 (message-fetch-field "bcc")
 			 (message-fetch-field "to"))
@@ -4539,7 +4558,9 @@ This function could be useful in `message-setup-hook'."
 			 (string= "base64"
 				  (message-fetch-field
 				   "content-transfer-encoding")))))))
-	    (message-insert-courtesy-copy))
+	    (message-insert-courtesy-copy
+	     (with-current-buffer mailbuf
+	       message-courtesy-message)))
           ;; Let's make sure we encoded all the body.
           (assert (save-excursion
                     (goto-char (point-min))
@@ -5980,7 +6001,7 @@ Headers already prepared in the buffer are not modified."
       ;; Check for IDNA
       (message-idna-to-ascii-rhs))))
 
-(defun message-insert-courtesy-copy ()
+(defun message-insert-courtesy-copy (message)
   "Insert a courtesy message in mail copies of combined messages."
   (let (newsgroups)
     (save-excursion
@@ -5990,12 +6011,12 @@ Headers already prepared in the buffer are not modified."
 	  (goto-char (point-max))
 	  (insert "Posted-To: " newsgroups "\n")))
       (forward-line 1)
-      (when message-courtesy-message
+      (when message
 	(cond
-	 ((string-match "%s" message-courtesy-message)
-	  (insert (format message-courtesy-message newsgroups)))
+	 ((string-match "%s" message)
+	  (insert (format message newsgroups)))
 	 (t
-	  (insert message-courtesy-message)))))))
+	  (insert message)))))))
 
 ;;;
 ;;; Setting up a message buffer
@@ -6332,11 +6353,11 @@ between beginning of field and beginning of line."
 ;; YANK-ACTION, if non-nil, can be a buffer or a yank action of the
 ;; form (FUNCTION . ARGS).
 (defun message-setup (headers &optional yank-action actions
-			      continue switch-function)
+			      continue switch-function return-action)
   (let ((mua (message-mail-user-agent))
 	subject to field)
     (if (not (and message-this-is-mail mua))
-	(message-setup-1 headers yank-action actions)
+	(message-setup-1 headers yank-action actions return-action)
       (setq headers (copy-sequence headers))
       (setq field (assq 'Subject headers))
       (when field
@@ -6384,11 +6405,12 @@ are not included."
 	(push header result)))
     (nreverse result)))
 
-(defun message-setup-1 (headers &optional yank-action actions)
+(defun message-setup-1 (headers &optional yank-action actions return-action)
   (dolist (action actions)
     (condition-case nil
 	(add-to-list 'message-send-actions
 		     `(apply ',(car action) ',(cdr action)))))
+  (setq message-return-action return-action)
   (setq message-reply-buffer
 	(if (and (consp yank-action)
 		 (eq (car yank-action) 'insert-buffer))
@@ -6407,7 +6429,10 @@ are not included."
    headers)
   (delete-region (point) (progn (forward-line -1) (point)))
   (when message-default-headers
-    (insert message-default-headers)
+    (insert
+     (if (functionp message-default-headers)
+         (funcall message-default-headers)
+       message-default-headers))
     (or (bolp) (insert ?\n)))
   (insert mail-header-separator "\n")
   (forward-line -1)
@@ -6514,9 +6539,9 @@ are not included."
 ;;;
 
 ;;;###autoload
-(defun message-mail (&optional to subject
-			       other-headers continue switch-function
-			       yank-action send-actions)
+(defun message-mail (&optional to subject other-headers continue
+			       switch-function yank-action send-actions
+			       return-action &rest ignored)
   "Start editing a mail message to be sent.
 OTHER-HEADERS is an alist of header/value pairs.  CONTINUE says whether
 to continue editing a message already being composed.  SWITCH-FUNCTION
@@ -6536,8 +6561,15 @@ is a function used to switch to and display the mail buffer."
     (message-setup
      (nconc
       `((To . ,(or to "")) (Subject . ,(or subject "")))
-      (when other-headers other-headers))
-     yank-action send-actions continue switch-function)
+      ;; C-h f compose-mail says that headers should be specified as
+      ;; (string . value); however all the rest of message expects
+      ;; headers to be symbols, not strings (eg message-header-format-alist).
+      ;; http://lists.gnu.org/archive/html/emacs-devel/2011-01/msg00337.html
+      ;; We need to convert any string input, eg from rmail-start-mail.
+      (dolist (h other-headers other-headers)
+ 	(if (stringp (car h)) (setcar h (intern (capitalize (car h)))))))
+     yank-action send-actions continue switch-function
+     return-action)
     ;; FIXME: Should return nil if failure.
     t))
 
@@ -7466,7 +7498,11 @@ is for the internal use."
       (when (looking-at "From ")
 	(replace-match "X-From-Line: "))
       ;; Send it.
-      (let ((message-inhibit-body-encoding t)
+      (let ((message-inhibit-body-encoding
+	     ;; Don't do any further encoding if it looks like the
+	     ;; message has already been encoded.
+	     (let ((case-fold-search t))
+	       (re-search-forward "^mime-version:" nil t)))
 	    (message-inhibit-ecomplete t)
 	    message-required-mail-headers
 	    message-generate-hashcash
@@ -7663,24 +7699,22 @@ Pre-defined symbols include `message-tool-bar-gnome' and
 
 (defcustom message-tool-bar-gnome
   '((ispell-message "spell" nil
+		    :vert-only t
 		    :visible (or (not (boundp 'flyspell-mode))
 				 (not flyspell-mode)))
     (flyspell-buffer "spell" t
+		     :vert-only t
 		     :visible (and (boundp 'flyspell-mode)
 				   flyspell-mode)
 		     :help "Flyspell whole buffer")
-    (gmm-ignore "separator")
-    (message-send-and-exit "mail/send")
+    (message-send-and-exit "mail/send" t :label "Send")
     (message-dont-send "mail/save-draft")
-    (message-kill-buffer "close") ;; stock_cancel
-    (mml-attach-file "attach" mml-mode-map)
+    (mml-attach-file "attach" mml-mode-map :vert-only t)
     (mml-preview "mail/preview" mml-mode-map)
     (mml-secure-message-sign-encrypt "lock" mml-mode-map :visible nil)
     (message-insert-importance-high "important" nil :visible nil)
     (message-insert-importance-low "unimportant" nil :visible nil)
-    (message-insert-disposition-notification-to "receipt" nil :visible nil)
-    (gmm-customize-mode "preferences" t :help "Edit mode preferences")
-    (message-info "help" t :help "Message manual"))
+    (message-insert-disposition-notification-to "receipt" nil :visible nil))
   "List of items for the message tool bar (GNOME style).
 
 See `gmm-tool-bar-from-list' for details on the format of the list."
@@ -7766,7 +7800,7 @@ When FORCE, rebuild the tool bar."
   :type '(alist :key-type regexp :value-type function))
 
 (defcustom message-expand-name-databases
-  (list 'bbdb 'eudc)
+  '(bbdb eudc)
   "List of databases to try for name completion (`message-expand-name').
 Each element is a symbol and can be `bbdb' or `eudc'."
   :group 'message
@@ -7788,15 +7822,25 @@ If nil, the function bound in `text-mode-map' or `global-map' is executed."
 Execute function specified by `message-tab-body-function' when not in
 those headers."
   (interactive)
+  (cond
+   ((if (and (boundp 'completion-fail-discreetly)
+             (fboundp 'completion-at-point))
+        (let ((completion-fail-discreetly t)) (completion-at-point))
+      (funcall (or (message-completion-function) #'ignore)))
+    ;; Completion was performed; nothing else to do.
+    nil)
+   (message-tab-body-function (funcall message-tab-body-function))
+   (t (funcall (or (lookup-key text-mode-map "\t")
+                   (lookup-key global-map "\t")
+                   'indent-relative)))))
+
+(defun message-completion-function ()
   (let ((alist message-completion-alist))
     (while (and alist
 		(let ((mail-abbrev-mode-regexp (caar alist)))
 		  (not (mail-abbrev-in-expansion-header-p))))
       (setq alist (cdr alist)))
-    (funcall (or (cdar alist) message-tab-body-function
-		 (lookup-key text-mode-map "\t")
-		 (lookup-key global-map "\t")
-		 'indent-relative))))
+    (cdar alist)))
 
 (eval-and-compile
   (condition-case nil