;;; gnus.el --- a newsreader for GNU Emacs
-;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996,
-;; 1997, 1998, 2000, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996,
+;; 1997, 1998, 2000, 2001, 2002 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
"Options related to newsservers and other servers used by Gnus."
:group 'gnus)
+(defgroup gnus-server-visual nil
+ "Highlighting and menus in the server buffer."
+ :group 'gnus-visual
+ :group 'gnus-server)
+
(defgroup gnus-message '((message custom-group))
"Composing replies and followups in Gnus."
:group 'gnus)
:link '(custom-manual "(gnus)Exiting Gnus")
:group 'gnus)
-(defconst gnus-version-number "0.04"
+(defconst gnus-version-number "0.05"
"Version number for this version of Gnus.")
(defconst gnus-version (format "Oort Gnus v%s" gnus-version-number)
(defface gnus-splash-face
'((((class color)
(background dark))
- (:foreground "Brown"))
+ (:foreground "#888888"))
(((class color)
(background light))
- (:foreground "Brown"))
+ (:foreground "#888888"))
(t
()))
- "Face of the splash screen.")
+ "Face for the splash screen.")
(defun gnus-splash ()
(save-excursion
(defvar gnus-simple-splash nil)
+;;(format "%02x%02x%02x" 114 66 20) "724214"
+
+(defvar gnus-logo-color-alist
+ '((flame "#cc3300" "#ff2200")
+ (pine "#c0cc93" "#f8ffb8")
+ (moss "#a1cc93" "#d2ffb8")
+ (irish "#04cc90" "#05ff97")
+ (sky "#049acc" "#05deff")
+ (tin "#6886cc" "#82b6ff")
+ (velvet "#7c68cc" "#8c82ff")
+ (grape "#b264cc" "#cf7df")
+ (labia "#cc64c2" "#fd7dff")
+ (berry "#cc6485" "#ff7db5")
+ (dino "#724214" "#1e3f03")
+ (oort "#cccccc" "#888888")
+ (neutral "#b4b4b4" "#878787")
+ (september "#bf9900" "#ffcc00"))
+ "Color alist used for the Gnus logo.")
+
+(defcustom gnus-logo-color-style 'oort
+ "*Color styles used for the Gnus logo."
+ :type '(choice (const flame) (const pine) (const moss)
+ (const irish) (const sky) (const tin)
+ (const velvet) (const grape) (const labia)
+ (const berry) (const neutral) (const september)
+ (const dino))
+ :group 'gnus-xmas)
+
+(defvar gnus-logo-colors
+ (cdr (assq gnus-logo-color-style gnus-logo-color-alist))
+ "Colors used for the Gnus logo.")
+
(defun gnus-group-startup-message (&optional x y)
"Insert startup message in current buffer."
;; Insert the message.
(fboundp 'find-image)
(display-graphic-p)
(let ((image (find-image
- `((:type xpm :file "gnus.xpm")
+ `((:type xpm :file "gnus.xpm"
+ :color-symbols
+ (("thing" . ,(car gnus-logo-colors))
+ ("shadow" . ,(cadr gnus-logo-colors))
+ ("background" . ,(face-background 'default))))
(:type pbm :file "gnus.pbm"
;; Account for the pbm's blackground.
:background ,(face-foreground 'gnus-splash-face)
REST is a plist of following:
:type One of `bool', `list' or `nil'.
:function The name of the function.
-:function-document The document of the function.
+:function-document The documentation of the function.
:parameter-type The type for customizing the parameter.
-:parameter-document The document for the parameter.
+:parameter-document The documentation for the parameter.
:variable The name of the variable.
-:variable-document The document for the variable.
+:variable-document The documentation for the variable.
:variable-group The group for customizing the variable.
:variable-type The type for customizing the variable.
:variable-default The default value of the variable."
(defcustom gnus-local-domain nil
"Local domain name without a host name.
The DOMAINNAME environment variable is used instead if it is defined.
-If the `system-name' function returns the full Internet name, there is
+If the function `system-name' returns the full Internet name, there is
no need to set this variable."
:group 'gnus-message
:type '(choice (const :tag "default" nil)
(defcustom gnus-group-faq-directory
'("/ftp@mirrors.aol.com:/pub/rtfm/usenet/"
- "/ftp@sunsite.auc.dk:/pub/usenet/"
"/ftp@sunsite.doc.ic.ac.uk:/pub/usenet/news-faqs/"
"/ftp@src.doc.ic.ac.uk:/usenet/news-FAQS/"
"/ftp@ftp.seas.gwu.edu:/pub/rtfm/"
+ "/ftp@ftp.pasteur.fr:/pub/FAQ/"
"/ftp@rtfm.mit.edu:/pub/usenet/"
"/ftp@ftp.uni-paderborn.de:/pub/FAQ/"
"/ftp@ftp.sunet.se:/pub/usenet/"
Europe: ftp.uni-paderborn.de /pub/FAQ
src.doc.ic.ac.uk /usenet/news-FAQS
ftp.sunet.se /pub/usenet
- sunsite.auc.dk /pub/usenet
+ ftp.pasteur.fr /pub/FAQ
Asia: nctuccca.edu.tw /USENET/FAQ
hwarang.postech.ac.kr /pub/usenet
ftp.hk.super.net /mirror/faqs"
:group 'gnus-meta
:type 'boolean)
-(defcustom gnus-use-picons nil
- "*If non-nil, display picons in a frame of their own."
- :group 'gnus-meta
- :type 'boolean)
-
(defcustom gnus-summary-prepare-exit-hook
'(gnus-summary-expire-articles)
"*A hook called when preparing to exit from the summary buffer.
("nnwarchive" none)
("nnlistserv" none)
("nnagent" post-mail)
- ("nnimap" post-mail address prompt-address physical-address))
+ ("nnimap" post-mail address prompt-address physical-address)
+ ("nnmaildir" mail respool address))
"*An alist of valid select methods.
The first element of each list lists should be a string with the name
of the select method. The other elements may be the category of
:variable-group gnus-group-foreign
:parameter-type
'(choice :tag "Posting Method"
- (const nil)
- (const current)
- (const native)
+ (const :tag "Use native server" native)
+ (const :tag "Use current server" current)
(list :convert-widget
(lambda (widget)
(list 'sexp :tag "Methods"
(const pick-menu)
(const grouplens-menu)))
+;; Byte-compiler warning.
+(defvar gnus-visual)
+;; Find out whether the gnus-visual TYPE is wanted.
+(defun gnus-visual-p (&optional type class)
+ (and gnus-visual ; Has to be non-nil, at least.
+ (if (not type) ; We don't care about type.
+ gnus-visual
+ (if (listp gnus-visual) ; It's a list, so we check it.
+ (or (memq type gnus-visual)
+ (memq class gnus-visual))
+ t))))
+
(defcustom gnus-mouse-face
(condition-case ()
(if (gnus-visual-p 'mouse-face 'highlight)
(scored . score) (saved . save)
(cached . cache) (downloadable . download)
(unsendable . unsend) (forwarded . forward)
- (recent . recent)))
+ (recent . recent) (seen . seen)))
+
+(defconst gnus-article-special-mark-lists
+ '((seen range)
+ (killed range)
+ (bookmark tuple)
+ (score tuple)))
+
+;; Propagate flags to server, with the following exceptions:
+;; `seen' is private to each gnus installation
+;; `cache' is a internal gnus flag for each gnus installation
+;; `download' is a agent flag private to each gnus installation
+;; `unsend' are for nndraft groups only
+;; `score' is not a proper mark
+(defconst gnus-article-unpropagated-mark-lists
+ '(seen cache download unsend score)
+ "Marks that shouldn't be propagated to backends.
+Typical marks are those that make no sense in a standalone backend,
+such as a mark that says whether an article is stored in the cache
+(which doesn't make sense in a standalone backend).")
(defvar gnus-headers-retrieved-by nil)
(defvar gnus-article-reply nil)
("gnus-msg" (gnus-summary-send-map keymap)
gnus-article-mail gnus-copy-article-buffer gnus-extended-version)
("gnus-msg" :interactive t
- gnus-group-post-news gnus-group-mail gnus-summary-post-news
+ gnus-group-post-news gnus-group-mail gnus-group-news
+ gnus-summary-post-news gnus-summary-news-other-window
gnus-summary-followup gnus-summary-followup-with-original
gnus-summary-cancel-article gnus-summary-supersede-article
gnus-post-news gnus-summary-reply gnus-summary-reply-with-original
gnus-summary-wide-reply-with-original
gnus-summary-post-forward gnus-summary-wide-reply-with-original
gnus-summary-post-forward)
- ("gnus-picon" :interactive t gnus-article-display-picons
- gnus-group-display-picons gnus-picons-article-display-x-face
- gnus-picons-display-x-face)
- ("gnus-picon" gnus-picons-buffer-name)
+ ("gnus-picon" :interactive t gnus-treat-from-picon)
("gnus-gl" bbb-login bbb-logout bbb-grouplens-group-p
gnus-grouplens-mode)
- ("smiley" :interactive t gnus-smiley-display)
+ ("smiley" :interactive t smiley-region)
("gnus-win" gnus-configure-windows gnus-add-configuration)
("gnus-sum" gnus-summary-insert-line gnus-summary-read-group
gnus-list-of-unread-articles gnus-list-of-read-articles
gnus-unplugged gnus-agentize gnus-agent-batch)
("gnus-vm" :interactive t gnus-summary-save-in-vm
gnus-summary-save-article-vm)
- ("gnus-draft" :interactive t gnus-draft-mode gnus-group-send-drafts)
+ ("gnus-draft" :interactive t gnus-draft-mode gnus-group-send-queue)
("gnus-mlspl" gnus-group-split gnus-group-split-fancy)
("gnus-mlspl" :interactive t gnus-group-split-setup
gnus-group-split-update))))
(defmacro gnus-get-info (group)
`(nth 2 (gnus-gethash ,group gnus-newsrc-hashtb)))
-;; Byte-compiler warning.
-(defvar gnus-visual)
-;; Find out whether the gnus-visual TYPE is wanted.
-(defun gnus-visual-p (&optional type class)
- (and gnus-visual ; Has to be non-nil, at least.
- (if (not type) ; We don't care about type.
- gnus-visual
- (if (listp gnus-visual) ; It's a list, so we check it.
- (or (memq type gnus-visual)
- (memq class gnus-visual))
- t))))
-
;;; Load the compatability functions.
(require 'gnus-ems)
;;; Gnus Utility Functions
;;;
+(defun gnus-find-subscribed-addresses ()
+ "Return a regexp matching the addresses of all subscribed mail groups.
+It consists of the `to-address' or `to-list' parameter of all groups
+with a `subscribed' parameter."
+ (let (group address addresses)
+ (dolist (entry (cdr gnus-newsrc-alist))
+ (setq group (car entry))
+ (when (gnus-group-find-parameter group 'subscribed)
+ (setq address (or (gnus-group-fast-parameter group 'to-address)
+ (gnus-group-fast-parameter group 'to-list)))
+ (when address
+ (push address addresses))))
+ (list (mapconcat 'regexp-quote addresses "\\|"))))
(defmacro gnus-string-or (&rest strings)
"Return the first element of STRINGS that is a non-blank string.
(insert (message gnus-version))
(message gnus-version)))
-(defun gnus-continuum-version (version)
+(defun gnus-continuum-version (&optional version)
"Return VERSION as a floating point number."
+ (interactive)
+ (unless version
+ (setq version gnus-version))
(when (or (string-match "^\\([^ ]+\\)? ?Gnus v?\\([0-9.]+\\)$" version)
(string-match "^\\(.?\\)gnus-\\([0-9.]+\\)$" version))
(let ((alpha (and (match-beginning 1) (match-string 1 version)))
0))
(string-to-number
(if (zerop major)
- (format "%s00%02d%02d"
- (if (member alpha '("(ding)" "d"))
- "4.99"
- (+ 5 (* 0.02
- (abs
- (- (mm-char-int (aref (downcase alpha) 0))
- (mm-char-int ?t))))
- -0.01))
- minor least)
+ (format "%s00%02d%02d"
+ (if (member alpha '("(ding)" "d"))
+ "4.99"
+ (+ 5 (* 0.02
+ (abs
+ (- (mm-char-int (aref (downcase alpha) 0))
+ (mm-char-int ?t))))
+ -0.01))
+ minor least)
(format "%d.%02d%02d" major minor least))))))
(defun gnus-info-find-node (&optional nodename)
(defun gnus-news-group-p (group &optional article)
"Return non-nil if GROUP (and ARTICLE) come from a news server."
- (or (gnus-member-of-valid 'post group) ; Ordinary news group.
- (and (gnus-member-of-valid 'post-mail group) ; Combined group.
- (if (or (null article)
- (not (< article 0)))
- (eq (gnus-request-type group article) 'news)
- (if (not (vectorp article))
- nil
- ;; It's a real article.
- (eq (gnus-request-type group (mail-header-id article))
- 'news))))))
+ (cond ((gnus-member-of-valid 'post group) ;Ordinary news group
+ t) ;is news of course.
+ ((not (gnus-member-of-valid 'post-mail group)) ;Non-combined.
+ nil) ;must be mail then.
+ ((vectorp article) ;Has header info.
+ (eq (gnus-request-type group (mail-header-id article)) 'news))
+ ((null article) ;Hasn't header info
+ (eq (gnus-request-type group) 'news)) ;(unknown ==> mail)
+ ((< article 0) ;Virtual message
+ nil) ;we don't know, guess mail.
+ (t ;Has positive number
+ (eq (gnus-request-type group article) 'news)))) ;use it.
;; Returns a list of writable groups.
(defun gnus-writable-groups ()
(not (string= (nth 1 method) "")))
(concat "+" (nth 1 method)))))
+(defsubst gnus-method-to-full-server-name (method)
+ (format "%s+%s" (car method) (nth 1 method)))
+
(defun gnus-group-prefixed-name (group method)
"Return the whole name from GROUP and METHOD."
(and (stringp method) (setq method (gnus-server-to-method method)))
(if (or (not method)
- (gnus-server-equal method "native"))
+ (gnus-server-equal method "native")
+ (string-match ":" group))
group
(concat (gnus-method-to-server-name method) ":" group)))
(when (string-match (car elem) group)
(setq params-list
(nconc (gnus-expand-group-parameters
- (copy-sequence (cdr elem)) group)
+ (car elem) (cdr elem) group)
params-list))))
params-list))
-(defun gnus-expand-group-parameters (parameters group)
+(defun gnus-expand-group-parameter (match value group)
+ "Use MATCH to expand VALUE in GROUP."
+ (with-temp-buffer
+ (insert group)
+ (goto-char (point-min))
+ (while (re-search-forward match nil t)
+ (replace-match value))
+ (buffer-string)))
+
+(defun gnus-expand-group-parameters (match parameters group)
"Go through PARAMETERS and expand them according to the match data."
- (dolist (elem parameters)
- (when (stringp (cdr elem))
- (setcdr elem (replace-match (cdr elem) nil nil group)))))
+ (let (new)
+ (dolist (elem parameters)
+ (if (and (stringp (cdr elem))
+ (string-match "\\\\" (cdr elem)))
+ (push (cons (car elem)
+ (gnus-expand-group-parameter match (cdr elem) group))
+ new)
+ (push elem new)))
+ new))
+
+(defun gnus-group-fast-parameter (group symbol &optional allow-list)
+ "For GROUP, return the value of SYMBOL.
+
+You should call this in the `gnus-group-buffer' buffer.
+The function `gnus-group-find-parameter' will do that for you."
+ ;; The speed trick: No cons'ing and quit early.
+ (or (let ((params (funcall gnus-group-get-parameter-function group)))
+ ;; Start easy, check the "real" group parameters.
+ (gnus-group-parameter-value params symbol allow-list))
+ ;; We didn't found it there, try `gnus-parameters'.
+ (let ((result nil)
+ (head nil)
+ (tail gnus-parameters))
+ ;; A good old-fashioned non-cl loop.
+ (while tail
+ (setq head (car tail)
+ tail (cdr tail))
+ ;; The car is regexp matching for matching the group name.
+ (when (string-match (car head) group)
+ ;; The cdr is the parameters.
+ (setq result (gnus-group-parameter-value (cdr head)
+ symbol allow-list))
+ (when result
+ ;; Expand if necessary.
+ (if (and (stringp result) (string-match "\\\\" result))
+ (setq result (gnus-expand-group-parameter (car head)
+ result group)))
+ ;; Exit the loop early.
+ (setq tail nil))))
+ ;; Done.
+ result)))
(defun gnus-group-find-parameter (group &optional symbol allow-list)
"Return the group parameters for GROUP.
-If SYMBOL, return the value of that symbol in the group parameters."
+If SYMBOL, return the value of that symbol in the group parameters.
+
+If you call this function inside a loop, consider using the faster
+`gnus-group-fast-parameter' instead."
(save-excursion
(set-buffer gnus-group-buffer)
- (let ((parameters
- (nconc
- (copy-sequence
- (funcall gnus-group-get-parameter-function group))
- (gnus-parameters-get-parameter group))))
- (if symbol
- (gnus-group-parameter-value parameters symbol allow-list)
+ (if symbol
+ (gnus-group-fast-parameter group symbol allow-list)
+ (let ((parameters
+ (nconc
+ (copy-sequence
+ (funcall gnus-group-get-parameter-function group))
+ (gnus-parameters-get-parameter group))))
parameters))))
(defun gnus-group-get-parameter (group &optional symbol allow-list)
startup level. If ARG is non-nil and not a positive number, Gnus will
prompt the user for the name of an NNTP server to use."
(interactive "P")
+ (unless (byte-code-function-p (symbol-function 'gnus))
+ (message "You should byte-compile Gnus")
+ (sit-for 2))
(gnus-1 arg dont-connect slave))
;; Allow redefinition of Gnus functions.
projects / gnus / blobdiff