X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnir.el;h=8e91c68b3914bea27e6a9b9d0e5397e442cdbd27;hb=c85ff27626350a909ee39474fecac012fec8cd26;hp=b706d150f7d4b7caf4170fe3cf55b379f0be4692;hpb=37a6bcd4423177ae79be2f6ac5b8f8ea4829aca7;p=gnus diff --git a/lisp/nnir.el b/lisp/nnir.el index b706d150f..8e91c68b3 100644 --- a/lisp/nnir.el +++ b/lisp/nnir.el @@ -1,7 +1,6 @@ ;;; 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 ;; Swish-e and Swish++ backends by: @@ -289,7 +288,9 @@ is `(valuefunc member)'." (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) @@ -303,13 +304,6 @@ is `(valuefunc member)'." "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." @@ -327,7 +321,7 @@ with three items unique to nnir summary buffers: %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 @@ -345,7 +339,8 @@ result, `gnus-retrieve-headers' will be called instead." "*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 @@ -544,6 +539,18 @@ needs the variables `nnir-namazu-program', Add an entry here when adding a new search engine.") +(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. @@ -635,7 +642,7 @@ Add an entry here when adding a new search engine.") (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) (push novitem headers)) @@ -656,17 +663,14 @@ Add an entry here when adding a new search engine.") 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 @@ -676,10 +680,7 @@ Add an entry here when adding a new search engine.") (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)) @@ -693,6 +694,27 @@ Add an entry here when adding a new search engine.") 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) @@ -779,16 +801,17 @@ details on the language and supported extensions" (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) @@ -1381,18 +1404,15 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." ;; 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$" - (or (cadr (assoc 'nntp-address (cddr (gnus-server-to-method 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))) "")) @@ -1427,9 +1447,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." (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: @@ -1524,7 +1542,8 @@ server is of form 'backend:name'." (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)) @@ -1570,10 +1589,14 @@ server is of form 'backend:name'." (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))))