-;;; gnus-msg.el --- mail and post interface for Gnus
-;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc.
+;;; gnus-msg.el --- mail and post interface for Semi-gnus
+;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: news
+;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
+;; Keywords: mail, news, MIME
;; This file is part of GNU Emacs.
(require 'message)
(require 'gnus-art)
-(defcustom gnus-post-method 'current
+(defcustom gnus-post-method nil
"*Preferred method for posting USENET news.
If this variable is `current', Gnus will use the \"current\" select
method when posting. If it is nil (which is the default), Gnus will
-use the native select method when posting.
+use the native posting method of the server.
This method will not be used in mail groups and the like, only in
\"real\" newsgroups.
(defvar gnus-posting-styles nil
"*Alist of styles to use when posting.")
-(defcustom gnus-group-posting-charset-alist
- '(("^no\\." iso-8859-1)
- (message-this-is-mail nil)
- ("^de\\." nil)
- (".*" iso-8859-1)
- (message-this-is-news iso-8859-1))
- "Alist of regexps (to match group names) and default charsets to be unencoded when posting."
- :type '(repeat (list (regexp :tag "Group")
- (symbol :tag "Charset")))
- :group 'gnus-charset)
+(defvar gnus-posting-style-alist
+ '((organization . message-user-organization)
+ (signature . message-signature)
+ (signature-file . message-signature-file)
+ (address . user-mail-address)
+ (name . user-full-name))
+ "*Mapping from style parameters to variables.")
;;; Internal variables.
(defvar gnus-message-group-art nil)
(defconst gnus-bug-message
- "Sending a bug report to the Gnus Towers.
+ (format "Sending a bug report to the Gnus Towers.
+========================================
+
+This gnus is the %s%s.
+If you think the bug is a Semi-gnus bug, send a bug report to Semi-gnus
+Developers. (the addresses below are mailing list addresses)
+
========================================
The buffer below is a mail buffer. When you press `C-c C-c', it will
be sent to the Gnus Bug Exterminators.
-The thing near the bottom of the buffer is how the environment
-settings will be included in the mail. Please do not delete that.
-They will tell the Bug People what your environment is, so that it
-will be easier to locate the bugs.
+At the bottom of the buffer you'll see lots of variable settings.
+Please do not delete those. They will tell the Bug People what your
+environment is, so that it will be easier to locate the bugs.
If you have found a bug that makes Emacs go \"beep\", set
debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET')
Please describe the bug in annoying, painstaking detail.
Thank you for your help in stamping out bugs.
-")
+"
+
+ gnus-product-name
+ (if (string= gnus-product-name "Semi-gnus")
+ ""
+ ", a modified version of Semi-gnus")))
(eval-and-compile
(autoload 'gnus-uu-post-news "gnus-uu" nil t)
"c" gnus-summary-cancel-article
"s" gnus-summary-supersede-article
"r" gnus-summary-reply
- "y" gnus-summary-yank-message
"R" gnus-summary-reply-with-original
"w" gnus-summary-wide-reply
"W" gnus-summary-wide-reply-with-original
"\M-c" gnus-summary-mail-crosspost-complaint
"om" gnus-summary-mail-forward
"op" gnus-summary-post-forward
- "Om" gnus-uu-digest-mail-forward
- "Op" gnus-uu-digest-post-forward)
+ "Om" gnus-summary-mail-digest
+ "Op" gnus-summary-post-digest)
(gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map)
"b" gnus-summary-resend-bounced-mail
(,group gnus-newsgroup-name)
(message-header-setup-hook
(copy-sequence message-header-setup-hook))
- (message-mode-hook (copy-sequence message-mode-hook)))
+ (message-mode-hook (copy-sequence message-mode-hook))
+ (message-startup-parameter-alist
+ '((reply-buffer . gnus-copy-article-buffer)
+ (original-buffer . gnus-original-article-buffer)
+ (user-agent . Gnus))))
(add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
(add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)
(add-hook 'message-mode-hook 'gnus-configure-posting-styles)
(setq gnus-message-buffer (current-buffer))
(set (make-local-variable 'gnus-message-group-art)
(cons ,group ,article))
- (set (make-local-variable 'gnus-newsgroup-name) ,group)
- (set (make-local-variable 'message-posting-charset)
- (gnus-setup-posting-charset ,group))
+ (make-local-variable 'gnus-newsgroup-name)
(gnus-run-hooks 'gnus-message-setup-hook))
(gnus-add-buffer)
(gnus-configure-windows ,config t)
(set-buffer-modified-p nil))))
-(defun gnus-setup-posting-charset (group)
- (let ((alist gnus-group-posting-charset-alist)
- (group (or group ""))
- elem)
- (when group
- (catch 'found
- (while (setq elem (pop alist))
- (when (or (and (stringp (car elem))
- (string-match (car elem) group))
- (and (gnus-functionp (car elem))
- (funcall (car elem) group))
- (and (symbolp (car elem))
- (symbol-value (car elem))))
- (throw 'found (cadr elem))))))))
-
(defun gnus-inews-add-send-actions (winconf buffer article)
(make-local-hook 'message-sent-hook)
(add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t)
(setq message-post-method
`(lambda (arg)
(gnus-post-method arg ,gnus-newsgroup-name)))
- (setq message-newsreader (setq message-mailer (gnus-extended-version)))
- (message-add-action
- `(set-window-configuration ,winconf) 'exit 'postpone 'kill)
+ (setq message-user-agent (gnus-extended-version))
+ (when (not message-use-multi-frames)
+ (message-add-action
+ `(set-window-configuration ,winconf) 'exit 'postpone 'kill))
(message-add-action
`(when (gnus-buffer-exists-p ,buffer)
(save-excursion
;;; Post news commands of Gnus group mode and summary mode
-(defun gnus-group-mail (&optional arg)
- "Start composing a mail.
-If ARG, use the group under the point to find a posting style.
-If ARG is 1, prompt for a group name to find the posting style."
- (interactive "P")
- ;; We can't `let' gnus-newsgroup-name here, since that leads
- ;; to local variables leaking.
- (let ((group gnus-newsgroup-name)
- (buffer (current-buffer)))
- (unwind-protect
- (progn
- (setq gnus-newsgroup-name
- (if arg
- (if (= 1 (prefix-numeric-value arg))
- (completing-read "Use posting style of group: "
- gnus-active-hashtb nil
- (gnus-read-active-file-p))
- (gnus-group-group-name))
- ""))
- (gnus-setup-message 'message (message-mail)))
- (save-excursion
- (set-buffer buffer)
- (setq gnus-newsgroup-name group)))))
+(defun gnus-group-mail ()
+ "Start composing a mail."
+ (interactive)
+ (gnus-setup-message 'message
+ (message-mail)))
(defun gnus-group-post-news (&optional arg)
"Start composing a news message.
article)
(while (setq article (pop articles))
(when (gnus-summary-select-article t nil nil article)
- (when (gnus-eval-in-buffer-window gnus-original-article-buffer
- (message-cancel-news))
+ (when (gnus-eval-in-buffer-window gnus-article-buffer
+ (save-excursion
+ (set-buffer gnus-original-article-buffer)
+ (message-cancel-news)))
(gnus-summary-mark-as-read article gnus-canceled-mark)
(gnus-cache-remove-article 1))
(gnus-article-hide-headers-if-wanted))
This is done simply by taking the old article and adding a Supersedes
header line with the old Message-ID."
(interactive)
- (let ((article (gnus-summary-article-number)))
+ (let ((article (gnus-summary-article-number))
+ gnus-message-setup-hook)
(gnus-setup-message 'reply-yank
(gnus-summary-select-article t)
(set-buffer gnus-original-article-buffer)
;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used
;; this buffer should be passed to all mail/news reply/post routines.
(setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*"))
- (save-excursion
- (set-buffer gnus-article-copy)
- (mm-enable-multibyte))
+ (buffer-disable-undo gnus-article-copy)
(let ((article-buffer (or article-buffer gnus-article-buffer))
end beg)
(if (not (and (get-buffer article-buffer)
;; Delete the headers from the displayed articles.
(set-buffer gnus-article-copy)
(delete-region (goto-char (point-min))
- (or (search-forward "\n\n" nil t) (point-max)))
+ (or (search-forward "\n\n" nil t) (point)))
;; Insert the original article headers.
(insert-buffer-substring gnus-original-article-buffer beg end)
- (article-decode-encoded-words)))
+ (gnus-article-decode-rfc1522)))
gnus-article-copy)))
(defun gnus-post-news (post &optional group header article-buffer yank subject
(list gnus-post-method)))
gnus-secondary-select-methods
(mapcar 'cdr gnus-server-alist)
- (mapcar 'car gnus-opened-servers)
(list gnus-select-method)
(list group-method)))
method-alist post-methods method)
;; Weed out all mail methods.
(while methods
(setq method (gnus-server-get-method "" (pop methods)))
- (when (and (or (gnus-method-option-p method 'post)
- (gnus-method-option-p method 'post-mail))
- (not (member method post-methods)))
+ (when (or (gnus-method-option-p method 'post)
+ (gnus-method-option-p method 'post-mail))
(push method post-methods)))
;; Create a name-method alist.
(setq method-alist
;; Override normal method.
((and (eq gnus-post-method 'current)
(not (eq (car group-method) 'nndraft))
- (gnus-get-function group-method 'request-post t)
(not arg))
- group-method)
+ group-method)
((and gnus-post-method
(not (eq gnus-post-method 'current)))
gnus-post-method)
\f
-;; Dummies to avoid byte-compile warning.
+;; Dummy to avoid byte-compile warning.
(defvar nnspool-rejected-article-hook)
(defvar xemacs-codename)
(defun gnus-extended-version ()
- "Stringified Gnus version and Emacs version."
+ "Stringified gnus version."
(interactive)
- (concat
- "Gnus/" (prin1-to-string (gnus-continuum-version gnus-version) t)
- " (" gnus-version ")"
- " "
- (cond
- ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version)
- (concat "Emacs/" (match-string 1 emacs-version)))
- ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?"
- emacs-version)
- (concat (match-string 1 emacs-version)
- (format "/%d.%d" emacs-major-version emacs-minor-version)
- (if (match-beginning 3)
- (match-string 3 emacs-version)
- "")
- (if (boundp 'xemacs-codename)
- (concat " (" xemacs-codename ")")
- "")))
- (t emacs-version))))
+ (concat gnus-product-name "/" gnus-version-number))
+
+(defun gnus-message-make-user-agent (&optional include-mime-info max-column)
+ "Return user-agent info.
+INCLUDE-MIME-INFO the optional first argument if it is non-nil and the variable
+ `mime-edit-user-agent-value' exists, the return value will include it.
+MAX-COLUMN the optional second argument if it is specified, the return value
+ will be folded up in the proper way."
+ (let ((user-agent (if (and include-mime-info
+ (boundp 'mime-edit-user-agent-value))
+ (concat (gnus-extended-version)
+ " "
+ mime-edit-user-agent-value)
+ (gnus-extended-version))))
+ (if max-column
+ (let (boundary)
+ (unless (natnump max-column) (setq max-column 76))
+ (with-temp-buffer
+ (insert " " user-agent)
+ (goto-char 13)
+ (while (re-search-forward "[\n\t ]+" nil t)
+ (replace-match " "))
+ (goto-char 13)
+ (while (re-search-forward "[^ ()/]+\\(/[^ ()/]+\\)? ?" nil t)
+ (while (eq ?\( (char-after (point)))
+ (forward-list)
+ (skip-chars-forward " "))
+ (skip-chars-backward " ")
+ (if (> (current-column) max-column)
+ (progn
+ (if (or (not boundary) (eq ?\n (char-after boundary)))
+ (progn
+ (setq boundary (point))
+ (unless (eobp)
+ (delete-char 1)
+ (insert "\n ")))
+ (goto-char boundary)
+ (delete-char 1)
+ (insert "\n ")))
+ (setq boundary (point))))
+ (buffer-substring 13 (point-max))))
+ user-agent)))
\f
;;;
(interactive "P")
(gnus-summary-reply-with-original n t))
-(defun gnus-summary-mail-forward (&optional not-used post)
+(defun gnus-summary-mail-forward (&optional full-headers post)
"Forward the current message to another user.
-If POST, post instead of mail."
+If FULL-HEADERS (the prefix), include full headers when forwarding."
(interactive "P")
(gnus-setup-message 'forward
(gnus-summary-select-article)
- (let (text)
- (save-excursion
- (set-buffer gnus-original-article-buffer)
- (setq text (buffer-string)))
- (set-buffer (gnus-get-buffer-create
- (generate-new-buffer-name " *Gnus forward*")))
- (erase-buffer)
- (insert text)
- (goto-char (point-min))
- (when (looking-at "From ")
- (replace-match "X-From-Line: ") )
- (run-hooks 'gnus-article-decode-hook)
+ (let ((charset default-mime-charset))
+ (set-buffer gnus-original-article-buffer)
+ (make-local-variable 'default-mime-charset)
+ (setq default-mime-charset charset)
+ )
+ (let ((message-included-forward-headers
+ (if full-headers "" message-included-forward-headers)))
(message-forward post))))
+(defun gnus-summary-post-forward (&optional full-headers)
+ "Forward the current article to a newsgroup.
+If FULL-HEADERS (the prefix), include full headers when forwarding."
+ (interactive "P")
+ (gnus-summary-mail-forward full-headers t))
+
+;;; XXX: generate Subject and ``Topics''?
+(defun gnus-summary-mail-digest (&optional n post)
+ "Digests and forwards all articles in this series."
+ (interactive "P")
+ (let ((subject "Digested Articles")
+ (articles (gnus-summary-work-articles n))
+ article)
+ (gnus-setup-message 'forward
+ (gnus-summary-select-article)
+ (if post (message-news nil subject) (message-mail nil subject))
+ (message-goto-body)
+ (while (setq article (pop articles))
+ (save-window-excursion
+ (set-buffer gnus-summary-buffer)
+ (gnus-summary-select-article nil nil nil article)
+ (gnus-summary-remove-process-mark article))
+ (insert (mime-make-tag "message" "rfc822") "\n")
+ (insert-buffer-substring gnus-original-article-buffer))
+ (push-mark)
+ (message-goto-body)
+ (mime-edit-enclose-digest-region (point)(mark t)))))
+
+(defun gnus-summary-post-digest (&optional n)
+ "Digest and forwards all articles in this series to a newsgroup."
+ (interactive "P")
+ (gnus-summary-mail-digest n t))
+
(defun gnus-summary-resend-message (address n)
"Resend the current article to ADDRESS."
(interactive "sResend message(s) to: \nP")
(set-buffer gnus-original-article-buffer)
(message-resend address)))))
-(defun gnus-summary-post-forward (&optional full-headers)
- "Forward the current article to a newsgroup.
-If FULL-HEADERS (the prefix), include full headers when forwarding."
- (interactive "P")
- (gnus-summary-mail-forward full-headers t))
-
(defvar gnus-nastygram-message
"The following article was inappropriately posted to %s.\n\n"
"Format string to insert in nastygrams.
(gnus-summary-select-article)
(set-buffer gnus-original-article-buffer)
(if (and (<= (length (message-tokenize-header
- (setq newsgroups
- (mail-fetch-field "newsgroups"))
+ (setq newsgroups (mail-fetch-field "newsgroups"))
", "))
1)
(or (not (setq followup-to (mail-fetch-field "followup-to")))
(insert gnus-bug-message)
(goto-char (point-min)))
(message-pop-to-buffer "*Gnus Bug*")
- (message-setup `((To . ,gnus-maintainer) (Subject . "")))
+ (message-setup
+ `((To . ,gnus-maintainer) (Cc . ,semi-gnus-developers) (Subject . "")))
(when gnus-bug-create-help-buffer
(push `(gnus-bug-kill-buffer) message-send-actions))
(goto-char (point-min))
(stringp nntp-server-type))
(insert nntp-server-type))
(insert "\n\n\n\n\n")
- (save-excursion
- (set-buffer (gnus-get-buffer-create " *gnus environment info*"))
- (gnus-debug))
- (insert "<#part type=application/x-emacs-lisp buffer=\" *gnus environment info*\" disposition=inline description=\"User settings\"><#/part>")
+ (gnus-debug)
(goto-char (point-min))
(search-forward "Subject: " nil t)
(message "")))
(when (get-buffer "*Gnus Help Bug*")
(kill-buffer "*Gnus Help Bug*")))
-(defun gnus-summary-yank-message (buffer n)
- "Yank the current article into a composed message."
- (interactive
- (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t)
- current-prefix-arg))
- (gnus-summary-iterate n
- (let ((gnus-display-mime-function nil)
- (gnus-inhibit-treatment t))
- (gnus-summary-select-article))
- (save-excursion
- (set-buffer buffer)
- (message-yank-buffer gnus-article-buffer))))
-
(defun gnus-debug ()
"Attempts to go through the Gnus source file and report what variables have been changed.
The source file has to be in the Emacs load path."
;; Go through all the files looking for non-default values for variables.
(save-excursion
(set-buffer (gnus-get-buffer-create " *gnus bug info*"))
+ (buffer-disable-undo (current-buffer))
(while files
(erase-buffer)
(when (and (setq file (locate-library (pop files)))
(interactive "P")
(gnus-summary-select-article t)
(set-buffer gnus-original-article-buffer)
- (gnus-setup-message 'compose-bounce
- (let* ((references (mail-fetch-field "references"))
- (parent (and references (gnus-parent-id references))))
- (message-bounce)
- ;; If there are references, we fetch the article we answered to.
- (and fetch parent
- (gnus-summary-refer-article parent)
- (gnus-summary-show-all-headers)))))
+ (let (gnus-message-setup-hook)
+ (gnus-setup-message 'compose-bounce
+ (let* ((references (mail-fetch-field "references"))
+ (parent (and references (gnus-parent-id references))))
+ (message-bounce)
+ ;; If there are references, we fetch the article we answered to.
+ (and fetch parent
+ (gnus-summary-refer-article parent)
+ (gnus-summary-show-all-headers))))))
;;; Gcc handling.
(save-restriction
(message-narrow-to-headers)
(let ((gcc (or gcc (mail-fetch-field "gcc" nil t)))
- (cur (current-buffer))
+ (coding-system-for-write 'raw-text)
groups group method)
(when gcc
(message-remove-header "gcc")
(gnus-request-create-group group method))
(save-excursion
(nnheader-set-temp-buffer " *acc*")
- (insert-buffer-substring cur)
- (message-encode-message-body)
- (save-restriction
- (message-narrow-to-headers)
- (mail-encode-encoded-word-buffer))
+ (insert-buffer-substring message-encoding-buffer)
+ (gnus-run-hooks 'gnus-before-do-gcc-hook)
(goto-char (point-min))
(when (re-search-forward
(concat "^" (regexp-quote mail-header-separator) "$")
nil t)
(replace-match "" t t ))
- (unless (gnus-request-accept-article group method t t)
+ (unless (gnus-request-accept-article group method t)
(gnus-message 1 "Couldn't store article in group %s: %s"
group (gnus-status-message method))
(sit-for 2))
(and gnus-newsgroup-name
(gnus-group-find-parameter
gnus-newsgroup-name 'gcc-self)))
- result
+ result
(groups
(cond
((null gnus-message-archive-method)
;;; Posting styles.
+(defvar gnus-message-style-insertions nil)
+
(defun gnus-configure-posting-styles ()
"Configure posting styles according to `gnus-posting-styles'."
(unless gnus-inhibit-posting-styles
- (let ((group (or gnus-newsgroup-name ""))
- (styles gnus-posting-styles)
- style match variable attribute value v results
- 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
- (setq styles (append styles (list (cons ".*" tmp-style)))))))
+ (let ((styles gnus-posting-styles)
+ (gnus-newsgroup-name (or gnus-newsgroup-name ""))
+ style match variable attribute value value-value)
+ (make-local-variable 'gnus-message-style-insertions)
;; 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.
- (string-match match group))
- ((eq match 'header)
- (let ((header (message-fetch-field (pop style))))
- (and header
- (string-match (pop style) header))))
- ((or (symbolp match)
- (gnus-functionp match))
- (cond
- ((gnus-functionp match)
- ;; Function to be called.
- (funcall match))
- ((boundp match)
- ;; Variable to be checked.
- (symbol-value match))))
- ((listp match)
- ;; This is a form to be evaled.
- (eval match)))
+ (while styles
+ (setq style (pop styles)
+ match (pop style))
+ (when (cond ((stringp match)
+ ;; Regexp string match on the group name.
+ (string-match match gnus-newsgroup-name))
+ ((or (symbolp match)
+ (gnus-functionp match))
+ (cond ((gnus-functionp match)
+ ;; Function to be called.
+ (funcall match))
+ ((boundp match)
+ ;; Variable to be checked.
+ (symbol-value match))))
+ ((listp match)
+ ;; This is a form to be evaled.
+ (eval match)))
;; We have a match, so we set the variables.
- (dolist (attribute style)
- (setq element (pop attribute)
- variable nil
- 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)
- value)
- ((or (symbolp value)
- (gnus-functionp value))
- (cond ((gnus-functionp value)
- (funcall value))
- ((boundp value)
- (symbol-value value))))
- ((listp value)
- (eval value))))
- ;; Translate obsolescent value.
- (when (eq element 'signature-file)
- (setq element 'signature
- filep t))
- ;; Get the contents of file elems.
- (when (and filep v)
- (setq v (with-temp-buffer
- (insert-file-contents v)
- (buffer-string))))
- (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)))
- (make-local-variable 'message-setup-hook)
- (dolist (result results)
- (when (cdr result)
- (add-hook 'message-setup-hook
- (cond
- ((eq 'eval (car result))
- 'ignore)
- ((eq 'body (car result))
- `(lambda ()
- (save-excursion
- (message-goto-body)
- (insert ,(cdr result)))))
- ((eq 'signature (car result))
- (set (make-local-variable 'message-signature) nil)
- (set (make-local-variable 'message-signature-file) nil)
- `(lambda ()
- (save-excursion
- (let ((message-signature ,(cdr result)))
- (when message-signature
- (message-insert-signature))))))
- (t
- (let ((header
- (if (symbolp (car result))
- (capitalize (symbol-name (car result)))
- (car result))))
- `(lambda ()
- (save-excursion
- (message-remove-header ,header)
- (message-goto-eoh)
- (insert ,header ": " ,(cdr result) "\n")))))))))
- (when (or name address)
- (add-hook 'message-setup-hook
- `(lambda ()
- (let ((user-full-name ,(or (cdr name) (user-full-name)))
- (user-mail-address
- ,(or (cdr address) user-mail-address)))
- (save-excursion
- (message-remove-header "From")
- (message-goto-eoh)
- (insert "From: " (message-make-from) "\n")))))))))
+ (while style
+ (setq attribute (pop style)
+ value (cadr attribute)
+ variable nil)
+ ;; We find the variable that is to be modified.
+ (if (and (not (stringp (car attribute)))
+ (not (eq 'body (car attribute)))
+ (not (setq variable
+ (cdr (assq (car attribute)
+ gnus-posting-style-alist)))))
+ (message "Couldn't find attribute %s" (car attribute))
+ ;; We get the value.
+ (setq value-value
+ (cond ((stringp value)
+ value)
+ ((or (symbolp value)
+ (gnus-functionp value))
+ (cond ((gnus-functionp value)
+ (funcall value))
+ ((boundp value)
+ (symbol-value value))))
+ ((listp value)
+ (eval value))))
+ (if variable
+ ;; This is an ordinary variable.
+ (set (make-local-variable variable) value-value)
+ ;; This is either a body or a header to be inserted in the
+ ;; message.
+ (when value-value
+ (let ((attr (car attribute)))
+ (make-local-variable 'message-setup-hook)
+ (if (eq 'body attr)
+ (add-hook 'message-setup-hook
+ `(lambda ()
+ (save-excursion
+ (message-goto-body)
+ (insert ,value-value))))
+ (add-hook 'message-setup-hook
+ 'gnus-message-insert-stylings)
+ (push (cons (if (stringp attr) attr
+ (symbol-name attr))
+ value-value)
+ gnus-message-style-insertions))))))))))))
+
+(defun gnus-message-insert-stylings ()
+ (let (val)
+ (save-excursion
+ (message-goto-eoh)
+ (while (setq val (pop gnus-message-style-insertions))
+ (when (cdr val)
+ (insert (car val) ": " (cdr val) "\n"))
+ (gnus-pull (car val) gnus-message-style-insertions)))))
;;; Allow redefinition of functions.
projects / elisp / gnus.git- / blobdiff