summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
authorGnus developers <ding@gnus.org>2010-09-24 22:33:34 +0000
committerKatsumi Yamaoka <yamaoka@jpl.org>2010-09-24 22:33:34 +0000
commit61b1af828927139930086a12ef20ff144f82e635 (patch)
tree0a913e5af097ee291f4714d9d7d709e7b2ce60eb /lisp
parent5816888b23238706d35d9d6e094c24866dedf2c6 (diff)
Merge changes made in Gnus trunk.
gnus.el (gnus-sloppily-equal-method-parameters): Avoid cl.el convenience functions. nnrss.el (nnrss-retrieve-groups): Change to the group before checking its data structures. nnimap.el (nnimap-split-incoming-mail): Fix paren typo in the 'junk handling. starttls.el: (starttls-open-stream): Add autoload cookie. nnimap.el (nnimap-command): Register the last command time so that we can use it for idling NOOPs. nnimap.el: Implement IMAP keepalive. gnus-cache.el (gnus-cache-braid-heads): When braiding heads, don't use the same article number for all the cached articles. nnimap.el (nnimap-update-info): Protect against nil uidnexts. gnus-group.el: Remove the outdated archive group stuff, which no longer works. gnus-group.el, gnus.el: Remove the outdated charter support. gnus-sum.el, gnus-group.el, gnus.el: Remove outdated support for FAQ fetching. gnus-gravatar.el, gravatar.el: New files.
Diffstat (limited to 'lisp')
-rw-r--r--lisp/gnus/ChangeLog54
-rw-r--r--lisp/gnus/gnus-art.el34
-rw-r--r--lisp/gnus/gnus-cache.el2
-rw-r--r--lisp/gnus/gnus-gravatar.el112
-rw-r--r--lisp/gnus/gnus-group.el93
-rw-r--r--lisp/gnus/gnus-sum.el53
-rw-r--r--lisp/gnus/gnus.el75
-rw-r--r--lisp/gnus/gravatar.el123
-rw-r--r--lisp/gnus/nnimap.el46
-rw-r--r--lisp/gnus/nnrss.el2
-rw-r--r--lisp/gnus/starttls.el1
11 files changed, 384 insertions, 211 deletions
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index b8fae31324..b62c702ed4 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,57 @@
+2010-09-24 Julien Danjou <julien@danjou.info>
+
+ * gnus-sum.el: Add support for Gravatars.
+
+ * gnus-art.el: Add support for Gravatars.
+
+ * gnus-gravatar.el: Add this file.
+
+ * gravatar.el: Add this file.
+
+2010-09-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-summary-fetch-faq): Removed.
+
+ * gnus-group.el (gnus-group-fetch-faq): Removed.
+
+ * gnus.el (gnus-group-faq-directory): Removed.
+
+ * gnus-group.el (gnus-group-fetch-charter): Removed.
+
+ * gnus.el (gnus-group-charter-alist): Removed.
+
+ * gnus-group.el (gnus-group-archive-directory): Removed.
+ (gnus-group-recent-archive-directory): Ditto.
+ (gnus-group-make-archive-group): Removed.
+
+ * nnimap.el (nnimap-update-info): Protect against nil uidnexts.
+
+ * gnus-cache.el (gnus-cache-braid-heads): When braiding heads, don't
+ use the same article number for all the cached articles.
+
+ * nnimap.el (nnimap-command): Register the last command time so
+ that we can use it for idling NOOPs.
+ (nnimap-open-connection): Start the keeplive timer.
+ (nnimap-make-process-buffer): Store all the process buffers.
+ (nnimap-keepalive): New function.
+
+ * starttls.el: (starttls-open-stream): Add autoload cookie.
+
+2010-09-24 Michael Welsh Duggan <md5i@md5i.com> (tiny change)
+
+ * nnimap.el (nnimap-split-incoming-mail): Fix paren typo in the 'junk
+ handling.
+
+2010-09-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnrss.el (nnrss-retrieve-groups): Change to the group before checking
+ its data structures.
+
+ * gnus.el (gnus-sloppily-equal-method-parameters): Use copy-sequence
+ instead of the cl.el copy-list.
+ (gnus-sloppily-equal-method-parameters): Use equal instead of the cl
+ equalp.
+
2010-09-24 Katsumi Yamaoka <yamaoka@jpl.org>
* gmm-utils.el (gmm-tool-bar-from-list): Always use tool-bar-local-item
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index d92d29d621..231f9e90e4 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -1529,10 +1529,40 @@ node `(gnus)Picons' for details."
:type gnus-article-treat-head-custom)
(put 'gnus-treat-newsgroups-picon 'highlight t)
+(defcustom gnus-treat-from-gravatar
+ (when (display-images-p) 'head)
+ "Display gravatars in the From header.
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles' and Info
+node `(gnus)Gravatars' for details."
+ :version "24.1"
+ :group 'gnus-article-treat
+ :group 'gnus-gravatar
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :link '(custom-manual "(gnus)Gravatars")
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-from-gravatar 'highlight t)
+
+(defcustom gnus-treat-mail-gravatar
+ (when (display-images-p) 'head)
+ "Display gravatars in To and Cc headers.
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles' and Info
+node `(gnus)Gravatars' for details."
+ :version "24.1"
+ :group 'gnus-article-treat
+ :group 'gnus-gravatar
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :link '(custom-manual "(gnus)Gravatars")
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-mail-gravatar 'highlight t)
+
(defcustom gnus-treat-body-boundary
(if (or gnus-treat-newsgroups-picon
gnus-treat-mail-picon
- gnus-treat-from-picon)
+ gnus-treat-from-picon
+ gnus-treat-from-gravatar
+ gnus-treat-mail-gravatar)
;; If there's much decoration, the user might prefer a boundery.
'head
nil)
@@ -1669,6 +1699,8 @@ This requires GNU Libidn, and by default only enabled if it is found."
(gnus-treat-from-picon gnus-treat-from-picon)
(gnus-treat-mail-picon gnus-treat-mail-picon)
(gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon)
+ (gnus-treat-from-gravatar gnus-treat-from-gravatar)
+ (gnus-treat-mail-gravatar gnus-treat-mail-gravatar)
(gnus-treat-highlight-headers gnus-article-highlight-headers)
(gnus-treat-highlight-signature gnus-article-highlight-signature)
(gnus-treat-strip-trailing-blank-lines
diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el
index 4b2d670570..550614f935 100644
--- a/lisp/gnus/gnus-cache.el
+++ b/lisp/gnus/gnus-cache.el
@@ -603,7 +603,7 @@ system for example was used.")
(insert-file-contents (gnus-cache-file-name group entry)))
(goto-char (point-min))
(insert "220 ")
- (princ (car cached) (current-buffer))
+ (princ (pop cached) (current-buffer))
(insert " Article retrieved.\n")
(search-forward "\n\n" nil 'move)
(delete-region (point) (point-max))
diff --git a/lisp/gnus/gnus-gravatar.el b/lisp/gnus/gnus-gravatar.el
new file mode 100644
index 0000000000..6b97a54845
--- /dev/null
+++ b/lisp/gnus/gnus-gravatar.el
@@ -0,0 +1,112 @@
+;;; gnus-gravatar.el --- Gnus Gravatar support
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Julien Danjou <julien@danjou.info>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gravatar)
+
+(defgroup gnus-gravatar nil
+ "Gnus Gravatar."
+ :group 'gnus-visual)
+
+(defcustom gnus-gravatar-size 32
+ "How big should gravatars be displayed."
+ :type 'integer
+ :group 'gnus-gravatar)
+
+(defcustom gnus-gravatar-relief 1
+ "If non-nil, adds a shadow rectangle around the image. The
+value, relief, specifies the width of the shadow lines, in
+pixels. If relief is negative, shadows are drawn so that the
+image appears as a pressed button; otherwise, it appears as an
+unpressed button."
+ :group 'gnus-gravatar)
+
+(defun gnus-gravatar-transform-address (header category)
+ (gnus-with-article-headers
+ (let ((addresses
+ (mail-header-parse-addresses
+ ;; mail-header-parse-addresses does not work (reliably) on
+ ;; decoded headers.
+ (or
+ (ignore-errors
+ (mail-encode-encoded-word-string
+ (or (mail-fetch-field header) "")))
+ (mail-fetch-field header)))))
+ (dolist (address addresses)
+ (gravatar-retrieve
+ (car address)
+ 'gnus-gravatar-insert
+ (list header (car address) category))))))
+
+(defun gnus-gravatar-insert (gravatar header address category)
+ "Insert GRAVATAR for ADDRESS in HEADER in current article buffer.
+Set image category to CATEGORY."
+ (unless (eq gravatar 'error)
+ (gnus-with-article-headers
+ (gnus-article-goto-header header)
+ (mail-header-narrow-to-field)
+ (when (and (search-forward address nil t)
+ (or (search-backward ", " nil t)
+ (search-backward ": " nil t)))
+ (goto-char (1+ (point)))
+ ;; Do not do anything if there's already a gravatar. This can
+ ;; happens if the buffer has been regenerated in the mean time, for
+ ;; example we were fetching someaddress, and then we change to
+ ;; another mail with the same someaddress.
+ (unless (memq 'gnus-gravatar (text-properties-at (point)))
+ (let ((inhibit-read-only t)
+ (point (point))
+ (gravatar (append
+ gravatar
+ `(:ascent center :relief ,gnus-gravatar-relief))))
+ (gnus-put-image gravatar nil category)
+ (put-text-property point (point) 'gnus-gravatar address)
+ (gnus-add-wash-type category)
+ (gnus-add-image category gravatar)))))))
+
+;;;###autoload
+(defun gnus-treat-from-gravatar ()
+ "Display gravatar in the From header.
+If gravatar is already displayed, remove it."
+ (interactive)
+ (gnus-with-article-buffer
+ (if (memq 'from-gravatar gnus-article-wash-types)
+ (gnus-delete-images 'from-gravatar)
+ (gnus-gravatar-transform-address "from" 'from-gravatar))))
+
+;;;###autoload
+(defun gnus-treat-mail-gravatar ()
+ "Display gravatars in the Cc and To headers.
+If gravatars are already displayed, remove them."
+ (interactive)
+ (gnus-with-article-buffer
+ (if (memq 'mail-gravatar gnus-article-wash-types)
+ (gnus-delete-images 'mail-gravatar)
+ (gnus-gravatar-transform-address "cc" 'mail-gravatar)
+ (gnus-gravatar-transform-address "to" 'mail-gravatar))))
+
+(provide 'gnus-gravatar)
+
+;;; gnus-gravatar.el ends here
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el
index 86cdb0e89e..482d8e9231 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -55,18 +55,6 @@
(autoload 'gnus-agent-total-fetched-for "gnus-agent")
(autoload 'gnus-cache-total-fetched-for "gnus-cache")
-(defcustom gnus-group-archive-directory
- "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/"
- "*The address of the (ding) archives."
- :group 'gnus-group-foreign
- :type 'directory)
-
-(defcustom gnus-group-recent-archive-directory
- "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list-recent/"
- "*The address of the most recent (ding) articles."
- :group 'gnus-group-foreign
- :type 'directory)
-
(defcustom gnus-no-groups-message "No Gnus is good news"
"*Message displayed by Gnus when no groups are available."
:group 'gnus-start
@@ -657,7 +645,6 @@ simple manner.")
"d" gnus-group-make-directory-group
"h" gnus-group-make-help-group
"u" gnus-group-make-useful-group
- "a" gnus-group-make-archive-group
"l" gnus-group-nnimap-edit-acl
"m" gnus-group-make-group
"E" gnus-group-edit-group
@@ -752,10 +739,8 @@ simple manner.")
"e" gnus-score-edit-all-score)
(gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map)
- "c" gnus-group-fetch-charter
"C" gnus-group-fetch-control
"d" gnus-group-describe-group
- "f" gnus-group-fetch-faq
"v" gnus-version)
(gnus-define-keys (gnus-group-sub-map "S" gnus-group-mode-map)
@@ -821,11 +806,6 @@ simple manner.")
["Describe" gnus-group-describe-group :active (gnus-group-group-name)
,@(if (featurep 'xemacs) nil
'(:help "Display description of the current group"))]
- ["Fetch FAQ" gnus-group-fetch-faq (gnus-group-group-name)]
- ["Fetch charter" gnus-group-fetch-charter
- :active (gnus-group-group-name)
- ,@(if (featurep 'xemacs) nil
- '(:help "Display the charter of the current group"))]
["Fetch control message" gnus-group-fetch-control
:active (gnus-group-group-name)
,@(if (featurep 'xemacs) nil
@@ -925,7 +905,6 @@ simple manner.")
["Make a foreign group..." gnus-group-make-group t]
["Add a directory group..." gnus-group-make-directory-group t]
["Add the help group" gnus-group-make-help-group t]
- ["Add the archive group" gnus-group-make-archive-group t]
["Make a doc group..." gnus-group-make-doc-group t]
["Make a web group..." gnus-group-make-web-group t]
["Make a virtual group..." gnus-group-make-empty-virtual t]
@@ -3089,22 +3068,6 @@ If there is, use Gnus to create an nnrss group"
(nnrss-save-server-data nil))
(error "No feeds found for %s" url))))
-(defun gnus-group-make-archive-group (&optional all)
- "Create the (ding) Gnus archive group of the most recent articles.
-Given a prefix, create a full group."
- (interactive "P")
- (let ((group (gnus-group-prefixed-name
- (if all "ding.archives" "ding.recent") '(nndir ""))))
- (when (gnus-group-entry group)
- (error "Archive group already exists"))
- (gnus-group-make-group
- (gnus-group-real-name group)
- (list 'nndir (if all "hpc" "edu")
- (list 'nndir-directory
- (if all gnus-group-archive-directory
- gnus-group-recent-archive-directory))))
- (gnus-group-add-parameter group (cons 'to-address "ding@gnus.org"))))
-
(defun gnus-group-make-directory-group (dir)
"Create an nndir group.
The user will be prompted for a directory. The contents of this
@@ -4049,62 +4012,6 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
(gnus-summary-position-point)
ret))
-(defun gnus-group-fetch-faq (group &optional faq-dir)
- "Fetch the FAQ for the current group.
-If given a prefix argument, prompt for the FAQ dir
-to use."
- (interactive
- (list
- (gnus-group-group-name)
- (when current-prefix-arg
- (completing-read
- "FAQ dir: " (and (listp gnus-group-faq-directory)
- (mapcar #'list
- gnus-group-faq-directory))))))
- (unless group
- (error "No group name given"))
- (let ((dirs (or faq-dir gnus-group-faq-directory))
- dir found file)
- (unless (listp dirs)
- (setq dirs (list dirs)))
- (while (and (not found)
- (setq dir (pop dirs)))
- (let ((name (gnus-group-real-name group)))
- (setq file (expand-file-name name dir)))
- (if (not (file-exists-p file))
- (gnus-message 1 "No such file: %s" file)
- (let ((enable-local-variables nil))
- (find-file file)
- (setq found t))))))
-
-(defun gnus-group-fetch-charter (group)
- "Fetch the charter for the current group.
-If given a prefix argument, prompt for a group."
- (interactive
- (list (or (when current-prefix-arg
- (gnus-group-completing-read "Group: "))
- (gnus-group-group-name)
- gnus-newsgroup-name)))
- (unless group
- (error "No group name given"))
- (require 'mm-url)
- (condition-case nil (require 'url-http) (error nil))
- (let ((name (mm-url-form-encode-xwfu (gnus-group-real-name group)))
- url hierarchy)
- (when (string-match "\\(^[^\\.]+\\)\\..*" name)
- (setq hierarchy (match-string 1 name))
- (if (and (setq url (cdr (assoc hierarchy gnus-group-charter-alist)))
- (if (fboundp 'url-http-file-exists-p)
- (url-http-file-exists-p (eval url))
- t))
- (browse-url (eval url))
- (setq url (concat "http://" hierarchy
- ".news-admin.org/charters/" name))
- (if (and (fboundp 'url-http-file-exists-p)
- (url-http-file-exists-p url))
- (browse-url url)
- (gnus-group-fetch-control group))))))
-
(defun gnus-group-fetch-control (group)
"Fetch the archived control messages for the current group.
If given a prefix argument, prompt for a group."
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index 50f9b32700..f019731d8b 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -2124,7 +2124,9 @@ increase the score of each group you read."
"W" gnus-html-show-images
"f" gnus-treat-from-picon
"m" gnus-treat-mail-picon
- "n" gnus-treat-newsgroups-picon)
+ "n" gnus-treat-newsgroups-picon
+ "g" gnus-treat-from-gravatar
+ "h" gnus-treat-mail-gravatar)
(gnus-define-keys (gnus-summary-wash-mime-map "M" gnus-summary-wash-map)
"w" gnus-article-decode-mime-words
@@ -2154,11 +2156,9 @@ increase the score of each group you read."
(gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map)
"v" gnus-version
- "f" gnus-summary-fetch-faq
"d" gnus-summary-describe-group
"h" gnus-summary-describe-briefly
"i" gnus-info-find-node
- "c" gnus-group-fetch-charter
"C" gnus-group-fetch-control)
(gnus-define-keys (gnus-summary-backend-map "B" gnus-summary-mode-map)
@@ -2374,6 +2374,8 @@ increase the score of each group you read."
["Show picons in From" gnus-treat-from-picon t]
["Show picons in mail headers" gnus-treat-mail-picon t]
["Show picons in news headers" gnus-treat-newsgroups-picon t]
+ ["Show Gravatars in From" gnus-treat-from-gravatar t]
+ ["Show Gravatars in mail headers" gnus-treat-mail-gravatar t]
("View as different encoding"
,@(gnus-summary-menu-split
(mapcar
@@ -2733,11 +2735,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs))))
["Randomize" gnus-summary-sort-by-random t]
["Original sort" gnus-summary-sort-by-original t])
("Help"
- ["Fetch group FAQ" gnus-summary-fetch-faq t]
["Describe group" gnus-summary-describe-group t]
- ["Fetch charter" gnus-group-fetch-charter
- ,@(if (featurep 'xemacs) nil
- '(:help "Display the charter of the current group"))]
["Fetch control message" gnus-group-fetch-control
,@(if (featurep 'xemacs) nil
'(:help "Display the archived control message for the current group"))]
@@ -5370,18 +5368,18 @@ or a straight list of headers."
(if (= gnus-tmp-lines -1)
(setq gnus-tmp-lines "?")
(setq gnus-tmp-lines (number-to-string gnus-tmp-lines)))
- (gnus-put-text-property
- (point)
- (progn (eval gnus-summary-line-format-spec) (point))
- 'gnus-number number)
- (when gnus-visual-p
- (forward-line -1)
- (gnus-summary-highlight-line)
- (when gnus-summary-update-hook
- (gnus-run-hooks 'gnus-summary-update-hook))
- (forward-line 1))
-
- (setq gnus-tmp-prev-subject simp-subject)))
+ (gnus-put-text-property
+ (point)
+ (progn (eval gnus-summary-line-format-spec) (point))
+ 'gnus-number number)
+ (when gnus-visual-p
+ (forward-line -1)
+ (gnus-summary-highlight-line)
+ (when gnus-summary-update-hook
+ (gnus-run-hooks 'gnus-summary-update-hook))
+ (forward-line 1))
+
+ (setq gnus-tmp-prev-subject simp-subject)))
(when (nth 1 thread)
(push (list (max 0 gnus-tmp-level)
@@ -7324,23 +7322,6 @@ The state which existed when entering the ephemeral is reset."
t)))
(gnus-message 3 "This dead summary is now alive again"))
-;; Suggested by Andrew Eskilsson <pi92ae@pt.hk-r.se>.
-(defun gnus-summary-fetch-faq (&optional faq-dir)
- "Fetch the FAQ for the current group.
-If FAQ-DIR (the prefix), prompt for a directory to search for the faq
-in."
- (interactive
- (list
- (when current-prefix-arg
- (completing-read
- "FAQ dir: " (and (listp gnus-group-faq-directory)
- (mapcar 'list
- gnus-group-faq-directory))))))
- (let (gnus-faq-buffer)
- (when (setq gnus-faq-buffer
- (gnus-group-fetch-faq gnus-newsgroup-name faq-dir))
- (gnus-configure-windows 'summary-faq))))
-
;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
(defun gnus-summary-describe-group (&optional force)
"Describe the current newsgroup."
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index 42881e58ed..5aea6634a9 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -1470,75 +1470,6 @@ list, Gnus will try all the methods in the list until it finds a match."
(nnweb "refer" (nnweb-type google)))
gnus-select-method))))
-(defcustom gnus-group-faq-directory
- '("/ftp@mirrors.aol.com:/pub/rtfm/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/"
- "/ftp@nctuccca.nctu.edu.tw:/pub/Documents/rtfm/usenet-by-group/"
- "/ftp@hwarang.postech.ac.kr:/pub/usenet/"
- "/ftp@ftp.hk.super.net:/mirror/faqs/")
- "*Directory where the group FAQs are stored.
-This will most commonly be on a remote machine, and the file will be
-fetched by ange-ftp.
-
-This variable can also be a list of directories. In that case, the
-first element in the list will be used by default. The others can
-be used when being prompted for a site.
-
-Note that Gnus uses an aol machine as the default directory. If this
-feels fundamentally unclean, just think of it as a way to finally get
-something of value back from them.
-
-If the default site is too slow, try one of these:
-
- North America: mirrors.aol.com /pub/rtfm/usenet
- ftp.seas.gwu.edu /pub/rtfm
- rtfm.mit.edu /pub/usenet
- Europe: ftp.uni-paderborn.de /pub/FAQ
- src.doc.ic.ac.uk /usenet/news-FAQS
- ftp.sunet.se /pub/usenet
- ftp.pasteur.fr /pub/FAQ
- Asia: nctuccca.nctu.edu.tw /pub/Documents/rtfm/usenet-by-group/
- hwarang.postech.ac.kr /pub/usenet
- ftp.hk.super.net /mirror/faqs"
- :group 'gnus-group-various
- :type '(choice directory
- (repeat directory)))
-
-(defcustom gnus-group-charter-alist
- '(("no" . (concat "http://no.news-admin.org/charter/" name ".txt"))
- ("de" . (concat "http://purl.net/charta/" name ".html"))
- ("dk" . (concat "http://www.usenet.dk/grupper.pl?get=" name))
- ("england" . (concat "http://england.news-admin.org/charters/" name))
- ("fr" . (concat "http://www.usenet-fr.net/fur/chartes/" name ".html"))
- ("europa" . (concat "http://www.europa.usenet.eu.org/chartas/charta-en-"
- (gnus-replace-in-string name "europa\\." "") ".html"))
- ("nl" . (concat "http://www.xs4all.nl/~sister/usenet/charters/" name))
- ("aus" . (concat "http://aus.news-admin.org/groupinfo.cgi/" name))
- ("pl" . (concat "http://www.usenet.pl/opisy/" name))
- ("ch" . (concat "http://www.use-net.ch/Usenet/charter.html#" name))
- ("at" . (concat "http://www.usenet.at/chartas/" name "/charta"))
- ("uk" . (concat "http://www.usenet.org.uk/" name ".html"))
- ("dfw" . (concat "http://www.cirr.com/dfw/charters/" name ".html"))
- ("se" . (concat "http://www.usenet-se.net/Reglementen/"
- (gnus-replace-in-string name "\\." "_") ".html"))
- ("milw" . (concat "http://usenet.mil.wi.us/"
- (gnus-replace-in-string name "milw\\." "") "-charter"))
- ("ca" . (concat "http://www.sbay.org/ca/charter-" name ".html"))
- ("netins" . (concat "http://www.netins.net/usenet/charter/"
- (gnus-replace-in-string name "\\." "-") "-charter.html")))
- "*An alist of (HIERARCHY . FORM) pairs used to construct the URL of a charter.
-When FORM is evaluated `name' is bound to the name of the group."
- :version "22.1"
- :group 'gnus-group-various
- :type '(repeat (cons (string :tag "Hierarchy") (sexp :tag "Form"))))
-(put 'gnus-group-charter-alist 'risky-local-variable t)
-
(defcustom gnus-group-fetch-control-use-browse-url nil
"*Non-nil means that control messages are displayed using `browse-url'.
Otherwise they are fetched with ange-ftp and displayed in an ephemeral
@@ -3695,8 +3626,8 @@ that that variable is buffer-local to the summary buffers."
(defsubst gnus-sloppily-equal-method-parameters (m1 m2)
;; Check parameters for sloppy equalness.
- (let ((p1 (copy-list (cddr m1)))
- (p2 (copy-list (cddr m2)))
+ (let ((p1 (copy-sequence (cddr m1)))
+ (p2 (copy-sequence (cddr m2)))
e1 e2)
(block nil
(while (setq e1 (pop p1))
@@ -3704,7 +3635,7 @@ that that variable is buffer-local to the summary buffers."
;; The parameter doesn't exist in p2.
(return nil))
(setq p2 (delq e2 p2))
- (unless (equalp e1 e2)
+ (unless (equal e1 e2)
(if (not (and (stringp (cadr e1))
(stringp (cadr e2))))
(return nil)
diff --git a/lisp/gnus/gravatar.el b/lisp/gnus/gravatar.el
new file mode 100644
index 0000000000..ec03b1b8a0
--- /dev/null
+++ b/lisp/gnus/gravatar.el
@@ -0,0 +1,123 @@
+;;; gravatar.el --- Get Gravatars
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Julien Danjou <julien@danjou.info>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'image)
+(require 'url)
+(require 'url-cache)
+
+(defgroup gravatar nil
+ "Gravatar."
+ :group 'comm)
+
+(defcustom gravatar-automatic-caching t
+ "Whether cache retrieved gravatar."
+ :group 'gravatar)
+
+(defcustom gravatar-cache-ttl (days-to-time 30)
+ "Time to live for gravatar cache entries."
+ :group 'gravatar)
+
+(defcustom gravatar-rating "g"
+ "Default rating for gravatar."
+ :group 'gravatar)
+
+(defcustom gravatar-size 32
+ "Default size in pixels for gravatars."
+ :group 'gravatar)
+
+(defconst gravatar-base-url
+ "http://www.gravatar.com/avatar"
+ "Base URL for getting gravatars.")
+
+(defun gravatar-hash (mail-address)
+ "Create an hash from MAIL-ADDRESS."
+ (md5 (downcase mail-address)))
+
+(defun gravatar-build-url (mail-address)
+ "Return an URL to retrieve MAIL-ADDRESS gravatar."
+ (format "%s/%s?d=404&r=%s&s=%d"
+ gravatar-base-url
+ (gravatar-hash mail-address)
+ gravatar-rating
+ gravatar-size))
+
+(defun gravatar-cache-expired (url)
+ "Check if URL is cached for more than `gravatar-cache-ttl'."
+ (cond (url-standalone-mode
+ (not (file-exists-p (url-cache-create-filename url))))
+ (t (let ((cache-time (url-is-cached url)))
+ (if cache-time
+ (time-less-p
+ (time-add
+ cache-time
+ gravatar-cache-ttl)
+ (current-time))
+ t)))))
+
+(defun gravatar-get-data ()
+ "Get data from current buffer."
+ (when (string-match "^HTTP/.+ 200 OK$"
+ (buffer-substring (point-min) (line-end-position)))
+ (when (search-forward "\n\n" nil t)
+ (buffer-substring (point) (point-max)))))
+
+(defun gravatar-data->image ()
+ "Get data of current buffer and return an image.
+If no image available, return 'error."
+ (let ((data (gravatar-get-data)))
+ (if data
+ (create-image data nil t)
+ 'error)))
+
+;;;###autoload
+(defun gravatar-retrieve (mail-address cb &optional cbargs)
+ "Retrieve MAIL-ADDRESS gravatar and call CB on retrieval.
+You can provide a list of argument to pass to CB in CBARGS."
+ (let ((url (gravatar-build-url mail-address)))
+ (if (gravatar-cache-expired url)
+ (url-retrieve url
+ 'gravatar-retrieved
+ (list cb (when cbargs cbargs)))
+ (apply cb
+ (with-temp-buffer
+ (mm-disable-multibyte)
+ (url-cache-extract (url-cache-create-filename url))
+ (gravatar-data->image))
+ cbargs))))
+
+(defun gravatar-retrieved (status cb &optional cbargs)
+ "Callback function used by `gravatar-retrieve'."
+ ;; Store gravatar?
+ (when gravatar-automatic-caching
+ (url-store-in-cache (current-buffer)))
+ (if (plist-get status :error)
+ ;; Error happened.
+ (apply cb 'error cbargs)
+ (apply cb (gravatar-data->image) cbargs)))
+
+(provide 'gravatar)
+
+;;; gravatar.el ends here
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index 2d4f0de87c..16a43423bf 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -90,8 +90,12 @@ not done by default on servers that doesn't support that command.")
(defvar nnimap-split-download-body-default nil
"Internal variable with default value for `nnimap-split-download-body'.")
+(defvar nnimap-keepalive-timer nil)
+(defvar nnimap-process-buffers nil)
+
(defstruct nnimap
- group process commands capabilities select-result newlinep server)
+ group process commands capabilities select-result newlinep server
+ last-command-time)
(defvar nnimap-object nil)
@@ -223,6 +227,7 @@ not done by default on servers that doesn't support that command.")
(set (make-local-variable 'nnimap-object)
(make-nnimap :server (nnoo-current-server 'nnimap)))
(push (list buffer (current-buffer)) nnimap-connection-alist)
+ (push (current-buffer) nnimap-process-buffers)
(current-buffer)))
(defun nnimap-open-shell-stream (name buffer host port)
@@ -246,7 +251,25 @@ not done by default on servers that doesn't support that command.")
'("login" "password") address port nil (null ports))))
credentials))
+(defun nnimap-keepalive ()
+ (let ((now (current-time)))
+ (dolist (buffer nnimap-process-buffers)
+ (when (buffer-name buffer)
+ (with-current-buffer buffer
+ (when (and nnimap-object
+ (nnimap-last-command-time nnimap-object)
+ (> (time-to-seconds
+ (time-subtract
+ now
+ (nnimap-last-command-time nnimap-object)))
+ ;; More than five minutes since the last command.
+ (* 5 60)))
+ (nnimap-send-command "NOOP")))))))
+
(defun nnimap-open-connection (buffer)
+ (unless nnimap-keepalive-timer
+ (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15)
+ 'nnimap-keepalive)))
(with-current-buffer (nnimap-make-process-buffer buffer)
(let* ((coding-system-for-read 'binary)
(coding-system-for-write 'binary)
@@ -801,12 +824,20 @@ not done by default on servers that doesn't support that command.")
(if (or completep
(not (gnus-active group)))
(gnus-set-active group
- (if (and low high)
- (cons low high)
+ (cond
+ ((and low high)
+ (cons low high))
+ (uidnext
;; No articles in this group.
- (cons uidnext (1- uidnext))))
+ (cons uidnext (1- uidnext)))
+ (start-article
+ (cons start-article (1- start-article)))
+ (t
+ ;; No articles and no uidnext.
+ nil)))
(setcdr (gnus-active group) (or high (1- uidnext))))
- (unless high
+ (when (and (not high)
+ uidnext)
(setq high (1- uidnext)))
;; Then update the list of read articles.
(let* ((unread
@@ -986,6 +1017,7 @@ not done by default on servers that doesn't support that command.")
(defun nnimap-command (&rest args)
(erase-buffer)
+ (setf (nnimap-last-command-time nnimap-object) (current-time))
(let* ((sequence (apply #'nnimap-send-command args))
(response (nnimap-get-response sequence)))
(if (equal (caar response) "OK")
@@ -1154,8 +1186,8 @@ not done by default on servers that doesn't support that command.")
;; And then mark the successful copy actions as deleted,
;; and possibly expunge them.
(nnimap-mark-and-expunge-incoming
- (nnimap-parse-copied-articles sequences))
- (nnimap-mark-and-expunge-incoming junk-articles))))))))
+ (nnimap-parse-copied-articles sequences)))
+ (nnimap-mark-and-expunge-incoming junk-articles)))))))
(defun nnimap-mark-and-expunge-incoming (range)
(when range
diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el
index f93d811068..379fee2eb8 100644
--- a/lisp/gnus/nnrss.el
+++ b/lisp/gnus/nnrss.el
@@ -391,8 +391,8 @@ used to render text. If it is nil, text will simply be folded.")
t)
(deffoo nnrss-retrieve-groups (groups &optional server)
- (nnrss-possibly-change-group nil server)
(dolist (group groups)
+ (nnrss-possibly-change-group group server)
(nnrss-check-group group server))
(with-current-buffer nntp-server-buffer
(erase-buffer)
diff --git a/lisp/gnus/starttls.el b/lisp/gnus/starttls.el
index bf1982f54d..a4d33b81bb 100644
--- a/lisp/gnus/starttls.el
+++ b/lisp/gnus/starttls.el
@@ -269,6 +269,7 @@ handshake, or nil on failure."
host port (if done "done" "failed"))
process))
+;;;###autoload
(defun starttls-open-stream (name buffer host port)
"Open a TLS connection for a port to a host.
Returns a subprocess object to represent the connection.