;;; gnus-namazu.el --- Search mail with Namazu -*- coding: iso-2022-7bit; -*-
-;; Copyright (C) 2000,2001,2002 TSUCHIYA Masatoshi <tsuchiya@namazu.org>
+;; Copyright (C) 2000, 2001, 2002, 2003, 2004
+;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Author: TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Keywords: mail searching namazu
-;; This file is a part of Semi-Gnus.
-
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, you can either send email to this
-;; program's maintainer or write to: The Free Software Foundation,
-;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Quick Start:
-;; If this module has already been installed, only 3 steps are
+;; If this module has already been installed, only four steps are
;; required to search articles with this module.
;;
;; (1) Install Namazu.
-;; (2) Start Gnus and type M-x gnus-namazu-create-index RET to make
+;;
+;; (2) Put this expression into your ~/.gnus.
+;;
+;; (gnus-namazu-insinuate)
+;;
+;; (3) Start Gnus and type M-x gnus-namazu-create-index RET to make
;; index of articles.
-;; (3) In group buffer or in summary buffer, type C-c C-n query RET.
+;;
+;; (4) In group buffer or in summary buffer, type C-c C-n query RET.
;;; Install:
;; Before installing this module, you must install Namazu.
;;
-;; This file is a part of T-gnus but is not *YET* a part of Gnus.
-;; When you would like to use this module in Gnus (not T-gnus), put
-;; this file into the lisp/ directory in the Gnus source tree and run
-;; `make install'. And then, put the following expression into your
+;; When you would like to byte-compile this module in Gnus, put this
+;; file into the lisp/ directory in the Gnus source tree and run `make
+;; install'. And then, put the following expression into your
;; ~/.gnus.
;;
-;; (require 'gnus-namazu)
;; (gnus-namazu-insinuate)
;;
;; In order to make index of articles with Namazu before using this
(require 'nnmail)
(require 'gnus-sum)
-;; It is required for Mule 2.3. See the file Mule23@1934.en.
-(eval-and-compile
- (autoload 'regexp-opt "regexp-opt"))
-
;; To suppress byte-compile warning.
(eval-when-compile
(defvar nnml-directory)
:type 'string
:group 'gnus-namazu)
+(defcustom gnus-namazu-command-prefix nil
+ "*Prefix commands to execute Namazu.
+If you put your index on a remote server, set this option as follows:
+
+ (setq gnus-namazu-command-prefix
+ '(\"ssh\" \"-x\" \"remote-server\"))
+
+This makes gnus-namazu execute \"ssh -x remote-server namazu ...\"
+instead of executing \"namazu\" directly."
+ :type '(repeat string)
+ :group 'gnus-namazu)
+
(defcustom gnus-namazu-additional-arguments nil
"*Additional arguments of Namazu.
The options `-q', `-a', and `-l' are always used, very few other
(defcustom gnus-namazu-make-index-arguments
(nconc
(list "--all" "--mailnews" "--deny=^.*[^0-9].*$")
- (when (or (and (boundp 'current-language-environment)
- (string= "Japanese"
- (symbol-value 'current-language-environment)))
- (boundp 'MULE))
+ (when (and (boundp 'current-language-environment)
+ (string= "Japanese"
+ (symbol-value 'current-language-environment)))
(list "--indexing-lang=ja")))
"*Arguments of the indexer of Namazu."
:type '(repeat string)
(defcustom gnus-namazu-coding-system
(if (memq system-type '(windows-nt OS/2 emx))
- (if (boundp 'MULE) '*sjis* 'shift_jis)
- (if (boundp 'MULE) '*euc-japan* 'euc-japan))
+ 'shift_jis
+ 'euc-japan)
"*Coding system for Namazu process."
:type 'coding-system
:group 'gnus-namazu)
"Face used for namazu query matching words."
:group 'gnus-namazu)
+(defcustom gnus-namazu-remote-groups nil
+ "*Alist of regular expressions matching remote groups and their base paths.
+If you use an IMAP server and have a special index, set this option as
+follows:
+
+ (setq gnus-namazu-remote-groups
+ '((\"^nnimap\\\\+server:INBOX\\\\.\" . \"~/Maildir/.\")))
+
+This means that the group \"nnimap+server:INBOX.group\" is placed in
+\"~/Maildir/.group\"."
+ :group 'gnus-namazu
+ :type '(repeat
+ (cons (regexp :tag "Regexp of group name")
+ (string :tag "Base path of groups")))
+ :set (lambda (symbol value)
+ (prog1 (set-default symbol value)
+ (when (featurep 'gnus-namazu)
+ (gnus-namazu/make-directory-table t)))))
+
;;; Internal Variable:
(defconst gnus-namazu/group-name-regexp "\\`nnvirtual:namazu-search\\?")
(fboundp 'gnus-group-decoded-name)
(let ((gnus-group-name-charset-group-alist
(list (cons gnus-namazu/group-name-regexp gnus-namazu-coding-system)))
- (query (decode-coding-string
- (string 27 36 66 52 65 59 122 27 40 66)
- (if (boundp 'MULE) '*iso-2022-jp* 'iso-2022-7bit))))
+ (query (decode-coding-string (string 27 36 66 52 65 59 122 27 40 66)
+ 'iso-2022-7bit)))
(not (string-match query
(gnus-summary-buffer-name
(encode-coding-string
(push (cons gnus-namazu/group-name-regexp
gnus-namazu-coding-system)
gnus-group-name-charset-group-alist))))
- (gnus-namazu-update-all-indices))
+ (unless gnus-namazu-command-prefix
+ (gnus-namazu-update-all-indices)))
(defun gnus-namazu/server-directory (server)
"Return the top directory of the server SERVER."
(replace-match "\\1:/"))
(eq ?~ (char-after (point))))
(insert (expand-file-name
- (buffer-substring (gnus-point-at-bol) (gnus-point-at-eol))))
- (delete-region (point) (gnus-point-at-eol)))
+ (buffer-substring (point-at-bol) (point-at-eol))))
+ (delete-region (point) (point-at-eol)))
(forward-line 1)))
(defsubst gnus-namazu/call-namazu (query)
(let ((coding-system-for-read gnus-namazu-coding-system)
(coding-system-for-write gnus-namazu-coding-system)
- (input-coding-system gnus-namazu-coding-system)
- (output-coding-system gnus-namazu-coding-system)
(default-process-coding-system
(cons gnus-namazu-coding-system gnus-namazu-coding-system))
program-coding-system-alist
(file-name-coding-system gnus-namazu-coding-system)
- (pathname-coding-system gnus-namazu-coding-system))
- (apply 'call-process
- `(,gnus-namazu-command
- nil ; input from /dev/null
- t ; output
- nil ; don't redisplay
- "-q" ; don't be verbose
- "-a" ; show all matches
- "-l" ; use list format
- ,@gnus-namazu-additional-arguments
- ,query
- ,@gnus-namazu-index-directories))))
-
-(defsubst gnus-namazu/group-prefixed-name (group method)
- "Return the whole name from GROUP and METHOD."
- (if gnus-namazu-case-sensitive-filesystem
- (gnus-group-prefixed-name group method)
- (let* ((orig (gnus-group-prefixed-name group method))
- (name (downcase orig)))
- (catch 'found-group
- (mapatoms (lambda (sym)
- (when (string= name (downcase (symbol-name sym)))
- (throw 'found-group (symbol-name sym))))
- gnus-newsrc-hashtb)
- orig))))
-
-(defun gnus-namazu/real-group-name (cond str)
- "Generate the real group name from the partial path, STR."
- (if cond
- str
- (catch 'found-group
- (dolist (group (gnus-namazu/possible-real-groups
- (nnheader-replace-chars-in-string str ?/ ?.)))
- (when (gnus-gethash group gnus-newsrc-hashtb)
- (throw 'found-group group))))))
-
-(defun gnus-namazu/possible-real-groups (str)
- "Regard the string STR as the partial path of the cached article and
-generate possible group names from it."
- (if (string-match "_\\(_\\(_\\)?\\)?" str)
- (let ((prefix (substring str 0 (match-beginning 0)))
- (suffix (substring str (match-end 0))))
- (cond
- ((match-beginning 2) ;; The number of discoverd underscores = 3
- (nconc
- (gnus-namazu/possible-real-groups (concat prefix "/__" suffix))
- (gnus-namazu/possible-real-groups (concat prefix ".._" suffix))))
- ((match-beginning 1) ;; The number of discoverd underscores = 2
- (nconc
- (gnus-namazu/possible-real-groups (concat prefix "//" suffix))
- (gnus-namazu/possible-real-groups (concat prefix ".." suffix))))
- (t ;; The number of discoverd underscores = 1
- (gnus-namazu/possible-real-groups (concat prefix "/" suffix)))))
- (if (string-match "\\." str)
- ;; Handle the first occurence of period.
- (list (concat (substring str 0 (match-beginning 0))
- ":"
- (substring str (match-end 0)))
- str)
- (list str))))
+ (commands
+ (append gnus-namazu-command-prefix
+ (list gnus-namazu-command
+ "-q" ; don't be verbose
+ "-a" ; show all matches
+ "-l") ; use list format
+ gnus-namazu-additional-arguments
+ (list query)
+ gnus-namazu-index-directories)))
+ (apply 'call-process (car commands) nil t nil (cdr commands))))
+
+(defvar gnus-namazu/directory-table nil)
+(defun gnus-namazu/make-directory-table (&optional force)
+ (interactive (list t))
+ (unless (and (not force)
+ gnus-namazu/directory-table
+ (eq gnus-namazu-case-sensitive-filesystem
+ (car gnus-namazu/directory-table)))
+ (let ((table (make-vector (length gnus-newsrc-hashtb) 0))
+ cache agent alist dir method)
+ (mapatoms
+ (lambda (group)
+ (unless (gnus-ephemeral-group-p (setq group (symbol-name group)))
+ (when (file-directory-p
+ (setq dir (file-name-as-directory
+ (gnus-cache-file-name group ""))))
+ (push (cons dir group) cache))
+ (when (file-directory-p
+ (setq dir (gnus-agent-group-pathname group)))
+ (push (cons dir group) agent))
+ (when (memq (car (setq method (gnus-find-method-for-group group)))
+ '(nnml nnmh))
+ (when (file-directory-p
+ (setq dir (nnmail-group-pathname
+ (gnus-group-short-name group)
+ (gnus-namazu/server-directory method))))
+ (push (cons dir group) alist)))
+ (dolist (pair gnus-namazu-remote-groups)
+ (when (string-match (car pair) group)
+ (setq dir (nnmail-group-pathname
+ (substring group (match-end 0))
+ "/"))
+ (push (cons (concat (cdr pair)
+ ;; nnmail-group-pathname() on some
+ ;; systems returns pathnames which
+ ;; have drive letters at their top.
+ (substring dir (1+ (string-match "/" dir))))
+ group)
+ alist)))))
+ gnus-newsrc-hashtb)
+ (dolist (pair (nconc agent cache alist))
+ (set (intern (if gnus-namazu-case-sensitive-filesystem
+ (car pair)
+ (downcase (car pair)))
+ table)
+ (cdr pair)))
+ (setq gnus-namazu/directory-table
+ (cons gnus-namazu-case-sensitive-filesystem table)))))
(defun gnus-namazu/search (groups query)
+ (gnus-namazu/make-directory-table)
(with-temp-buffer
(let ((exit-status (gnus-namazu/call-namazu query)))
(unless (zerop exit-status)
- (error "Namazu finished abnormally: %d" exit-status))
- (let* ((articles)
- (server-alist
- (delq nil
- (let (dir)
- (mapcar
- (lambda (s)
- (when (setq dir (gnus-namazu/server-directory s))
- (cons (file-name-as-directory dir) s)))
- (gnus-namazu/indexed-servers)))))
- (topdir-regexp (regexp-opt (mapcar 'car server-alist)))
- (cache-regexp (concat
- (regexp-quote
- (file-name-as-directory
- (expand-file-name gnus-cache-directory)))
- "\\(.*\\)/\\([0-9]+\\)$"))
- (agent-regexp (concat
- (regexp-quote
- (file-name-as-directory
- (expand-file-name gnus-agent-directory)))
- "\\(.*\\)/\\([0-9]+\\)$")))
- (gnus-namazu/normalize-results)
- (goto-char (point-min))
- (while (not (eobp))
- (let (server group file)
- (and (or
- ;; Check the discoverd file is the persistent article.
- (and (looking-at cache-regexp)
- (setq file (match-string-no-properties 2)
- group (gnus-namazu/real-group-name
- (gnus-use-long-file-name 'not-cache)
- (match-string-no-properties 1))))
- ;; Check the discoverd file is covered by the agent.
- (and (looking-at agent-regexp)
- (setq file (match-string-no-properties 2)
- group (gnus-namazu/real-group-name
- nnmail-use-long-file-names
- (match-string-no-properties 1))))
- ;; Check the discovered file is managed by Gnus servers.
- (and (looking-at topdir-regexp)
- (setq file (buffer-substring-no-properties
- (match-end 0) (gnus-point-at-eol))
- server (cdr (assoc (match-string-no-properties 0)
- server-alist)))
- ;; Check validity of the file name.
- (string-match "/\\([0-9]+\\)\\'" file)
- (progn
- (setq group (substring file 0 (match-beginning 0))
- file (match-string 1 file))
- (setq group
- (gnus-namazu/group-prefixed-name
- (if nnmail-use-long-file-names
- group
- (nnheader-replace-chars-in-string group
- ?/ ?.))
- server)))))
- (or (not groups)
- (member group groups))
- (push (gnus-namazu/make-article group (string-to-number file))
- articles)))
- (forward-line 1))
- (nreverse articles)))))
-
+ (error "Namazu finished abnormally: %d" exit-status)))
+ (gnus-namazu/normalize-results)
+ (goto-char (point-min))
+ (let (articles group)
+ (while (not (eobp))
+ (setq group (buffer-substring-no-properties
+ (point)
+ (progn
+ (end-of-line)
+ ;; NOTE: Only numeric characters are permitted
+ ;; as file names of articles.
+ (skip-chars-backward "0-9")
+ (point))))
+ (and (setq group
+ (symbol-value
+ (intern-soft (if gnus-namazu-case-sensitive-filesystem
+ group
+ (downcase group))
+ (cdr gnus-namazu/directory-table))))
+ (or (not groups)
+ (member group groups))
+ (push (gnus-namazu/make-article
+ group
+ (string-to-number
+ (buffer-substring-no-properties (point)
+ (point-at-eol))))
+ articles))
+ (forward-line 1))
+ (nreverse articles))))
;;; User Interface:
(defun gnus-namazu/get-target-groups ()
(gnus-namazu/mknmz-cleanup directory))
(message "Make index at %s...done" directory)
(unless force
- (kill-buffer (current-buffer)))))))
+ (kill-buffer (current-buffer)))))
+ (gnus-namazu/make-directory-table t)))
(defun gnus-namazu/lapse-seconds (start end)
"Return lapse seconds from START to END.
nil)))))
;;;###autoload
-(defun gnus-namazu-update-all-indices (&optional directories force)
+(defun gnus-namazu-update-all-indices (&optional force)
"Update all indices which is set to `gnus-namazu-index-directories'."
- (interactive (list nil t))
+ (interactive (list t))
+ (gnus-namazu-update-indices gnus-namazu-index-directories force))
+
+(defun gnus-namazu-update-indices (&optional directories force)
(when (setq directories
- (delq nil (mapcar
- (lambda (d) (gnus-namazu/update-p d force))
- (or directories gnus-namazu-index-directories))))
- (setq gnus-namazu/update-directories (cdr directories))
- (gnus-namazu-update-index (car directories))))
+ (delq nil (mapcar (lambda (d)
+ (gnus-namazu/update-p d force))
+ directories)))
+ (setq gnus-namazu/update-directories (cons force (cdr directories)))
+ (gnus-namazu-update-index (car directories) force)))
(defun gnus-namazu/update-sentinel (process event)
(let ((buffer (process-buffer process)))
(unless (or debug-on-error debug-on-quit)
(kill-buffer buffer)))))))
(setq gnus-namazu/update-process nil)
- (when gnus-namazu/update-directories
- (gnus-namazu-update-all-indices gnus-namazu/update-directories)))
+ (unless (gnus-namazu-update-indices (cdr gnus-namazu/update-directories)
+ (car gnus-namazu/update-directories))
+ (gnus-namazu/make-directory-table t)))
;;;###autoload
(defun gnus-namazu-stop-update ()
projects / elisp / gnus.git- / blobdiff