git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-namazu.el

   1 ;;; gnus-namazu.el --- Search mail with Namazu. -*- coding: iso-2022-7bit; -*-
   2
   3 ;; Copyright (C) 2000,2001,2002 TSUCHIYA Masatoshi <tsuchiya@namazu.org>
   4
   5 ;; Author: TSUCHIYA Masatoshi <tsuchiya@namazu.org>
   6 ;; Keywords: mail searching namazu
   7
   8 ;; This file is a part of Semi-Gnus.
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program; if not, you can either send email to this
  22 ;; program's maintainer or write to: The Free Software Foundation,
  23 ;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.
  24
  25
  26 ;;; Commentary:
  27
  28 ;; This file defines the command to search mails and persistent
  29 ;; articles with Namazu and to browse its results with Gnus.
  30 ;;
  31 ;; Namazu is a full-text search engine intended for easy use.  For
  32 ;; more detail about Namazu, visit the following page:
  33 ;;
  34 ;;     http://namazu.org/
  35
  36
  37 ;;; Quick Start:
  38
  39 ;; If this module has already been installed, only 3 steps are
  40 ;; required to search articles.
  41 ;;
  42 ;;   (1) Install Namazu.
  43 ;;   (2) Start Gnus and type M-x gnus-namazu-make-index RET to make
  44 ;;       index of articles.
  45 ;;   (3) In group buffer or in summary buffer, type C-c C-n query RET.
  46
  47
  48 ;;; Install:
  49
  50 ;; Before installing this module, you must install Namazu.
  51 ;;
  52 ;; This file is a part of T-gnus but is not *YET* a part of Gnus.
  53 ;; When you would like to use this module in Gnus (not T-gnus), put
  54 ;; this file into the lisp/ directory in the Gnus source tree and run
  55 ;; `make install'.  And then, put the following expression into your
  56 ;; ~/.gnus.
  57 ;;
  58 ;;      (gnus-namazu-insinuate)
  59 ;;
  60 ;; In order to make index of articles with Namazu before using this
  61 ;; module, type M-x gnus-namazu-make-index RET.  Otherwise, you can
  62 ;; create index by yourself with the following commands:
  63 ;;
  64 ;;      % mkdir ~/News/namazu
  65 ;;      % mknmz -a -h -O ~/News/namazu ~/Mail ~/News/cache
  66 ;;
  67 ;; The first command makes the directory for index files, and the
  68 ;; second command generates index files of mails and persistent
  69 ;; articles.
  70 ;;
  71 ;; In order to update index for incoming articles, this module
  72 ;; automatically runs mknmz at an interval of 3 days, which is decided
  73 ;; by the value of `gnus-namazu-make-index-interval'.  If you want to
  74 ;; control mknmz closely, you can disable this feature and run mknmz
  75 ;; by yourself.  In this case, set nil to the above option.
  76 ;;
  77 ;;      (setq gnus-namazu-make-index-interval nil)
  78 ;;
  79 ;; When you put index into the directory other than the default one
  80 ;; (~/News/namazu), it is necessary to set the place to
  81 ;; `gnus-namazu-index-directories' as follows:
  82 ;;
  83 ;;      (setq gnus-namazu-index-directories
  84 ;;            (list (expand-file-name "~/namazu")))
  85 ;;
  86 ;; In this case, the feature to update index may be disabled.  So, you
  87 ;; should check the value of `gnus-namazu-make-index-interval'
  88 ;; whenever `gnus-namazu-index-directories' is modified.
  89
  90
  91 ;;; Code:
  92
  93 (eval-when-compile (require 'cl))
  94 (require 'nnoo)
  95 (require 'nnheader)
  96 (require 'nnmail)
  97 (require 'gnus-sum)
  98
  99 ;; It is required for Mule 2.3.  See the file Mule23@1934.en.
 100 (eval-and-compile
 101   (autoload 'regexp-opt "regexp-opt"))
 102
 103 ;; To suppress byte-compile warning.
 104 (eval-when-compile
 105   (defvar nnml-directory)
 106   (defvar nnmh-directory))
 107
 108
 109 (defgroup gnus-namazu nil
 110   "Search nnmh and nnml groups in Gnus with Namazu."
 111   :group 'namazu
 112   :group 'gnus
 113   :prefix "gnus-namazu-")
 114
 115 (defconst gnus-namazu-default-index-directory
 116   (expand-file-name "namazu" gnus-directory)
 117   "Default place of Namazu index files.")
 118
 119 (defcustom gnus-namazu-index-directories
 120   (list
 121    (or (and (boundp 'gnus-namazu-index-directory)
 122             (symbol-value 'gnus-namazu-index-directory))
 123        (and (boundp 'nnir-namazu-index-directory)
 124             (symbol-value 'nnir-namazu-index-directory))
 125        (and (boundp 'gnus-namazu-index-directory)
 126             (symbol-value 'gnus-namazu-index-directory))
 127        gnus-namazu-default-index-directory))
 128   "*Places of Namazu index files."
 129   :type '(repeat directory)
 130   :group 'gnus-namazu)
 131
 132 (defcustom gnus-namazu-command
 133   (or (and (boundp 'namazu-command)
 134            (symbol-value 'namazu-command))
 135       (and (boundp 'nnir-namazu-program)
 136            (symbol-value 'nnir-namazu-program))
 137       "namazu")
 138   "*Name of the executable file of Namazu."
 139   :type 'string
 140   :group 'gnus-namazu)
 141
 142 (defcustom gnus-namazu-additional-arguments nil
 143   "*Additional arguments of Namazu.
 144 The options `-q', `-a', and `-l' are always used, very few other
 145 options make any sense in this context."
 146   :type '(repeat string)
 147   :group 'gnus-namazu)
 148
 149 (defcustom gnus-namazu-make-index-interval
 150   (when (member gnus-namazu-default-index-directory
 151                 gnus-namazu-index-directories)
 152     259200) ;; 3 days == 259200 seconds.
 153   "*Number of seconds between running the indexer of Namazu."
 154   :type '(choice (const :tag "Never run the indexer" nil)
 155                  (integer :tag "Number of seconds"))
 156   :group 'gnus-namazu)
 157
 158 (defcustom gnus-namazu-make-index-command "mknmz"
 159   "*Name of the executable file of the indexer of Namazu."
 160   :type 'string
 161   :group 'gnus-namazu)
 162
 163 (defcustom gnus-namazu-make-index-arguments
 164   (nconc
 165    (list "--all" "--mailnews" "--deny=^.*[^0-9].*$")
 166    (when (or (and (boundp 'current-language-environment)
 167                   (string= "Japanese"
 168                            (symbol-value 'current-language-environment)))
 169              (boundp 'MULE))
 170      (list "--indexing-lang=ja")))
 171   "*Arguments of the indexer of Namazu."
 172   :type '(repeat string)
 173   :group 'gnus-namazu)
 174
 175 (defcustom gnus-namazu-field-keywords
 176   '("date" "from" "newsgroups" "size" "subject" "summary" "to" "uri")
 177   "*List of keywords to do field-search."
 178   :type '(repeat string)
 179   :group 'gnus-namazu)
 180
 181 (defcustom gnus-namazu-coding-system
 182   (if (memq system-type '(windows-nt OS/2 emx))
 183       (if (boundp 'MULE) '*sjis* 'shift_jis)
 184     (if (boundp 'MULE) '*euc-japan* 'euc-japan))
 185   "*Coding system for Namazu process."
 186   :type 'coding-system
 187   :group 'gnus-namazu)
 188
 189 (defcustom gnus-namazu-need-path-normalization
 190   (eq system-type 'windows-nt)
 191   "*Non-nil means that outputs of namazu may contain a not normalized path."
 192   :type 'boolean
 193   :group 'gnus-namazu)
 194
 195 (defcustom gnus-namazu-case-sensitive-filesystem
 196   (not (eq system-type 'windows-nt))
 197   "*Non-nil means that the using file system distinguishes cases of characters."
 198   :type 'boolean
 199   :group 'gnus-namazu)
 200
 201 (defcustom gnus-namazu-query-highlight t
 202   "Non-nil means that queried words is highlighted."
 203   :type 'boolean
 204   :group 'gnus-namazu)
 205
 206 (defface gnus-namazu-query-highlight-face
 207   '((((type tty pc) (class color))
 208      (:background "magenta4" :foreground "cyan1"))
 209     (((class color) (background light))
 210      (:background "magenta4" :foreground "lightskyblue1"))
 211     (((class color) (background dark))
 212      (:background "palevioletred2" :foreground "brown4"))
 213     (t (:inverse-video t)))
 214   "Face used for namazu query matching words."
 215   :group 'gnus-namazu)
 216
 217 ;;; Internal Variable:
 218 (defconst gnus-namazu/group-name-regexp "\\`nnvirtual:namazu-search\\?")
 219
 220 ;; Multibyte group name:
 221 (and
 222  (fboundp 'gnus-group-decoded-name)
 223  (let ((gnus-group-name-charset-group-alist
 224         (list (cons gnus-namazu/group-name-regexp gnus-namazu-coding-system)))
 225        (query (decode-coding-string
 226                (string 27 36 66 52 65 59 122 27 40 66)
 227                (if (boundp 'MULE) '*iso-2022-jp* 'iso-2022-7bit))))
 228    (not (string-match query
 229                       (gnus-summary-buffer-name
 230                        (encode-coding-string
 231                         (concat "nnvirtual:namazu-search?query=" query)
 232                         gnus-namazu-coding-system)))))
 233  (let (current-load-list)
 234    (defadvice gnus-summary-buffer-name
 235      (before gnus-namazu-summary-buffer-name activate compile)
 236      "Advised by `gnus-namazu' to handle encoded group names."
 237      (ad-set-arg 0 (gnus-group-decoded-name (ad-get-arg 0))))))
 238
 239 (defmacro gnus-namazu/make-article (group number)
 240   `(cons ,group ,number))
 241 (defmacro gnus-namazu/article-group  (x) `(car ,x))
 242 (defmacro gnus-namazu/article-number (x) `(cdr ,x))
 243
 244 (defsubst gnus-namazu/indexed-servers ()
 245   "Choice appropriate servers from opened ones, and return thier list."
 246   (append
 247    (gnus-servers-using-backend 'nnml)
 248    (gnus-servers-using-backend 'nnmh)))
 249
 250 (defsubst gnus-namazu/default-index-directory ()
 251   (if (member gnus-namazu-default-index-directory
 252               gnus-namazu-index-directories)
 253       gnus-namazu-default-index-directory
 254     (car gnus-namazu-index-directories)))
 255
 256 (defun gnus-namazu/setup ()
 257   (and (boundp 'gnus-group-name-charset-group-alist)
 258        (not (member (cons gnus-namazu/group-name-regexp
 259                           gnus-namazu-coding-system)
 260                     gnus-group-name-charset-group-alist))
 261        (let ((pair (assoc gnus-namazu/group-name-regexp
 262                           gnus-group-name-charset-group-alist)))
 263          (if pair
 264              (setcdr pair gnus-namazu-coding-system)
 265            (push (cons gnus-namazu/group-name-regexp
 266                        gnus-namazu-coding-system)
 267                  gnus-group-name-charset-group-alist))))
 268   (gnus-namazu-make-index (gnus-namazu/default-index-directory)))
 269
 270 (defun gnus-namazu/server-directory (server)
 271   "Return the top directory of the server SERVER."
 272   (and (memq (car server) '(nnml nnmh))
 273        (nnoo-change-server (car server) (nth 1 server) (nthcdr 2 server))
 274        (file-name-as-directory
 275         (expand-file-name (if (eq 'nnml (car server))
 276                               nnml-directory
 277                             nnmh-directory)))))
 278
 279 ;;; Functions to call Namazu.
 280 (defsubst gnus-namazu/normalize-results ()
 281   "Normalize file names returned by Namazu in this current buffer."
 282   (goto-char (point-min))
 283   (while (not (eobp))
 284     (when (if gnus-namazu-need-path-normalization
 285               (or (not (looking-at "/\\(.\\)|/"))
 286                   (replace-match "\\1:/"))
 287             (eq ?~ (char-after (point))))
 288       (insert (expand-file-name
 289                (buffer-substring (gnus-point-at-bol) (gnus-point-at-eol))))
 290       (delete-region (point) (gnus-point-at-eol)))
 291     (forward-line 1)))
 292
 293 (defsubst gnus-namazu/call-namazu (query)
 294   (let ((coding-system-for-read gnus-namazu-coding-system)
 295         (coding-system-for-write gnus-namazu-coding-system)
 296         (input-coding-system gnus-namazu-coding-system)
 297         (output-coding-system gnus-namazu-coding-system)
 298         (default-process-coding-system
 299           (cons gnus-namazu-coding-system gnus-namazu-coding-system))
 300         program-coding-system-alist
 301         (file-name-coding-system gnus-namazu-coding-system)
 302         (pathname-coding-system gnus-namazu-coding-system))
 303     (apply 'call-process
 304            `(,gnus-namazu-command
 305              nil                        ; input from /dev/null
 306              t                          ; output
 307              nil                        ; don't redisplay
 308              "-q"                       ; don't be verbose
 309              "-a"                       ; show all matches
 310              "-l"                       ; use list format
 311              ,@gnus-namazu-additional-arguments
 312              ,query
 313              ,@gnus-namazu-index-directories))))
 314
 315 (defsubst gnus-namazu/group-prefixed-name (group method)
 316   "Return the whole name from GROUP and METHOD."
 317   (if gnus-namazu-case-sensitive-filesystem
 318       (gnus-group-prefixed-name group method)
 319     (let* ((orig (gnus-group-prefixed-name group method))
 320            (name (downcase orig)))
 321       (catch 'found-group
 322         (mapatoms (lambda (sym)
 323                     (when (string= name (downcase (symbol-name sym)))
 324                       (throw 'found-group (symbol-name sym))))
 325                   gnus-newsrc-hashtb)
 326         orig))))
 327
 328 (defun gnus-namazu/real-group-name (cond str)
 329   "Generate the real group name from the partial path, STR."
 330   (if cond
 331       str
 332     (catch 'found-group
 333       (dolist (group (gnus-namazu/possible-real-groups
 334                       (nnheader-replace-chars-in-string str ?/ ?.)))
 335         (when (gnus-gethash group gnus-newsrc-hashtb)
 336           (throw 'found-group group))))))
 337
 338 (defun gnus-namazu/possible-real-groups (str)
 339   "Regard the string STR as the partial path of the cached article and
 340 generate possible group names from it."
 341   (if (string-match "_\\(_\\(_\\)?\\)?" str)
 342       (let ((prefix (substring str 0 (match-beginning 0)))
 343             (suffix (substring str (match-end 0))))
 344         (cond
 345          ((match-beginning 2) ;; The number of discoverd underscores = 3
 346           (nconc
 347            (gnus-namazu/possible-real-groups (concat prefix "/__" suffix))
 348            (gnus-namazu/possible-real-groups (concat prefix ".._" suffix))))
 349          ((match-beginning 1) ;; The number of discoverd underscores = 2
 350           (nconc
 351            (gnus-namazu/possible-real-groups (concat prefix "//" suffix))
 352            (gnus-namazu/possible-real-groups (concat prefix ".." suffix))))
 353          (t ;; The number of discoverd underscores = 1
 354           (gnus-namazu/possible-real-groups (concat prefix "/" suffix)))))
 355     (if (string-match "\\." str)
 356         ;; Handle the first occurence of period.
 357         (list (concat (substring str 0 (match-beginning 0))
 358                       ":"
 359                       (substring str (match-end 0)))
 360               str)
 361       (list str))))
 362
 363 (defun gnus-namazu/search (groups query)
 364   (with-temp-buffer
 365     (let ((exit-status (gnus-namazu/call-namazu query)))
 366       (unless (zerop exit-status)
 367         (error "Namazu finished abnormally: %d" exit-status))
 368       (let* ((articles)
 369              (server-alist
 370               (delq nil
 371                     (let (dir)
 372                       (mapcar
 373                        (lambda (s)
 374                          (when (setq dir (gnus-namazu/server-directory s))
 375                            (cons (file-name-as-directory dir) s)))
 376                        (gnus-namazu/indexed-servers)))))
 377              (topdir-regexp (regexp-opt (mapcar 'car server-alist)))
 378              (cache-regexp (concat
 379                             (regexp-quote
 380                              (file-name-as-directory
 381                               (expand-file-name gnus-cache-directory)))
 382                             "\\(.*\\)/\\([0-9]+\\)$"))
 383              (agent-regexp (concat
 384                             (regexp-quote
 385                              (file-name-as-directory
 386                               (expand-file-name gnus-agent-directory)))
 387                             "\\(.*\\)/\\([0-9]+\\)$")))
 388         (gnus-namazu/normalize-results)
 389         (goto-char (point-min))
 390         (while (not (eobp))
 391           (let (server group file)
 392             (and (or
 393                   ;; Check the discoverd file is the persistent article.
 394                   (and (looking-at cache-regexp)
 395                        (setq file (match-string-no-properties 2)
 396                              group (gnus-namazu/real-group-name
 397                                     (gnus-use-long-file-name 'not-cache)
 398                                     (match-string-no-properties 1))))
 399                   ;; Check the discoverd file is covered by the agent.
 400                   (and (looking-at agent-regexp)
 401                        (setq file (match-string-no-properties 2)
 402                              group (gnus-namazu/real-group-name
 403                                     nnmail-use-long-file-names
 404                                     (match-string-no-properties 1))))
 405                   ;; Check the discovered file is managed by Gnus servers.
 406                   (and (looking-at topdir-regexp)
 407                        (setq file (buffer-substring-no-properties
 408                                    (match-end 0) (gnus-point-at-eol))
 409                              server (cdr (assoc (match-string-no-properties 0)
 410                                                 server-alist)))
 411                        ;; Check validity of the file name.
 412                        (string-match "/\\([0-9]+\\)\\'" file)
 413                        (progn
 414                          (setq group (substring file 0 (match-beginning 0))
 415                                file (match-string 1 file))
 416                          (setq group
 417                                (gnus-namazu/group-prefixed-name
 418                                 (if nnmail-use-long-file-names
 419                                     group
 420                                   (nnheader-replace-chars-in-string group
 421                                                                     ?/ ?.))
 422                                 server)))))
 423                  (or (not groups)
 424                      (member group groups))
 425                  (push (gnus-namazu/make-article group (string-to-number file))
 426                        articles)))
 427           (forward-line 1))
 428         (nreverse articles)))))
 429
 430
 431 ;;; User Interface:
 432 (defun gnus-namazu/get-target-groups ()
 433   (cond
 434    ((eq major-mode 'gnus-group-mode)
 435     ;; In Group buffer.
 436     (cond
 437      (current-prefix-arg
 438       (gnus-group-process-prefix current-prefix-arg))
 439      (gnus-group-marked
 440       (prog1 gnus-group-marked (gnus-group-unmark-all-groups)))))
 441    ((eq major-mode 'gnus-summary-mode)
 442     ;; In Summary buffer.
 443     (if current-prefix-arg
 444         (list (gnus-read-group "Group: "))
 445       (if (and
 446            (gnus-ephemeral-group-p gnus-newsgroup-name)
 447            (string-match gnus-namazu/group-name-regexp gnus-newsgroup-name))
 448           (cadr (assq 'gnus-namazu-target-groups
 449                       (gnus-info-method (gnus-get-info gnus-newsgroup-name))))
 450         (list gnus-newsgroup-name))))))
 451
 452 (defun gnus-namazu/get-current-query ()
 453   (and (eq major-mode 'gnus-summary-mode)
 454        (gnus-ephemeral-group-p gnus-newsgroup-name)
 455        (string-match gnus-namazu/group-name-regexp gnus-newsgroup-name)
 456        (cadr (assq 'gnus-namazu-current-query
 457                    (gnus-info-method (gnus-get-info gnus-newsgroup-name))))))
 458
 459 (defvar gnus-namazu/read-query-original-buffer nil)
 460 (defvar gnus-namazu/read-query-prompt nil)
 461 (defvar gnus-namazu/read-query-history nil)
 462
 463 (defun gnus-namazu/get-current-subject ()
 464   (and gnus-namazu/read-query-original-buffer
 465        (bufferp gnus-namazu/read-query-original-buffer)
 466        (with-current-buffer gnus-namazu/read-query-original-buffer
 467          (when (eq major-mode 'gnus-summary-mode)
 468            (let ((s (gnus-summary-article-subject)))
 469              ;; Remove typically prefixes of mailing lists.
 470              (when (string-match
 471                     "^\\(\\[[^]]*[0-9]+\\]\\|([^)]*[0-9]+)\\)\\s-*" s)
 472                (setq s (substring s (match-end 0))))
 473              (when (string-match
 474                     "^\\(Re\\(\\^?\\([0-9]+\\|\\[[0-9]+\\]\\)\\)?:\\s-*\\)+" s)
 475                (setq s (substring s (match-end 0))))
 476              (when (string-match "\\s-*(\\(re\\|was\\)\\b" s)
 477                (setq s (substring s 0 (match-beginning 0))))
 478              s)))))
 479
 480 (defun gnus-namazu/get-current-from ()
 481   (and gnus-namazu/read-query-original-buffer
 482        (bufferp gnus-namazu/read-query-original-buffer)
 483        (with-current-buffer gnus-namazu/read-query-original-buffer
 484          (when (eq major-mode 'gnus-summary-mode)
 485            (cadr (mail-extract-address-components
 486                   (mail-header-from
 487                    (gnus-summary-article-header))))))))
 488
 489 (defun gnus-namazu/get-current-to ()
 490   (and gnus-namazu/read-query-original-buffer
 491        (bufferp gnus-namazu/read-query-original-buffer)
 492        (with-current-buffer gnus-namazu/read-query-original-buffer
 493          (when (eq major-mode 'gnus-summary-mode)
 494            (cadr (mail-extract-address-components
 495                   (cdr (assq 'To (mail-header-extra
 496                                   (gnus-summary-article-header))))))))))
 497
 498 (defmacro gnus-namazu/minibuffer-prompt-end ()
 499   (if (fboundp 'minibuffer-prompt-end)
 500       '(minibuffer-prompt-end)
 501     '(point-min)))
 502
 503 (defun gnus-namazu/message (string &rest arguments)
 504   (let* ((s1 (concat
 505               gnus-namazu/read-query-prompt
 506               (buffer-substring (gnus-namazu/minibuffer-prompt-end)
 507                                 (point-max))))
 508          (s2 (apply (function format) string arguments))
 509          (w (- (window-width)
 510                (string-width s1)
 511                (string-width s2)
 512                1)))
 513     (message (if (>= w 0)
 514                  (concat s1 (make-string w ?\ ) s2)
 515                s2))
 516     (if (sit-for 0.3) (message s1))
 517     s2))
 518
 519 (defun gnus-namazu/complete-query ()
 520   (interactive)
 521   (let ((pos (point)))
 522     (cond
 523      ((and (re-search-backward "\\+\\([-a-z]*\\)" nil t)
 524            (= pos (match-end 0)))
 525       (let* ((partial (match-string 1))
 526              (completions
 527               (all-completions
 528                partial
 529                (mapcar 'list gnus-namazu-field-keywords))))
 530         (cond
 531          ((null completions)
 532           (gnus-namazu/message "No completions of %s" partial))
 533          ((= 1 (length completions))
 534           (goto-char (match-beginning 1))
 535           (delete-region (match-beginning 1) (match-end 1))
 536           (insert (car completions) ":")
 537           (setq pos (point))
 538           (gnus-namazu/message "Completed"))
 539          (t
 540           (let ((x (try-completion partial (mapcar 'list completions))))
 541             (if (string= x partial)
 542                 (if (and (eq last-command
 543                              'gnus-namazu/field-keyword-completion)
 544                          completion-auto-help)
 545                     (with-output-to-temp-buffer "*Completions*"
 546                       (display-completion-list completions))
 547                   (gnus-namazu/message "Sole completion"))
 548               (goto-char (match-beginning 1))
 549               (delete-region (match-beginning 1) (match-end 1))
 550               (insert x)
 551               (setq pos (point))))))))
 552      ((and (looking-at "\\+subject:")
 553            (= pos (match-end 0)))
 554       (let ((s (gnus-namazu/get-current-subject)))
 555         (when s
 556           (goto-char pos)
 557           (insert "\"" s "\"")
 558           (setq pos (point)))))
 559      ((and (looking-at "\\+from:")
 560            (= pos (match-end 0)))
 561       (let ((f (gnus-namazu/get-current-from)))
 562         (when f
 563           (goto-char pos)
 564           (insert "\"" f "\"")
 565           (setq pos (point)))))
 566      ((and (looking-at "\\+to:")
 567            (= pos (match-end 0)))
 568       (let ((to (gnus-namazu/get-current-to)))
 569         (when to
 570           (goto-char pos)
 571           (insert "\"" to "\"")
 572           (setq pos (point))))))
 573     (goto-char pos)))
 574
 575 (defvar gnus-namazu/read-query-map
 576   (let ((keymap (copy-keymap minibuffer-local-map)))
 577     (define-key keymap "\t" 'gnus-namazu/complete-query)
 578     keymap))
 579
 580 (defun gnus-namazu/read-query (prompt &optional initial)
 581   (let ((gnus-namazu/read-query-original-buffer (current-buffer))
 582         (gnus-namazu/read-query-prompt prompt))
 583     (unless initial
 584       (when (setq initial (gnus-namazu/get-current-query))
 585         (setq initial (cons initial 0))))
 586     (read-from-minibuffer prompt initial gnus-namazu/read-query-map nil
 587                           'gnus-namazu/read-query-history)))
 588
 589 (defun gnus-namazu/highlight-words (query)
 590   (with-temp-buffer
 591     (insert " " query)
 592     ;; Remove tokens for NOT search
 593     (goto-char (point-min))
 594     (while (re-search-forward "[\e$B!!\e(B \t\r\f\n]+not[\e$B!!\e(B \t\r\f\n]+\
 595 \\([^\e$B!!\e(B \t\r\f\n\"{(/]+\\|\"[^\"]+\"\\|{[^}]+}\\|([^)]+)\\|/[^/]+/\\)+" nil t)
 596       (delete-region (match-beginning 0) (match-end 0)))
 597     ;; Remove tokens for Field search
 598     (goto-char (point-min))
 599     (while (re-search-forward "[\e$B!!\e(B \t\r\f\n]+\\+[^\e$B!!\e(B \t\r\f\n:]+:\
 600 \\([^\e$B!!\e(B \t\r\f\n\"{(/]+\\|\"[^\"]+\"\\|{[^}]+}\\|([^)]+)\\|/[^/]+/\\)+" nil t)
 601       (delete-region (match-beginning 0) (match-end 0)))
 602     ;; Remove tokens for Regexp search
 603     (goto-char (point-min))
 604     (while (re-search-forward "/[^/]+/" nil t)
 605       (delete-region (match-beginning 0) (match-end 0)))
 606     ;; Remove brackets, double quote, asterisk and operators
 607     (goto-char (point-min))
 608     (while (re-search-forward "\\([(){}\"*]\\|\\b\\(and\\|or\\)\\b\\)" nil t)
 609       (delete-region (match-beginning 0) (match-end 0)))
 610     ;; Collect all keywords
 611     (setq query nil)
 612     (goto-char (point-min))
 613     (while (re-search-forward "[^\e$B!!\e(B \t\r\f\n]+" nil t)
 614       (push (match-string 0) query))
 615     (when query
 616       (list (list (regexp-opt query)
 617                   0 0 'gnus-namazu-query-highlight-face)))))
 618
 619 (defun gnus-namazu/truncate-article-list (articles)
 620   (let ((hit (length articles)))
 621     (when (and gnus-large-newsgroup
 622                (> hit gnus-large-newsgroup))
 623       (let* ((cursor-in-echo-area nil)
 624              (input (read-from-minibuffer
 625                      (format "\
 626 Too many articles were retrieved.  How many articles (max %d): "
 627                              hit)
 628                      (cons (number-to-string gnus-large-newsgroup) 0))))
 629         (unless (string-match "\\`[ \t]*\\'" input)
 630           (setcdr (nthcdr (min (1- (string-to-number input)) hit) articles)
 631                   nil)))))
 632   articles)
 633
 634 ;;;###autoload
 635 (defun gnus-namazu-search (groups query)
 636   "Search QUERY through GROUPS with Namazu,
 637 and make a virtual group contains its results."
 638   (interactive
 639    (list
 640     (gnus-namazu/get-target-groups)
 641     (gnus-namazu/read-query "Enter query: ")))
 642   (gnus-namazu/setup)
 643   (let ((articles (gnus-namazu/search groups query)))
 644     (if articles
 645         (let ((real-groups groups)
 646               (vgroup
 647                (apply (function format)
 648                       "nnvirtual:namazu-search?query=%s&groups=%s&id=%d%d%d"
 649                       query
 650                       (if groups (mapconcat 'identity groups ",") "ALL")
 651                       (current-time))))
 652           (gnus-namazu/truncate-article-list articles)
 653           (unless real-groups
 654             (dolist (a articles)
 655               (add-to-list 'real-groups (gnus-namazu/article-group a))))
 656           ;; Generate virtual group which includes all results.
 657           (when (fboundp 'gnus-group-decoded-name)
 658             (setq vgroup
 659                   (encode-coding-string vgroup gnus-namazu-coding-system)))
 660           (setq vgroup
 661                 (gnus-group-read-ephemeral-group
 662                  vgroup
 663                  `(nnvirtual ,vgroup
 664                              (nnvirtual-component-groups ,real-groups)
 665                              (gnus-namazu-target-groups ,groups)
 666                              (gnus-namazu-current-query ,query))
 667                  t (cons (current-buffer) (current-window-configuration)) t))
 668           (when gnus-namazu-query-highlight
 669             (gnus-group-set-parameter vgroup 'highlight-words
 670                                       (gnus-namazu/highlight-words query)))
 671           ;; Generate new summary buffer which contains search results.
 672           (gnus-group-read-group
 673            t t vgroup
 674            (sort (delq nil ;; Ad-hoc fix, to avoid wrong-type-argument error.
 675                        (mapcar
 676                         (lambda (a)
 677                           (nnvirtual-reverse-map-article
 678                            (gnus-namazu/article-group a)
 679                            (gnus-namazu/article-number a)))
 680                         articles))
 681                  '<)))
 682       (message "No entry."))))
 683
 684 (defun gnus-namazu/lapse-seconds (start end)
 685   "Return lapse seconds from START to END.
 686 START and END are lists which represent time in Emacs-style."
 687   (+ (* (- (car end) (car start)) 65536)
 688      (cadr end)
 689      (- (cadr start))))
 690
 691 (defvar gnus-namazu/mknmz-process nil)
 692
 693 (defmacro gnus-namazu/lock-file-name (&optional directory)
 694   `(expand-file-name "NMZ.lock2" ,directory))
 695
 696 (defmacro gnus-namazu/index-file-name (&optional directory)
 697   `(expand-file-name "NMZ.i" ,directory))
 698
 699 (defun gnus-namazu/mknmz-sentinel (process event)
 700   (let ((buffer (process-buffer process)))
 701     (when (buffer-name buffer)
 702       (with-current-buffer buffer
 703         (let ((lockfile (gnus-namazu/lock-file-name)))
 704           (cond
 705            ((file-exists-p lockfile)
 706             (delete-file lockfile)
 707             (dolist (tmpfile (directory-files default-directory t
 708                                               "\\`NMZ\\..*\\.tmp\\'" t))
 709               (delete-file tmpfile)))
 710            ((and (eq 'exit (process-status process))
 711                  (zerop (process-exit-status process)))
 712             (message "Make indices of Namazu...done")))))
 713       (unless (or debug-on-error debug-on-quit)
 714         (kill-buffer buffer))))
 715   (setq gnus-namazu/mknmz-process nil))
 716
 717 ;;;###autoload
 718 (defun gnus-namazu-make-index (directory &optional target-directories force)
 719   "Make indices of Namazu under DIRECTORY."
 720   (interactive
 721    (list
 722     (if (and current-prefix-arg (> (length gnus-namazu-index-directories) 1))
 723         (completing-read "Directory: "
 724                          (mapcar 'list gnus-namazu-index-directories) nil t)
 725       (gnus-namazu/default-index-directory))
 726     nil t))
 727   (setq directory (file-name-as-directory directory))
 728   (unless target-directories
 729     (setq target-directories
 730           (delq nil
 731                 (mapcar (lambda (dir)
 732                           (when (file-directory-p dir) dir))
 733                         (append
 734                          (mapcar 'gnus-namazu/server-directory
 735                                  (gnus-namazu/indexed-servers))
 736                          (list
 737                           (expand-file-name gnus-cache-directory)
 738                           (expand-file-name gnus-agent-directory)))))))
 739   (if gnus-namazu/mknmz-process
 740       (when force
 741         (error "%s" "Can not run two mknmz processes simultaneously"))
 742     (and (or force
 743              (let ((file (gnus-namazu/index-file-name directory)))
 744                (if (file-exists-p file)
 745                    (and (integerp gnus-namazu-make-index-interval)
 746                         (>= (gnus-namazu/lapse-seconds
 747                              (nth 5 (file-attributes file))
 748                              (current-time))
 749                             gnus-namazu-make-index-interval)
 750                         (y-or-n-p
 751                          "Index files are too old.  Regenerate them now? "))
 752                  (y-or-n-p
 753                   "Can not find index files.  Generate them now? "))))
 754          (not (file-exists-p (gnus-namazu/lock-file-name directory)))
 755          (with-current-buffer (generate-new-buffer " *mknmz*")
 756            (unless (file-directory-p directory)
 757              (make-directory directory t))
 758            (setq default-directory directory)
 759            (let ((proc (apply 'start-process
 760                               `(,gnus-namazu-make-index-command
 761                                 ,(current-buffer)
 762                                 ,gnus-namazu-make-index-command
 763                                 ,@gnus-namazu-make-index-arguments
 764                                 ,@target-directories))))
 765              (if (processp proc)
 766                  (prog1 (setq gnus-namazu/mknmz-process proc)
 767                    (process-kill-without-query proc)
 768                    (set-process-sentinel proc 'gnus-namazu/mknmz-sentinel)
 769                    (add-hook 'kill-emacs-hook 'gnus-namazu-make-index-stop)
 770                    (message "Make indices of Namazu..."))
 771                (kill-buffer (current-buffer))))))))
 772
 773 ;;;###autoload
 774 (defun gnus-namazu-make-index-stop ()
 775   "Stop the running indexer of Namazu."
 776   (interactive)
 777   (and gnus-namazu/mknmz-process
 778        (processp gnus-namazu/mknmz-process)
 779        (kill-process gnus-namazu/mknmz-process)))
 780
 781 (let (current-load-list)
 782   (defadvice gnus-offer-save-summaries
 783     (before gnus-namazu-kill-summary-buffers activate compile)
 784     "Advised by `gnus-namazu'.
 785 In order to avoid annoying questions, kill summary buffers which
 786 generated by `gnus-namazu' itself before `gnus-offer-save-summaries'
 787 is called."
 788     (let ((buffers (buffer-list)))
 789       (while buffers
 790         (when (with-current-buffer (car buffers)
 791                 (and (eq major-mode 'gnus-summary-mode)
 792                      (gnus-ephemeral-group-p gnus-newsgroup-name)
 793                      (string-match gnus-namazu/group-name-regexp
 794                                    gnus-newsgroup-name)))
 795           (kill-buffer (car buffers)))
 796         (setq buffers (cdr buffers))))))
 797
 798 ;;;###autoload
 799 (defun gnus-namazu-insinuate ()
 800   (add-hook
 801    'gnus-group-mode-hook
 802    (lambda ()
 803      (define-key gnus-group-mode-map "\C-c\C-n" 'gnus-namazu-search)))
 804   (add-hook
 805    'gnus-summary-mode-hook
 806    (lambda ()
 807      (define-key gnus-summary-mode-map "\C-c\C-n" 'gnus-namazu-search))))
 808
 809 (provide 'gnus-namazu)
 810
 811 ;; gnus-namazu.el ends here.