;;; nnir.el --- search mail with various search engines -*- coding: iso-8859-1 -*-
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
;; Author: Kai Großjohann <grossjohann@ls6.cs.uni-dortmund.de>
;; Swish-e and Swish++ backends by:
;; `nnir-engines'. Then, users can choose the backend by setting
;; `nnir-search-engine' as a server variable.
-;;; Setup Code:
+;;; Code:
+
+;;; Setup:
;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(require 'nnoo)
(require 'gnus-group)
-(require 'gnus-sum)
(require 'message)
(require 'gnus-util)
(eval-when-compile
(require 'cl))
+;;; Internal Variables:
+
+(defvar nnir-current-query nil
+ "Internal: stores current query (= group name).")
+
+(defvar nnir-current-server nil
+ "Internal: stores current server (does it ever change?).")
+
+(defvar nnir-current-group-marked nil
+ "Internal: stores current list of process-marked groups.")
+
+(defvar nnir-artlist nil
+ "Internal: stores search result.")
+
+(defvar nnir-tmp-buffer " *nnir*"
+ "Internal: temporary buffer.")
+
+(defvar nnir-search-history ()
+ "Internal: the history for querying search options in nnir")
+
+(defvar nnir-extra-parms nil
+ "Internal: stores request for extra search parms")
+
+;; Imap variables
+
+(defvar nnir-imap-search-arguments
+ '(("Whole message" . "TEXT")
+ ("Subject" . "SUBJECT")
+ ("To" . "TO")
+ ("From" . "FROM")
+ ("Imap" . ""))
+ "Mapping from user readable keys to IMAP search items for use in nnir")
+
+(defvar nnir-imap-search-other "HEADER %S"
+ "The IMAP search item to use for anything other than
+ `nnir-imap-search-arguments'. By default this is the name of an
+ email header field")
+
+(defvar nnir-imap-search-argument-history ()
+ "The history for querying search options in nnir")
+
+;;; Helper macros
+
+;; Data type article list.
+
+(defmacro nnir-artlist-length (artlist)
+ "Returns number of articles in artlist."
+ `(length ,artlist))
+
+(defmacro nnir-artlist-article (artlist n)
+ "Returns from ARTLIST the Nth artitem (counting starting at 1)."
+ `(when (> ,n 0)
+ (elt ,artlist (1- ,n))))
+
+(defmacro nnir-artitem-group (artitem)
+ "Returns the group from the ARTITEM."
+ `(elt ,artitem 0))
+
+(defmacro nnir-artitem-number (artitem)
+ "Returns the number from the ARTITEM."
+ `(elt ,artitem 1))
+
+(defmacro nnir-artitem-rsv (artitem)
+ "Returns the Retrieval Status Value (RSV, score) from the ARTITEM."
+ `(elt ,artitem 2))
+
+(defmacro nnir-article-group (article)
+ "Returns the group for ARTICLE"
+ `(nnir-artitem-group (nnir-artlist-article nnir-artlist ,article)))
+
+(defmacro nnir-article-number (article)
+ "Returns the number for ARTICLE"
+ `(nnir-artitem-number (nnir-artlist-article nnir-artlist ,article)))
+
+(defmacro nnir-article-rsv (article)
+ "Returns the rsv for ARTICLE"
+ `(nnir-artitem-rsv (nnir-artlist-article nnir-artlist ,article)))
+
+(defsubst nnir-article-ids (article)
+ "Returns the pair `(nnir id . real id)' of ARTICLE"
+ (cons article (nnir-article-number article)))
+
+(defmacro nnir-categorize (sequence keyfunc &optional valuefunc)
+ "Sorts a sequence into categories and returns a list of the form
+`((key1 (element11 element12)) (key2 (element21 element22))'.
+The category key for a member of the sequence is obtained
+as `(keyfunc member)' and the corresponding element is just
+`member'. If `valuefunc' is non-nil, the element of the list
+is `(valuefunc member)'."
+ `(unless (null ,sequence)
+ (let (value)
+ (mapc
+ (lambda (member)
+ (let ((y (,keyfunc member))
+ (x ,(if valuefunc
+ `(,valuefunc member)
+ 'member)))
+ (if (assoc y value)
+ (push x (cadr (assoc y value)))
+ (push (list y (list x)) value))))
+ ,sequence)
+ value)))
+
+;;; Finish setup:
+
+(require 'gnus-sum)
(eval-when-compile
(autoload 'nnimap-buffer "nnimap")
(autoload 'nnimap-command "nnimap")
(autoload 'nnimap-possibly-change-group "nnimap")
- (autoload 'gnus-registry-action "gnus-registry"))
+ (autoload 'gnus-registry-action "gnus-registry")
+ (defvar gnus-registry-install))
+
(nnoo-declare nnir)
(nnoo-define-basics nnir)
"Search groups in Gnus with assorted seach engines."
:group 'gnus)
-(defcustom nnir-method-default-engines
- '((nnimap . imap)
- (nntp . gmane))
- "*Alist of default search engines keyed by server method."
- :type '(alist)
- :group 'nnir)
-
(defcustom nnir-ignored-newsgroups ""
"*A regexp to match newsgroups in the active file that should
be skipped when searching."
%g Article original short group name (string)
If nil this will use `gnus-summary-line-format'."
- :type '(regexp)
+ :type '(string)
+ :group 'nnir)
+
+(defcustom nnir-retrieve-headers-override-function nil
+ "*If non-nil, a function that accepts an article list and group
+and populates the `nntp-server-buffer' with the retrieved
+headers. Must return either 'nov or 'headers indicating the
+retrieved header format.
+
+If this variable is nil, or if the provided function returns nil for a search
+result, `gnus-retrieve-headers' will be called instead."
+ :type '(function)
:group 'nnir)
(defcustom nnir-imap-default-search-key "Whole message"
"*The default IMAP search key for an nnir search. Must be one of
the keys in `nnir-imap-search-arguments'. To use raw imap queries
by default set this to \"Imap\"."
- :type '(string)
+ :type `(choice ,@(mapcar (lambda (elem) (list 'const (car elem)))
+ nnir-imap-search-arguments))
:group 'nnir)
(defcustom nnir-swish++-configuration-file
:type '(directory)
:group 'nnir)
-;; Imap variables
-
-(defvar nnir-imap-search-arguments
- '(("Whole message" . "TEXT")
- ("Subject" . "SUBJECT")
- ("To" . "TO")
- ("From" . "FROM")
- ("Imap" . ""))
- "Mapping from user readable keys to IMAP search items for use in nnir")
-
-(defvar nnir-imap-search-other "HEADER %S"
- "The IMAP search item to use for anything other than
- `nnir-imap-search-arguments'. By default this is the name of an
- email header field")
-
-(defvar nnir-imap-search-argument-history ()
- "The history for querying search options in nnir")
-
;;; Developer Extension Variable:
(defvar nnir-engines
Add an entry here when adding a new search engine.")
-(defvar nnir-retrieve-headers-override-function nil
- "If non-nil, a function that accepts an article list and group
-and populates the `nntp-server-buffer' with the retrieved
-headers. Must return either 'nov or 'headers indicating the
-retrieved header format.
-
-If this variable is nil, or if the provided function returns nil for a search
-result, `gnus-retrieve-headers' will be called instead.")
-
-;;; Internal Variables:
-
-(defvar nnir-current-query nil
- "Internal: stores current query (= group name).")
-
-(defvar nnir-current-server nil
- "Internal: stores current server (does it ever change?).")
-
-(defvar nnir-current-group-marked nil
- "Internal: stores current list of process-marked groups.")
-
-(defvar nnir-artlist nil
- "Internal: stores search result.")
-
-(defvar nnir-tmp-buffer " *nnir*"
- "Internal: temporary buffer.")
-
-(defvar nnir-search-history ()
- "Internal: the history for querying search options in nnir")
-
-(defvar nnir-extra-parms nil
- "Internal: stores request for extra search parms")
-
-;;; Code:
-
-;;; Helper macros
-
-;; Data type article list.
-
-(defmacro nnir-artlist-length (artlist)
- "Returns number of articles in artlist."
- `(length ,artlist))
-
-(defmacro nnir-artlist-article (artlist n)
- "Returns from ARTLIST the Nth artitem (counting starting at 1)."
- `(when (> ,n 0)
- (elt ,artlist (1- ,n))))
-
-(defmacro nnir-artitem-group (artitem)
- "Returns the group from the ARTITEM."
- `(elt ,artitem 0))
-
-(defmacro nnir-artitem-number (artitem)
- "Returns the number from the ARTITEM."
- `(elt ,artitem 1))
-
-(defmacro nnir-artitem-rsv (artitem)
- "Returns the Retrieval Status Value (RSV, score) from the ARTITEM."
- `(elt ,artitem 2))
-
-(defmacro nnir-article-group (article)
- "Returns the group for ARTICLE"
- `(nnir-artitem-group (nnir-artlist-article nnir-artlist ,article)))
-
-(defmacro nnir-article-number (article)
- "Returns the number for ARTICLE"
- `(nnir-artitem-number (nnir-artlist-article nnir-artlist ,article)))
-
-(defmacro nnir-article-rsv (article)
- "Returns the rsv for ARTICLE"
- `(nnir-artitem-rsv (nnir-artlist-article nnir-artlist ,article)))
-
-(defsubst nnir-article-ids (article)
- "Returns the pair `(nnir id . real id)' of ARTICLE"
- (cons article (nnir-article-number article)))
-
-(defmacro nnir-categorize (sequence keyfunc &optional valuefunc)
- "Sorts a sequence into categories and returns a list of the form
-`((key1 (element11 element12)) (key2 (element21 element22))'.
-The category key for a member of the sequence is obtained
-as `(keyfunc member)' and the corresponding element is just
-`member'. If `valuefunc' is non-nil, the element of the list
-is `(valuefunc member)'."
- `(unless (null ,sequence)
- (let (value)
- (mapcar
- (lambda (member)
- (let ((y (,keyfunc member))
- (x ,(if valuefunc
- `(,valuefunc member)
- 'member)))
- (if (assoc y value)
- (push x (cadr (assoc y value)))
- (push (list y (list x)) value))))
- ,sequence)
- value)))
+(defcustom nnir-method-default-engines
+ '((nnimap . imap)
+ (nntp . gmane))
+ "*Alist of default search engines keyed by server method."
+ :type `(repeat (cons (choice (const nnimap) (const nttp) (const nnspool)
+ (const nneething) (const nndir) (const nnmbox)
+ (const nnml) (const nnmh) (const nndraft)
+ (const nnfolder) (const nnmaildir))
+ (choice
+ ,@(mapcar (lambda (elem) (list 'const (car elem)))
+ nnir-engines))))
+ :group 'nnir)
;; Gnus glue.
(while (not (eobp))
(let* ((novitem (funcall parsefunc))
(artno (mail-header-number novitem))
- (art (car (rassoc artno articleids))))
+ (art (car (rassq artno articleids))))
(when art
(mail-header-set-number novitem art)
- ;; (mail-header-set-subject
- ;; novitem
- ;; (format "[%d: %s/%d] %s"
- ;; (nnir-article-rsv art) artgroup artno
- ;; (mail-header-subject novitem)))
(push novitem headers))
(forward-line 1)))))
(setq headers
article)
(save-excursion
(let ((artfullgroup (nnir-article-group article))
- (artno (nnir-article-number article))
- ;; Bug?
- ;; Why must we bind nntp-server-buffer here? It won't
- ;; work if `buf' is used, say. (Of course, the set-buffer
- ;; line below must then be updated, too.)
- (nntp-server-buffer (or to-buffer nntp-server-buffer)))
- (set-buffer nntp-server-buffer)
- (erase-buffer)
+ (artno (nnir-article-number article)))
(message "Requesting article %d from group %s"
artno artfullgroup)
- (gnus-request-article artno artfullgroup nntp-server-buffer)
+ (if to-buffer
+ (with-current-buffer to-buffer
+ (let ((gnus-article-decode-hook nil))
+ (gnus-request-article-this-buffer artno artfullgroup)))
+ (gnus-request-article artno artfullgroup))
(cons artfullgroup artno)))))
(deffoo nnir-request-move-article (article group server accept-form
(to-newsgroup (nth 1 accept-form))
(to-method (gnus-find-method-for-group to-newsgroup))
(from-method (gnus-find-method-for-group artfullgroup))
- (move-is-internal (gnus-server-equal from-method to-method))
- (artsubject (mail-header-subject
- (gnus-data-header
- (assoc article (gnus-data-list nil))))))
+ (move-is-internal (gnus-server-equal from-method to-method)))
(unless (gnus-check-backend-function
'request-move-article artfullgroup)
(error "The group %s does not support article moving" artfullgroup))
to-newsgroup ; Not respooling
(gnus-group-real-name to-newsgroup)))))
+(deffoo nnir-request-expire-articles (articles group &optional server force)
+ (if force
+ (let ((articles-by-group (nnir-categorize
+ articles nnir-article-group nnir-article-ids))
+ not-deleted)
+ (while (not (null articles-by-group))
+ (let* ((group-articles (pop articles-by-group))
+ (artgroup (car group-articles))
+ (articleids (cadr group-articles))
+ (artlist (sort (mapcar 'cdr articleids) '<)))
+ (unless (gnus-check-backend-function 'request-expire-articles
+ artgroup)
+ (error "The group %s does not support article deletion" artgroup))
+ (unless (gnus-check-server (gnus-find-method-for-group artgroup))
+ (error "Couldn't open server for group %s" artgroup))
+ (push (gnus-request-expire-articles
+ artlist artgroup force)
+ not-deleted)))
+ (sort (delq nil not-deleted) '<))
+ articles))
+
(deffoo nnir-warp-to-article ()
(let* ((cur (if (> (gnus-summary-article-number) 0)
(gnus-summary-article-number)
(nnir-imap-make-query
criteria qstring)))))
(mapc
- (lambda (artnum) (push (vector group artnum 100) artlist)
- (setq arts (1+ arts)))
- (and (car result)
- (delete 0 (mapcar #'string-to-number
- (cdr (assoc "SEARCH"
- (cdr result)))))))
+ (lambda (artnum)
+ (let ((artn (string-to-number artnum)))
+ (when (> artn 0)
+ (push (vector group artn 100)
+ artlist)
+ (setq arts (1+ arts)))))
+ (and (car result) (cdr (assoc "SEARCH" (cdr result)))))
(message "Searching %s... %d matches" group arts)))
(message "Searching %s...done" group))
(quit nil))
- artlist))
+ (nreverse artlist)))
groups)))))
(defun nnir-imap-make-query (criteria qstring)
;; gmane interface
(defun nnir-run-gmane (query srv &optional groups)
"Run a search against a gmane back-end server."
- (if (gnus-string-match-p "gmane.org$" srv)
(let* ((case-fold-search t)
(qstring (cdr (assq 'query query)))
(server (cadr (gnus-server-to-method srv)))
- (groupspec (if groups
- (mapconcat
- (lambda (x)
- (format "group:%s" (gnus-group-short-name x)))
- groups " ") ""))
+ (groupspec (mapconcat
+ (lambda (x)
+ (if (gnus-string-match-p "gmane" x)
+ (format "group:%s" (gnus-group-short-name x))
+ (error "Can't search non-gmane groups: %s" x)))
+ groups " "))
(authorspec
(if (assq 'author query)
(format "author:%s" (cdr (assq 'author query))) ""))
(string-to-number (match-string 2 xref)) xscore)
artlist)))))
(forward-line 1)))
- (apply 'vector (nreverse (mm-delete-duplicates artlist))))
- (message "Can't search non-gmane nntp groups")
- nil))
+ (apply 'vector (nreverse (mm-delete-duplicates artlist)))))
;;; Util Code:
(let ((cur (current-buffer))
name)
(goto-char (point-min))
- (unless (string= nnir-ignored-newsgroups "")
+ (unless (or (null nnir-ignored-newsgroups)
+ (string= nnir-ignored-newsgroups ""))
(delete-matching-lines nnir-ignored-newsgroups))
(if (eq (car method) 'nntp)
(while (not (eobp))
(when (eq (car (gnus-find-method-for-group gnus-newsgroup-name)) 'nnir)
(setq gnus-summary-line-format
(or nnir-summary-line-format gnus-summary-line-format))
- (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action t)
- (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action t)
- (add-hook 'gnus-summary-article-delete-hook 'nnir-registry-action t t)
- (add-hook 'gnus-summary-article-move-hook 'nnir-registry-action t t)))
+ (when (and (boundp 'gnus-registry-install)
+ (eq gnus-registry-install t))
+ (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action t)
+ (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action t)
+ (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action t)
+ (add-hook 'gnus-summary-article-delete-hook 'nnir-registry-action t t)
+ (add-hook 'gnus-summary-article-move-hook 'nnir-registry-action t t)
+ (add-hook 'gnus-summary-article-expire-hook 'nnir-registry-action t t))))
projects / gnus / blobdiff