X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnir.el;h=d1ca0213ed968c5280824f97cb66971f4f1ea5da;hb=31c28e438ad11d0e4dfa251bf705ef2d2b5ee972;hp=bb64f871bc84cf733172c64161ffa693afdb4067;hpb=1cdd2da7c7d06922634d602883f053df3e4ce5b6;p=gnus diff --git a/lisp/nnir.el b/lisp/nnir.el index bb64f871b..d1ca0213e 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-2012 Free Software Foundation, Inc. ;; Author: Kai Großjohann ;; Swish-e and Swish++ backends by: @@ -41,9 +40,10 @@ ;; Retrieval Status Value (score). ;; When looking at the retrieval result (in the Summary buffer) you -;; can type `G T' (aka M-x gnus-summary-nnir-goto-thread RET) on an -;; article. You will be teleported into the group this article came -;; from, showing the thread this article is part of. +;; can type `A W' (aka M-x gnus-warp-to-article RET) on an article. You +;; will be warped into the group this article came from. Typing `A T' +;; (aka M-x gnus-summary-refer-thread RET) will warp to the group and +;; also show the thread this article is part of. ;; The Lisp setup may involve setting a few variables and setting up the ;; search engine. You can define the variables in the server definition @@ -162,33 +162,53 @@ ;; `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 + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (require 'nnoo) (require 'gnus-group) -(require 'gnus-sum) (require 'message) (require 'gnus-util) (eval-when-compile (require 'cl)) +;;; Internal Variables: -(eval-when-compile - (autoload 'nnimap-buffer "nnimap") - (autoload 'nnimap-command "nnimap") - (autoload 'nnimap-possibly-change-group "nnimap")) +(defvar nnir-current-query nil + "Internal: stores current query (= group name).") -(nnoo-declare nnir) -(nnoo-define-basics nnir) +(defvar nnir-current-server nil + "Internal: stores current server (does it ever change?).") -(gnus-declare-backend "nnir" 'mail) +(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" . "")) + '(("whole message" . "TEXT") + ("subject" . "SUBJECT") + ("to" . "TO") + ("from" . "FROM") + ("body" . "BODY") + ("imap" . "")) "Mapping from user readable keys to IMAP search items for use in nnir") (defvar nnir-imap-search-other "HEADER %S" @@ -199,113 +219,135 @@ (defvar nnir-imap-search-argument-history () "The history for querying search options in nnir") -(defvar nnir-search-history () - "The history for querying search options in nnir") +;;; Helper macros -(defvar nnir-get-article-nov-override-function nil - "If non-nil, a function that will be passed each search result. This -should return a message's headers in NOV format. +;; Data type article list. -If this variable is nil, or if the provided function returns nil for a search -result, `gnus-retrieve-headers' will be called instead.") +(defmacro nnir-artlist-length (artlist) + "Returns number of articles in artlist." + `(length ,artlist)) -;;; Developer Extension Variable: +(defmacro nnir-artlist-article (artlist n) + "Returns from ARTLIST the Nth artitem (counting starting at 1)." + `(when (> ,n 0) + (elt ,artlist (1- ,n)))) -(defcustom nnir-search-engine 'wais - "*The search engine to use. Must be a symbol. -See `nnir-engines' for a list of supported engines, and for example -settings of `nnir-search-engine'." - :type '(sexp) - :group 'nnir) +(defmacro nnir-artitem-group (artitem) + "Returns the group from the ARTITEM." + `(elt ,artitem 0)) -(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) - :group 'nnir) +(defmacro nnir-artitem-number (artitem) + "Returns the number from the ARTITEM." + `(elt ,artitem 1)) -(defvar nnir-engines - `((wais nnir-run-waissearch - ()) - (imap nnir-run-imap - ((criteria - "Imap Search in" ; Prompt - ,(mapcar 'car nnir-imap-search-arguments) ; alist for completing - nil ; allow any user input - nil ; initial value - nnir-imap-search-argument-history ; the history to use - ,nnir-imap-default-search-key ; default - ))) - (gmane nnir-run-gmane - ((author . "Gmane Author: "))) - (swish++ nnir-run-swish++ - ((group . "Swish++ Group spec: "))) - (swish-e nnir-run-swish-e - ((group . "Swish-e Group spec: "))) - (namazu nnir-run-namazu - ()) - (hyrex nnir-run-hyrex - ((group . "Hyrex Group spec: "))) - (find-grep nnir-run-find-grep - ((grep-options . "Grep options: ")))) - "Alist of supported search engines. -Each element in the alist is a three-element list (ENGINE FUNCTION ARGS). -ENGINE is a symbol designating the searching engine. FUNCTION is also -a symbol, giving the function that does the search. The third element -ARGS is a list of cons pairs (PARAM . PROMPT). When issuing a query, -the FUNCTION will issue a query for each of the PARAMs, using PROMPT. +(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: -The value of `nnir-search-engine' must be one of the ENGINE symbols. -For example, for searching a server using namazu include - (nnir-search-engine namazu) -in the server definition. Note that you have to set additional -variables for most backends. For example, the `namazu' backend -needs the variables `nnir-namazu-program', -`nnir-namazu-index-directory' and `nnir-namazu-remove-prefix'. +(require 'gnus-sum) + +(eval-when-compile + (autoload 'nnimap-buffer "nnimap") + (autoload 'nnimap-command "nnimap") + (autoload 'nnimap-possibly-change-group "nnimap") + (autoload 'nnimap-make-thread-query "nnimap") + (autoload 'gnus-registry-action "gnus-registry")) + +(nnoo-declare nnir) +(nnoo-define-basics nnir) + +(defvoo nnir-address nil + "The address of the nnir server.") + +(gnus-declare-backend "nnir" 'mail) -Add an entry here when adding a new search engine.") ;;; User Customizable Variables: (defgroup nnir nil - "Search groups in Gnus with assorted seach engines." + "Search groups in Gnus with assorted search engines." :group 'gnus) -(defcustom nnir-method-default-engines - '((nnimap . imap) - (nntp . gmane)) - "*Alist of default search engines keyed by server method" - :type '(alist) +(defcustom nnir-ignored-newsgroups "" + "*A regexp to match newsgroups in the active file that should + be skipped when searching." + :version "24.1" + :type '(regexp) :group 'nnir) -(defcustom nnir-wais-program "waissearch" - "*Name of waissearch executable." +(defcustom nnir-summary-line-format nil + "*The format specification of the lines in an nnir summary buffer. + +All the items from `gnus-summary-line-format' are available, along +with three items unique to nnir summary buffers: + +%Z Search retrieval score value (integer) +%G Article original full group name (string) +%g Article original short group name (string) + +If nil this will use `gnus-summary-line-format'." + :version "24.1" :type '(string) :group 'nnir) -(defcustom nnir-wais-database (expand-file-name "~/.wais/mail") - "*Name of Wais database containing the mail. +(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. -Note that this should be a file name without extension. For example, -if you have a file /home/john/.wais/mail.fmt, use this: - (setq nnir-wais-database \"/home/john/.wais/mail\") -The string given here is passed to `waissearch -d' as-is." - :type '(file) +If this variable is nil, or if the provided function returns nil for a search +result, `gnus-retrieve-headers' will be called instead." + :version "24.1" + :type '(function) :group 'nnir) -(defcustom nnir-wais-remove-prefix (concat (getenv "HOME") "/Mail/") - "*The prefix to remove from each directory name returned by waissearch -in order to get a group name (albeit with / instead of .). This is a -regular expression. - -For example, suppose that Wais returns file names such as -\"/home/john/Mail/mail/misc/42\". For this example, use the following -setting: (setq nnir-wais-remove-prefix \"/home/john/Mail/\") -Note the trailing slash. Removing this prefix gives \"mail/misc/42\". -`nnir' knows to remove the \"/42\" and to replace \"/\" with \".\" to -arrive at the correct group name, \"mail.misc\"." - :type '(regexp) +(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\"." + :version "24.1" + :type `(choice ,@(mapcar (lambda (elem) (list 'const (car elem))) + nnir-imap-search-arguments)) :group 'nnir) (defcustom nnir-swish++-configuration-file @@ -463,101 +505,115 @@ arrive at the correct group name, \"mail.misc\"." :type '(directory) :group 'nnir) -;;; Internal Variables: +(defcustom nnir-notmuch-program "notmuch" + "*Name of notmuch search executable." + :version "24.1" + :type '(string) + :group 'nnir) -(defvar nnir-current-query nil - "Internal: stores current query (= group name).") +(defcustom nnir-notmuch-additional-switches '() + "*A list of strings, to be given as additional arguments to notmuch. -(defvar nnir-current-server nil - "Internal: stores current server (does it ever change?).") +Note that this should be a list. Ie, do NOT use the following: + (setq nnir-notmuch-additional-switches \"-i -w\") ; wrong +Instead, use this: + (setq nnir-notmuch-additional-switches '(\"-i\" \"-w\"))" + :version "24.1" + :type '(repeat (string)) + :group 'nnir) -(defvar nnir-current-group-marked nil - "Internal: stores current list of process-marked groups.") +(defcustom nnir-notmuch-remove-prefix (concat (getenv "HOME") "/Mail/") + "*The prefix to remove from each file name returned by notmuch +in order to get a group name (albeit with / instead of .). This is a +regular expression. -(defvar nnir-artlist nil - "Internal: stores search result.") +This variable is very similar to `nnir-namazu-remove-prefix', except +that it is for notmuch, not Namazu." + :version "24.1" + :type '(regexp) + :group 'nnir) -(defvar nnir-tmp-buffer " *nnir*" - "Internal: temporary buffer.") +;;; Developer Extension Variable: -(defvar nnir-extra-parms nil - "Internal: stores request for extra search parms") +(defvar nnir-engines + `((imap nnir-run-imap + ((criteria + "Imap Search in" ; Prompt + ,(mapcar 'car nnir-imap-search-arguments) ; alist for completing + nil ; allow any user input + nil ; initial value + nnir-imap-search-argument-history ; the history to use + ,nnir-imap-default-search-key ; default + ))) + (gmane nnir-run-gmane + ((author . "Gmane Author: "))) + (swish++ nnir-run-swish++ + ((group . "Swish++ Group spec: "))) + (swish-e nnir-run-swish-e + ((group . "Swish-e Group spec: "))) + (namazu nnir-run-namazu + ()) + (notmuch nnir-run-notmuch + ()) + (hyrex nnir-run-hyrex + ((group . "Hyrex Group spec: "))) + (find-grep nnir-run-find-grep + ((grep-options . "Grep options: ")))) + "Alist of supported search engines. +Each element in the alist is a three-element list (ENGINE FUNCTION ARGS). +ENGINE is a symbol designating the searching engine. FUNCTION is also +a symbol, giving the function that does the search. The third element +ARGS is a list of cons pairs (PARAM . PROMPT). When issuing a query, +the FUNCTION will issue a query for each of the PARAMs, using PROMPT. -;;; Code: +The value of `nnir-search-engine' must be one of the ENGINE symbols. +For example, for searching a server using namazu include + (nnir-search-engine namazu) +in the server definition. Note that you have to set additional +variables for most backends. For example, the `namazu' backend +needs the variables `nnir-namazu-program', +`nnir-namazu-index-directory' and `nnir-namazu-remove-prefix'. + +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." + :version "24.1" + :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. -(defun gnus-group-make-nnir-group (nnir-extra-parms) +(defun gnus-group-make-nnir-group (nnir-extra-parms &optional parms) "Create an nnir group. Asks for query." (interactive "P") (setq nnir-current-query nil nnir-current-server nil nnir-current-group-marked nil nnir-artlist nil) - (let* ((query (read-string "Query: " nil 'nnir-search-history)) - (parms (list (cons 'query query)))) - (add-to-list 'parms (cons 'unique-id (message-unique-id)) t) + (let* ((query (unless parms (read-string "Query: " nil 'nnir-search-history))) + (parms (or parms (list (cons 'query query)))) + (srv (or (cdr (assq 'server parms)) (gnus-server-server-name) "nnir"))) + (add-to-list 'parms (cons 'unique-id (message-unique-id)) t) (gnus-group-read-ephemeral-group - (concat "nnir:" (prin1-to-string parms)) '(nnir "") t + (concat "nnir:" (prin1-to-string parms)) (list 'nnir srv) t (cons (current-buffer) gnus-current-window-configuration) nil))) -;; Summary mode commands. - -(defun gnus-summary-nnir-goto-thread () - "Only applies to nnir groups. Go to group this article came from -and show thread that contains this article." - (interactive) - (unless (eq 'nnir (car (gnus-find-method-for-group gnus-newsgroup-name))) - (error "Can't execute this command unless in nnir group")) - (let* ((cur (gnus-summary-article-number)) - (group (nnir-artlist-artitem-group nnir-artlist cur)) - (backend-number (nnir-artlist-artitem-number nnir-artlist cur)) - (id (mail-header-id (gnus-summary-article-header))) - (refs (split-string - (mail-header-references (gnus-summary-article-header))))) - (if (eq (car (gnus-find-method-for-group group)) 'nnimap) - (progn - (nnimap-possibly-change-group (gnus-group-short-name group) nil) - (with-current-buffer (nnimap-buffer) - (let* ((cmd - (let ((value - (format - "(OR HEADER REFERENCES %s HEADER Message-Id %s)" - id id))) - (dolist (refid refs value) - (setq value - (format - "(OR (OR HEADER Message-Id %s HEADER REFERENCES %s) %s)" - refid refid value))))) - (result (nnimap-command "UID SEARCH %s" cmd))) - (gnus-summary-read-group-1 - group t t gnus-summary-buffer nil - (and (car result) - (delete 0 (mapcar - #'string-to-number - (cdr (assoc "SEARCH" (cdr result)))))))))) - (gnus-summary-read-group-1 group t t gnus-summary-buffer - nil (list backend-number)) - (gnus-summary-limit (list backend-number)) - (gnus-summary-refer-thread)))) - - -(if (fboundp 'eval-after-load) - (eval-after-load "gnus-sum" - '(define-key gnus-summary-goto-map - "T" 'gnus-summary-nnir-goto-thread)) - (add-hook 'gnus-summary-mode-hook - (function (lambda () - (define-key gnus-summary-goto-map - "T" 'gnus-summary-nnir-goto-thread))))) - - ;; Gnus backend interface functions. (deffoo nnir-open-server (server &optional definitions) ;; Just set the server variables appropriately. + (add-hook 'gnus-summary-mode-hook 'nnir-mode) (nnoo-change-server 'nnir server definitions)) (deffoo nnir-request-group (group &optional server fast info) @@ -585,86 +641,151 @@ and show thread that contains this article." group)))) ; group name (deffoo nnir-retrieve-headers (articles &optional group server fetch-old) - (save-excursion - (let ((artlist (copy-sequence articles)) - art artitem artgroup artno artrsv artfullgroup - novitem novdata foo server) - (while (not (null artlist)) - (setq art (car artlist)) - (or (numberp art) - (nnheader-report - 'nnir - "nnir-retrieve-headers doesn't grok message ids: %s" - art)) - (setq artitem (nnir-artlist-article nnir-artlist art)) - (setq artrsv (nnir-artitem-rsv artitem)) - (setq artfullgroup (nnir-artitem-group artitem)) - (setq artno (nnir-artitem-number artitem)) - (setq artgroup (gnus-group-real-name artfullgroup)) - (setq server (gnus-group-server artfullgroup)) - ;; retrieve NOV or HEAD data for this article, transform into - ;; NOV data and prepend to `novdata' - (set-buffer nntp-server-buffer) - (nnir-possibly-change-server server) - (let ((gnus-override-method - (gnus-server-to-method server))) - ;; if nnir-get-article-nov-override-function is set, use it - (if nnir-get-article-nov-override-function - (setq novitem (funcall nnir-get-article-nov-override-function - artitem)) - ;; else, set novitem through nnheader-parse-nov/nnheader-parse-head - (case (setq foo (gnus-retrieve-headers (list artno) - artfullgroup nil)) - (nov - (goto-char (point-min)) - (setq novitem (nnheader-parse-nov))) - (headers - (goto-char (point-min)) - (setq novitem (nnheader-parse-head))) - (t (error "Unknown header type %s while requesting article %s of group %s" - foo artno artfullgroup))))) - ;; replace article number in original group with article number - ;; in nnir group - (when novitem - (mail-header-set-number novitem art) - (mail-header-set-from novitem - (mail-header-from novitem)) - (mail-header-set-subject - novitem - (format "[%d: %s/%d] %s" - artrsv artgroup artno - (mail-header-subject novitem))) - (push novitem novdata) - (setq artlist (cdr artlist)))) - (setq novdata (nreverse novdata)) - (set-buffer nntp-server-buffer) (erase-buffer) - (mapc 'nnheader-insert-nov novdata) + (with-current-buffer nntp-server-buffer + (let ((gnus-inhibit-demon t) + (articles-by-group (nnir-categorize + articles nnir-article-group nnir-article-ids)) + headers) + (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) '<)) + (server (gnus-group-server artgroup)) + (gnus-override-method (gnus-server-to-method server)) + parsefunc) + ;; (or (numberp art) + ;; (nnheader-report + ;; 'nnir + ;; "nnir-retrieve-headers doesn't grok message ids: %s" + ;; art)) + (nnir-possibly-change-server server) + ;; is this needed? + (erase-buffer) + (case (setq gnus-headers-retrieved-by + (or + (and + nnir-retrieve-headers-override-function + (funcall nnir-retrieve-headers-override-function + artlist artgroup)) + (gnus-retrieve-headers artlist artgroup nil))) + (nov + (setq parsefunc 'nnheader-parse-nov)) + (headers + (setq parsefunc 'nnheader-parse-head)) + (t (error "Unknown header type %s while requesting articles \ + of group %s" gnus-headers-retrieved-by artgroup))) + (goto-char (point-min)) + (while (not (eobp)) + (let* ((novitem (funcall parsefunc)) + (artno (and novitem + (mail-header-number novitem))) + (art (car (rassq artno articleids)))) + (when art + (mail-header-set-number novitem art) + (push novitem headers)) + (forward-line 1))))) + (setq headers + (sort headers + (lambda (x y) + (< (mail-header-number x) (mail-header-number y))))) + (erase-buffer) + (mapc 'nnheader-insert-nov headers) 'nov))) -(deffoo nnir-request-article (article - &optional group server to-buffer) - (if (stringp article) +(deffoo nnir-request-article (article &optional group server to-buffer) + (if (and (stringp article) + (not (eq 'nnimap (car (gnus-server-to-method server))))) (nnheader-report 'nnir - "nnir-retrieve-headers doesn't grok message ids: %s" - article) + "nnir-request-article only groks message ids for nnimap servers: %s" + server) (save-excursion - (let* ((artitem (nnir-artlist-article nnir-artlist - article)) - (artfullgroup (nnir-artitem-group artitem)) - (artno (nnir-artitem-number artitem)) - ;; 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) - (message "Requesting article %d from group %s" - artno artfullgroup) - (gnus-request-article artno artfullgroup nntp-server-buffer) - (cons artfullgroup artno))))) - + (let ((article article) + query) + (when (stringp article) + (setq gnus-override-method (gnus-server-to-method server)) + (setq query + (list + (cons 'query (format "HEADER Message-ID %s" article)) + (cons 'unique-id article) + (cons 'criteria "") + (cons 'shortcut t))) + (unless (and (equal query nnir-current-query) + (equal server nnir-current-server)) + (setq nnir-artlist (nnir-run-imap query server)) + (setq nnir-current-query query) + (setq nnir-current-server server)) + (setq article 1)) + (unless (zerop (length nnir-artlist)) + (let ((artfullgroup (nnir-article-group article)) + (artno (nnir-article-number article))) + (message "Requesting article %d from group %s" + artno artfullgroup) + (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 + &optional last internal-move-group) + (let* ((artfullgroup (nnir-article-group article)) + (artno (nnir-article-number article)) + (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))) + (unless (gnus-check-backend-function + 'request-move-article artfullgroup) + (error "The group %s does not support article moving" artfullgroup)) + (gnus-request-move-article + artno + artfullgroup + (nth 1 from-method) + accept-form + last + (and move-is-internal + 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) + (error "This is not a real article"))) + (backend-article-group (nnir-article-group cur)) + (backend-article-number (nnir-article-number cur)) + (quit-config (gnus-ephemeral-group-p gnus-newsgroup-name))) + ;; first exit from the nnir summary buffer. + (gnus-summary-exit) + ;; and if the nnir summary buffer in turn came from another + ;; summary buffer we have to clean that summary up too. + (when (eq (cdr quit-config) 'summary) + (gnus-summary-exit)) + (gnus-summary-read-group-1 backend-article-group t t nil + nil (list backend-article-number)))) (nnoo-define-skeleton nnir) @@ -692,7 +813,7 @@ ready to be added to the list of search results." ;; remove trailing slash and, for nnmaildir, cur/new/tmp (setq dirnam (substring dirnam 0 - (if (string= (gnus-group-server server) "nnmaildir") + (if (string-match "^nnmaildir:" (gnus-group-server server)) -5 -1))) ;; Set group to dirnam without any leading dots or slashes, @@ -701,8 +822,8 @@ ready to be added to the list of search results." (gnus-replace-in-string dirnam "^[./\\]" "" t) "[/\\]" "." t))) - (vector (nnir-group-full-name group server) - (if (string= (gnus-group-server server) "nnmaildir") + (vector (gnus-group-full-name group server) + (if (string-match "^nnmaildir:" (gnus-group-server server)) (nnmaildir-base-name-to-article-number (substring article 0 (string-match ":" article)) group nil) @@ -711,56 +832,11 @@ ready to be added to the list of search results." ;;; Search Engine Interfaces: -;; freeWAIS-sf interface. -(defun nnir-run-waissearch (query server &optional group) - "Run given query agains waissearch. Returns vector of (group name, file name) -pairs (also vectors, actually)." - ;; (when group - ;; (error "The freeWAIS-sf backend cannot search specific groups")) - (save-excursion - (let ((qstring (cdr (assq 'query query))) - (prefix (nnir-read-server-parm 'nnir-wais-remove-prefix server)) - artlist score artno dirnam) - (set-buffer (get-buffer-create nnir-tmp-buffer)) - (erase-buffer) - (message "Doing WAIS query %s..." query) - (call-process nnir-wais-program - nil ; input from /dev/null - t ; output to current buffer - nil ; don't redisplay - "-d" (nnir-read-server-parm 'nnir-wais-database server) ; database to search - qstring) - (message "Massaging waissearch output...") - ;; remove superfluous lines - (keep-lines "Score:") - ;; extract data from result lines - (goto-char (point-min)) - (while (re-search-forward - "Score: +\\([0-9]+\\).*'\\([0-9]+\\) +\\([^']+\\)/'" nil t) - (setq score (match-string 1) - artno (match-string 2) - dirnam (match-string 3)) - (unless (string-match prefix dirnam) - (nnheader-report 'nnir "Dir name %s doesn't contain prefix %s" - dirnam prefix)) - (setq group (gnus-replace-in-string - (replace-match "" t t dirnam) "/" ".")) - (push (vector (nnir-group-full-name group server) - (string-to-number artno) - (string-to-number score)) - artlist)) - (message "Massaging waissearch output...done") - (apply 'vector - (sort artlist - (function (lambda (x y) - (> (nnir-artitem-rsv x) - (nnir-artitem-rsv y))))))))) - ;; imap interface (defun nnir-run-imap (query srv &optional groups) "Run a search against an IMAP back-end server. This uses a custom query language parser; see `nnir-imap-make-query' for -details on the language and supported extensions" +details on the language and supported extensions." (save-excursion (let ((qstring (cdr (assq 'query query))) (server (cadr (gnus-server-to-method srv))) @@ -769,36 +845,40 @@ details on the language and supported extensions" (cdr (assoc nnir-imap-default-search-key nnir-imap-search-arguments)))) (gnus-inhibit-demon t) - artlist) + (groups (or groups (nnir-get-active srv)))) (message "Opening server %s" server) (apply 'vconcat - (mapcar - (lambda (x) - (let ((group x)) - (condition-case () - (when (nnimap-possibly-change-group - (gnus-group-short-name group) server) - (with-current-buffer (nnimap-buffer) - (message "Searching %s..." group) - (let ((arts 0) - (result (nnimap-command "UID SEARCH %s" - (if (string= criteria "") - qstring - (nnir-imap-make-query - criteria qstring))))) - (mapc - (lambda (artnum) (push (vector group artnum 1) artlist) - (setq arts (1+ arts))) - (and (car result) - (delete 0 (mapcar #'string-to-number - (cdr (assoc "SEARCH" - (cdr result))))))) - (message "Searching %s... %d matches" group arts))) - (message "Searching %s...done" group)) - (quit nil)) - (reverse artlist))) - groups))))) + (catch 'found + (mapcar + (lambda (group) + (let (artlist) + (condition-case () + (when (nnimap-possibly-change-group + (gnus-group-short-name group) server) + (with-current-buffer (nnimap-buffer) + (message "Searching %s..." group) + (let ((arts 0) + (result (nnimap-command "UID SEARCH %s" + (if (string= criteria "") + qstring + (nnir-imap-make-query + criteria qstring))))) + (mapc + (lambda (artnum) + (let ((artn (string-to-number artnum))) + (when (> artn 0) + (push (vector group artn 100) + artlist) + (when (assq 'shortcut query) + (throw 'found (list 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)) + (nreverse artlist))) + groups)))))) (defun nnir-imap-make-query (criteria qstring) "Parse the query string and criteria into an appropriate IMAP search @@ -1000,7 +1080,8 @@ Windows NT 4.0." ;; is sufficient. Note that we can't only use the value of ;; nnml-use-compressed-files because old articles might have been ;; saved with a different value. - (article-pattern (if (string= (gnus-group-server server) "nnmaildir") + (article-pattern (if (string-match "^nnmaildir:" + (gnus-group-server server)) ":[0-9]+" "^[0-9]+\\(\\.[a-z0-9]+\\)?$")) score artno dirnam filenam) @@ -1148,7 +1229,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." ;; Windows "\\" -> "." (setq group (gnus-replace-in-string group "\\\\" ".")) - (push (vector (nnir-group-full-name group server) + (push (vector (gnus-group-full-name group server) (string-to-number artno) (string-to-number score)) artlist)))) @@ -1197,12 +1278,12 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." ;; nnir-search failure reason is in this buffer, show it if ;; the user wants it. (when (> gnus-verbose 6) - (display-buffer nnir-tmp-buffer)))) ;; FIXME: Dont clear buffer ! + (display-buffer nnir-tmp-buffer)))) ;; FIXME: Don't clear buffer ! (message "Doing hyrex-search query \"%s\"...done" qstring) (sit-for 0) ;; nnir-search returns: - ;; for nnml/nnfolder: "filename mailid weigth" - ;; for nnimap: "group mailid weigth" + ;; for nnml/nnfolder: "filename mailid weight" + ;; for nnimap: "group mailid weight" (goto-char (point-min)) (delete-non-matching-lines "^\\S + [0-9]+ [0-9]+$") ;; HyREX doesn't search directly in groups -- so filter out here. @@ -1217,7 +1298,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." score (match-string 3)) (when (string-match prefix dirnam) (setq dirnam (replace-match "" t t dirnam))) - (push (vector (nnir-group-full-name + (push (vector (gnus-group-full-name (gnus-replace-in-string dirnam "/" ".") server) (string-to-number artno) (string-to-number score)) @@ -1242,7 +1323,8 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." ;; (when group ;; (error "The Namazu backend cannot search specific groups")) (save-excursion - (let ((article-pattern (if (string= (gnus-group-server server) "nnmaildir") + (let ((article-pattern (if (string-match "^nnmaildir:" + (gnus-group-server server)) ":[0-9]+" "^[0-9]+$")) artlist @@ -1302,6 +1384,81 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." (> (nnir-artitem-rsv x) (nnir-artitem-rsv y))))))))) +(defun nnir-run-notmuch (query server &optional group) + "Run QUERY against notmuch. +Returns a vector of (group name, file name) pairs (also vectors, +actually)." + + ;; (when group + ;; (error "The notmuch backend cannot search specific groups")) + + (save-excursion + (let ( (qstring (cdr (assq 'query query))) + (groupspec (cdr (assq 'group query))) + (prefix (nnir-read-server-parm 'nnir-notmuch-remove-prefix server)) + artlist + (article-pattern (if (string-match "^nnmaildir:" + (gnus-group-server server)) + ":[0-9]+" + "^[0-9]+$")) + artno dirnam filenam) + + (when (equal "" qstring) + (error "notmuch: You didn't enter anything")) + + (set-buffer (get-buffer-create nnir-tmp-buffer)) + (erase-buffer) + + (if groupspec + (message "Doing notmuch query %s on %s..." qstring groupspec) + (message "Doing notmuch query %s..." qstring)) + + (let* ((cp-list `( ,nnir-notmuch-program + nil ; input from /dev/null + t ; output + nil ; don't redisplay + "search" + "--format=text" + "--output=files" + ,@(nnir-read-server-parm 'nnir-notmuch-additional-switches server) + ,qstring ; the query, in notmuch format + )) + (exitstatus + (progn + (message "%s args: %s" nnir-notmuch-program + (mapconcat 'identity (cddddr cp-list) " ")) ;; ??? + (apply 'call-process cp-list)))) + (unless (or (null exitstatus) + (zerop exitstatus)) + (nnheader-report 'nnir "Couldn't run notmuch: %s" exitstatus) + ;; notmuch failure reason is in this buffer, show it if + ;; the user wants it. + (when (> gnus-verbose 6) + (display-buffer nnir-tmp-buffer)))) + + ;; The results are output in the format of: + ;; absolute-path-name + (goto-char (point-min)) + (while (not (eobp)) + (setq filenam (buffer-substring-no-properties (line-beginning-position) + (line-end-position)) + artno (file-name-nondirectory filenam) + dirnam (file-name-directory filenam)) + (forward-line 1) + + ;; don't match directories + (when (string-match article-pattern artno) + (when (not (null dirnam)) + + ;; maybe limit results to matching groups. + (when (or (not groupspec) + (string-match groupspec dirnam)) + (nnir-add-result dirnam artno "" prefix server artlist))))) + + (message "Massaging notmuch output...done") + + artlist))) + (defun nnir-run-find-grep (query server &optional grouplist) "Run find and grep to obtain matching articles." (let* ((method (gnus-server-to-method server)) @@ -1310,6 +1467,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." (directory (cadr (assoc sym (cddr method)))) (regexp (cdr (assoc 'query query))) (grep-options (cdr (assoc 'grep-options query))) + (grouplist (or grouplist (nnir-get-active server))) artlist) (unless directory (error "No directory found in method specification of server %s" @@ -1375,7 +1533,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." (nreverse res)) "."))) (push - (vector (nnir-group-full-name group server) art 0) + (vector (gnus-group-full-name group server) art 0) artlist)) (forward-line 1))) (message "Searching %s using find-grep...done" @@ -1383,26 +1541,30 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." artlist))) grouplist)))) +(declare-function mm-url-insert "mm-url" (url &optional follow-refresh)) +(declare-function mm-url-encode-www-form-urlencoded "mm-url" (pairs)) + ;; gmane interface (defun nnir-run-gmane (query srv &optional groups) "Run a search against a gmane back-end server." - (if (string-match-p "gmane" srv) (let* ((case-fold-search t) (qstring (cdr (assq 'query query))) (server (cadr (gnus-server-to-method srv))) - (groupspec (if groups - (mapconcat - (function (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))) "")) (search (format "%s %s %s" qstring groupspec authorspec)) + (gnus-inhibit-demon t) artlist) - (with-current-buffer nntp-server-buffer + (require 'mm-url) + (with-current-buffer (get-buffer-create nnir-tmp-buffer) (erase-buffer) (mm-url-insert (concat @@ -1418,23 +1580,24 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." (while (not (eobp)) (unless (or (eolp) (looking-at "\x0d")) (let ((header (nnheader-parse-nov))) - (let ((xref (mail-header-xref header))) + (let ((xref (mail-header-xref header)) + (xscore (string-to-number (cdr (assoc 'X-Score + (mail-header-extra header)))))) (when (string-match " \\([^:]+\\)[:/]\\([0-9]+\\)" xref) (push (vector (gnus-group-prefixed-name (match-string 1 xref) srv) - (string-to-number (match-string 2 xref)) 1) + (string-to-number (match-string 2 xref)) xscore) artlist))))) (forward-line 1))) - (reverse artlist)) - (message "Can't search non-gmane nntp groups"))) + (apply 'vector (nreverse (mm-delete-duplicates artlist))))) ;;; Util Code: -(defun nnir-read-parms (query) +(defun nnir-read-parms (query nnir-search-engine) "Reads additional search parameters according to `nnir-engines'." (let ((parmspec (caddr (assoc nnir-search-engine nnir-engines)))) - (nconc query + (append query (mapcar 'nnir-read-parm parmspec)))) (defun nnir-read-parm (parmspec) @@ -1449,87 +1612,74 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." (cons sym (format (cdr mapping) result))) (cons sym (read-string prompt))))) +(autoload 'gnus-group-topic-name "gnus-topic") + (defun nnir-run-query (query) "Invoke appropriate search engine function (see `nnir-engines'). If some groups were process-marked, run the query for each of the groups and concat the results." (let ((q (car (read-from-string query))) - (groups (nnir-sort-groups-by-server - (or gnus-group-marked (list (gnus-group-group-name)))))) + (groups (if (not (string= "nnir" nnir-address)) + (list (list nnir-address)) + (nnir-categorize + (or gnus-group-marked + (if (gnus-group-group-name) + (list (gnus-group-group-name)) + (cdr (assoc (gnus-group-topic-name) + gnus-topic-alist)))) + gnus-group-server)))) (apply 'vconcat - (mapcar (lambda (x) - (let* ((server (car x)) - (nnir-search-engine - (or (nnir-read-server-parm 'nnir-search-engine - server) - (cdr (assoc (car - (gnus-server-to-method server)) - nnir-method-default-engines)))) - search-func) - (setq search-func (cadr - (assoc nnir-search-engine - nnir-engines))) - (if search-func - (funcall search-func - (if nnir-extra-parms - (nnir-read-parms q) - q) - server (cdr x)) - nil))) - groups)))) - -(defun nnir-read-server-parm (key server) - "Returns the parameter value of key for the given server, where -server is of form 'backend:name'." + (mapcar + (lambda (x) + (let* ((server (car x)) + (nnir-search-engine + (or (nnir-read-server-parm 'nnir-search-engine + server t) + (cdr (assoc (car + (gnus-server-to-method server)) + nnir-method-default-engines)))) + search-func) + (setq search-func (cadr (assoc nnir-search-engine + nnir-engines))) + (if search-func + (funcall + search-func + (if nnir-extra-parms + (or (and (eq nnir-search-engine 'imap) + (assq 'criteria q) q) + (setq q (nnir-read-parms q nnir-search-engine))) + q) + server (cadr x)) + nil))) + groups)))) + +(defun nnir-read-server-parm (key server &optional not-global) + "Returns the parameter value corresponding to `key' for +`server'. If no server-specific value is found consult the global +environment unless `not-global' is non-nil." (let ((method (gnus-server-to-method server))) (cond ((and method (assq key (cddr method))) - (nth 1 (assq key (cddr method)))) - (t nil)))) + (nth 1 (assq key (cddr method)))) + ((and (not not-global) (boundp key)) (symbol-value key)) + (t nil)))) -(defun nnir-group-full-name (shortname server) - "For the given group name, return a full Gnus group name. -The Gnus backend/server information is added." - (gnus-group-prefixed-name shortname (gnus-server-to-method server))) (defun nnir-possibly-change-server (server) (unless (and server (nnir-server-opened server)) (nnir-open-server server))) -;; Data type article list. - -(defun nnir-artlist-length (artlist) - "Returns number of articles in artlist." - (length artlist)) - -(defun nnir-artlist-article (artlist n) - "Returns from ARTLIST the Nth artitem (counting starting at 1)." - (elt artlist (1- n))) - -(defun nnir-artitem-group (artitem) - "Returns the group from the ARTITEM." - (elt artitem 0)) - -(defun nnir-artlist-artitem-group (artlist n) - "Returns from ARTLIST the group of the Nth artitem (counting from 1)." - (nnir-artitem-group (nnir-artlist-article artlist n))) - -(defun nnir-artitem-number (artitem) - "Returns the number from the ARTITEM." - (elt artitem 1)) - -(defun nnir-artlist-artitem-number (artlist n) - "Returns from ARTLIST the number of the Nth artitem (counting from 1)." - (nnir-artitem-number (nnir-artlist-article artlist n))) - -(defun nnir-artitem-rsv (artitem) - "Returns the Retrieval Status Value (RSV, score) from the ARTITEM." - (elt artitem 2)) - -(defun nnir-artlist-artitem-rsv (artlist n) - "Returns from ARTLIST the Retrieval Status Value of the Nth -artitem (counting from 1)." - (nnir-artitem-rsv (nnir-artlist-article artlist n))) +(defun nnir-search-thread (header) + "Make an nnir group based on the thread containing the article header" + (let ((parm (list + (cons 'query + (nnimap-make-thread-query header)) + (cons 'criteria "") + (cons 'server (gnus-method-to-server + (gnus-find-method-for-group + gnus-newsgroup-name)))))) + (gnus-group-make-nnir-group nil parm) + (gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header))))) ;; unused? (defun nnir-artlist-groups (artlist) @@ -1543,17 +1693,70 @@ artitem (counting from 1)." with-dups) res)) -(defun nnir-sort-groups-by-server (groups) - "sorts a list of groups into an alist keyed by server" -(if (car groups) - (let (value) - (dolist (var groups value) - (let ((server (gnus-group-server var))) - (if (assoc server value) - (nconc (cdr (assoc server value)) (list var)) - (push (cons (gnus-group-server var) (list var)) value)))) - value) - nil)) +(defun nnir-get-active (srv) + (let ((method (gnus-server-to-method srv)) + groups) + (gnus-request-list method) + (with-current-buffer nntp-server-buffer + (let ((cur (current-buffer)) + name) + (goto-char (point-min)) + (unless (or (null nnir-ignored-newsgroups) + (string= nnir-ignored-newsgroups "")) + (delete-matching-lines nnir-ignored-newsgroups)) + (if (eq (car method) 'nntp) + (while (not (eobp)) + (ignore-errors + (push (mm-string-as-unibyte + (gnus-group-full-name + (buffer-substring + (point) + (progn + (skip-chars-forward "^ \t") + (point))) method)) + groups)) + (forward-line)) + (while (not (eobp)) + (ignore-errors + (push (mm-string-as-unibyte + (if (eq (char-after) ?\") + (gnus-group-full-name (read cur) method) + (let ((p (point)) (name "")) + (skip-chars-forward "^ \t\\\\") + (setq name (buffer-substring p (point))) + (while (eq (char-after) ?\\) + (setq p (1+ (point))) + (forward-char 2) + (skip-chars-forward "^ \t\\\\") + (setq name (concat name (buffer-substring + p (point))))) + (gnus-group-full-name name method)))) + groups)) + (forward-line))))) + groups)) + +(defun nnir-registry-action (action data-header from &optional to method) + "Call `gnus-registry-action' with the original article group." + (gnus-registry-action + action + data-header + (nnir-article-group (mail-header-number data-header)) + to + method)) + +(defun nnir-mode () + (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)) + (when (gnus-bound-and-true-p 'gnus-registry-enabled) + (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)))) + + ;; The end. (provide 'nnir)