cgit.sxemacs.org Git - gnus/blob - lisp/nnir.el

   1 ;;; nnir.el --- search mail with various search engines -*- coding: iso-8859-1 -*-
   2
   3 ;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
   4
   5 ;; Author: Kai Großjohann <grossjohann@ls6.cs.uni-dortmund.de>
   6 ;; Swish-e and Swish++ backends by:
   7 ;;   Christoph Conrad <christoph.conrad@gmx.de>.
   8 ;; IMAP backend by: Simon Josefsson <jas@pdc.kth.se>.
   9 ;; IMAP search by: Torsten Hilbrich <torsten.hilbrich <at> gmx.net>
  10 ;; IMAP search improved by Daniel Pittman  <daniel@rimspace.net>.
  11 ;; nnmaildir support for Swish++ and Namazu backends by:
  12 ;;   Justus Piater <Justus <at> Piater.name>
  13 ;; Keywords: news mail searching ir
  14
  15 ;; This file is part of GNU Emacs.
  16
  17 ;; GNU Emacs is free software: you can redistribute it and/or modify
  18 ;; it under the terms of the GNU General Public License as published by
  19 ;; the Free Software Foundation, either version 3 of the License, or
  20 ;; (at your option) any later version.
  21
  22 ;; GNU Emacs is distributed in the hope that it will be useful,
  23 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  24 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  25 ;; GNU General Public License for more details.
  26
  27 ;; You should have received a copy of the GNU General Public License
  28 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  29
  30 ;;; Commentary:
  31
  32 ;; TODO: Documentation in the Gnus manual
  33
  34 ;; Where in the existing gnus manual would this fit best?
  35
  36 ;; What does it do?  Well, it allows you to search your mail using
  37 ;; some search engine (imap, namazu, swish-e, gmane and others -- see
  38 ;; later) by typing `G G' in the Group buffer.  You will then get a
  39 ;; buffer which shows all articles matching the query, sorted by
  40 ;; Retrieval Status Value (score).
  41
  42 ;; When looking at the retrieval result (in the Summary buffer) you
  43 ;; can type `A W' (aka M-x gnus-warp-to-article RET) on an article.  You
  44 ;; will be warped into the group this article came from. Typing `A T'
  45 ;; (aka M-x gnus-summary-refer-thread RET) will warp to the group and
  46 ;; also show the thread this article is part of.
  47
  48 ;; The Lisp setup may involve setting a few variables and setting up the
  49 ;; search engine. You can define the variables in the server definition
  50 ;; like this :
  51 ;;   (setq gnus-secondary-select-methods '(
  52 ;;       (nnimap "" (nnimap-address "localhost")
  53 ;;                  (nnir-search-engine namazu)
  54 ;;       )))
  55 ;; The main variable to set is `nnir-search-engine'.  Choose one of
  56 ;; the engines listed in `nnir-engines'.  (Actually `nnir-engines' is
  57 ;; an alist, type `C-h v nnir-engines RET' for more information; this
  58 ;; includes examples for setting `nnir-search-engine', too.)
  59
  60 ;; If you use one of the local indices (namazu, find-grep, swish) you
  61 ;; must also set up a search engine backend.
  62
  63 ;; 1. Namazu
  64 ;;
  65 ;; The Namazu backend requires you to have one directory containing all
  66 ;; index files, this is controlled by the `nnir-namazu-index-directory'
  67 ;; variable.  To function the `nnir-namazu-remove-prefix' variable must
  68 ;; also be correct, see the documentation for `nnir-namazu-remove-prefix'
  69 ;; above.
  70 ;;
  71 ;; It is particularly important not to pass any any switches to namazu
  72 ;; that will change the output format.  Good switches to use include
  73 ;; `--sort', `--ascending', `--early' and `--late'.  Refer to the Namazu
  74 ;; documentation for further information on valid switches.
  75 ;;
  76 ;; To index my mail with the `mknmz' program I use the following
  77 ;; configuration file:
  78 ;;
  79 ;; ,----
  80 ;; | package conf;  # Don't remove this line!
  81 ;; |
  82 ;; | # Paths which will not be indexed. Don't use `^' or `$' anchors.
  83 ;; | $EXCLUDE_PATH = "spam|sent";
  84 ;; |
  85 ;; | # Header fields which should be searchable. case-insensitive
  86 ;; | $REMAIN_HEADER = "from|date|message-id|subject";
  87 ;; |
  88 ;; | # Searchable fields. case-insensitive
  89 ;; | $SEARCH_FIELD = "from|date|message-id|subject";
  90 ;; |
  91 ;; | # The max length of a word.
  92 ;; | $WORD_LENG_MAX = 128;
  93 ;; |
  94 ;; | # The max length of a field.
  95 ;; | $MAX_FIELD_LENGTH = 256;
  96 ;; `----
  97 ;;
  98 ;; My mail is stored in the directories ~/Mail/mail/, ~/Mail/lists/ and
  99 ;; ~/Mail/archive/, so to index them I go to the directory set in
 100 ;; `nnir-namazu-index-directory' and issue the following command.
 101 ;;
 102 ;;      mknmz --mailnews ~/Mail/archive/ ~/Mail/mail/ ~/Mail/lists/
 103 ;;
 104 ;; For maximum searching efficiency I have a cron job set to run this
 105 ;; command every four hours.
 106
 107 ;; 2. find-grep
 108 ;;
 109 ;; The find-grep engine simply runs find(1) to locate eligible
 110 ;; articles and searches them with grep(1).  This, of course, is much
 111 ;; slower than using a proper search engine but OTOH doesn't require
 112 ;; maintenance of an index and is still faster than using any built-in
 113 ;; means for searching.  The method specification of the server to
 114 ;; search must include a directory for this engine to work (E.g.,
 115 ;; `nnml-directory').  The tools must be POSIX compliant.  GNU Find
 116 ;; prior to version 4.2.12 (4.2.26 on Linux due to incorrect ARG_MAX
 117 ;; handling) does not work.
 118 ;; ,----
 119 ;; |    ;; find-grep configuration for searching the Gnus Cache
 120 ;; |
 121 ;; |    (nnml "cache"
 122 ;; |          (nnml-get-new-mail nil)
 123 ;; |          (nnir-search-engine find-grep)
 124 ;; |          (nnml-directory "~/News/cache/")
 125 ;; |          (nnml-active-file "~/News/cache/active"))
 126 ;; `----
 127
 128 ;; Developer information:
 129
 130 ;; I have tried to make the code expandable.  Basically, it is divided
 131 ;; into two layers.  The upper layer is somewhat like the `nnvirtual'
 132 ;; backend: given a specification of what articles to show from
 133 ;; another backend, it creates a group containing exactly those
 134 ;; articles.  The lower layer issues a query to a search engine and
 135 ;; produces such a specification of what articles to show from the
 136 ;; other backend.
 137
 138 ;; The interface between the two layers consists of the single
 139 ;; function `nnir-run-query', which just selects the appropriate
 140 ;; function for the search engine one is using.  The input to
 141 ;; `nnir-run-query' is a string, representing the query as input by
 142 ;; the user.  The output of `nnir-run-query' is supposed to be a
 143 ;; vector, each element of which should in turn be a three-element
 144 ;; vector.  The first element should be full group name of the article,
 145 ;; the second element should be the article number, and the third
 146 ;; element should be the Retrieval Status Value (RSV) as returned from
 147 ;; the search engine.  An RSV is the score assigned to the document by
 148 ;; the search engine.  For Boolean search engines, the
 149 ;; RSV is always 1000 (or 1 or 100, or whatever you like).
 150
 151 ;; The sorting order of the articles in the summary buffer created by
 152 ;; nnir is based on the order of the articles in the above mentioned
 153 ;; vector, so that's where you can do the sorting you'd like.  Maybe
 154 ;; it would be nice to have a way of displaying the search result
 155 ;; sorted differently?
 156
 157 ;; So what do you need to do when you want to add another search
 158 ;; engine?  You write a function that executes the query.  Temporary
 159 ;; data from the search engine can be put in `nnir-tmp-buffer'.  This
 160 ;; function should return the list of articles as a vector, as
 161 ;; described above.  Then, you need to register this backend in
 162 ;; `nnir-engines'.  Then, users can choose the backend by setting
 163 ;; `nnir-search-engine' as a server variable.
 164
 165 ;;; Code:
 166
 167 ;;; Setup:
 168
 169 ;; For Emacs <22.2 and XEmacs.
 170 (eval-and-compile
 171   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
 172
 173 (require 'nnoo)
 174 (require 'gnus-group)
 175 (require 'message)
 176 (require 'gnus-util)
 177 (eval-when-compile
 178   (require 'cl))
 179
 180 ;;; Internal Variables:
 181
 182 (defvar nnir-current-query nil
 183   "Internal: stores current query (= group name).")
 184
 185 (defvar nnir-current-server nil
 186   "Internal: stores current server (does it ever change?).")
 187
 188 (defvar nnir-current-group-marked nil
 189   "Internal: stores current list of process-marked groups.")
 190
 191 (defvar nnir-artlist nil
 192   "Internal: stores search result.")
 193
 194 (defvar nnir-tmp-buffer " *nnir*"
 195   "Internal: temporary buffer.")
 196
 197 (defvar nnir-search-history ()
 198   "Internal: the history for querying search options in nnir")
 199
 200 (defvar nnir-extra-parms nil
 201   "Internal: stores request for extra search parms")
 202
 203 ;; Imap variables
 204
 205 (defvar nnir-imap-search-arguments
 206   '(("Whole message" . "TEXT")
 207     ("Subject" . "SUBJECT")
 208     ("To" . "TO")
 209     ("From" . "FROM")
 210     ("Imap" . ""))
 211   "Mapping from user readable keys to IMAP search items for use in nnir")
 212
 213 (defvar nnir-imap-search-other "HEADER %S"
 214   "The IMAP search item to use for anything other than
 215   `nnir-imap-search-arguments'. By default this is the name of an
 216   email header field")
 217
 218 (defvar nnir-imap-search-argument-history ()
 219   "The history for querying search options in nnir")
 220
 221 ;;; Helper macros
 222
 223 ;; Data type article list.
 224
 225 (defmacro nnir-artlist-length (artlist)
 226   "Returns number of articles in artlist."
 227   `(length ,artlist))
 228
 229 (defmacro nnir-artlist-article (artlist n)
 230   "Returns from ARTLIST the Nth artitem (counting starting at 1)."
 231   `(when (> ,n 0)
 232      (elt ,artlist (1- ,n))))
 233
 234 (defmacro nnir-artitem-group (artitem)
 235   "Returns the group from the ARTITEM."
 236   `(elt ,artitem 0))
 237
 238 (defmacro nnir-artitem-number (artitem)
 239   "Returns the number from the ARTITEM."
 240   `(elt ,artitem 1))
 241
 242 (defmacro nnir-artitem-rsv (artitem)
 243   "Returns the Retrieval Status Value (RSV, score) from the ARTITEM."
 244   `(elt ,artitem 2))
 245
 246 (defmacro nnir-article-group (article)
 247   "Returns the group for ARTICLE"
 248   `(nnir-artitem-group (nnir-artlist-article nnir-artlist ,article)))
 249
 250 (defmacro nnir-article-number (article)
 251   "Returns the number for ARTICLE"
 252   `(nnir-artitem-number (nnir-artlist-article nnir-artlist ,article)))
 253
 254 (defmacro nnir-article-rsv (article)
 255   "Returns the rsv for ARTICLE"
 256   `(nnir-artitem-rsv (nnir-artlist-article nnir-artlist ,article)))
 257
 258 (defsubst nnir-article-ids (article)
 259   "Returns the pair `(nnir id . real id)' of ARTICLE"
 260   (cons article (nnir-article-number article)))
 261
 262 (defmacro nnir-categorize (sequence keyfunc &optional valuefunc)
 263   "Sorts a sequence into categories and returns a list of the form
 264 `((key1 (element11 element12)) (key2 (element21 element22))'.
 265 The category key for a member of the sequence is obtained
 266 as `(keyfunc member)' and the corresponding element is just
 267 `member'. If `valuefunc' is non-nil, the element of the list
 268 is `(valuefunc member)'."
 269   `(unless (null ,sequence)
 270      (let (value)
 271        (mapc
 272         (lambda (member)
 273           (let ((y (,keyfunc member))
 274                 (x ,(if valuefunc
 275                         `(,valuefunc member)
 276                       'member)))
 277             (if (assoc y value)
 278                 (push x (cadr (assoc y value)))
 279               (push (list y (list x)) value))))
 280         ,sequence)
 281        value)))
 282
 283 ;;; Finish setup:
 284
 285 (require 'gnus-sum)
 286
 287 (eval-when-compile
 288   (autoload 'nnimap-buffer "nnimap")
 289   (autoload 'nnimap-command "nnimap")
 290   (autoload 'nnimap-possibly-change-group "nnimap")
 291   (autoload 'gnus-registry-action "gnus-registry")
 292   (defvar gnus-registry-install))
 293
 294
 295 (nnoo-declare nnir)
 296 (nnoo-define-basics nnir)
 297
 298 (gnus-declare-backend "nnir" 'mail)
 299
 300
 301 ;;; User Customizable Variables:
 302
 303 (defgroup nnir nil
 304   "Search groups in Gnus with assorted seach engines."
 305   :group 'gnus)
 306
 307 (defcustom nnir-ignored-newsgroups ""
 308   "*A regexp to match newsgroups in the active file that should
 309   be skipped when searching."
 310   :type '(regexp)
 311   :group 'nnir)
 312
 313 (defcustom nnir-summary-line-format nil
 314   "*The format specification of the lines in an nnir summary buffer.
 315
 316 All the items from `gnus-summary-line-format' are available, along
 317 with three items unique to nnir summary buffers:
 318
 319 %Z    Search retrieval score value (integer)
 320 %G    Article original full group name (string)
 321 %g    Article original short group name (string)
 322
 323 If nil this will use `gnus-summary-line-format'."
 324   :type '(string)
 325   :group 'nnir)
 326
 327 (defcustom nnir-retrieve-headers-override-function nil
 328   "*If non-nil, a function that accepts an article list and group
 329 and populates the `nntp-server-buffer' with the retrieved
 330 headers. Must return either 'nov or 'headers indicating the
 331 retrieved header format.
 332
 333 If this variable is nil, or if the provided function returns nil for a search
 334 result, `gnus-retrieve-headers' will be called instead."
 335   :type '(function)
 336   :group 'nnir)
 337
 338 (defcustom nnir-imap-default-search-key "Whole message"
 339   "*The default IMAP search key for an nnir search. Must be one of
 340   the keys in `nnir-imap-search-arguments'. To use raw imap queries
 341   by default set this to \"Imap\"."
 342   :type `(choice ,@(mapcar (lambda (elem) (list 'const (car elem)))
 343                            nnir-imap-search-arguments))
 344   :group 'nnir)
 345
 346 (defcustom nnir-swish++-configuration-file
 347   (expand-file-name "~/Mail/swish++.conf")
 348   "*Configuration file for swish++."
 349   :type '(file)
 350   :group 'nnir)
 351
 352 (defcustom nnir-swish++-program "search"
 353   "*Name of swish++ search executable."
 354   :type '(string)
 355   :group 'nnir)
 356
 357 (defcustom nnir-swish++-additional-switches '()
 358   "*A list of strings, to be given as additional arguments to swish++.
 359
 360 Note that this should be a list.  Ie, do NOT use the following:
 361     (setq nnir-swish++-additional-switches \"-i -w\") ; wrong
 362 Instead, use this:
 363     (setq nnir-swish++-additional-switches '(\"-i\" \"-w\"))"
 364   :type '(repeat (string))
 365   :group 'nnir)
 366
 367 (defcustom nnir-swish++-remove-prefix (concat (getenv "HOME") "/Mail/")
 368   "*The prefix to remove from each file name returned by swish++
 369 in order to get a group name (albeit with / instead of .).  This is a
 370 regular expression.
 371
 372 This variable is very similar to `nnir-namazu-remove-prefix', except
 373 that it is for swish++, not Namazu."
 374   :type '(regexp)
 375   :group 'nnir)
 376
 377 ;; Swish-E.
 378 ;; URL: http://swish-e.org/
 379 ;; Variables `nnir-swish-e-index-file', `nnir-swish-e-program' and
 380 ;; `nnir-swish-e-additional-switches'
 381
 382 (make-obsolete-variable 'nnir-swish-e-index-file
 383                         'nnir-swish-e-index-files "Emacs 23.1")
 384 (defcustom nnir-swish-e-index-file
 385   (expand-file-name "~/Mail/index.swish-e")
 386   "*Index file for swish-e.
 387 This could be a server parameter.
 388 It is never consulted once `nnir-swish-e-index-files', which should be
 389 used instead, has been customized."
 390   :type '(file)
 391   :group 'nnir)
 392
 393 (defcustom nnir-swish-e-index-files
 394   (list nnir-swish-e-index-file)
 395   "*List of index files for swish-e.
 396 This could be a server parameter."
 397   :type '(repeat (file))
 398   :group 'nnir)
 399
 400 (defcustom nnir-swish-e-program "swish-e"
 401   "*Name of swish-e search executable.
 402 This cannot be a server parameter."
 403   :type '(string)
 404   :group 'nnir)
 405
 406 (defcustom nnir-swish-e-additional-switches '()
 407   "*A list of strings, to be given as additional arguments to swish-e.
 408
 409 Note that this should be a list.  Ie, do NOT use the following:
 410     (setq nnir-swish-e-additional-switches \"-i -w\") ; wrong
 411 Instead, use this:
 412     (setq nnir-swish-e-additional-switches '(\"-i\" \"-w\"))
 413
 414 This could be a server parameter."
 415   :type '(repeat (string))
 416   :group 'nnir)
 417
 418 (defcustom nnir-swish-e-remove-prefix (concat (getenv "HOME") "/Mail/")
 419   "*The prefix to remove from each file name returned by swish-e
 420 in order to get a group name (albeit with / instead of .).  This is a
 421 regular expression.
 422
 423 This variable is very similar to `nnir-namazu-remove-prefix', except
 424 that it is for swish-e, not Namazu.
 425
 426 This could be a server parameter."
 427   :type '(regexp)
 428   :group 'nnir)
 429
 430 ;; HyREX engine, see <URL:http://ls6-www.cs.uni-dortmund.de/>
 431
 432 (defcustom nnir-hyrex-program "nnir-search"
 433   "*Name of the nnir-search executable."
 434   :type '(string)
 435   :group 'nnir)
 436
 437 (defcustom nnir-hyrex-additional-switches '()
 438   "*A list of strings, to be given as additional arguments for nnir-search.
 439 Note that this should be a list. Ie, do NOT use the following:
 440     (setq nnir-hyrex-additional-switches \"-ddl ddl.xml -c nnir\") ; wrong !
 441 Instead, use this:
 442     (setq nnir-hyrex-additional-switches '(\"-ddl\" \"ddl.xml\" \"-c\" \"nnir\"))"
 443   :type '(repeat (string))
 444   :group 'nnir)
 445
 446 (defcustom nnir-hyrex-index-directory (getenv "HOME")
 447   "*Index directory for HyREX."
 448   :type '(directory)
 449   :group 'nnir)
 450
 451 (defcustom nnir-hyrex-remove-prefix (concat (getenv "HOME") "/Mail/")
 452   "*The prefix to remove from each file name returned by HyREX
 453 in order to get a group name (albeit with / instead of .).
 454
 455 For example, suppose that HyREX returns file names such as
 456 \"/home/john/Mail/mail/misc/42\".  For this example, use the following
 457 setting:  (setq nnir-hyrex-remove-prefix \"/home/john/Mail/\")
 458 Note the trailing slash.  Removing this prefix gives \"mail/misc/42\".
 459 `nnir' knows to remove the \"/42\" and to replace \"/\" with \".\" to
 460 arrive at the correct group name, \"mail.misc\"."
 461   :type '(directory)
 462   :group 'nnir)
 463
 464 ;; Namazu engine, see <URL:http://www.namazu.org/>
 465
 466 (defcustom nnir-namazu-program "namazu"
 467   "*Name of Namazu search executable."
 468   :type '(string)
 469   :group 'nnir)
 470
 471 (defcustom nnir-namazu-index-directory (expand-file-name "~/Mail/namazu/")
 472   "*Index directory for Namazu."
 473   :type '(directory)
 474   :group 'nnir)
 475
 476 (defcustom nnir-namazu-additional-switches '()
 477   "*A list of strings, to be given as additional arguments to namazu.
 478 The switches `-q', `-a', and `-s' are always used, very few other switches
 479 make any sense in this context.
 480
 481 Note that this should be a list.  Ie, do NOT use the following:
 482     (setq nnir-namazu-additional-switches \"-i -w\") ; wrong
 483 Instead, use this:
 484     (setq nnir-namazu-additional-switches '(\"-i\" \"-w\"))"
 485   :type '(repeat (string))
 486   :group 'nnir)
 487
 488 (defcustom nnir-namazu-remove-prefix (concat (getenv "HOME") "/Mail/")
 489   "*The prefix to remove from each file name returned by Namazu
 490 in order to get a group name (albeit with / instead of .).
 491
 492 For example, suppose that Namazu returns file names such as
 493 \"/home/john/Mail/mail/misc/42\".  For this example, use the following
 494 setting:  (setq nnir-namazu-remove-prefix \"/home/john/Mail/\")
 495 Note the trailing slash.  Removing this prefix gives \"mail/misc/42\".
 496 `nnir' knows to remove the \"/42\" and to replace \"/\" with \".\" to
 497 arrive at the correct group name, \"mail.misc\"."
 498   :type '(directory)
 499   :group 'nnir)
 500
 501 ;;; Developer Extension Variable:
 502
 503 (defvar nnir-engines
 504   `((imap    nnir-run-imap
 505              ((criteria
 506                "Imap Search in"                   ; Prompt
 507                ,(mapcar 'car nnir-imap-search-arguments) ; alist for completing
 508                nil                                ; allow any user input
 509                nil                                ; initial value
 510                nnir-imap-search-argument-history  ; the history to use
 511                ,nnir-imap-default-search-key      ; default
 512                )))
 513     (gmane   nnir-run-gmane
 514              ((author . "Gmane Author: ")))
 515     (swish++ nnir-run-swish++
 516              ((group . "Swish++ Group spec: ")))
 517     (swish-e nnir-run-swish-e
 518              ((group . "Swish-e Group spec: ")))
 519     (namazu  nnir-run-namazu
 520              ())
 521     (hyrex   nnir-run-hyrex
 522              ((group . "Hyrex Group spec: ")))
 523     (find-grep nnir-run-find-grep
 524                ((grep-options . "Grep options: "))))
 525   "Alist of supported search engines.
 526 Each element in the alist is a three-element list (ENGINE FUNCTION ARGS).
 527 ENGINE is a symbol designating the searching engine.  FUNCTION is also
 528 a symbol, giving the function that does the search.  The third element
 529 ARGS is a list of cons pairs (PARAM . PROMPT).  When issuing a query,
 530 the FUNCTION will issue a query for each of the PARAMs, using PROMPT.
 531
 532 The value of `nnir-search-engine' must be one of the ENGINE symbols.
 533 For example, for searching a server using namazu include
 534     (nnir-search-engine namazu)
 535 in the server definition.  Note that you have to set additional
 536 variables for most backends.  For example, the `namazu' backend
 537 needs the variables `nnir-namazu-program',
 538 `nnir-namazu-index-directory' and `nnir-namazu-remove-prefix'.
 539
 540 Add an entry here when adding a new search engine.")
 541
 542 (defcustom nnir-method-default-engines
 543   '((nnimap . imap)
 544     (nntp . gmane))
 545   "*Alist of default search engines keyed by server method."
 546   :type `(repeat (cons (choice (const nnimap) (const nttp) (const nnspool)
 547                                (const nneething) (const nndir) (const nnmbox)
 548                                (const nnml) (const nnmh) (const nndraft)
 549                                (const nnfolder) (const nnmaildir))
 550                        (choice
 551                         ,@(mapcar (lambda (elem) (list 'const (car elem)))
 552                                   nnir-engines))))
 553   :group 'nnir)
 554
 555 ;; Gnus glue.
 556
 557 (defun gnus-group-make-nnir-group (nnir-extra-parms)
 558   "Create an nnir group.  Asks for query."
 559   (interactive "P")
 560   (setq nnir-current-query nil
 561         nnir-current-server nil
 562         nnir-current-group-marked nil
 563         nnir-artlist nil)
 564   (let* ((query (read-string "Query: " nil 'nnir-search-history))
 565          (parms (list (cons 'query query)))
 566          (srv (if (gnus-server-server-name)
 567                   "all" "")))
 568     (add-to-list 'parms (cons 'unique-id (message-unique-id)) t)
 569     (gnus-group-read-ephemeral-group
 570      (concat "nnir:" (prin1-to-string parms)) (list 'nnir srv) t
 571      (cons (current-buffer) gnus-current-window-configuration)
 572      nil)))
 573
 574
 575 ;; Gnus backend interface functions.
 576
 577 (deffoo nnir-open-server (server &optional definitions)
 578   ;; Just set the server variables appropriately.
 579   (add-hook 'gnus-summary-mode-hook 'nnir-mode)
 580   (nnoo-change-server 'nnir server definitions))
 581
 582 (deffoo nnir-request-group (group &optional server fast info)
 583   "GROUP is the query string."
 584   (nnir-possibly-change-server server)
 585   ;; Check for cache and return that if appropriate.
 586   (if (and (equal group nnir-current-query)
 587            (equal gnus-group-marked nnir-current-group-marked)
 588            (or (null server)
 589                (equal server nnir-current-server)))
 590       nnir-artlist
 591     ;; Cache miss.
 592     (setq nnir-artlist (nnir-run-query group server)))
 593   (with-current-buffer nntp-server-buffer
 594     (setq nnir-current-query group)
 595     (when server (setq nnir-current-server server))
 596     (setq nnir-current-group-marked gnus-group-marked)
 597     (if (zerop (length nnir-artlist))
 598         (nnheader-report 'nnir "Search produced empty results.")
 599       ;; Remember data for cache.
 600       (nnheader-insert "211 %d %d %d %s\n"
 601                        (nnir-artlist-length nnir-artlist) ; total #
 602                        1              ; first #
 603                        (nnir-artlist-length nnir-artlist) ; last #
 604                        group))))      ; group name
 605
 606 (deffoo nnir-retrieve-headers (articles &optional group server fetch-old)
 607   (with-current-buffer nntp-server-buffer
 608     (let ((gnus-inhibit-demon t)
 609           (articles-by-group (nnir-categorize
 610                               articles nnir-article-group nnir-article-ids))
 611           headers)
 612       (while (not (null articles-by-group))
 613         (let* ((group-articles (pop articles-by-group))
 614                (artgroup (car group-articles))
 615                (articleids (cadr group-articles))
 616                (artlist (sort (mapcar 'cdr articleids) '<))
 617                (server (gnus-group-server artgroup))
 618                (gnus-override-method (gnus-server-to-method server))
 619                parsefunc)
 620           ;; (or (numberp art)
 621           ;;     (nnheader-report
 622           ;;      'nnir
 623           ;;      "nnir-retrieve-headers doesn't grok message ids: %s"
 624           ;;      art))
 625           (nnir-possibly-change-server server)
 626           ;; is this needed?
 627           (erase-buffer)
 628           (case (setq gnus-headers-retrieved-by
 629                       (or
 630                        (and
 631                         nnir-retrieve-headers-override-function
 632                         (funcall nnir-retrieve-headers-override-function
 633                                  artlist artgroup))
 634                        (gnus-retrieve-headers artlist artgroup nil)))
 635             (nov
 636              (setq parsefunc 'nnheader-parse-nov))
 637             (headers
 638              (setq parsefunc 'nnheader-parse-head))
 639             (t (error "Unknown header type %s while requesting articles \
 640                     of group %s" gnus-headers-retrieved-by artgroup)))
 641           (goto-char (point-min))
 642           (while (not (eobp))
 643             (let* ((novitem (funcall parsefunc))
 644                    (artno (mail-header-number novitem))
 645                    (art (car (rassq artno articleids))))
 646               (when art
 647                 (mail-header-set-number novitem art)
 648                 (push novitem headers))
 649               (forward-line 1)))))
 650       (setq headers
 651             (sort headers
 652                   (lambda (x y)
 653                     (< (mail-header-number x) (mail-header-number y)))))
 654       (erase-buffer)
 655       (mapc 'nnheader-insert-nov headers)
 656       'nov)))
 657
 658 (deffoo nnir-request-article (article &optional group server to-buffer)
 659   (if (stringp article)
 660       (nnheader-report
 661        'nnir
 662        "nnir-retrieve-headers doesn't grok message ids: %s"
 663        article)
 664     (save-excursion
 665       (let ((artfullgroup (nnir-article-group article))
 666             (artno (nnir-article-number article)))
 667         (message "Requesting article %d from group %s"
 668                  artno artfullgroup)
 669         (if to-buffer
 670             (with-current-buffer to-buffer
 671               (let ((gnus-article-decode-hook nil))
 672                 (gnus-request-article-this-buffer artno artfullgroup)))
 673           (gnus-request-article artno artfullgroup))
 674         (cons artfullgroup artno)))))
 675
 676 (deffoo nnir-request-move-article (article group server accept-form
 677                                            &optional last internal-move-group)
 678   (let* ((artfullgroup (nnir-article-group article))
 679          (artno (nnir-article-number article))
 680          (to-newsgroup (nth 1 accept-form))
 681          (to-method (gnus-find-method-for-group to-newsgroup))
 682          (from-method (gnus-find-method-for-group artfullgroup))
 683          (move-is-internal (gnus-server-equal from-method to-method)))
 684     (unless (gnus-check-backend-function
 685              'request-move-article artfullgroup)
 686       (error "The group %s does not support article moving" artfullgroup))
 687     (gnus-request-move-article
 688      artno
 689      artfullgroup
 690      (nth 1 from-method)
 691      accept-form
 692      last
 693      (and move-is-internal
 694           to-newsgroup          ; Not respooling
 695           (gnus-group-real-name to-newsgroup)))))
 696
 697 (deffoo nnir-request-expire-articles (articles group &optional server force)
 698   (if force
 699     (let ((articles-by-group (nnir-categorize
 700                               articles nnir-article-group nnir-article-ids))
 701           not-deleted)
 702       (while (not (null articles-by-group))
 703         (let* ((group-articles (pop articles-by-group))
 704                (artgroup (car group-articles))
 705                (articleids (cadr group-articles))
 706                (artlist (sort (mapcar 'cdr articleids) '<)))
 707           (unless (gnus-check-backend-function 'request-expire-articles
 708                                                artgroup)
 709             (error "The group %s does not support article deletion" artgroup))
 710           (unless (gnus-check-server (gnus-find-method-for-group artgroup))
 711             (error "Couldn't open server for group %s" artgroup))
 712           (push (gnus-request-expire-articles
 713                  artlist artgroup force)
 714                 not-deleted)))
 715       (sort (delq nil not-deleted) '<))
 716     articles))
 717
 718 (deffoo nnir-warp-to-article ()
 719   (let* ((cur (if (> (gnus-summary-article-number) 0)
 720                   (gnus-summary-article-number)
 721                 (error "This is not a real article.")))
 722          (gnus-newsgroup-name (nnir-article-group cur))
 723          (backend-number (nnir-article-number cur)))
 724     (gnus-summary-read-group-1 gnus-newsgroup-name t t gnus-summary-buffer
 725                                nil (list backend-number))))
 726
 727 (nnoo-define-skeleton nnir)
 728
 729
 730 (defmacro nnir-add-result (dirnam artno score prefix server artlist)
 731   "Ask `nnir-compose-result' to construct a result vector,
 732 and if it is non-nil, add it to artlist."
 733   `(let ((result (nnir-compose-result ,dirnam ,artno ,score ,prefix ,server)))
 734      (when (not (null result))
 735        (push result ,artlist))))
 736
 737 (autoload 'nnmaildir-base-name-to-article-number "nnmaildir")
 738
 739 ;; Helper function currently used by the Swish++ and Namazu backends;
 740 ;; perhaps useful for other backends as well
 741 (defun nnir-compose-result (dirnam article score prefix server)
 742   "Extract the group from dirnam, and create a result vector
 743 ready to be added to the list of search results."
 744
 745   ;; remove nnir-*-remove-prefix from beginning of dirnam filename
 746   (when (string-match (concat "^" prefix) dirnam)
 747     (setq dirnam (replace-match "" t t dirnam)))
 748
 749   (when (file-readable-p (concat prefix dirnam article))
 750     ;; remove trailing slash and, for nnmaildir, cur/new/tmp
 751     (setq dirnam
 752           (substring dirnam 0
 753                      (if (string= (gnus-group-server server) "nnmaildir")
 754                          -5 -1)))
 755
 756     ;; Set group to dirnam without any leading dots or slashes,
 757     ;; and with all subsequent slashes replaced by dots
 758     (let ((group (gnus-replace-in-string
 759                  (gnus-replace-in-string dirnam "^[./\\]" "" t)
 760                  "[/\\]" "." t)))
 761
 762     (vector (gnus-group-full-name group server)
 763             (if (string= (gnus-group-server server) "nnmaildir")
 764                 (nnmaildir-base-name-to-article-number
 765                  (substring article 0 (string-match ":" article))
 766                  group nil)
 767               (string-to-number article))
 768             (string-to-number score)))))
 769
 770 ;;; Search Engine Interfaces:
 771
 772 ;; imap interface
 773 (defun nnir-run-imap (query srv &optional groups)
 774   "Run a search against an IMAP back-end server.
 775 This uses a custom query language parser; see `nnir-imap-make-query' for
 776 details on the language and supported extensions"
 777   (save-excursion
 778     (let ((qstring (cdr (assq 'query query)))
 779           (server (cadr (gnus-server-to-method srv)))
 780           (defs (caddr (gnus-server-to-method srv)))
 781           (criteria (or (cdr (assq 'criteria query))
 782                         (cdr (assoc nnir-imap-default-search-key
 783                                     nnir-imap-search-arguments))))
 784           (gnus-inhibit-demon t)
 785           (groups (or groups (nnir-get-active srv))))
 786       (message "Opening server %s" server)
 787       (apply
 788        'vconcat
 789        (mapcar
 790         (lambda (group)
 791           (let (artlist)
 792             (condition-case ()
 793                 (when (nnimap-possibly-change-group
 794                        (gnus-group-short-name group) server)
 795                   (with-current-buffer (nnimap-buffer)
 796                     (message "Searching %s..." group)
 797                     (let ((arts 0)
 798                           (result (nnimap-command "UID SEARCH %s"
 799                                                   (if (string= criteria "")
 800                                                       qstring
 801                                                     (nnir-imap-make-query
 802                                                      criteria qstring)))))
 803                       (mapc
 804                        (lambda (artnum)
 805                          (let ((artn (string-to-number artnum)))
 806                            (when (> artn 0)
 807                              (push (vector group artn 100)
 808                                    artlist)
 809                              (setq arts (1+ arts)))))
 810                        (and (car result) (cdr (assoc "SEARCH" (cdr result)))))
 811                       (message "Searching %s... %d matches" group arts)))
 812                   (message "Searching %s...done" group))
 813               (quit nil))
 814             (nreverse artlist)))
 815         groups)))))
 816
 817 (defun nnir-imap-make-query (criteria qstring)
 818   "Parse the query string and criteria into an appropriate IMAP search
 819 expression, returning the string query to make.
 820
 821 This implements a little language designed to return the expected results
 822 to an arbitrary query string to the end user.
 823
 824 The search is always case-insensitive, as defined by RFC2060, and supports
 825 the following features (inspired by the Google search input language):
 826
 827 Automatic \"and\" queries
 828     If you specify multiple words then they will be treated as an \"and\"
 829     expression intended to match all components.
 830
 831 Phrase searches
 832     If you wrap your query in double-quotes then it will be treated as a
 833     literal string.
 834
 835 Negative terms
 836     If you precede a term with \"-\" then it will negate that.
 837
 838 \"OR\" queries
 839     If you include an upper-case \"OR\" in your search it will cause the
 840     term before it and the term after it to be treated as alternatives.
 841
 842 In future the following will be added to the language:
 843  * support for date matches
 844  * support for location of text matching within the query
 845  * from/to/etc headers
 846  * additional search terms
 847  * flag based searching
 848  * anything else that the RFC supports, basically."
 849   ;; Walk through the query and turn it into an IMAP query string.
 850   (nnir-imap-query-to-imap criteria (nnir-imap-parse-query qstring)))
 851
 852
 853 (defun nnir-imap-query-to-imap (criteria query)
 854   "Turn a s-expression format query into IMAP."
 855   (mapconcat
 856    ;; Turn the expressions into IMAP text
 857    (lambda (item)
 858      (nnir-imap-expr-to-imap criteria item))
 859    ;; The query, already in s-expr format.
 860    query
 861    ;; Append a space between each expression
 862    " "))
 863
 864
 865 (defun nnir-imap-expr-to-imap (criteria expr)
 866   "Convert EXPR into an IMAP search expression on CRITERIA"
 867   ;; What sort of expression is this, eh?
 868   (cond
 869    ;; Simple string term
 870    ((stringp expr)
 871     (format "%s %S" criteria expr))
 872    ;; Trivial term: and
 873    ((eq expr 'and) nil)
 874    ;; Composite term: or expression
 875    ((eq (car-safe expr) 'or)
 876     (format "OR %s %s"
 877             (nnir-imap-expr-to-imap criteria (second expr))
 878             (nnir-imap-expr-to-imap criteria (third expr))))
 879    ;; Composite term: just the fax, mam
 880    ((eq (car-safe expr) 'not)
 881     (format "NOT (%s)" (nnir-imap-query-to-imap criteria (rest expr))))
 882    ;; Composite term: just expand it all.
 883    ((and (not (null expr)) (listp expr))
 884     (format "(%s)" (nnir-imap-query-to-imap criteria expr)))
 885    ;; Complex value, give up for now.
 886    (t (error "Unhandled input: %S" expr))))
 887
 888
 889 (defun nnir-imap-parse-query (string)
 890   "Turn STRING into an s-expression based query based on the IMAP
 891 query language as defined in `nnir-imap-make-query'.
 892
 893 This involves turning individual tokens into higher level terms
 894 that the search language can then understand and use."
 895   (with-temp-buffer
 896     ;; Set up the parsing environment.
 897     (insert string)
 898     (goto-char (point-min))
 899     ;; Now, collect the output terms and return them.
 900     (let (out)
 901       (while (not (nnir-imap-end-of-input))
 902         (push (nnir-imap-next-expr) out))
 903       (reverse out))))
 904
 905
 906 (defun nnir-imap-next-expr (&optional count)
 907   "Return the next expression from the current buffer."
 908   (let ((term (nnir-imap-next-term count))
 909         (next (nnir-imap-peek-symbol)))
 910     ;; Are we looking at an 'or' expression?
 911     (cond
 912      ;; Handle 'expr or expr'
 913      ((eq next 'or)
 914       (list 'or term (nnir-imap-next-expr 2)))
 915      ;; Anything else
 916      (t term))))
 917
 918
 919 (defun nnir-imap-next-term (&optional count)
 920   "Return the next TERM from the current buffer."
 921   (let ((term (nnir-imap-next-symbol count)))
 922     ;; What sort of term is this?
 923     (cond
 924      ;; and -- just ignore it
 925      ((eq term 'and) 'and)
 926      ;; negated term
 927      ((eq term 'not) (list 'not (nnir-imap-next-expr)))
 928      ;; generic term
 929      (t term))))
 930
 931
 932 (defun nnir-imap-peek-symbol ()
 933   "Return the next symbol from the current buffer, but don't consume it."
 934   (save-excursion
 935     (nnir-imap-next-symbol)))
 936
 937 (defun nnir-imap-next-symbol (&optional count)
 938   "Return the next symbol from the current buffer, or nil if we are
 939 at the end of the buffer.  If supplied COUNT skips some symbols before
 940 returning the one at the supplied position."
 941   (when (and (numberp count) (> count 1))
 942     (nnir-imap-next-symbol (1- count)))
 943   (let ((case-fold-search t))
 944     ;; end of input stream?
 945     (unless (nnir-imap-end-of-input)
 946       ;; No, return the next symbol from the stream.
 947       (cond
 948        ;; negated expression -- return it and advance one char.
 949        ((looking-at "-") (forward-char 1) 'not)
 950        ;; quoted string
 951        ((looking-at "\"") (nnir-imap-delimited-string "\""))
 952        ;; list expression -- we parse the content and return this as a list.
 953        ((looking-at "(")
 954         (nnir-imap-parse-query (nnir-imap-delimited-string ")")))
 955        ;; keyword input -- return a symbol version
 956        ((looking-at "\\band\\b") (forward-char 3) 'and)
 957        ((looking-at "\\bor\\b")  (forward-char 2) 'or)
 958        ((looking-at "\\bnot\\b") (forward-char 3) 'not)
 959        ;; Simple, boring keyword
 960        (t (let ((start (point))
 961                 (end (if (search-forward-regexp "[[:blank:]]" nil t)
 962                          (prog1
 963                              (match-beginning 0)
 964                            ;; unskip if we hit a non-blank terminal character.
 965                            (when (string-match "[^[:blank:]]" (match-string 0))
 966                              (backward-char 1)))
 967                        (goto-char (point-max)))))
 968             (buffer-substring start end)))))))
 969
 970 (defun nnir-imap-delimited-string (delimiter)
 971   "Return a delimited string from the current buffer."
 972   (let ((start (point)) end)
 973     (forward-char 1)                    ; skip the first delimiter.
 974     (while (not end)
 975       (unless (search-forward delimiter nil t)
 976         (error "Unmatched delimited input with %s in query" delimiter))
 977       (let ((here (point)))
 978         (unless (equal (buffer-substring (- here 2) (- here 1)) "\\")
 979           (setq end (point)))))
 980     (buffer-substring (1+ start) (1- end))))
 981
 982 (defun nnir-imap-end-of-input ()
 983   "Are we at the end of input?"
 984   (skip-chars-forward "[[:blank:]]")
 985   (looking-at "$"))
 986
 987
 988 ;; Swish++ interface.
 989 ;; -cc- Todo
 990 ;; Search by
 991 ;; - group
 992 ;; Sort by
 993 ;; - rank (default)
 994 ;; - article number
 995 ;; - file size
 996 ;; - group
 997 (defun nnir-run-swish++ (query server &optional group)
 998   "Run QUERY against swish++.
 999 Returns a vector of (group name, file name) pairs (also vectors,
1000 actually).
1001
1002 Tested with swish++ 4.7 on GNU/Linux and with swish++ 5.0b2 on
1003 Windows NT 4.0."
1004
1005   ;; (when group
1006   ;;   (error "The swish++ backend cannot search specific groups"))
1007
1008   (save-excursion
1009     (let ( (qstring (cdr (assq 'query query)))
1010            (groupspec (cdr (assq 'group query)))
1011            (prefix (nnir-read-server-parm 'nnir-swish++-remove-prefix server))
1012            artlist
1013            ;; nnml-use-compressed-files might be any string, but probably this
1014            ;; is sufficient.  Note that we can't only use the value of
1015            ;; nnml-use-compressed-files because old articles might have been
1016            ;; saved with a different value.
1017            (article-pattern (if (string= (gnus-group-server server) "nnmaildir")
1018                                 ":[0-9]+"
1019                               "^[0-9]+\\(\\.[a-z0-9]+\\)?$"))
1020            score artno dirnam filenam)
1021
1022       (when (equal "" qstring)
1023         (error "swish++: You didn't enter anything"))
1024
1025       (set-buffer (get-buffer-create nnir-tmp-buffer))
1026       (erase-buffer)
1027
1028       (if groupspec
1029           (message "Doing swish++ query %s on %s..." qstring groupspec)
1030         (message "Doing swish++ query %s..." qstring))
1031
1032       (let* ((cp-list `( ,nnir-swish++-program
1033                          nil            ; input from /dev/null
1034                          t              ; output
1035                          nil            ; don't redisplay
1036                          "--config-file" ,(nnir-read-server-parm 'nnir-swish++-configuration-file server)
1037                          ,@(nnir-read-server-parm 'nnir-swish++-additional-switches server)
1038                          ,qstring       ; the query, in swish++ format
1039                          ))
1040              (exitstatus
1041               (progn
1042                 (message "%s args: %s" nnir-swish++-program
1043                          (mapconcat 'identity (cddddr cp-list) " ")) ;; ???
1044                 (apply 'call-process cp-list))))
1045         (unless (or (null exitstatus)
1046                     (zerop exitstatus))
1047           (nnheader-report 'nnir "Couldn't run swish++: %s" exitstatus)
1048           ;; swish++ failure reason is in this buffer, show it if
1049           ;; the user wants it.
1050           (when (> gnus-verbose 6)
1051             (display-buffer nnir-tmp-buffer))))
1052
1053       ;; The results are output in the format of:
1054       ;; V 4.7 Linux
1055       ;; rank relative-path-name file-size file-title
1056       ;; V 5.0b2:
1057       ;; rank relative-path-name file-size topic??
1058       ;; where rank is an integer from 1 to 100.
1059       (goto-char (point-min))
1060       (while (re-search-forward
1061               "\\(^[0-9]+\\) \\([^ ]+\\) [0-9]+ \\(.*\\)$" nil t)
1062         (setq score (match-string 1)
1063               filenam (match-string 2)
1064               artno (file-name-nondirectory filenam)
1065               dirnam (file-name-directory filenam))
1066
1067         ;; don't match directories
1068         (when (string-match article-pattern artno)
1069           (when (not (null dirnam))
1070
1071             ;; maybe limit results to matching groups.
1072             (when (or (not groupspec)
1073                       (string-match groupspec dirnam))
1074               (nnir-add-result dirnam artno score prefix server artlist)))))
1075
1076       (message "Massaging swish++ output...done")
1077
1078       ;; Sort by score
1079       (apply 'vector
1080              (sort artlist
1081                    (function (lambda (x y)
1082                                (> (nnir-artitem-rsv x)
1083                                   (nnir-artitem-rsv y)))))))))
1084
1085 ;; Swish-E interface.
1086 (defun nnir-run-swish-e (query server &optional group)
1087   "Run given query against swish-e.
1088 Returns a vector of (group name, file name) pairs (also vectors,
1089 actually).
1090
1091 Tested with swish-e-2.0.1 on Windows NT 4.0."
1092
1093   ;; swish-e crashes with empty parameter to "-w" on commandline...
1094   ;; (when group
1095   ;;   (error "The swish-e backend cannot search specific groups"))
1096
1097   (save-excursion
1098     (let ((qstring (cdr (assq 'query query)))
1099           (prefix
1100            (or (nnir-read-server-parm 'nnir-swish-e-remove-prefix server)
1101                (error "Missing parameter `nnir-swish-e-remove-prefix'")))
1102           artlist score artno dirnam group )
1103
1104       (when (equal "" qstring)
1105         (error "swish-e: You didn't enter anything"))
1106
1107       (set-buffer (get-buffer-create nnir-tmp-buffer))
1108       (erase-buffer)
1109
1110       (message "Doing swish-e query %s..." query)
1111       (let* ((index-files
1112               (or (nnir-read-server-parm
1113                    'nnir-swish-e-index-files server)
1114                   (error "Missing parameter `nnir-swish-e-index-files'")))
1115              (additional-switches
1116               (nnir-read-server-parm
1117                'nnir-swish-e-additional-switches server))
1118              (cp-list `(,nnir-swish-e-program
1119                         nil             ; input from /dev/null
1120                         t               ; output
1121                         nil             ; don't redisplay
1122                         "-f" ,@index-files
1123                         ,@additional-switches
1124                         "-w"
1125                         ,qstring        ; the query, in swish-e format
1126                         ))
1127              (exitstatus
1128               (progn
1129                 (message "%s args: %s" nnir-swish-e-program
1130                          (mapconcat 'identity (cddddr cp-list) " "))
1131                 (apply 'call-process cp-list))))
1132         (unless (or (null exitstatus)
1133                     (zerop exitstatus))
1134           (nnheader-report 'nnir "Couldn't run swish-e: %s" exitstatus)
1135           ;; swish-e failure reason is in this buffer, show it if
1136           ;; the user wants it.
1137           (when (> gnus-verbose 6)
1138             (display-buffer nnir-tmp-buffer))))
1139
1140       ;; The results are output in the format of:
1141       ;; rank path-name file-title file-size
1142       (goto-char (point-min))
1143       (while (re-search-forward
1144               "\\(^[0-9]+\\) \\([^ ]+\\) \"\\([^\"]+\\)\" [0-9]+$" nil t)
1145         (setq score (match-string 1)
1146               artno (match-string 3)
1147               dirnam (file-name-directory (match-string 2)))
1148
1149         ;; don't match directories
1150         (when (string-match "^[0-9]+$" artno)
1151           (when (not (null dirnam))
1152
1153             ;; remove nnir-swish-e-remove-prefix from beginning of dirname
1154             (when (string-match (concat "^" prefix) dirnam)
1155               (setq dirnam (replace-match "" t t dirnam)))
1156
1157             (setq dirnam (substring dirnam 0 -1))
1158             ;; eliminate all ".", "/", "\" from beginning. Always matches.
1159             (string-match "^[./\\]*\\(.*\\)$" dirnam)
1160             ;; "/" -> "."
1161             (setq group (gnus-replace-in-string (match-string 1 dirnam) "/" "."))
1162             ;; Windows "\\" -> "."
1163             (setq group (gnus-replace-in-string group "\\\\" "."))
1164
1165             (push (vector (gnus-group-full-name group server)
1166                           (string-to-number artno)
1167                           (string-to-number score))
1168                   artlist))))
1169
1170       (message "Massaging swish-e output...done")
1171
1172       ;; Sort by score
1173       (apply 'vector
1174              (sort artlist
1175                    (function (lambda (x y)
1176                                (> (nnir-artitem-rsv x)
1177                                   (nnir-artitem-rsv y)))))))))
1178
1179 ;; HyREX interface
1180 (defun nnir-run-hyrex (query server &optional group)
1181   (save-excursion
1182     (let ((artlist nil)
1183           (groupspec (cdr (assq 'group query)))
1184           (qstring (cdr (assq 'query query)))
1185           (prefix (nnir-read-server-parm 'nnir-hyrex-remove-prefix server))
1186           score artno dirnam)
1187       (when (and (not groupspec) group)
1188         (setq groupspec
1189               (regexp-opt
1190                (mapcar (lambda (x) (gnus-group-real-name x)) group))))
1191       (set-buffer (get-buffer-create nnir-tmp-buffer))
1192       (erase-buffer)
1193       (message "Doing hyrex-search query %s..." query)
1194       (let* ((cp-list
1195               `( ,nnir-hyrex-program
1196                  nil                    ; input from /dev/null
1197                  t                      ; output
1198                  nil                    ; don't redisplay
1199                  "-i",(nnir-read-server-parm 'nnir-hyrex-index-directory server) ; index directory
1200                  ,@(nnir-read-server-parm 'nnir-hyrex-additional-switches server)
1201                  ,qstring          ; the query, in hyrex-search format
1202                  ))
1203              (exitstatus
1204               (progn
1205                 (message "%s args: %s" nnir-hyrex-program
1206                          (mapconcat 'identity (cddddr cp-list) " "))
1207                 (apply 'call-process cp-list))))
1208         (unless (or (null exitstatus)
1209                     (zerop exitstatus))
1210           (nnheader-report 'nnir "Couldn't run hyrex-search: %s" exitstatus)
1211           ;; nnir-search failure reason is in this buffer, show it if
1212           ;; the user wants it.
1213           (when (> gnus-verbose 6)
1214             (display-buffer nnir-tmp-buffer)))) ;; FIXME: Dont clear buffer !
1215       (message "Doing hyrex-search query \"%s\"...done" qstring)
1216       (sit-for 0)
1217       ;; nnir-search returns:
1218       ;;   for nnml/nnfolder: "filename mailid weigth"
1219       ;;   for nnimap:        "group mailid weigth"
1220       (goto-char (point-min))
1221       (delete-non-matching-lines "^\\S + [0-9]+ [0-9]+$")
1222       ;; HyREX doesn't search directly in groups -- so filter out here.
1223       (when groupspec
1224         (keep-lines groupspec))
1225       ;; extract data from result lines
1226       (goto-char (point-min))
1227       (while (re-search-forward
1228               "\\(\\S +\\) \\([0-9]+\\) \\([0-9]+\\)" nil t)
1229         (setq dirnam (match-string 1)
1230               artno (match-string 2)
1231               score (match-string 3))
1232         (when (string-match prefix dirnam)
1233           (setq dirnam (replace-match "" t t dirnam)))
1234         (push (vector (gnus-group-full-name
1235                        (gnus-replace-in-string dirnam "/" ".") server)
1236                       (string-to-number artno)
1237                       (string-to-number score))
1238               artlist))
1239       (message "Massaging hyrex-search output...done.")
1240       (apply 'vector
1241              (sort artlist
1242                    (function (lambda (x y)
1243                                (if (string-lessp (nnir-artitem-group x)
1244                                                  (nnir-artitem-group y))
1245                                    t
1246                                  (< (nnir-artitem-number x)
1247                                     (nnir-artitem-number y)))))))
1248       )))
1249
1250 ;; Namazu interface
1251 (defun nnir-run-namazu (query server &optional group)
1252   "Run given query against Namazu.  Returns a vector of (group name, file name)
1253 pairs (also vectors, actually).
1254
1255 Tested with Namazu 2.0.6 on a GNU/Linux system."
1256   ;; (when group
1257   ;;   (error "The Namazu backend cannot search specific groups"))
1258   (save-excursion
1259     (let ((article-pattern (if (string= (gnus-group-server server) "nnmaildir")
1260                                ":[0-9]+"
1261                              "^[0-9]+$"))
1262           artlist
1263           (qstring (cdr (assq 'query query)))
1264           (prefix (nnir-read-server-parm 'nnir-namazu-remove-prefix server))
1265           score group article
1266           (process-environment (copy-sequence process-environment)))
1267       (setenv "LC_MESSAGES" "C")
1268       (set-buffer (get-buffer-create nnir-tmp-buffer))
1269       (erase-buffer)
1270       (let* ((cp-list
1271               `( ,nnir-namazu-program
1272                  nil                    ; input from /dev/null
1273                  t                      ; output
1274                  nil                    ; don't redisplay
1275                  "-q"                   ; don't be verbose
1276                  "-a"                   ; show all matches
1277                  "-s"                   ; use short format
1278                  ,@(nnir-read-server-parm 'nnir-namazu-additional-switches server)
1279                  ,qstring               ; the query, in namazu format
1280                  ,(nnir-read-server-parm 'nnir-namazu-index-directory server) ; index directory
1281                  ))
1282              (exitstatus
1283               (progn
1284                 (message "%s args: %s" nnir-namazu-program
1285                          (mapconcat 'identity (cddddr cp-list) " "))
1286                 (apply 'call-process cp-list))))
1287         (unless (or (null exitstatus)
1288                     (zerop exitstatus))
1289           (nnheader-report 'nnir "Couldn't run namazu: %s" exitstatus)
1290           ;; Namazu failure reason is in this buffer, show it if
1291           ;; the user wants it.
1292           (when (> gnus-verbose 6)
1293             (display-buffer nnir-tmp-buffer))))
1294
1295       ;; Namazu output looks something like this:
1296       ;; 2. Re: Gnus agent expire broken (score: 55)
1297       ;; /home/henrik/Mail/mail/sent/1310 (4,138 bytes)
1298
1299       (goto-char (point-min))
1300       (while (re-search-forward
1301               "^\\([0-9]+\\.\\).*\\((score: \\([0-9]+\\)\\))\n\\([^ ]+\\)"
1302               nil t)
1303         (setq score (match-string 3)
1304               group (file-name-directory (match-string 4))
1305               article (file-name-nondirectory (match-string 4)))
1306
1307         ;; make sure article and group is sane
1308         (when (and (string-match article-pattern article)
1309                    (not (null group)))
1310           (nnir-add-result group article score prefix server artlist)))
1311
1312       ;; sort artlist by score
1313       (apply 'vector
1314              (sort artlist
1315                    (function (lambda (x y)
1316                                (> (nnir-artitem-rsv x)
1317                                   (nnir-artitem-rsv y)))))))))
1318
1319 (defun nnir-run-find-grep (query server &optional grouplist)
1320   "Run find and grep to obtain matching articles."
1321   (let* ((method (gnus-server-to-method server))
1322          (sym (intern
1323                (concat (symbol-name (car method)) "-directory")))
1324          (directory (cadr (assoc sym (cddr method))))
1325          (regexp (cdr (assoc 'query query)))
1326          (grep-options (cdr (assoc 'grep-options query)))
1327          (grouplist (or grouplist (nnir-get-active server)))
1328          artlist)
1329     (unless directory
1330       (error "No directory found in method specification of server %s"
1331              server))
1332     (apply
1333      'vconcat
1334      (mapcar (lambda (x)
1335                (let ((group x))
1336                  (message "Searching %s using find-grep..."
1337                           (or group server))
1338                  (save-window-excursion
1339                    (set-buffer (get-buffer-create nnir-tmp-buffer))
1340                    (erase-buffer)
1341                    (if (> gnus-verbose 6)
1342                        (pop-to-buffer (current-buffer)))
1343                    (cd directory) ; Using relative paths simplifies
1344                                   ; postprocessing.
1345                    (let ((group
1346                           (if (not group)
1347                               "."
1348                             ;; Try accessing the group literally as
1349                             ;; well as interpreting dots as directory
1350                             ;; separators so the engine works with
1351                             ;; plain nnml as well as the Gnus Cache.
1352                             (let ((group (gnus-group-real-name group)))
1353                               ;; Replace cl-func find-if.
1354                               (if (file-directory-p group)
1355                                   group
1356                                 (if (file-directory-p
1357                                      (setq group
1358                                            (gnus-replace-in-string
1359                                             group
1360                                             "\\." "/" t)))
1361                                     group))))))
1362                      (unless group
1363                        (error "Cannot locate directory for group"))
1364                      (save-excursion
1365                        (apply
1366                         'call-process "find" nil t
1367                         "find" group "-type" "f" "-name" "[0-9]*" "-exec"
1368                         "grep"
1369                         `("-l" ,@(and grep-options
1370                                       (split-string grep-options "\\s-" t))
1371                           "-e" ,regexp "{}" "+"))))
1372
1373                    ;; Translate relative paths to group names.
1374                    (while (not (eobp))
1375                      (let* ((path (split-string
1376                                    (buffer-substring
1377                                     (point)
1378                                     (line-end-position)) "/" t))
1379                             (art (string-to-number (car (last path)))))
1380                        (while (string= "." (car path))
1381                          (setq path (cdr path)))
1382                        (let ((group (mapconcat 'identity
1383                                                ;; Replace cl-func:
1384                                                ;; (subseq path 0 -1)
1385                                                (let ((end (1- (length path)))
1386                                                      res)
1387                                                  (while
1388                                                      (>= (setq end (1- end)) 0)
1389                                                    (push (pop path) res))
1390                                                  (nreverse res))
1391                                                ".")))
1392                          (push
1393                           (vector (gnus-group-full-name group server) art 0)
1394                           artlist))
1395                        (forward-line 1)))
1396                    (message "Searching %s using find-grep...done"
1397                             (or group server))
1398                    artlist)))
1399      grouplist))))
1400
1401 (declare-function mm-url-insert "mm-url" (url &optional follow-refresh))
1402 (declare-function mm-url-encode-www-form-urlencoded "mm-url" (pairs))
1403
1404 ;; gmane interface
1405 (defun nnir-run-gmane (query srv &optional groups)
1406   "Run a search against a gmane back-end server."
1407       (let* ((case-fold-search t)
1408              (qstring (cdr (assq 'query query)))
1409              (server (cadr (gnus-server-to-method srv)))
1410              (groupspec (mapconcat
1411                          (lambda (x)
1412                            (if (gnus-string-match-p "gmane" x)
1413                                (format "group:%s" (gnus-group-short-name x))
1414                              (error "Can't search non-gmane groups: %s" x)))
1415                            groups " "))
1416              (authorspec
1417               (if (assq 'author query)
1418                   (format "author:%s" (cdr (assq 'author query))) ""))
1419              (search (format "%s %s %s"
1420                              qstring groupspec authorspec))
1421              (gnus-inhibit-demon t)
1422              artlist)
1423         (require 'mm-url)
1424         (with-current-buffer (get-buffer-create nnir-tmp-buffer)
1425           (erase-buffer)
1426           (mm-url-insert
1427            (concat
1428             "http://search.gmane.org/nov.php"
1429             "?"
1430             (mm-url-encode-www-form-urlencoded
1431              `(("query" . ,search)
1432                ("HITSPERPAGE" . "999")))))
1433           (unless (featurep 'xemacs) (set-buffer-multibyte t))
1434           (mm-decode-coding-region (point-min) (point-max) 'utf-8)
1435           (goto-char (point-min))
1436           (forward-line 1)
1437           (while (not (eobp))
1438             (unless (or (eolp) (looking-at "\x0d"))
1439               (let ((header (nnheader-parse-nov)))
1440                 (let ((xref (mail-header-xref header))
1441                       (xscore (string-to-number (cdr (assoc 'X-Score
1442                                (mail-header-extra header))))))
1443                   (when (string-match " \\([^:]+\\)[:/]\\([0-9]+\\)" xref)
1444                     (push
1445                      (vector
1446                       (gnus-group-prefixed-name (match-string 1 xref) srv)
1447                       (string-to-number (match-string 2 xref)) xscore)
1448                      artlist)))))
1449             (forward-line 1)))
1450         (apply 'vector (nreverse (mm-delete-duplicates artlist)))))
1451
1452 ;;; Util Code:
1453
1454 (defun nnir-read-parms (query nnir-search-engine)
1455   "Reads additional search parameters according to `nnir-engines'."
1456   (let ((parmspec (caddr (assoc nnir-search-engine nnir-engines))))
1457     (append query
1458            (mapcar 'nnir-read-parm parmspec))))
1459
1460 (defun nnir-read-parm (parmspec)
1461   "Reads a single search parameter.
1462 `parmspec' is a cons cell, the car is a symbol, the cdr is a prompt."
1463   (let ((sym (car parmspec))
1464         (prompt (cdr parmspec)))
1465     (if (listp prompt)
1466         (let* ((result (apply 'gnus-completing-read prompt))
1467                (mapping (or (assoc result nnir-imap-search-arguments)
1468                             (cons nil nnir-imap-search-other))))
1469           (cons sym (format (cdr mapping) result)))
1470       (cons sym (read-string prompt)))))
1471
1472 (autoload 'gnus-group-topic-name "gnus-topic")
1473
1474 (defun nnir-run-query (query nserver)
1475   "Invoke appropriate search engine function (see `nnir-engines').
1476   If some groups were process-marked, run the query for each of the groups
1477   and concat the results."
1478   (let ((q (car (read-from-string query)))
1479         (groups (if (string= "all-ephemeral" nserver)
1480                     (with-current-buffer gnus-server-buffer
1481                       (list (list (gnus-server-server-name))))
1482                   (nnir-categorize
1483                    (or gnus-group-marked
1484                        (if (gnus-group-group-name)
1485                            (list (gnus-group-group-name))
1486                          (cdr (assoc (gnus-group-topic-name)
1487                                      gnus-topic-alist))))
1488                    gnus-group-server))))
1489     (apply 'vconcat
1490            (mapcar
1491             (lambda (x)
1492               (let* ((server (car x))
1493                      (nnir-search-engine
1494                       (or (nnir-read-server-parm 'nnir-search-engine
1495                                                  server)
1496                           (cdr (assoc (car
1497                                        (gnus-server-to-method server))
1498                                       nnir-method-default-engines))))
1499                      search-func)
1500                 (setq search-func (cadr (assoc nnir-search-engine
1501                                                nnir-engines)))
1502                 (if search-func
1503                     (funcall search-func
1504                              (if nnir-extra-parms
1505                                  (nnir-read-parms q nnir-search-engine)
1506                                q)
1507                              server (cadr x))
1508                   nil)))
1509             groups))))
1510
1511 (defun nnir-read-server-parm (key server)
1512   "Returns the parameter value of key for the given server, where
1513 server is of form 'backend:name'."
1514   (let ((method (gnus-server-to-method server)))
1515     (cond ((and method (assq key (cddr method)))
1516            (nth 1 (assq key (cddr method))))
1517           (t nil))))
1518
1519 (defun nnir-possibly-change-server (server)
1520   (unless (and server (nnir-server-opened server))
1521     (nnir-open-server server)))
1522
1523
1524
1525 ;; unused?
1526 (defun nnir-artlist-groups (artlist)
1527   "Returns a list of all groups in the given ARTLIST."
1528   (let ((res nil)
1529         (with-dups nil))
1530     ;; from each artitem, extract group component
1531     (setq with-dups (mapcar 'nnir-artitem-group artlist))
1532     ;; remove duplicates from above
1533     (mapc (function (lambda (x) (add-to-list 'res x)))
1534             with-dups)
1535     res))
1536
1537 (defun nnir-get-active (srv)
1538   (let ((method (gnus-server-to-method srv))
1539         groups)
1540     (gnus-request-list method)
1541     (with-current-buffer nntp-server-buffer
1542       (let ((cur (current-buffer))
1543             name)
1544         (goto-char (point-min))
1545         (unless (or (null nnir-ignored-newsgroups)
1546                     (string= nnir-ignored-newsgroups ""))
1547           (delete-matching-lines nnir-ignored-newsgroups))
1548         (if (eq (car method) 'nntp)
1549             (while (not (eobp))
1550               (ignore-errors
1551                 (push (mm-string-as-unibyte
1552                        (gnus-group-full-name
1553                         (buffer-substring
1554                          (point)
1555                          (progn
1556                            (skip-chars-forward "^ \t")
1557                            (point))) method))
1558                       groups))
1559               (forward-line))
1560           (while (not (eobp))
1561             (ignore-errors
1562               (push (mm-string-as-unibyte
1563                      (if (eq (char-after) ?\")
1564                          (gnus-group-full-name (read cur) method)
1565                        (let ((p (point)) (name ""))
1566                          (skip-chars-forward "^ \t\\\\")
1567                          (setq name (buffer-substring p (point)))
1568                          (while (eq (char-after) ?\\)
1569                            (setq p (1+ (point)))
1570                            (forward-char 2)
1571                            (skip-chars-forward "^ \t\\\\")
1572                            (setq name (concat name (buffer-substring
1573                                                     p (point)))))
1574                          (gnus-group-full-name name method))))
1575                     groups))
1576             (forward-line)))))
1577     groups))
1578
1579 (defun nnir-registry-action (action data-header from &optional to method)
1580   "Call `gnus-registry-action' with the original article group."
1581   (gnus-registry-action
1582    action
1583    data-header
1584    (nnir-article-group (mail-header-number data-header))
1585    to
1586    method))
1587
1588 (defun nnir-mode ()
1589   (when (eq (car (gnus-find-method-for-group gnus-newsgroup-name)) 'nnir)
1590     (setq gnus-summary-line-format
1591           (or nnir-summary-line-format gnus-summary-line-format))
1592     (when (and (boundp 'gnus-registry-install)
1593                        (eq gnus-registry-install t))
1594       (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action t)
1595       (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action t)
1596       (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action t)
1597       (add-hook 'gnus-summary-article-delete-hook 'nnir-registry-action t t)
1598       (add-hook 'gnus-summary-article-move-hook 'nnir-registry-action t t)
1599       (add-hook 'gnus-summary-article-expire-hook 'nnir-registry-action t t))))
1600
1601
1602
1603 ;; The end.
1604 (provide 'nnir)
1605
1606 ;;; nnir.el ends here