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