X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-namazu.el;h=d09d0aba833d2ac9769f6306f0d4d233b468b54b;hb=27688c4fe73986a46e3f2cb9051170f41ef82f4c;hp=5ef95ebd07d9ae840090827834c225cb56e3b5c9;hpb=e6b31519e256eaa52280b45df80d5b436c1539b1;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-namazu.el b/lisp/gnus-namazu.el index 5ef95eb..d09d0ab 100644 --- a/lisp/gnus-namazu.el +++ b/lisp/gnus-namazu.el @@ -1,12 +1,11 @@ ;;; gnus-namazu.el --- Search mail with Namazu -*- coding: iso-2022-7bit; -*- -;; Copyright (C) 2000,2001,2002 TSUCHIYA Masatoshi +;; Copyright (C) 2000, 2001, 2002, 2003, 2004 +;; TSUCHIYA Masatoshi ;; Author: TSUCHIYA Masatoshi ;; 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) @@ -18,9 +17,9 @@ ;; 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: @@ -36,26 +35,30 @@ ;;; 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 @@ -101,10 +104,6 @@ (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) @@ -142,6 +141,18 @@ :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 @@ -164,10 +175,9 @@ options make any sense in this context." (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) @@ -181,8 +191,8 @@ options make any sense in this context." (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) @@ -215,6 +225,25 @@ options make any sense in this context." "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\\?") @@ -223,9 +252,8 @@ options make any sense in this context." (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 @@ -266,7 +294,8 @@ options make any sense in this context." (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." @@ -289,147 +318,110 @@ options make any sense in this context." (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 () @@ -754,7 +746,8 @@ and make a virtual group contains its results." (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. @@ -834,15 +827,18 @@ than the period that is set to `gnus-namazu-index-update-interval'" 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))) @@ -862,8 +858,9 @@ than the period that is set to `gnus-namazu-index-update-interval'" (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 ()