Function: gnus-configure-posting-styles

gnus-configure-posting-styles is a byte-compiled function defined in gnus-msg.el.gz.

Signature

(gnus-configure-posting-styles &optional GROUP-NAME)

Documentation

Configure posting styles according to gnus-posting-styles.

Source Code

;; Defined in /usr/src/emacs/lisp/gnus/gnus-msg.el.gz
;;; Posting styles.

(defun gnus-configure-posting-styles (&optional group-name)
  "Configure posting styles according to `gnus-posting-styles'."
  (unless gnus-inhibit-posting-styles
    (let ((group (or group-name gnus-newsgroup-name ""))
	  (styles (if (gnus-buffer-live-p gnus-summary-buffer)
		      (with-current-buffer gnus-summary-buffer
			gnus-posting-styles)
		    gnus-posting-styles))
	  match value v results matched-string ;; style attribute
	  filep name address element)
      ;; If the group has a posting-style parameter, add it at the end with a
      ;; regexp matching everything, to be sure it takes precedence over all
      ;; the others.
      (when gnus-newsgroup-name
	(let ((tmp-style (gnus-group-find-parameter group 'posting-style t)))
	  (when tmp-style
	    (dolist (style tmp-style)
	      (when (stringp (cadr style))
		(setcdr style (list (decode-coding-string (cadr style)
							  'utf-8)))))
	    (setq styles (append styles (list (cons ".*" tmp-style)))))))
      ;; Go through all styles and look for matches.
      (dolist (style styles)
	(setq match (pop style))
	(goto-char (point-min))
	(when (cond
	       ((stringp match)
		;; Regexp string match on the group name.
		(when (string-match match group)
                  (setq matched-string group)
                  t))
	       ((eq match 'header)
		;; Obsolete format of header match.
		(and (gnus-buffer-live-p gnus-article-copy)
		     (with-current-buffer gnus-article-copy
		       (save-restriction
			 (nnheader-narrow-to-headers)
			 (let ((header (message-fetch-field (pop style))))
			   (and header
				(string-match (pop style) header)))))))
	       ((or (symbolp match)
		    (functionp match))
		(cond
		 ((functionp match)
		  ;; Function to be called.
		  (funcall match))
		 ((boundp match)
		  ;; Variable to be checked.
		  (symbol-value match))))
	       ((listp match)
		(cond
		 ((eq (car match) 'header)
		  ;; New format of header match.
		  (and (gnus-buffer-live-p gnus-article-copy)
		       (with-current-buffer gnus-article-copy
			 (save-restriction
			   (nnheader-narrow-to-headers)
			   (let ((header (message-fetch-field (nth 1 match))))
			     (and header
				  (string-match (nth 2 match) header)
				  (setq matched-string header)))))))
		 (t
		  ;; This is a form to be evalled.
		  (eval match t)))))
	  ;; We have a match, so we set the variables.
	  (dolist (attribute style)
	    (setq element (pop attribute)
		  filep nil)
	    (setq value
		  (cond
		   ((eq (car attribute) :file)
		    (setq filep t)
		    (cadr attribute))
		   ((eq (car attribute) :value)
		    (cadr attribute))
		   (t
		    (car attribute))))
	    ;; We get the value.
	    (setq v
		  (cond
		   ((stringp value)
		    (if (and matched-string
			     (string-match-p "\\\\[&[:digit:]]" value)
			     (match-beginning 1))
			(match-substitute-replacement value nil nil
						      matched-string)
		      value))
		   ((or (symbolp value)
			(functionp value))
		    (cond ((functionp value)
			   (funcall value))
			  ((boundp value)
			   (symbol-value value))))
		   ((listp value)
		    (eval value t))))
	    ;; Translate obsolescent value.
	    (cond
	     ((eq element 'signature-file)
	      (setq element 'signature
		    filep t))
	     ((eq element 'x-face-file)
	      (setq element 'x-face
		    filep t)))
	    ;; Post-processing for the signature posting-style:
	    (and (eq element 'signature) filep
		 message-signature-directory
		 ;; don't actually use the signature directory
		 ;; if message-signature-file contains a path.
		 (not (file-name-directory v))
		 (setq v (nnheader-concat message-signature-directory v)))
	    ;; Get the contents of file elems.
	    (when (and filep v)
	      (setq v (with-temp-buffer
			(insert-file-contents v)
			(buffer-substring
			 (point-min)
			 (progn
			   (goto-char (point-max))
			   (if (zerop (skip-chars-backward "\n"))
			       (point)
			     (1+ (point))))))))
	    (setq results (delq (assoc element results) results))
	    (push (cons element v) results))))
      ;; Now we have all the styles, so we insert them.
      (setq name (assq 'name results)
	    address (assq 'address results))
      (setq results (delq name (delq address results)))
      (setq results (sort results (lambda (x y)
				    (string-lessp (car x) (car y)))))
      (dolist (result results)
	(add-hook 'message-setup-hook
		  (cond
		   ((eq 'eval (car result))
		    #'ignore)
		   ((eq 'body (car result))
		    (let ((txt (cdr result)))
		      (lambda ()
			(save-excursion
			  (message-goto-body)
			  (insert txt)))))
		   ((eq 'signature (car result))
                    (setq-local message-signature nil)
                    (setq-local message-signature-file nil)
		    (let ((txt (cdr result)))
		      (if (not txt)
			  #'ignore
			(lambda ()
			  (save-excursion
			    (let ((message-signature txt))
			      (when message-signature
                                (message-insert-signature))))))))
		   (t
		    (let ((header
			   (if (symbolp (car result))
			       (capitalize (symbol-name (car result)))
			     (car result)))
			  (value (cdr result)))
		      (lambda ()
			(save-excursion
			  (message-remove-header header)
			  (when value
			    (message-goto-eoh)
			    (insert header ": " value)
			    (unless (bolp)
			      (insert "\n"))))))))
		  nil 'local))
      (when (or name address)
	(add-hook 'message-setup-hook
		  (let ((name (or (cdr name) (user-full-name)))
                        (email (or (cdr address) user-mail-address)))
		    (lambda ()
                      (setq-local user-mail-address email)
		      (let ((user-full-name name)
			    (user-mail-address email))
			(save-excursion
			  (message-remove-header "From")
			  (message-goto-eoh)
			  (insert "From: " (message-make-from) "\n")))))
		  nil 'local)))))