X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fnnir.el;h=d1ca0213ed968c5280824f97cb66971f4f1ea5da;hp=87377e6c6a9ee85de6b0a4c590ab62ebd37b725b;hb=31c28e438ad11d0e4dfa251bf705ef2d2b5ee972;hpb=47d02275b36aad454fe54173269a2c1f3cae8c5b diff --git a/lisp/nnir.el b/lisp/nnir.el index 87377e6c6..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: @@ -204,11 +203,12 @@ ;; 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" @@ -289,25 +289,28 @@ is `(valuefunc member)'." (autoload 'nnimap-buffer "nnimap") (autoload 'nnimap-command "nnimap") (autoload 'nnimap-possibly-change-group "nnimap") - (autoload 'gnus-registry-action "gnus-registry") - (defvar gnus-registry-install)) - + (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) ;;; 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-ignored-newsgroups "" "*A regexp to match newsgroups in the active file that should be skipped when searching." + :version "24.1" :type '(regexp) :group 'nnir) @@ -322,6 +325,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'." + :version "24.1" :type '(string) :group 'nnir) @@ -333,13 +337,15 @@ 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." + :version "24.1" :type '(function) :group 'nnir) -(defcustom nnir-imap-default-search-key "Whole message" +(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) @@ -499,6 +505,34 @@ arrive at the correct group name, \"mail.misc\"." :type '(directory) :group 'nnir) +(defcustom nnir-notmuch-program "notmuch" + "*Name of notmuch search executable." + :version "24.1" + :type '(string) + :group 'nnir) + +(defcustom nnir-notmuch-additional-switches '() + "*A list of strings, to be given as additional arguments to notmuch. + +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) + +(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. + +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) + ;;; Developer Extension Variable: (defvar nnir-engines @@ -519,6 +553,8 @@ arrive at the correct group name, \"mail.misc\"." ((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 @@ -544,6 +580,7 @@ Add an entry here when adding a new search engine.") '((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) @@ -555,18 +592,17 @@ Add an entry here when adding a new search engine.") ;; 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))) - (srv (if (gnus-server-server-name) - "all" ""))) - (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)) (list 'nnir srv) t (cons (current-buffer) gnus-current-window-configuration) @@ -590,7 +626,7 @@ Add an entry here when adding a new search engine.") (equal server nnir-current-server))) nnir-artlist ;; Cache miss. - (setq nnir-artlist (nnir-run-query group server))) + (setq nnir-artlist (nnir-run-query group))) (with-current-buffer nntp-server-buffer (setq nnir-current-query group) (when server (setq nnir-current-server server)) @@ -642,7 +678,8 @@ Add an entry here when adding a new search engine.") (goto-char (point-min)) (while (not (eobp)) (let* ((novitem (funcall parsefunc)) - (artno (mail-header-number novitem)) + (artno (and novitem + (mail-header-number novitem))) (art (car (rassq artno articleids)))) (when art (mail-header-set-number novitem art) @@ -657,22 +694,40 @@ Add an entry here when adding a new search engine.") 'nov))) (deffoo nnir-request-article (article &optional group server to-buffer) - (if (stringp article) + (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 ((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))))) + (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) @@ -719,11 +774,18 @@ Add an entry here when adding a new search engine.") (deffoo nnir-warp-to-article () (let* ((cur (if (> (gnus-summary-article-number) 0) (gnus-summary-article-number) - (error "This is not a real article."))) - (gnus-newsgroup-name (nnir-article-group cur)) - (backend-number (nnir-article-number cur))) - (gnus-summary-read-group-1 gnus-newsgroup-name t t gnus-summary-buffer - nil (list backend-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) @@ -751,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, @@ -761,7 +823,7 @@ ready to be added to the list of search results." "[/\\]" "." t))) (vector (gnus-group-full-name group server) - (if (string= (gnus-group-server server) "nnmaildir") + (if (string-match "^nnmaildir:" (gnus-group-server server)) (nnmaildir-base-name-to-article-number (substring article 0 (string-match ":" article)) group nil) @@ -774,7 +836,7 @@ ready to be added to the list of search results." (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))) @@ -787,33 +849,36 @@ details on the language and supported extensions" (message "Opening server %s" server) (apply 'vconcat - (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) - (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))))) + (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 @@ -1015,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) @@ -1212,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. @@ -1257,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 @@ -1317,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)) @@ -1472,14 +1614,13 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." (autoload 'gnus-group-topic-name "gnus-topic") -(defun nnir-run-query (query nserver) +(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 (if (string= "all-ephemeral" nserver) - (with-current-buffer gnus-server-buffer - (list (list (gnus-server-server-name)))) + (groups (if (not (string= "nnir" nnir-address)) + (list (list nnir-address)) (nnir-categorize (or gnus-group-marked (if (gnus-group-group-name) @@ -1493,7 +1634,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." (let* ((server (car x)) (nnir-search-engine (or (nnir-read-server-parm 'nnir-search-engine - server) + server t) (cdr (assoc (car (gnus-server-to-method server)) nnir-method-default-engines)))) @@ -1501,27 +1642,44 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." (setq search-func (cadr (assoc nnir-search-engine nnir-engines))) (if search-func - (funcall search-func - (if nnir-extra-parms - (nnir-read-parms q nnir-search-engine) - q) - server (cadr x)) + (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) - "Returns the parameter value of key for the given server, where -server is of form 'backend:name'." +(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-possibly-change-server (server) (unless (and server (nnir-server-opened server)) (nnir-open-server server))) +(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) @@ -1590,8 +1748,7 @@ 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)) - (when (and (boundp 'gnus-registry-install) - (eq gnus-registry-install t)) + (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)