1 ;;; gnus-namazu.el --- Search mail with Namazu. -*- coding: iso-2022-7bit; -*-
3 ;; Copyright (C) 2000,2001,2002 TSUCHIYA Masatoshi <tsuchiya@namazu.org>
5 ;; Author: TSUCHIYA Masatoshi <tsuchiya@namazu.org>
6 ;; Keywords: mail searching namazu
8 ;; This file is a part of Semi-Gnus.
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)
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.
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.
28 ;; This file defines the command to search mails and persistent
29 ;; articles with Namazu and to browse its results with Gnus.
31 ;; Namazu is a full-text search engine intended for easy use. For
32 ;; more detail about Namazu, visit the following page:
39 ;; If this module has already been installed, only 3 steps are
40 ;; required to search articles.
42 ;; (1) Install Namazu.
43 ;; (2) Start Gnus and type M-x gnus-namazu-create-index RET to make
45 ;; (3) In group buffer or in summary buffer, type C-c C-n query RET.
50 ;; Before installing this module, you must install Namazu.
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
58 ;; (require 'gnus-namazu)
59 ;; (gnus-namazu-insinuate)
61 ;; In order to make index of articles with Namazu before using this
62 ;; module, type M-x gnus-namazu-create-index RET. Otherwise, you can
63 ;; create index by yourself with the following commands:
65 ;; % mkdir ~/News/namazu
66 ;; % mknmz -a -h -O ~/News/namazu ~/Mail ~/News/cache
68 ;; The first command makes the directory for index files, and the
69 ;; second command generates index files of mails and persistent
72 ;; In order to update index for incoming articles, this module
73 ;; automatically runs mknmz at an interval of 3 days, which is decided
74 ;; by the value of `gnus-namazu-index-update-interval'. If you want to
75 ;; control mknmz closely, you can disable this feature and run mknmz
76 ;; by yourself. In this case, set nil to the above option.
78 ;; (setq gnus-namazu-index-update-interval nil)
80 ;; When you put index into the directory other than the default one
81 ;; (~/News/namazu), it is necessary to set the place to
82 ;; `gnus-namazu-index-directories' as follows:
84 ;; (setq gnus-namazu-index-directories
85 ;; (list (expand-file-name "~/namazu")))
90 (eval-when-compile (require 'cl))
96 ;; It is required for Mule 2.3. See the file Mule23@1934.en.
98 (autoload 'regexp-opt "regexp-opt"))
100 ;; To suppress byte-compile warning.
102 (defvar nnml-directory)
103 (defvar nnmh-directory))
106 (defgroup gnus-namazu nil
107 "Search nnmh and nnml groups in Gnus with Namazu."
110 :prefix "gnus-namazu-")
112 (defconst gnus-namazu-default-index-directory
113 (expand-file-name "namazu" gnus-directory)
114 "Default place of Namazu index files.")
116 (defcustom gnus-namazu-index-directories
118 (or (and (boundp 'gnus-namazu-index-directory)
119 (symbol-value 'gnus-namazu-index-directory))
120 (and (boundp 'nnir-namazu-index-directory)
121 (symbol-value 'nnir-namazu-index-directory))
122 (and (boundp 'gnus-namazu-index-directory)
123 (symbol-value 'gnus-namazu-index-directory))
124 gnus-namazu-default-index-directory))
125 "*Places of Namazu index files."
126 :type '(repeat directory)
129 (defcustom gnus-namazu-command
130 (or (and (boundp 'namazu-command)
131 (symbol-value 'namazu-command))
132 (and (boundp 'nnir-namazu-program)
133 (symbol-value 'nnir-namazu-program))
135 "*Name of the executable file of Namazu."
139 (defcustom gnus-namazu-additional-arguments nil
140 "*Additional arguments of Namazu.
141 The options `-q', `-a', and `-l' are always used, very few other
142 options make any sense in this context."
143 :type '(repeat string)
146 (defcustom gnus-namazu-index-update-interval
147 259200 ; 3 days == 259200 seconds.
148 "*Number of seconds between running the indexer of Namazu."
149 :type '(choice (const :tag "Never run the indexer" nil)
150 (integer :tag "Number of seconds"))
153 (defcustom gnus-namazu-make-index-command "mknmz"
154 "*Name of the executable file of the indexer of Namazu."
158 (defcustom gnus-namazu-make-index-arguments
160 (list "--all" "--mailnews" "--deny=^.*[^0-9].*$")
161 (when (or (and (boundp 'current-language-environment)
163 (symbol-value 'current-language-environment)))
165 (list "--indexing-lang=ja")))
166 "*Arguments of the indexer of Namazu."
167 :type '(repeat string)
170 (defcustom gnus-namazu-field-keywords
171 '("date" "from" "newsgroups" "size" "subject" "summary" "to" "uri")
172 "*List of keywords to do field-search."
173 :type '(repeat string)
176 (defcustom gnus-namazu-coding-system
177 (if (memq system-type '(windows-nt OS/2 emx))
178 (if (boundp 'MULE) '*sjis* 'shift_jis)
179 (if (boundp 'MULE) '*euc-japan* 'euc-japan))
180 "*Coding system for Namazu process."
184 (defcustom gnus-namazu-need-path-normalization
185 (eq system-type 'windows-nt)
186 "*Non-nil means that outputs of namazu may contain a not normalized path."
190 (defcustom gnus-namazu-case-sensitive-filesystem
191 (not (eq system-type 'windows-nt))
192 "*Non-nil means that the using file system distinguishes cases of characters."
196 (defcustom gnus-namazu-query-highlight t
197 "Non-nil means that queried words is highlighted."
201 (defface gnus-namazu-query-highlight-face
202 '((((type tty pc) (class color))
203 (:background "magenta4" :foreground "cyan1"))
204 (((class color) (background light))
205 (:background "magenta4" :foreground "lightskyblue1"))
206 (((class color) (background dark))
207 (:background "palevioletred2" :foreground "brown4"))
208 (t (:inverse-video t)))
209 "Face used for namazu query matching words."
212 ;;; Internal Variable:
213 (defconst gnus-namazu/group-name-regexp "\\`nnvirtual:namazu-search\\?")
215 ;; Multibyte group name:
217 (fboundp 'gnus-group-decoded-name)
218 (let ((gnus-group-name-charset-group-alist
219 (list (cons gnus-namazu/group-name-regexp gnus-namazu-coding-system)))
220 (query (decode-coding-string
221 (string 27 36 66 52 65 59 122 27 40 66)
222 (if (boundp 'MULE) '*iso-2022-jp* 'iso-2022-7bit))))
223 (not (string-match query
224 (gnus-summary-buffer-name
225 (encode-coding-string
226 (concat "nnvirtual:namazu-search?query=" query)
227 gnus-namazu-coding-system)))))
228 (let (current-load-list)
229 (defadvice gnus-summary-buffer-name
230 (before gnus-namazu-summary-buffer-name activate compile)
231 "Advised by `gnus-namazu' to handle encoded group names."
232 (ad-set-arg 0 (gnus-group-decoded-name (ad-get-arg 0))))))
234 (defmacro gnus-namazu/make-article (group number)
235 `(cons ,group ,number))
236 (defmacro gnus-namazu/article-group (x) `(car ,x))
237 (defmacro gnus-namazu/article-number (x) `(cdr ,x))
239 (defsubst gnus-namazu/indexed-servers ()
240 "Choice appropriate servers from opened ones, and return thier list."
242 (gnus-servers-using-backend 'nnml)
243 (gnus-servers-using-backend 'nnmh)))
245 (defsubst gnus-namazu/default-index-directory ()
246 (if (member gnus-namazu-default-index-directory
247 gnus-namazu-index-directories)
248 gnus-namazu-default-index-directory
249 (car gnus-namazu-index-directories)))
251 (defun gnus-namazu/setup ()
252 (and (boundp 'gnus-group-name-charset-group-alist)
253 (not (member (cons gnus-namazu/group-name-regexp
254 gnus-namazu-coding-system)
255 gnus-group-name-charset-group-alist))
256 (let ((pair (assoc gnus-namazu/group-name-regexp
257 gnus-group-name-charset-group-alist)))
259 (setcdr pair gnus-namazu-coding-system)
260 (push (cons gnus-namazu/group-name-regexp
261 gnus-namazu-coding-system)
262 gnus-group-name-charset-group-alist))))
263 (gnus-namazu-update-all-indices gnus-namazu-index-directories))
265 (defun gnus-namazu/server-directory (server)
266 "Return the top directory of the server SERVER."
267 (and (memq (car server) '(nnml nnmh))
268 (nnoo-change-server (car server) (nth 1 server) (nthcdr 2 server))
269 (file-name-as-directory
270 (expand-file-name (if (eq 'nnml (car server))
274 ;;; Functions to call Namazu.
275 (defsubst gnus-namazu/normalize-results ()
276 "Normalize file names returned by Namazu in this current buffer."
277 (goto-char (point-min))
279 (when (if gnus-namazu-need-path-normalization
280 (or (not (looking-at "/\\(.\\)|/"))
281 (replace-match "\\1:/"))
282 (eq ?~ (char-after (point))))
283 (insert (expand-file-name
284 (buffer-substring (gnus-point-at-bol) (gnus-point-at-eol))))
285 (delete-region (point) (gnus-point-at-eol)))
288 (defsubst gnus-namazu/call-namazu (query)
289 (let ((coding-system-for-read gnus-namazu-coding-system)
290 (coding-system-for-write gnus-namazu-coding-system)
291 (input-coding-system gnus-namazu-coding-system)
292 (output-coding-system gnus-namazu-coding-system)
293 (default-process-coding-system
294 (cons gnus-namazu-coding-system gnus-namazu-coding-system))
295 program-coding-system-alist
296 (file-name-coding-system gnus-namazu-coding-system)
297 (pathname-coding-system gnus-namazu-coding-system))
299 `(,gnus-namazu-command
300 nil ; input from /dev/null
302 nil ; don't redisplay
303 "-q" ; don't be verbose
304 "-a" ; show all matches
305 "-l" ; use list format
306 ,@gnus-namazu-additional-arguments
308 ,@gnus-namazu-index-directories))))
310 (defsubst gnus-namazu/group-prefixed-name (group method)
311 "Return the whole name from GROUP and METHOD."
312 (if gnus-namazu-case-sensitive-filesystem
313 (gnus-group-prefixed-name group method)
314 (let* ((orig (gnus-group-prefixed-name group method))
315 (name (downcase orig)))
317 (mapatoms (lambda (sym)
318 (when (string= name (downcase (symbol-name sym)))
319 (throw 'found-group (symbol-name sym))))
323 (defun gnus-namazu/real-group-name (cond str)
324 "Generate the real group name from the partial path, STR."
328 (dolist (group (gnus-namazu/possible-real-groups
329 (nnheader-replace-chars-in-string str ?/ ?.)))
330 (when (gnus-gethash group gnus-newsrc-hashtb)
331 (throw 'found-group group))))))
333 (defun gnus-namazu/possible-real-groups (str)
334 "Regard the string STR as the partial path of the cached article and
335 generate possible group names from it."
336 (if (string-match "_\\(_\\(_\\)?\\)?" str)
337 (let ((prefix (substring str 0 (match-beginning 0)))
338 (suffix (substring str (match-end 0))))
340 ((match-beginning 2) ;; The number of discoverd underscores = 3
342 (gnus-namazu/possible-real-groups (concat prefix "/__" suffix))
343 (gnus-namazu/possible-real-groups (concat prefix ".._" suffix))))
344 ((match-beginning 1) ;; The number of discoverd underscores = 2
346 (gnus-namazu/possible-real-groups (concat prefix "//" suffix))
347 (gnus-namazu/possible-real-groups (concat prefix ".." suffix))))
348 (t ;; The number of discoverd underscores = 1
349 (gnus-namazu/possible-real-groups (concat prefix "/" suffix)))))
350 (if (string-match "\\." str)
351 ;; Handle the first occurence of period.
352 (list (concat (substring str 0 (match-beginning 0))
354 (substring str (match-end 0)))
358 (defun gnus-namazu/search (groups query)
360 (let ((exit-status (gnus-namazu/call-namazu query)))
361 (unless (zerop exit-status)
362 (error "Namazu finished abnormally: %d" exit-status))
369 (when (setq dir (gnus-namazu/server-directory s))
370 (cons (file-name-as-directory dir) s)))
371 (gnus-namazu/indexed-servers)))))
372 (topdir-regexp (regexp-opt (mapcar 'car server-alist)))
373 (cache-regexp (concat
375 (file-name-as-directory
376 (expand-file-name gnus-cache-directory)))
377 "\\(.*\\)/\\([0-9]+\\)$"))
378 (agent-regexp (concat
380 (file-name-as-directory
381 (expand-file-name gnus-agent-directory)))
382 "\\(.*\\)/\\([0-9]+\\)$")))
383 (gnus-namazu/normalize-results)
384 (goto-char (point-min))
386 (let (server group file)
388 ;; Check the discoverd file is the persistent article.
389 (and (looking-at cache-regexp)
390 (setq file (match-string-no-properties 2)
391 group (gnus-namazu/real-group-name
392 (gnus-use-long-file-name 'not-cache)
393 (match-string-no-properties 1))))
394 ;; Check the discoverd file is covered by the agent.
395 (and (looking-at agent-regexp)
396 (setq file (match-string-no-properties 2)
397 group (gnus-namazu/real-group-name
398 nnmail-use-long-file-names
399 (match-string-no-properties 1))))
400 ;; Check the discovered file is managed by Gnus servers.
401 (and (looking-at topdir-regexp)
402 (setq file (buffer-substring-no-properties
403 (match-end 0) (gnus-point-at-eol))
404 server (cdr (assoc (match-string-no-properties 0)
406 ;; Check validity of the file name.
407 (string-match "/\\([0-9]+\\)\\'" file)
409 (setq group (substring file 0 (match-beginning 0))
410 file (match-string 1 file))
412 (gnus-namazu/group-prefixed-name
413 (if nnmail-use-long-file-names
415 (nnheader-replace-chars-in-string group
419 (member group groups))
420 (push (gnus-namazu/make-article group (string-to-number file))
423 (nreverse articles)))))
427 (defun gnus-namazu/get-target-groups ()
429 ((eq major-mode 'gnus-group-mode)
433 (gnus-group-process-prefix current-prefix-arg))
435 (prog1 gnus-group-marked (gnus-group-unmark-all-groups)))))
436 ((eq major-mode 'gnus-summary-mode)
437 ;; In Summary buffer.
438 (if current-prefix-arg
439 (list (gnus-read-group "Group: "))
441 (gnus-ephemeral-group-p gnus-newsgroup-name)
442 (string-match gnus-namazu/group-name-regexp gnus-newsgroup-name))
443 (cadr (assq 'gnus-namazu-target-groups
444 (gnus-info-method (gnus-get-info gnus-newsgroup-name))))
445 (list gnus-newsgroup-name))))))
447 (defun gnus-namazu/get-current-query ()
448 (and (eq major-mode 'gnus-summary-mode)
449 (gnus-ephemeral-group-p gnus-newsgroup-name)
450 (string-match gnus-namazu/group-name-regexp gnus-newsgroup-name)
451 (cadr (assq 'gnus-namazu-current-query
452 (gnus-info-method (gnus-get-info gnus-newsgroup-name))))))
454 (defvar gnus-namazu/read-query-original-buffer nil)
455 (defvar gnus-namazu/read-query-prompt nil)
456 (defvar gnus-namazu/read-query-history nil)
458 (defun gnus-namazu/get-current-subject ()
459 (and gnus-namazu/read-query-original-buffer
460 (bufferp gnus-namazu/read-query-original-buffer)
461 (with-current-buffer gnus-namazu/read-query-original-buffer
462 (when (eq major-mode 'gnus-summary-mode)
463 (let ((s (gnus-summary-article-subject)))
464 ;; Remove typically prefixes of mailing lists.
466 "^\\(\\[[^]]*[0-9]+\\]\\|([^)]*[0-9]+)\\)\\s-*" s)
467 (setq s (substring s (match-end 0))))
469 "^\\(Re\\(\\^?\\([0-9]+\\|\\[[0-9]+\\]\\)\\)?:\\s-*\\)+" s)
470 (setq s (substring s (match-end 0))))
471 (when (string-match "\\s-*(\\(re\\|was\\)\\b" s)
472 (setq s (substring s 0 (match-beginning 0))))
475 (defun gnus-namazu/get-current-from ()
476 (and gnus-namazu/read-query-original-buffer
477 (bufferp gnus-namazu/read-query-original-buffer)
478 (with-current-buffer gnus-namazu/read-query-original-buffer
479 (when (eq major-mode 'gnus-summary-mode)
480 (cadr (mail-extract-address-components
482 (gnus-summary-article-header))))))))
484 (defun gnus-namazu/get-current-to ()
485 (and gnus-namazu/read-query-original-buffer
486 (bufferp gnus-namazu/read-query-original-buffer)
487 (with-current-buffer gnus-namazu/read-query-original-buffer
488 (when (eq major-mode 'gnus-summary-mode)
489 (cadr (mail-extract-address-components
490 (cdr (assq 'To (mail-header-extra
491 (gnus-summary-article-header))))))))))
493 (defmacro gnus-namazu/minibuffer-prompt-end ()
494 (if (fboundp 'minibuffer-prompt-end)
495 '(minibuffer-prompt-end)
498 (defun gnus-namazu/message (string &rest arguments)
500 gnus-namazu/read-query-prompt
501 (buffer-substring (gnus-namazu/minibuffer-prompt-end)
503 (s2 (apply (function format) string arguments))
508 (message (if (>= w 0)
509 (concat s1 (make-string w ?\ ) s2)
511 (if (sit-for 0.3) (message s1))
514 (defun gnus-namazu/complete-query ()
518 ((and (re-search-backward "\\+\\([-a-z]*\\)" nil t)
519 (= pos (match-end 0)))
520 (let* ((partial (match-string 1))
524 (mapcar 'list gnus-namazu-field-keywords))))
527 (gnus-namazu/message "No completions of %s" partial))
528 ((= 1 (length completions))
529 (goto-char (match-beginning 1))
530 (delete-region (match-beginning 1) (match-end 1))
531 (insert (car completions) ":")
533 (gnus-namazu/message "Completed"))
535 (let ((x (try-completion partial (mapcar 'list completions))))
536 (if (string= x partial)
537 (if (and (eq last-command
538 'gnus-namazu/field-keyword-completion)
539 completion-auto-help)
540 (with-output-to-temp-buffer "*Completions*"
541 (display-completion-list completions))
542 (gnus-namazu/message "Sole completion"))
543 (goto-char (match-beginning 1))
544 (delete-region (match-beginning 1) (match-end 1))
546 (setq pos (point))))))))
547 ((and (looking-at "\\+subject:")
548 (= pos (match-end 0)))
549 (let ((s (gnus-namazu/get-current-subject)))
553 (setq pos (point)))))
554 ((and (looking-at "\\+from:")
555 (= pos (match-end 0)))
556 (let ((f (gnus-namazu/get-current-from)))
560 (setq pos (point)))))
561 ((and (looking-at "\\+to:")
562 (= pos (match-end 0)))
563 (let ((to (gnus-namazu/get-current-to)))
566 (insert "\"" to "\"")
567 (setq pos (point))))))
570 (defvar gnus-namazu/read-query-map
571 (let ((keymap (copy-keymap minibuffer-local-map)))
572 (define-key keymap "\t" 'gnus-namazu/complete-query)
575 (defun gnus-namazu/read-query (prompt &optional initial)
576 (let ((gnus-namazu/read-query-original-buffer (current-buffer))
577 (gnus-namazu/read-query-prompt prompt))
579 (when (setq initial (gnus-namazu/get-current-query))
580 (setq initial (cons initial 0))))
581 (read-from-minibuffer prompt initial gnus-namazu/read-query-map nil
582 'gnus-namazu/read-query-history)))
584 (defun gnus-namazu/highlight-words (query)
587 ;; Remove tokens for NOT search
588 (goto-char (point-min))
589 (while (re-search-forward "[
\e$B!!
\e(B \t\r\f\n]+not[
\e$B!!
\e(B \t\r\f\n]+\
590 \\([^
\e$B!!
\e(B \t\r\f\n\"{(/]+\\|\"[^\"]+\"\\|{[^}]+}\\|([^)]+)\\|/[^/]+/\\)+" nil t)
591 (delete-region (match-beginning 0) (match-end 0)))
592 ;; Remove tokens for Field search
593 (goto-char (point-min))
594 (while (re-search-forward "[
\e$B!!
\e(B \t\r\f\n]+\\+[^
\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 Regexp search
598 (goto-char (point-min))
599 (while (re-search-forward "/[^/]+/" nil t)
600 (delete-region (match-beginning 0) (match-end 0)))
601 ;; Remove brackets, double quote, asterisk and operators
602 (goto-char (point-min))
603 (while (re-search-forward "\\([(){}\"*]\\|\\b\\(and\\|or\\)\\b\\)" nil t)
604 (delete-region (match-beginning 0) (match-end 0)))
605 ;; Collect all keywords
607 (goto-char (point-min))
608 (while (re-search-forward "[^
\e$B!!
\e(B \t\r\f\n]+" nil t)
609 (push (match-string 0) query))
611 (list (list (regexp-opt query)
612 0 0 'gnus-namazu-query-highlight-face)))))
614 (defun gnus-namazu/truncate-article-list (articles)
615 (let ((hit (length articles)))
616 (when (and gnus-large-newsgroup
617 (> hit gnus-large-newsgroup))
618 (let* ((cursor-in-echo-area nil)
619 (input (read-from-minibuffer
621 Too many articles were retrieved. How many articles (max %d): "
623 (cons (number-to-string gnus-large-newsgroup) 0))))
624 (unless (string-match "\\`[ \t]*\\'" input)
625 (setcdr (nthcdr (min (1- (string-to-number input)) hit) articles)
630 (defun gnus-namazu-search (groups query)
631 "Search QUERY through GROUPS with Namazu,
632 and make a virtual group contains its results."
635 (gnus-namazu/get-target-groups)
636 (gnus-namazu/read-query "Enter query: ")))
638 (let ((articles (gnus-namazu/search groups query)))
640 (let ((real-groups groups)
642 (apply (function format)
643 "nnvirtual:namazu-search?query=%s&groups=%s&id=%d%d%d"
645 (if groups (mapconcat 'identity groups ",") "ALL")
647 (gnus-namazu/truncate-article-list articles)
650 (add-to-list 'real-groups (gnus-namazu/article-group a))))
651 ;; Generate virtual group which includes all results.
652 (when (fboundp 'gnus-group-decoded-name)
654 (encode-coding-string vgroup gnus-namazu-coding-system)))
656 (gnus-group-read-ephemeral-group
659 (nnvirtual-component-groups ,real-groups)
660 (gnus-namazu-target-groups ,groups)
661 (gnus-namazu-current-query ,query))
662 t (cons (current-buffer) (current-window-configuration)) t))
663 (when gnus-namazu-query-highlight
664 (gnus-group-set-parameter vgroup 'highlight-words
665 (gnus-namazu/highlight-words query)))
666 ;; Generate new summary buffer which contains search results.
667 (gnus-group-read-group
669 (sort (delq nil ;; Ad-hoc fix, to avoid wrong-type-argument error.
672 (nnvirtual-reverse-map-article
673 (gnus-namazu/article-group a)
674 (gnus-namazu/article-number a)))
677 (message "No entry."))))
679 (defun gnus-namazu/lapse-seconds (start end)
680 "Return lapse seconds from START to END.
681 START and END are lists which represent time in Emacs-style."
682 (+ (* (- (car end) (car start)) 65536)
686 (defmacro gnus-namazu/lock-file-name (&optional directory)
687 `(expand-file-name "NMZ.lock2" ,directory))
689 (defmacro gnus-namazu/status-file-name (&optional directory)
690 `(expand-file-name "NMZ.status" ,directory))
692 (defmacro gnus-namazu/index-file-name (&optional directory)
693 `(expand-file-name "NMZ.i" ,directory))
695 (defun gnus-namazu/mknmz-cleanup (directory)
696 (let ((lockfile (gnus-namazu/lock-file-name directory)))
697 (when (file-exists-p lockfile)
698 (delete-file lockfile)
699 (dolist (tmpfile (directory-files directory t "\\`NMZ\\..*\\.tmp\\'" t))
700 (delete-file tmpfile)))))
702 (defun gnus-namazu/index-old-p (directory)
703 (let ((file (gnus-namazu/index-file-name directory)))
704 (or (not (file-exists-p file))
705 (and (integerp gnus-namazu-index-update-interval)
706 (>= (gnus-namazu/lapse-seconds
707 (nth 5 (file-attributes file))
709 gnus-namazu-index-update-interval)))))
712 (defun gnus-namazu-create-index (directory &optional target-directories force)
713 "Create index under DIRECTORY."
716 (if (and current-prefix-arg (> (length gnus-namazu-index-directories) 1))
717 (completing-read "Directory: "
718 (mapcar 'list gnus-namazu-index-directories) nil t)
719 (gnus-namazu/default-index-directory))
721 (setq directory (file-name-as-directory (expand-file-name directory)))
722 (unless target-directories
723 (setq target-directories
725 (mapcar (lambda (dir)
726 (when (file-directory-p dir) dir))
728 (mapcar 'gnus-namazu/server-directory
729 (gnus-namazu/indexed-servers))
731 (expand-file-name gnus-cache-directory)
732 (expand-file-name gnus-agent-directory)))))))
733 (if (file-exists-p (gnus-namazu/lock-file-name directory))
735 (error "Found lock file: %s" (gnus-namazu/lock-file-name directory)))
737 (get-buffer-create (concat " *mknmz*" directory))
739 (unless (file-directory-p directory)
740 (make-directory directory t))
741 (setq default-directory directory)
742 (let ((args (append gnus-namazu-make-index-arguments
743 target-directories)))
744 (insert "% " gnus-namazu-make-index-command " "
745 (mapconcat 'identity args " ") "\n")
746 (goto-char (point-max))
748 (pop-to-buffer (current-buffer)))
749 (message "Make index at %s..." directory)
750 (apply 'call-process gnus-namazu-make-index-command nil t t args)
751 (gnus-namazu/mknmz-cleanup directory)
752 (message "Make index at %s...done" directory)
754 (kill-buffer (current-buffer)))))))
756 (defvar gnus-namazu/update-directories nil)
757 (defvar gnus-namazu/update-process nil)
760 (defun gnus-namazu-update-all-indices (directories &optional force)
761 "Update all indices under DIRECTORIES."
762 (interactive (list gnus-namazu-index-directories t))
763 (while (and directories
764 (not (gnus-namazu-update-index (car directories) force)))
765 (setq directories (cdr directories)))
766 (setq gnus-namazu/update-directories (cdr directories)))
769 (defun gnus-namazu-update-index (directory &optional force)
770 "Update index under DIRECTORY."
773 (if (and current-prefix-arg (> (length gnus-namazu-index-directories) 1))
774 (completing-read "Directory: "
775 (mapcar 'list gnus-namazu-index-directories) nil t)
776 (gnus-namazu/default-index-directory))
778 (setq directory (file-name-as-directory (expand-file-name directory)))
779 (if gnus-namazu/update-process
781 (error "%s" "Can not run two update processes simultaneously"))
782 (and (or force (gnus-namazu/index-old-p directory))
783 (let ((status-file (gnus-namazu/status-file-name directory)))
784 (or (file-exists-p status-file)
786 (error "Can not find status file: %s" status-file))))
787 (let ((lock-file (gnus-namazu/lock-file-name directory)))
788 (or (not (file-exists-p lock-file))
790 (error "Found lock file: %s" lock-file))))
792 (get-buffer-create (concat " *mknmz*" directory))
794 (unless (file-directory-p directory)
795 (make-directory directory t))
796 (setq default-directory directory)
797 (let ((proc (start-process gnus-namazu-make-index-command
799 gnus-namazu-make-index-command
800 (format "--update=%s" directory))))
802 (prog1 (setq gnus-namazu/update-process proc)
803 (process-kill-without-query proc)
804 (set-process-sentinel proc 'gnus-namazu/update-sentinel)
805 (add-hook 'kill-emacs-hook 'gnus-namazu-stop-update)
806 (message "Update index at %s..." directory))
807 (kill-buffer (current-buffer))
809 (error "Can not start %s"
810 gnus-namazu-make-index-command))))))))
812 (defun gnus-namazu/update-sentinel (process event)
813 (let ((buffer (process-buffer process)))
814 (when (buffer-name buffer)
815 (with-current-buffer buffer
816 (gnus-namazu/mknmz-cleanup default-directory)
817 (when (and (eq 'exit (process-status process))
818 (zerop (process-exit-status process)))
819 (message "Update index at %s...done" default-directory)))
820 (unless (or debug-on-error debug-on-quit)
821 (kill-buffer buffer))))
822 (setq gnus-namazu/update-process nil)
823 (gnus-namazu-update-all-indices gnus-namazu/update-directories))
826 (defun gnus-namazu-stop-update ()
827 "Stop the running indexer of Namazu."
829 (setq gnus-namazu/update-directories nil)
830 (and gnus-namazu/update-process
831 (processp gnus-namazu/update-process)
832 (kill-process gnus-namazu/update-process)))
834 (let (current-load-list)
835 (defadvice gnus-offer-save-summaries
836 (before gnus-namazu-kill-summary-buffers activate compile)
837 "Advised by `gnus-namazu'.
838 In order to avoid annoying questions, kill summary buffers which
839 generated by `gnus-namazu' itself before `gnus-offer-save-summaries'
841 (let ((buffers (buffer-list)))
843 (when (with-current-buffer (car buffers)
844 (and (eq major-mode 'gnus-summary-mode)
845 (gnus-ephemeral-group-p gnus-newsgroup-name)
846 (string-match gnus-namazu/group-name-regexp
847 gnus-newsgroup-name)))
848 (kill-buffer (car buffers)))
849 (setq buffers (cdr buffers))))))
852 (defun gnus-namazu-insinuate ()
854 'gnus-group-mode-hook
856 (define-key gnus-group-mode-map "\C-c\C-n" 'gnus-namazu-search)))
858 'gnus-summary-mode-hook
860 (define-key gnus-summary-mode-map "\C-c\C-n" 'gnus-namazu-search))))
862 (provide 'gnus-namazu)
864 ;; gnus-namazu.el ends here.