xemacs-beta: lisp/gnus/message.el comparison

comparison lisp/gnus/message.el @ 108:360340f9fd5f r20-1b6

Import from CVS: tag r20-1b6

author	cvs
date	Mon, 13 Aug 2007 09:18:39 +0200
parents	cf808b4c4290
children	fe104dbd9147

comparison

equal deleted inserted replaced

-:523141596bda
+:360340f9fd5f
 ;; consists mainly of large chunks of code from the sendmail.el,
 ;; gnus-msg.el and rnewspost.el files.
 ;;; Code:
-(eval-when-compile
+(require 'cl)
-(require 'cl))
 (require 'mailheader)
 (require 'rmail)
 (require 'nnheader)
 (require 'timezone)
 (require 'easymenu)
 approved sender empty empty-headers message-id from subject
 shorten-followup-to existing-newsgroups."
 :group 'message-news)
 (defcustom message-required-news-headers
 '(From Newsgroups Subject Date Message-ID
 	 (optional . Organization) Lines
 	 (optional . X-Newsreader))
 "Headers to be generated or prompted for when posting an article.
 RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
 Message-ID.  Organization, Lines, In-Reply-To, Expires, and
 X-Newsreader are optional.  If don't you want message to insert some
 header, remove it from this list."
 :group 'message-news
 :group 'message-headers
 :type '(repeat sexp))
 (defcustom message-required-mail-headers
 '(From Subject Date (optional . In-Reply-To) Message-ID Lines
 	 (optional . X-Mailer))
 "Headers to be generated or prompted for when mailing a message.
 RFC822 required that From, Date, To, Subject and Message-ID be
 included.  Organization, Lines and X-Mailer are optional."
 (defcustom message-deletable-headers '(Message-ID Date Lines)
 "Headers to be deleted if they already exist and were generated by message previously."
 :group 'message-headers
 :type 'sexp)
 (defcustom message-ignored-news-headers
 "^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:\\|^Resent-Fcc:"
 "*Regexp of headers to be removed unconditionally before posting."
 :group 'message-news
 :group 'message-headers
 :type 'regexp)
 :group 'message-various)
 (defcustom message-elide-elipsis "\n[...]\n\n"
 "*The string which is inserted for elided text.")
 (defcustom message-interactive nil
 "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
 :group 'message-mail
 :type 'boolean)
 "*Non-nil means that the message buffer will be killed after sending a message."
 :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)
 "*Directory where message autosaves buffers.
 If nil, message won't autosave."
 :group 'message-buffers
 :type 'directory)
 (defcustom message-forward-start-separator
 "------- Start of forwarded message -------\n"
 "*Delimiter inserted before forwarded messages."
 :group 'message-forwarding
 :type 'string)
 (defcustom message-signature-before-forwarded-message t
 "*If non-nil, put the signature before any included forwarded message."
 :group 'message-forwarding
 :type 'boolean)
 (defcustom message-included-forward-headers
 "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:"
 "*Regexp matching headers to be included in forwarded messages."
 :group 'message-forwarding
 :type 'regexp)
 :group 'message-sending
 :type '(repeat string))
 (defvar gnus-post-method)
 (defvar gnus-select-method)
 (defcustom message-post-method
 (cond ((and (boundp 'gnus-post-method)
 	      gnus-post-method)
 	 gnus-post-method)
 	((boundp 'gnus-select-method)
 	 gnus-select-method)
 :group 'message-various
 :type 'hook)
 (defcustom message-signature-setup-hook nil
 "Normal hook, run each time a new outgoing message is initialized.
 It is run after the headers have been inserted and before
 the signature is inserted."
 :group 'message-various
 :type 'hook)
 (defcustom message-mode-hook nil
 :type 'string)
 ;; Note: could use /usr/ucb/mail instead of sendmail;
 ;; options -t, and -v if not interactive.
 (defcustom message-mailer-swallows-blank-line
 (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)"
 			 system-configuration)
 	   (file-readable-p "/etc/sendmail.cf")
 	   (let ((buffer (get-buffer-create " *temp*")))
 	     (unwind-protect
 		 (save-excursion
 :group 'message-sending
 :type 'sexp)
 (ignore-errors
 (define-mail-user-agent 'message-user-agent
 'message-mail 'message-send-and-exit
 'message-kill-buffer 'message-send-hook))
 (defvar message-mh-deletable-headers '(Message-ID Date Lines Sender)
 "If non-nil, delete the deletable headers before feeding to mh.")
 ;;; Internal variables.
 ;;; Well, not really internal.
 (defvar message-mode-syntax-table
 (let ((table (copy-syntax-table text-mode-syntax-table)))
 (modify-syntax-entry ?% ". " table)
 table)
 "Syntax table used while in Message mode.")
 (defvar message-mode-abbrev-table text-mode-abbrev-table
 "Abbrev table used in Message mode buffers.
 Defaults to `text-mode-abbrev-table'.")
+(defgroup message-headers nil
+"Message headers."
+:link '(custom-manual "(message)Variables")
+:group 'message)
+(defface message-header-to-face
+'((((class color)
+(background dark))
+(:foreground "green2" :bold t))
+(((class color)
+(background light))
+(:foreground "MidnightBlue" :bold t))
+(t
+(:bold t :italic t)))
+"Face used for displaying From headers."
+:group 'message-headers)
+(defface message-header-cc-face
+'((((class color)
+(background dark))
+(:foreground "green4" :bold t))
+(((class color)
+(background light))
+(:foreground "MidnightBlue"))
+(t
+(:bold t)))
+"Face used for displaying Cc headers."
+:group 'message-headers)
+(defface message-header-subject-face
+'((((class color)
+(background dark))
+(:foreground "green3"))
+(((class color)
+(background light))
+(:foreground "navy blue" :bold t))
+(t
+(:bold t)))
+"Face used for displaying subject headers."
+:group 'message-headers)
+(defface message-header-newsgroups-face
+'((((class color)
+(background dark))
+(:foreground "yellow" :bold t :italic t))
+(((class color)
+(background light))
+(:foreground "blue4" :bold t :italic t))
+(t
+(:bold t :italic t)))
+"Face used for displaying newsgroups headers."
+:group 'message-headers)
+(defface message-header-other-face
+'((((class color)
+(background dark))
+(:foreground "red4"))
+(((class color)
+(background light))
+(:foreground "steel blue"))
+(t
+(:bold t :italic t)))
+"Face used for displaying newsgroups headers."
+:group 'message-headers)
+(defface message-header-name-face
+'((((class color)
+(background dark))
+(:foreground "DarkGreen"))
+(((class color)
+(background light))
+(:foreground "cornflower blue"))
+(t
+(:bold t)))
+"Face used for displaying header names."
+:group 'message-headers)
+(defface message-header-xheader-face
+'((((class color)
+(background dark))
+(:foreground "blue"))
+(((class color)
+(background light))
+(:foreground "blue"))
+(t
+(:bold t)))
+"Face used for displaying X-Header headers."
+:group 'message-headers)
+(defface message-separator-face
+'((((class color)
+(background dark))
+(:foreground "blue4"))
+(((class color)
+(background light))
+(:foreground "brown"))
+(t
+(:bold t)))
+"Face used for displaying the separator."
+:group 'message-headers)
+(defface message-cited-text-face
+'((((class color)
+(background dark))
+(:foreground "red"))
+(((class color)
+(background light))
+(:foreground "red"))
+(t
+(:bold t)))
+"Face used for displaying cited text names."
+:group 'message-headers)
 (defvar message-font-lock-keywords
-(let* ((cite-prefix "A-Za-z") (cite-suffix (concat cite-prefix "0-9_.@-")))
+(let* ((cite-prefix "A-Za-z")
-(list '("^To:" . font-lock-function-name-face)
+	 (cite-suffix (concat cite-prefix "0-9_.@-"))
-'("^[GBF]?[Cc][Cc]:\\|^Reply-To:" . font-lock-keyword-face)
+	 (content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)"))
-	  '("^\\(Subject:\\)[ \t]*\\(.+\\)?"
+`((,(concat "^\\(To:\\)" content)
-	    (1 font-lock-comment-face) (2 font-lock-type-face nil t))
+(1 'message-header-name-face)
-	  (list (concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
+(2 'message-header-to-face nil t))
-		1 'font-lock-comment-face)
+(,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^Reply-To:\\)" content)
-	  (cons (concat "^[ \t]*"
+(1 'message-header-name-face)
-			"\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
+(2 'message-header-cc-face nil t))
-			"[>|}].*")
+(,(concat "^\\(Subject:\\)" content)
-		'font-lock-reference-face)
+(1 'message-header-name-face)
-	  '("^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):.*"
+(2 'message-header-subject-face nil t))
-	    . font-lock-string-face)))
+(,(concat "^\\(Newsgroups:\\|Followup-to:\\)" content)
+(1 'message-header-name-face)
+(2 'message-header-newsgroups-face nil t))
+(,(concat "^\\([^: \n\t]+:\\)" content)
+(1 'message-header-name-face)
+(2 'message-header-other-face nil t))
+(,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content)
+(1 'message-header-name-face)
+(2 'message-header-name-face))
+(,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
+1 'message-separator-face)
+(,(concat "^[ \t]*"
+		"\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
+		"[>|}].*")
+(0 'message-cited-text-face))))
 "Additional expressions to highlight in Message mode.")
 (defvar message-face-alist
 '((bold . bold-region)
 (underline . underline-region)
 (default . (lambda (b e)
 		 (unbold-region b e)
 		 (ununderline-region b e))))
 "Alist of mail and news faces for facemenu.
 The cdr of ech entry is a function for applying the face to a region.")
 ;; Byte-compiler warning
 (defvar gnus-active-hashtb)
 (defvar gnus-read-active-file)
 ;;; Regexp matching the delimiter of messages in UNIX mail format
 ;;; (UNIX From lines), minus the initial ^.
 (defvar message-unix-mail-delimiter
 (let ((time-zone-regexp
 	 (concat "\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?"
 		 "\\|[-+]?[0-9][0-9][0-9][0-9]"
 		 "\\|"
 	  "^ *--+ +begin message +--+ *$\\|"
 	  "^ *---+ +Original message follows +---+ *$\\|"
 	  "^|? *---+ +Message text follows: +---+ *|?$")
 "A regexp that matches the separator before the text of a failed message.")
 (defvar message-header-format-alist
 `((Newsgroups)
 (To . message-fill-address)
 (Cc . message-fill-address)
 (Subject)
 (In-Reply-To)
 (Fcc)
 (Bcc)
 (autoload 'message-setup-toolbar "messagexmas")
 (autoload 'mh-send-letter "mh-comp")
 (autoload 'gnus-point-at-eol "gnus-util")
 (autoload 'gnus-point-at-bol "gnus-util")
 (autoload 'gnus-output-to-mail "gnus-util")
-(autoload 'gnus-output-to-rmail "gnus-util"))
+(autoload 'gnus-output-to-rmail "gnus-util")
+(autoload 'mail-abbrev-in-expansion-header-p "mailabbrev"))
 ;;;
 ;;; Utility functions.
 ;;;
 (defmacro message-y-or-n-p (question show &rest text)
 "Ask QUESTION, displaying the rest of the arguments in a temp. buffer if SHOW"
 		((and (= (following-char) ?\))
 		      (not quoted))
 		 (setq paren nil))))
 	(nreverse elems)))))
+(defun message-mail-file-mbox-p (file)
+"Say whether FILE looks like a Unix mbox file."
+(when (and (file-exists-p file)
+	     (file-readable-p file)
+	     (file-regular-p file))
+(nnheader-temp-write nil
+(nnheader-insert-file-contents file)
+(goto-char (point-min))
+(looking-at message-unix-mail-delimiter))))
 (defun message-fetch-field (header &optional not-all)
 "The same as `mail-fetch-field', only remove all newlines."
 (let ((value (mail-fetch-field header nil (not not-all))))
 (when value
 (nnheader-replace-chars-in-string value ?\n ? ))))
 (beginning-of-line)
 (or (eobp) (forward-char 1))
 (not (if (re-search-forward "^[^ \t]" nil t)
 	   (beginning-of-line)
 	 (goto-char (point-max)))))
 (defun message-sort-headers-1 ()
 "Sort the buffer as headers using `message-rank' text props."
 (goto-char (point-min))
 (sort-subr
 nil 'message-next-header
 (lambda ()
 (message-next-header)
 (unless (bobp)
 (forward-char -1)))
 (lambda ()
 (define-key message-mode-map "\C-c\C-b" 'message-goto-body)
 (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\C-n" 'message-insert-newsgroups)
 (define-key message-mode-map "\C-c\C-y" 'message-yank-original)
 (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message)
 (define-key message-mode-map "\C-c\C-w" 'message-insert-signature)
 (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body)
 (define-key message-mode-map "\C-c\C-o" 'message-sort-headers)
 (define-key message-mode-map "\C-c\C-e" 'message-elide-region)
 (define-key message-mode-map "\t" 'message-tab))
 (easy-menu-define
 message-mode-menu message-mode-map "Message Menu."
 '("Message"
 ["Sort Headers" message-sort-headers t]
 ["Yank Original" message-yank-original t]
 ["Fill Yanked Message" message-fill-yanked-message t]
 ["Spellcheck" ispell-message t]
 "----"
 ["Send Message" message-send-and-exit t]
 ["Abort Message" message-dont-send t]))
 (easy-menu-define
 message-mode-field-menu message-mode-map ""
 '("Field"
 ["Fetch To" message-insert-to t]
 ["Fetch Newsgroups" message-insert-newsgroups t]
 "----"
 (defun message-insert-to ()
 "Insert a To header that points to the author of the article being replied to."
 (interactive)
 (let ((co (message-fetch-field "courtesy-copies-to")))
 (when (and co
 	       (equal (downcase co) "never"))
 (error "The user has requested not to have copies sent via mail")))
 (when (and (message-position-on-field "To")
 	     (mail-fetch-field "to")
 	     (not (string-match "\\` *\\'" (mail-fetch-field "to"))))
 ;;; Various commands
 (defun message-insert-signature (&optional force)
 "Insert a signature.  See documentation for the `message-signature' variable."
 (interactive (list 0))
 (let* ((signature
 	  (cond
 	   ((and (null message-signature)
 		 (eq force 0))
 	    (save-excursion
 	      (goto-char (point-max))
 ;; We build the table, if necessary.
 (when (or (not message-caesar-translation-table)
 	      (/= (aref message-caesar-translation-table ?a) (+ ?a n)))
 	(setq message-caesar-translation-table
 	      (message-make-caesar-translation-table n)))
 ;; Then we translate the region.  Do it this way to retain
 ;; text properties.
 (while (< b e)
 (subst-char-in-region
 b (1+ b) (char-after b)
 (aref message-caesar-translation-table (char-after b)))
 (incf b))))
 (defun message-make-caesar-translation-table (n)
 "Create a rot table with offset N."
 (let ((i -1)
 	(table (make-string 256 0)))
 (while (< (incf i) 256)
 (aset table i i))
 (concat
 (substring table 0 ?A)
 (narrow-to-region (point) (point-max)))
 (let ((body (buffer-substring (point-min) (point-max))))
 (unless (equal 0 (call-process-region
 (point-min) (point-max) program t t))
 (insert body)
-(gnus-message 1 "%s failed." program))))))
+(message "%s failed." program))))))
 (defun message-rename-buffer (&optional enter-string)
 "Rename the *message* buffer to \"*message* RECIPIENT\".
 If the function is run with a prefix, it will ask for a new buffer
 name, rather than giving an automatic name."
 (interactive "Pbuffer name: ")
 (save-excursion
 (save-restriction
 (goto-char (point-min))
 (narrow-to-region (point)
 			(search-forward mail-header-separator nil 'end))
 (let* ((mail-to (or
 		       (if (message-news-p) (message-fetch-field "Newsgroups")
 			 (message-fetch-field "To"))
 		       ""))
 However, if `message-yank-prefix' is non-nil, insert that prefix on each line."
 (let ((start (point)))
 ;; Remove unwanted headers.
 (when message-ignored-cited-headers
 (save-restriction
 	(narrow-to-region
 	 (goto-char start)
 	 (if (search-forward "\n\n" nil t)
 	     (1- (point))
 	   (point)))
 	(message-remove-header message-ignored-cited-headers t)
 	(setq message-checksum (cons (message-checksum) (buffer-size)))))))
 (defun message-cite-original ()
 "Cite function in the standard Message manner."
 (let ((start (point))
 	(functions
 	 (when message-indent-citation-function
 	   (if (listp message-indent-citation-function)
 	       message-indent-citation-function
 	     (list message-indent-citation-function)))))
 (goto-char start)
 (let ((case-fold-search t))
 (save-restriction
 (narrow-to-region
 (goto-char (point-min))
 (progn
 	 (re-search-forward
 	  (concat "^" (regexp-quote mail-header-separator) "$"))
 	 (match-beginning 0)))
 (goto-char (point-min))
 (if (re-search-forward (concat "^" (regexp-quote header) ":") nil t)
 	  (progn
 	    (re-search-forward "^[^ \t]" nil 'move)
 	    (beginning-of-line)
 	    (skip-chars-backward "\n")
 	    t)
 	(while (and afters
 		    (not (re-search-forward
 			  (concat "^" (regexp-quote (car afters)) ":")
 			  nil t)))
 	  (pop afters))
 	(when afters
 	  (re-search-forward "^[^ \t]" nil 'move)
 (message-do-actions actions)))
 (defun message-kill-buffer ()
 "Kill the current buffer."
 (interactive)
-(let ((actions message-kill-actions))
+(when (yes-or-no-p "Kill the buffer? ")
-(kill-buffer (current-buffer))
+(let ((actions message-kill-actions))
-(message-do-actions actions)))
+(kill-buffer (current-buffer))
+(message-do-actions actions))))
 (defun message-bury (buffer)
 "Bury this mail buffer."
 (let ((newbuf (other-buffer buffer)))
 (bury-buffer buffer)
 (defun message-do-actions (actions)
 "Perform all actions in ACTIONS."
 ;; Now perform actions on successful sending.
 (while actions
 (ignore-errors
 (cond
 ;; A simple function.
 ((message-functionp (car actions))
 	(funcall (car actions)))
 ;; Something to be evaled.
 (t
 (unwind-protect
 	(save-excursion
 	  (set-buffer tembuf)
 	  (erase-buffer)
 	  ;; Avoid copying text props.
 	  (insert (format
 		   "%s" (save-excursion
 			  (set-buffer mailbuf)
 			  (buffer-string))))
 	  ;; Remove some headers.
 	  (save-restriction
 ;; reading a formatted (i. e., at least a To: or Resent-To header)
 ;; message from stdin.
 ;;
 ;; qmail also has the advantage of not having been raped by
 ;; various vendors, so we don't have to allow for that, either --
 ;; compare this with message-send-mail-with-sendmail and weep
 ;; for sendmail's lost innocence.
 ;;
 ;; all this is way cool coz it lets us keep the arguments entirely
 ;; free for -inject-arguments -- a big win for the user and for us
 ;; since we don't have to play that double-guessing game and the user
 (defun message-send-mail-with-mh ()
 "Send the prepared message buffer with mh."
 (let ((mh-previous-window-config nil)
 	(name (make-temp-name
 	       (concat (file-name-as-directory
 			(expand-file-name message-autosave-directory))
 		       "msg."))))
 (setq buffer-file-name name)
 ;; MH wants to generate these headers itself.
 (when message-mh-deletable-headers
 (let ((headers message-mh-deletable-headers))
 	(while headers
 	  (goto-char (point-min))
 	  (and (re-search-forward
 		(concat "^" (symbol-name (car headers)) ": *") nil t)
 	       (message-delete-line))
 	  (pop headers))))
 (run-hooks 'message-send-mail-hook)
 ;; Pass it on to mh.
 	  nil)
 (unwind-protect
 	  (save-excursion
 	    (set-buffer tembuf)
 	    (buffer-disable-undo (current-buffer))
 	    (erase-buffer)
 	    ;; Avoid copying text props.
 	    (insert (format
 		     "%s" (save-excursion
 			    (set-buffer messbuf)
 			    (buffer-string))))
 	    ;; Remove some headers.
 	    (save-restriction
 (defun message-check-news-syntax ()
 "Check the syntax of the message."
 (save-excursion
 (save-restriction
 (widen)
 (and
 ;; We narrow to the headers and check them first.
 (save-excursion
 	 (save-restriction
 	   (message-narrow-to-headers)
 	   (message-check-news-header-syntax)))
 ;; Check the body.
 (message-check-news-body-syntax)))))
 (defun message-check-news-header-syntax ()
 (and
 ;; Check for commands in Subject.
 (message-check 'subject-cmsg
 (if (string-match "^cmsg " (message-fetch-field "subject"))
 	 (y-or-n-p
 	  "The control code \"cmsg\" is in the subject.  Really post? ")
 t))
 ;; Check for multiple identical headers.
 (message-check 'multiple-headers
 (let (found)
 (while (and (not found)
 		   (re-search-forward "^[^ \t:]+: " nil t))
 	 (save-excursion
 	   (or (re-search-forward
 		(concat "^"
 			(regexp-quote
 			 (setq found
 			       (buffer-substring
 				(match-beginning 0) (- (match-end 0) 2))))
 			":")
 ;; Check for Version and Sendsys.
 (message-check 'sendsys
 (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
 	 (y-or-n-p
 	  (format "The article contains a %s command.  Really post? "
 		  (buffer-substring (match-beginning 0)
 				    (1- (match-end 0)))))
 t))
 ;; See whether we can shorten Followup-To.
 (message-check 'shorten-followup-to
 (let ((newsgroups (message-fetch-field "newsgroups"))
 		  (string-match "," newsgroups)
 		  (not followup-to)
 		  (not
 		   (zerop
 		    (length
 		     (setq to (completing-read
 			       "Followups to: (default all groups) "
 			       (mapcar (lambda (g) (list g))
 				       (cons "poster"
 					     (message-tokenize-header
 					      newsgroups)))))))))
 	 (goto-char (point-min))
 	 (insert "Followup-To: " to "\n"))
 t))
 ;; Check "Shoot me".
 	    (subject (message-fetch-field "subject")))
 (or
 	(and subject
 	     (not (string-match "\\`[ \t]*\\'" subject)))
 	(ignore
 	 (message
 	  "The subject field is empty or missing.  Posting is denied.")))))
 ;; Check the Newsgroups & Followup-To headers.
 (message-check 'existing-newsgroups
 (let* ((case-fold-search t)
 	    (newsgroups (message-fetch-field "newsgroups"))
 	   (headers '("Newsgroups" "Followup-To"))
 	   header error)
 (while (and headers (not error))
 	 (when (setq header (mail-fetch-field (car headers)))
 	   (if (or
 		(not
 		 (string-match
 		  "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'"
 		  header))
 		(memq
 		 nil (mapcar
 		      (lambda (g)
 			(not (string-match "\\.\\'\\|\\.\\." g)))
 		      (message-tokenize-header header ","))))
 	       (setq error t)))
 	 (unless error
 (or (re-search-backward "[^ \n\t]" b t)
 	   (y-or-n-p "Empty article.  Really post? "))))
 ;; Check for control characters.
 (message-check 'control-chars
 (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
 	 (y-or-n-p
 	  "The article contains control characters.  Really post? ")
 t))
 ;; Check excessive size.
 (message-check 'size
 (if (> (buffer-size) 60000)
 	      (funcall message-fcc-handler-function file)
 	    (if (and (file-readable-p file) (mail-file-babyl-p file))
 		(rmail-output file 1 nil t)
 	      (let ((mail-use-rfc822 t))
 		(rmail-output file 1 t t))))))
 (kill-buffer (current-buffer)))))
 (defun message-output (filename)
 "Append this article to Unix/babyl mail file.."
 (if (and (file-readable-p filename)
 	(replace-match "" t t)))))
 (defun message-make-date ()
 "Make a valid data header."
 (let ((now (current-time)))
 (timezone-make-date-arpa-standard
 (current-time-string now) (current-time-zone now))))
 (defun message-make-message-id ()
 "Make a unique Message-ID."
 (concat "<" (message-unique-id)
 	  (let ((psubject (save-excursion (message-fetch-field "subject"))))
 	    (if (and message-reply-headers
 		     (mail-header-references message-reply-headers)
 		     (mail-header-subject message-reply-headers)
 		     psubject
 		     (mail-header-subject message-reply-headers)
 		     (not (string=
 			   (message-strip-subject-re
 			    (mail-header-subject message-reply-headers))
 			   (message-strip-subject-re psubject))))
 		"_-_" ""))
 	  "@" (message-make-fqdn) ">"))
 	 (let ((user (downcase (user-login-name))))
 	   (while (string-match "[^a-z0-9_]" user)
 	     (aset user (match-beginning 0) ?_))
 	   user)
 (message-number-base36 (user-uid) -1))
 (message-number-base36 (+ (car   tm)
 			       (lsh (% message-unique-id-char 25) 16)) 4)
 (message-number-base36 (+ (nth 1 tm)
 			       (lsh (/ message-unique-id-char 25) 16)) 4)
 ;; Append the newsreader name, because while the generated
 ;; ID is unique to this newsreader, other newsreaders might
 	    (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
 				  (% num 36))))))
 (defun message-make-organization ()
 "Make an Organization header."
 (let* ((organization
 	  (or (getenv "ORGANIZATION")
 	      (when message-user-organization
 		(if (message-functionp message-user-organization)
 		    (funcall message-user-organization)
 		  message-user-organization)))))
 "Count the number of lines and return numeric string."
 (save-excursion
 (save-restriction
 (widen)
 (goto-char (point-min))
 (re-search-forward
 (concat "^" (regexp-quote mail-header-separator) "$"))
 (forward-line 1)
 (int-to-string (count-lines (point) (point-max))))))
 (defun message-make-in-reply-to ()
 "Return the In-Reply-To header for this message."
 (when message-reply-headers
 (let ((from (mail-header-from message-reply-headers))
 	  (date (mail-header-date message-reply-headers)))
 (when from
 	(let ((stop-pos
 	       (string-match "  *at \\|  *@ \\| *(\\| *<" from)))
 	  (concat (if stop-pos (substring from 0 stop-pos) from)
 		  "'s message of "
 		  (if (or (not date) (string= date ""))
 		      "(unknown date)" date)))))))
 (defun message-make-distribution ()
 "Make a Distribution header."
 	(future (* 1.0 message-expires 60 60 24)))
 ;; Add the future to current.
 (setcar current (+ (car current) (round (/ future (expt 2 16)))))
 (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16))))
 ;; Return the date in the future in UT.
 (timezone-make-date-arpa-standard
 (current-time-string current) (current-time-zone current) '(0 "UT"))))
 (defun message-make-path ()
 "Return uucp path."
 (let ((login-name (user-login-name)))
 	  (t login-name))))
 (defun message-make-from ()
 "Make a From header."
 (let* ((login (message-make-address))
 	 (fullname
 	  (or (and (boundp 'user-full-name)
 		   user-full-name)
 	      (user-full-name))))
 (when (string= fullname "&")
 (setq fullname (user-login-name)))
 (save-excursion
 (message-set-work-buffer)
 (cond
 ((or (null message-from-style)
 	    (equal fullname ""))
 	(insert login))
 ((or (eq message-from-style 'angles)
 	    (and (not (eq message-from-style 'parens))
 	  (while (re-search-forward "[()\\]" nil 1)
 	    (replace-match "\\\\\\&" t))
 	  ;; ... then undo escaping of matching parentheses,
 	  ;; including matching nested parentheses.
 	  (goto-char fullname-start)
 	  (while (re-search-forward
 		  "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
 		  nil 1)
 	    (replace-match "\\1(\\3)" t)
 	    (goto-char fullname-start)))
 	(insert ")")))
 (buffer-string))))
 (defun message-make-sender ()
 "Return the \"real\" user address.
 This function tries to ignore all user modifications, and
 give as trustworthy answer as possible."
 (concat (user-login-name) "@" (system-name)))
 (defun message-make-address ()
 "Make the address of the user."
 (defun message-make-fqdn ()
 "Return user's fully qualified domain name."
 (let ((system-name (system-name))
 	(user-mail (message-user-mail-address)))
 (cond
 ((string-match "[^.]\\.[^.]" system-name)
 ;; `system-name' returned the right result.
 system-name)
 ;; Try `mail-host-address'.
 ((and (boundp 'mail-host-address)
 	   header value elem)
 ;; First we remove any old generated headers.
 (let ((headers message-deletable-headers))
 	(while headers
 	  (goto-char (point-min))
 	  (and (re-search-forward
 		(concat "^" (symbol-name (car headers)) ": *") nil t)
 	       (get-text-property (1+ (match-beginning 0)) 'message-deletable)
 	       (message-delete-line))
 	  (pop headers)))
 ;; Go through all the required headers and see if they are in the
 ;; articles already.  If they are not, or are empty, they are
 ;; inserted automatically - except for Subject, Newsgroups and
 ;; Distribution.
 (while headers
 	(goto-char (point-min))
 	(setq elem (pop headers))
 	(if (consp elem)
 	    (if (eq (car elem) 'optional)
 		(setq header (cdr elem))
 	      (setq header (car elem)))
 	  (setq header elem))
 	(when (or (not (re-search-forward
 			(concat "^" (downcase (symbol-name header)) ":")
 			nil t))
 		  (progn
 		    ;; The header was found.  We insert a space after the
 		    ;; colon, if there is none.
 		    (if (/= (following-char) ? ) (insert " ") (forward-char 1))
 		    ;; Find out whether the header is empty...
 		    (looking-at "[ \t]*$")))
 	  ;; So we find out what value we should insert.
 	  (setq value
 		(cond
 		 ((and (consp elem) (eq (car elem) 'optional))
 		  ;; This is an optional header.  If the cdr of this
 		  ;; is something that is nil, then we do not insert
 		  ;; this header.
 		  (setq header (cdr elem))
 		  ;; We couldn't generate a value for this header,
 		  ;; so we just ask the user.
 		  (read-from-minibuffer
 		   (format "Empty header for %s; enter value: " header)))))
 	  ;; Finally insert the header.
 	  (when (and value
 		     (not (equal value "")))
 	    (save-excursion
 	      (if (bolp)
 		  (progn
 		    ;; This header didn't exist, so we insert it.
 		(delete-region (point) (gnus-point-at-eol))
 		(insert value))
 	      ;; Add the deletable property to the headers that require it.
 	      (and (memq header message-deletable-headers)
 		   (progn (beginning-of-line) (looking-at "[^:]+: "))
 		   (add-text-properties
 		    (point) (match-end 0)
 		    '(message-deletable t face italic) (current-buffer)))))))
 ;; Insert new Sender if the From is strange.
 (let ((from (message-fetch-field "from"))
 	    (sender (message-fetch-field "sender"))
 	    (secure-sender (message-make-sender)))
 	(when (and from
 		   (not (message-check-element 'sender))
 		   (not (string=
 			 (downcase
 			  (cadr (mail-extract-address-components from)))
 			 (downcase secure-sender)))
 		   (or (null sender)
 		       (not
 			(string=
 			 (downcase
 			  (cadr (mail-extract-address-components sender)))
 			 (downcase secure-sender)))))
 	  (goto-char (point-min))
 	  ;; Rename any old Sender headers to Original-Sender.
 	  (when (re-search-forward "^\\(Original-\\)*Sender:" nil t)
 	    (beginning-of-line)
 	    (insert "Original-")
 	    (beginning-of-line))
 	(cond
 	 ((string-match "%s" message-courtesy-message)
 	  (insert (format message-courtesy-message newsgroups)))
 	 (t
 	  (insert message-courtesy-message)))))))
 ;;;
 ;;; Setting up a message buffer
 ;;;
 (defun message-fill-address (header value)
 (goto-char (point-max)))))
 (defun message-position-point ()
 "Move point to where the user probably wants to find it."
 (message-narrow-to-headers)
 (cond
 ((re-search-forward "^[^:]+:[ \t]*$" nil t)
 (search-backward ":" )
 (widen)
 (forward-char 1)
 (if (= (following-char) ? )
 (sit-for 0)))
 (defun message-buffer-name (type &optional to group)
 "Return a new (unique) buffer name based on TYPE and TO."
 (cond
 ;; Check whether `message-generate-new-buffers' is a function,
 ;; and if so, call it.
 ((message-functionp message-generate-new-buffers)
 (funcall message-generate-new-buffers type to group))
 ;; Generate a new buffer name The Message Way.
 (message-generate-new-buffers
 	(kill-buffer buffer))))
 ;; Rename the buffer.
 (if message-send-rename-function
 (funcall message-send-rename-function)
 (when (string-match "\\`\\*" (buffer-name))
 (rename-buffer
 (concat "*sent " (substring (buffer-name) (match-end 0))) t)))
 ;; Push the current buffer onto the list.
 (when message-max-buffers
 (setq message-buffer-list
 	  (nconc message-buffer-list (list (current-buffer))))))
 (defvar mc-modes-alist)
 (defun message-setup (headers &optional replybuffer actions)
 (when (and (boundp 'mc-modes-alist)
 (when actions
 (setq message-send-actions actions))
 (setq message-reply-buffer replybuffer)
 (goto-char (point-min))
 ;; Insert all the headers.
 (mail-header-format
 (let ((h headers)
 	 (alist message-header-format-alist))
 (while h
 (unless (assq (caar h) message-header-format-alist)
 	 (push (list (caar h)) alist))
 			       yank-action send-actions)
 "Start editing a mail message to be sent."
 (interactive)
 (let ((message-this-is-mail t))
 (message-pop-to-buffer (message-buffer-name "mail" to))
 (message-setup
 (nconc
 `((To . ,(or to "")) (Subject . ,(or subject "")))
 (when other-headers other-headers)))))
 ;;;###autoload
 (defun message-news (&optional newsgroups subject)
 "Start editing a news article to be sent."
 (interactive)
 (let ((message-this-is-news t))
 (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))
 (message-setup `((Newsgroups . ,(or newsgroups ""))
 		     (Subject . ,(or subject ""))))))
 ;;;###autoload
 (defun message-reply (&optional to-address wide ignore-reply-to)
 "Start editing a reply to the article in the current buffer."
 (interactive)
 (let ((cur (current-buffer))
 	from subject date reply-to to cc
 	references message-id follow-to
 	(inhibit-point-motion-hooks t)
 	mct never-mct gnus-warning)
 (save-restriction
 (message-narrow-to-head)
 ;; Allow customizations to have their say.
 	    (save-excursion
 	      (setq follow-to
 		    (funcall message-wide-reply-to-function)))))
 ;; Find all relevant headers we need.
 (setq from (message-fetch-field "from")
 	    date (message-fetch-field "date")
 	    subject (or (message-fetch-field "subject") "none")
 	    to (message-fetch-field "to")
 	    cc (message-fetch-field "cc")
 	    mct (message-fetch-field "mail-copies-to")
 	    reply-to (unless ignore-reply-to (message-fetch-field "reply-to"))
 (setq subject (concat "Re: " subject))
 (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
 		 (string-match "<[^>]+>" gnus-warning))
 	(setq message-id (match-string 0 gnus-warning)))
 ;; Handle special values of Mail-Copies-To.
 (when mct
 	(cond ((equal (downcase mct) "never")
 	       (setq never-mct t)
 	       (setq mct nil))
 	      (unless never-mct
 		(insert (or reply-to from "")))
 	      (insert (if (bolp) "" ", ") (or to ""))
 	      (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
 	      (insert (if cc (concat (if (bolp) "" ", ") cc) ""))
 	      ;; Remove addresses that match `rmail-dont-reply-to-names'.
 	      (insert (prog1 (rmail-dont-reply-to (buffer-string))
 			(erase-buffer)))
 	      (goto-char (point-min))
 	      ;; Perhaps Mail-Copies-To: never removed the only address?
 	      (when (eobp)
 	      (let ((s ccalist))
 		(while s
 		  (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
 	    (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
 	    (when ccalist
 	      (let ((ccs (cons 'Cc (mapconcat
 				    (lambda (addr) (cdr addr)) ccalist ", "))))
 		(when (string-match "^ +" (cdr ccs))
 		  (setcdr ccs (substring (cdr ccs) (match-end 0))))
 		(push ccs follow-to))))))
 (widen))
 (setq message-reply-headers
 	  (vector 0 subject from date message-id references 0 0 ""))
 (message-setup
 `((Subject . ,subject)
 ,@follow-to
 ,@(if (or references message-id)
 	     `((References . ,(concat (or references "") (and references " ")
 				      (or message-id ""))))
 	   nil))
 cur)))
 "Follow up to the message in the current buffer.
 If TO-NEWSGROUPS, use that as the new Newsgroups line."
 (interactive)
 (let ((cur (current-buffer))
 	from subject date reply-to mct
 	references message-id follow-to
 	(inhibit-point-motion-hooks t)
 	(message-this-is-news t)
 	followup-to distribution newsgroups gnus-warning posted-to)
 (save-restriction
 (narrow-to-region
 	 (point-max)))
 (when (message-functionp message-followup-to-function)
 	(setq follow-to
 	      (funcall message-followup-to-function)))
 (setq from (message-fetch-field "from")
 	    date (message-fetch-field "date")
 	    subject (or (message-fetch-field "subject") "none")
 	    references (message-fetch-field "references")
 	    message-id (message-fetch-field "message-id" t)
 	    followup-to (message-fetch-field "followup-to")
 	    newsgroups (message-fetch-field "newsgroups")
 (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
 (message-setup
 `((Subject . ,subject)
 ,@(cond
 	  (to-newsgroups
 	   (list (cons 'Newsgroups to-newsgroups)))
 	  (follow-to follow-to)
 	  ((and followup-to message-use-followup-to)
 	   (list
 	    (cond
 	     ((equal (downcase followup-to) "poster")
 	      (if (or (eq message-use-followup-to 'use)
 		      (message-y-or-n-p "Obey Followup-To: poster? " t "\
 You should normally obey the Followup-To: header.
 "Start composing a message to supersede the current message.
 This is done simply by taking the old article and adding a Supersedes
 header line with the old Message-ID."
 (interactive)
 (let ((cur (current-buffer)))
 ;; Check whether the user owns the article that is to be superseded.
 (unless (string-equal
 	     (downcase (cadr (mail-extract-address-components
 			      (message-fetch-field "from"))))
 	     (downcase (message-make-address)))
 (error "This article is not yours"))
 "Return a Subject header suitable for the message in the current buffer."
 (save-excursion
 (save-restriction
 (current-buffer)
 (message-narrow-to-head)
 (concat "[" (or (message-fetch-field
 		       (if (message-news-p) "newsgroups" "from"))
 		      "(nowhere)")
 	      "] " (or (message-fetch-field "Subject") "")))))
 ;;;###autoload
 (defun message-forward (&optional news)
 "Forward the current message via mail.
 Optional NEWS will use news to forward instead of mail."
 (interactive "P")
 (let ((cur (current-buffer))
 	(subject (message-make-forward-subject))
 	art-beg)
 (if news (message-news nil subject) (message-mail nil subject))
 ;; Put point where we want it before inserting the forwarded
 ;; message.
 (if message-signature-before-forwarded-message
 	(goto-char (point-max))
 (message-goto-body))
 ;; Make sure we're at the start of the line.
 (unless (eolp)
 	(and (re-search-forward message-unsent-separator nil t)
 	     (forward-line 1))
 	(and (search-forward "\n\n" nil t)
 	     (re-search-forward "^Return-Path:.*\n" nil t)))
 ;; We remove everything before the bounced mail.
 (delete-region
 (point-min)
 (if (re-search-forward "^[^ \n\t]+:" nil t)
 	 (match-beginning 0)
 (point)))
 (save-restriction
 	(special-display-buffer-names nil)
 	(special-display-regexps nil)
 	(same-window-buffer-names nil)
 	(same-window-regexps nil))
 (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
 (message-setup `((Newsgroups . ,(or newsgroups ""))
 		   (Subject . ,(or subject "")))))
 ;;;###autoload
 (defun message-news-other-frame (&optional newsgroups subject)
 "Start editing a news article to be sent."
 	(special-display-buffer-names nil)
 	(special-display-regexps nil)
 	(same-window-buffer-names nil)
 	(same-window-regexps nil))
 (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
 (message-setup `((Newsgroups . ,(or newsgroups ""))
 		   (Subject . ,(or subject "")))))
 ;;; underline.el
 ;; This code should be moved to underline.el (from which it is stolen).
 ;;;###autoload
 (defun bold-region (start end)
 "Bold all nonblank characters in the region.
 Works by overstriking characters.
 which specify the range to operate on."
 (interactive "r")
 (save-excursion
 (let ((end1 (make-marker)))
 (move-marker end1 (max start end))
 (goto-char (min start end))
 (while (re-search-forward "\b" end1 t)
 	(if (eq (following-char) (char-after (- (point) 2)))
 	    (delete-char -2))))))
 (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
 (require 'messagexmas))
 ;;; Group name completion.
 (defvar message-newgroups-header-regexp
-"^\\(Newsgroups\\|Followup-To\\|Posted-To\\):"
+"^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):"
 "Regexp that match headers that lists groups.")
 (defun message-tab ()
 "Expand group names in Newsgroups and Followup-To headers.
 Do a `tab-to-tab-stop' if not in those headers."
 (message-expand-group)
 (tab-to-tab-stop)))
 (defvar gnus-active-hashtb)
 (defun message-expand-group ()
 (let* ((b (save-excursion
 	      (save-restriction
 		(narrow-to-region
 		 (save-excursion
 		   (beginning-of-line)
 		   (skip-chars-forward "^:")
 		   (1+ (point)))
 		 (point))
 	 (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
 	 (completions (all-completions string hashtb))
 	 (cur (current-buffer))
 	 comp)
 (delete-region b (point))
 (cond
 ((= (length completions) 1)
 (if (string= (car completions) string)
 	  (progn
 	    (insert string)
 	    (message "Only matching group"))
 	  (pop-to-buffer cur)))))))
 ;;; Help stuff.
 (defun message-talkative-question (ask question show &rest text)
 "Call FUNCTION with argument QUESTION, displaying the rest of the arguments in a temporary buffer if SHOW.
 The following arguments may contain lists of values."
 (if (and show
 	   (setq text (message-flatten-list text)))
 (save-window-excursion
 	(save-excursion
 (defun message-flatten-list (list)
 "Return a new, flat list that contains all elements of LIST.
 \(message-flatten-list '(1 (2 3 (4 5 (6))) 7))
 => (1 2 3 4 5 6 7)"
 (cond ((consp list)
 	 (apply 'append (mapcar 'message-flatten-list list)))
 	(list
 	 (list list))))
 (defun message-generate-new-buffer-clone-locals (name &optional varstr)

Mercurial > hg > xemacs-beta

comparison lisp/gnus/message.el @ 108:360340f9fd5f r20-1b6