Function: message-generate-headers

message-generate-headers is a byte-compiled function defined in message.el.gz.

Signature

(message-generate-headers HEADERS)

Documentation

Prepare article HEADERS.

Headers already prepared in the buffer are not modified.

Source Code

;; Defined in /usr/src/emacs/lisp/gnus/message.el.gz
(defun message-generate-headers (headers)
  "Prepare article HEADERS.
Headers already prepared in the buffer are not modified."
  (setq headers (append headers message-required-headers))
  (save-restriction
    (message-narrow-to-headers)
    (let* ((header-values
	    (list 'Date (message-make-date)
		  'Message-ID (message-make-message-id)
		  'Organization (message-make-organization)
		  'From (message-make-from)
		  'Path (message-make-path)
		  'Subject nil
		  'Newsgroups nil
		  'In-Reply-To (message-make-in-reply-to)
		  'References (message-make-references)
		  'To nil
		  'Distribution (message-make-distribution)
		  'Lines (message-make-lines)
		  'User-Agent message-newsreader
		  'Expires (message-make-expires)))
	   (case-fold-search t)
	   (optionalp nil)
	   header value elem header-string)
      ;; First we remove any old generated headers.
      (let ((headers message-deletable-headers))
	(unless (buffer-modified-p)
	  (setq headers (delq 'Message-ID (copy-sequence 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)
	       (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)
		      optionalp t)
	      (setq header (car elem)))
	  (setq header elem))
	(setq header-string  (if (stringp header)
				 header
			       (symbol-name header)))
	(when (or (not (re-search-forward
			(concat "^"
				(regexp-quote (downcase header-string))
				":")
			nil t))
		  (progn
		    ;; The header was found.  We insert a space after the
		    ;; colon, if there is none.
		    (if (/= (char-after) ? ) (insert " ") (forward-char 1))
		    ;; Find out whether the header is empty.
		    (looking-at "[ \t]*\n[^ \t]")))
	  ;; So we find out what value we should insert.
	  (setq value
		(cond
		 ((and (consp elem)
		       (eq (car elem) 'optional)
		       (not (member header-string message-inserted-headers)))
		  ;; 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))
		  (or (and (functionp (cdr elem))
			   (funcall (cdr elem)))
		      (and (symbolp (cdr elem))
			   (plist-get header-values (cdr elem)))))
		 ((consp elem)
		  ;; The element is a cons.  Either the cdr is a
		  ;; string to be inserted verbatim, or it is a
		  ;; function, and we insert the value returned from
		  ;; this function.
		  (or (and (stringp (cdr elem))
			   (cdr elem))
		      (and (functionp (cdr elem))
			   (funcall (cdr elem)))))
		 ((and (symbolp header)
		       (plist-member header-values header))
		  ;; The element is a symbol.  We insert the value of
		  ;; this symbol, if any.
		  (plist-get header-values header))
		 ((not (message-check-element
			(intern (downcase (symbol-name header)))))
		  ;; 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.
		    (goto-char (point-max))
		    (let ((formatter
			   (cdr (assq header message-header-format-alist))))
		      (if formatter
			  (funcall formatter header value)
			(insert header-string ": " value))
		      (push header-string message-inserted-headers)
		      (goto-char (message-fill-field))
		      ;; We check whether the value was ended by a
		      ;; newline.  If not, we insert one.
		      (unless (bolp)
			(insert "\n"))
		      (forward-line -1)))
		;; The value of this header was empty, so we clear
		;; totally and insert the new value.
                (delete-region (point) (line-end-position))
		;; If the header is optional, and the header was
		;; empty, we can't insert it anyway.
		(unless optionalp
		  (push header-string message-inserted-headers)
		  (insert value)
		  (message-fill-field)))
	      ;; 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))
	  (when (or (message-news-p)
		    (string-match "@.+\\.." secure-sender))
	    (insert "Sender: " secure-sender "\n"))))
      ;; Check for IDNA
      (message-idna-to-ascii-rhs))))