X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-namazu.el;h=91707e67909f6e62126b33719d804f6e51f2345a;hb=9b741e050b400987d68ff761c6cc3276c932839c;hp=ad12933664945158846d1930d49f4d2932e16848;hpb=86b35a3760cb69dbcac3cdbc9470dc9338ac29b4;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-namazu.el b/lisp/gnus-namazu.el index ad12933..91707e6 100644 --- a/lisp/gnus-namazu.el +++ b/lisp/gnus-namazu.el @@ -1,12 +1,10 @@ -;;; gnus-namazu.el --- Search mail with Namazu. +;;; gnus-namazu.el --- Search mail with Namazu. -*- coding: iso-2022-7bit; -*- -;; Copyright (C) 2000,2001 Tsuchiya Masatoshi +;; Copyright (C) 2000,2001,2002 TSUCHIYA Masatoshi -;; Author: Tsuchiya Masatoshi +;; Author: TSUCHIYA Masatoshi ;; Keywords: mail searching namazu -;;; Copyright: - ;; This file is a part of Semi-Gnus. ;; This program is free software; you can redistribute it and/or modify @@ -27,11 +25,12 @@ ;;; Commentary: -;; This file defines the command to search mails with Namazu and -;; browse its results with Gnus. This module requires the external -;; command Namazu. Visit the following page for more information. +;; This file defines the command to search mails and persistent +;; articles with Namazu and browse its results with Gnus. This module +;; requires the external command, Namazu. Visit the following page +;; for more information. ;; -;; http://www.namazu.org/ +;; http://namazu.org/ ;;; Install: @@ -39,20 +38,26 @@ ;; Make index of articles with Namzu before using this module. ;; ;; % mkdir ~/News/namazu -;; % mknmz -a -h -O ~/News/namazu ~/Mail +;; % mknmz -a -h -O ~/News/namazu ~/Mail ~/News/cache ;; -;; Furthermore, put these expressions to your ~/.gnus, to set the path -;; of the index files to `gnus-namazu-index-directories'. +;; The first command makes the directory for index files, and the +;; second command generates index files of mails and persistent +;; articles. +;; +;; When you put index files of Namazu into the directory other than +;; the default one (~/News/namazu), it is necessary to put this +;; expression to your ~/.gnus, in order to set the path of index files +;; to `gnus-namazu-index-directories'. +;; +;; (setq gnus-namazu-index-directories +;; (list (expand-file-name "~/namazu"))) ;; -;; (setq gnus-namazu-index-directories -;; (list (expand-file-name "~/News/namazu"))) - ;; If 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 expressions into your ~/.gnus. ;; -;; (require 'gnus-namazu) -;; (gnus-namazu-insinuate) +;; (require 'gnus-namazu) +;; (gnus-namazu-insinuate) ;;; Usage: @@ -75,7 +80,10 @@ ;; To suppress byte-compile warning. (eval-when-compile (defvar nnml-directory) - (defvar nnmh-directory)) + (defvar nnml-group-alist) + (defvar nnmh-directory) + (defvar nnmh-group-alist)) + (defgroup gnus-namazu nil "Search nnmh and nnml groups in Gnus with Namazu." @@ -83,31 +91,23 @@ :group 'gnus :prefix "gnus-namazu-") -(defcustom gnus-namazu-indexed-servers nil - "*List of servers indexed with Namazu." - :type '(repeat gnus-select-method) - :group 'gnus-namazu) - (defcustom gnus-namazu-index-directories (list - (cond - ((boundp 'nnir-namazu-index-directory) - (symbol-value 'nnir-namazu-index-directory)) - ((boundp 'gnus-namazu-index-directory) - (symbol-value 'gnus-namazu-index-directory)) - (t - (expand-file-name "namazu" gnus-directory)))) + (or (and (boundp 'gnus-namazu-index-directory) + (symbol-value 'gnus-namazu-index-directory)) + (and (boundp 'nnir-namazu-index-directory) + (symbol-value 'nnir-namazu-index-directory)) + (expand-file-name "namazu" gnus-directory))) "*Index directory of Namazu." :type '(repeat directory) :group 'gnus-namazu) (defcustom gnus-namazu-command - (cond - ((boundp 'namazu-command) - (symbol-value 'namazu-command)) - ((boundp 'nnir-namazu-program) - (symbol-value 'nnir-namazu-program)) - (t "namazu")) + (or (and (boundp 'namazu-command) + (symbol-value 'namazu-command)) + (and (boundp 'nnir-namazu-program) + (symbol-value 'nnir-namazu-program)) + "namazu") "*Name of the executable file of Namazu." :group 'gnus-namazu :type 'string) @@ -127,8 +127,8 @@ options make any sense in this context." (defcustom gnus-namazu-coding-system (if (memq system-type '(windows-nt OS/2 emx)) - (if (>= emacs-major-version 20) 'shift_jis '*sjis*) - (if (>= emacs-major-version 20) 'euc-japan '*euc-japan*)) + (if (boundp 'MULE) '*sjis* 'shift_jis) + (if (boundp 'MULE) '*euc-japan* 'euc-japan)) "*Coding system for Namazu process." :type 'coding-system :group 'gnus-namazu) @@ -139,37 +139,86 @@ options make any sense in this context." :type 'boolean :group 'gnus-namazu) +(defcustom gnus-namazu-case-sensitive-filesystem + (not (eq system-type 'windows-nt)) + "*Non-nil means that the using file system distinguishes cases of characters." + :type 'boolean + :group 'gnus-namazu) + +(defcustom gnus-namazu-query-highlight t + "Non-nil means that queried words is highlighted." + :type 'boolean + :group 'gnus-namazu) + +(defface gnus-namazu-query-highlight-face + '((((type tty pc) (class color)) + (:background "magenta4" :foreground "cyan1")) + (((class color) (background light)) + (:background "magenta4" :foreground "lightskyblue1")) + (((class color) (background dark)) + (:background "palevioletred2" :foreground "brown4")) + (t (:inverse-video t))) + "Face used for namazu query matching words." + :group 'gnus-namazu) + +;;; Internal Variable: +(defconst gnus-namazu/group-name-regexp "\\`nnvirtual:namazu-search\\?") + +;; Multibyte group name: +(and + (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)))) + (not (string-match query + (gnus-summary-buffer-name + (encode-coding-string + (concat "nnvirtual:namazu-search?query=" query) + gnus-namazu-coding-system))))) + (let (current-load-list) + (defadvice gnus-summary-buffer-name + (before gnus-namazu-summary-buffer-name activate compile) + "Advised by `gnus-namazu' to handle encoded group names." + (ad-set-arg 0 (gnus-group-decoded-name (ad-get-arg 0)))))) (defmacro gnus-namazu/make-article (group number) `(cons ,group ,number)) (defmacro gnus-namazu/article-group (x) `(car ,x)) (defmacro gnus-namazu/article-number (x) `(cdr ,x)) +(defsubst gnus-namazu/indexed-servers () + "Choice appropriate servers from opened ones, and return thier list." + (append + (gnus-servers-using-backend 'nnml) + (gnus-servers-using-backend 'nnmh))) (defun gnus-namazu/setup () - (unless gnus-namazu-indexed-servers - (setq gnus-namazu-indexed-servers - (delq nil - (mapcar (lambda (method) - (when (memq (car method) '(nnml nnmh)) - method)) - (cons gnus-select-method - gnus-secondary-select-methods))))) - (unless gnus-namazu-indexed-servers - (error "%s" "Can't find either nnml backend or nnmh backend")) - (when (or (not gnus-namazu-index-directories) - (memq nil (mapcar - (lambda (dir) - (and (stringp dir) - (file-directory-p dir) - (file-readable-p - (expand-file-name "NMZ.i" dir)) - dir)) - gnus-namazu-index-directories))) - (error "%s" "Can't find index. Check `gnus-namazu-index-directories'"))) + (and (boundp 'gnus-group-name-charset-group-alist) + (not (member (cons gnus-namazu/group-name-regexp + gnus-namazu-coding-system) + gnus-group-name-charset-group-alist)) + (let ((pair (assoc gnus-namazu/group-name-regexp + gnus-group-name-charset-group-alist))) + (if pair + (setcdr pair gnus-namazu-coding-system) + (push (cons gnus-namazu/group-name-regexp + gnus-namazu-coding-system) + gnus-group-name-charset-group-alist))))) + +(defun gnus-namazu/request-list (server) + "Return groups of the server SERVER." + (and (memq (car server) '(nnml nnmh)) + (nnoo-change-server (car server) (nth 1 server) (nthcdr 2 server)) + (gnus-request-list server) + (mapcar (function car) + (if (eq 'nnml (car server)) + nnml-group-alist + nnmh-group-alist)))) (defun gnus-namazu/server-directory (server) - "Return the top directory of articles in SERVER." + "Return the top directory of the server SERVER." (and (memq (car server) '(nnml nnmh)) (nnoo-change-server (car server) (nth 1 server) (nthcdr 2 server)) (file-name-as-directory @@ -179,6 +228,7 @@ options make any sense in this context." ;;; Functions to call Namazu. (defsubst gnus-namazu/normalize-results () + "Normalize file names returned by Namazu in this current buffer." (goto-char (point-min)) (while (not (eobp)) (when (if gnus-namazu-need-path-normalization @@ -193,8 +243,11 @@ options make any sense in this context." (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 @@ -209,9 +262,59 @@ options make any sense in this context." ,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/check-cache-group (str) + "Get the news group from the partial path STR of the cached article." + (if (gnus-use-long-file-name 'not-cache) + str + (catch 'found-group + (dolist (group (gnus-namazu/cache-group-candidates + (nnheader-replace-chars-in-string str ?/ ?.))) + (when (gnus-gethash group gnus-newsrc-hashtb) + (throw 'found-group group)))))) + +(defun gnus-namazu/cache-group-candidates (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/cache-group-candidates (concat prefix "/__" suffix)) + (gnus-namazu/cache-group-candidates (concat prefix ".._" suffix)))) + ((match-beginning 1) ;; The number of discoverd underscores = 2 + (nconc + (gnus-namazu/cache-group-candidates (concat prefix "//" suffix)) + (gnus-namazu/cache-group-candidates (concat prefix ".." suffix)))) + (t ;; The number of discoverd underscores = 1 + (gnus-namazu/cache-group-candidates (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)))) + (defun gnus-namazu/search (groups query) (with-temp-buffer - (when (zerop (gnus-namazu/call-namazu query)) + (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 @@ -220,34 +323,47 @@ options make any sense in this context." (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) t))) + (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]+\\)$"))) (gnus-namazu/normalize-results) (goto-char (point-min)) (while (not (eobp)) (let (server group file) - (and (looking-at topdir-regexp) - (setq server (cdr (assoc (match-string 1) server-alist)) - file (buffer-substring-no-properties - (match-end 0) (point-at-eol))) - (string-match "/\\([0-9]+\\)\\'" file) - (progn - (setq group (substring file 0 (match-beginning 0)) - file (match-string 1 file)) - (setq group - (gnus-group-prefixed-name - (nnheader-replace-chars-in-string group ?/ ?.) - server)) - (when (or (not groups) - (member group groups)) - (push (gnus-namazu/make-article - group (string-to-number file)) - articles))))) + (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/check-cache-group + (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 + (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))))) +;;; User Interface: (defun gnus-namazu/get-target-groups () (cond ((eq major-mode 'gnus-group-mode) @@ -261,8 +377,9 @@ options make any sense in this context." ;; In Summary buffer. (if current-prefix-arg (list (gnus-read-group "Group: ")) - (if (and (gnus-ephemeral-group-p gnus-newsgroup-name) - (string-match "\\`nnvirtual:namazu-search" gnus-newsgroup-name)) + (if (and + (gnus-ephemeral-group-p gnus-newsgroup-name) + (string-match gnus-namazu/group-name-regexp gnus-newsgroup-name)) (cadr (assq 'gnus-namazu-target-groups (gnus-info-method (gnus-get-info gnus-newsgroup-name)))) (list gnus-newsgroup-name)))))) @@ -270,7 +387,7 @@ options make any sense in this context." (defun gnus-namazu/get-current-query () (and (eq major-mode 'gnus-summary-mode) (gnus-ephemeral-group-p gnus-newsgroup-name) - (string-match "\\`nnvirtual:namazu-search" gnus-newsgroup-name) + (string-match gnus-namazu/group-name-regexp gnus-newsgroup-name) (cadr (assq 'gnus-namazu-current-query (gnus-info-method (gnus-get-info gnus-newsgroup-name)))))) @@ -329,7 +446,7 @@ options make any sense in this context." (interactive) (let ((pos (point))) (cond - ((and (re-search-backward "\\+\\([a-z]*\\)" nil t) + ((and (re-search-backward "\\+\\([-a-z]*\\)" nil t) (= pos (match-end 0))) (let* ((partial (match-string 1)) (completions @@ -388,6 +505,36 @@ options make any sense in this context." (read-from-minibuffer prompt initial gnus-namazu/read-query-map nil 'gnus-namazu/read-query-history))) +(defun gnus-namazu/highlight-words (query) + (with-temp-buffer + (insert " " query) + ;; Remove tokens for NOT search + (goto-char (point-min)) + (while (re-search-forward "[　 \t\r\f\n]+not[　 \t\r\f\n]+\ +\\([^　 \t\r\f\n\"{(/]+\\|\"[^\"]+\"\\|{[^}]+}\\|([^)]+)\\|/[^/]+/\\)+" nil t) + (delete-region (match-beginning 0) (match-end 0))) + ;; Remove tokens for Field search + (goto-char (point-min)) + (while (re-search-forward "[　 \t\r\f\n]+\\+[^　 \t\r\f\n:]+:\ +\\([^　 \t\r\f\n\"{(/]+\\|\"[^\"]+\"\\|{[^}]+}\\|([^)]+)\\|/[^/]+/\\)+" nil t) + (delete-region (match-beginning 0) (match-end 0))) + ;; Remove tokens for Regexp search + (goto-char (point-min)) + (while (re-search-forward "/[^/]+/" nil t) + (delete-region (match-beginning 0) (match-end 0))) + ;; Remove brackets, double quote, asterisk and operators + (goto-char (point-min)) + (while (re-search-forward "\\([(){}\"*]\\|\\b\\(and\\|or\\)\\b\\)" nil t) + (delete-region (match-beginning 0) (match-end 0))) + ;; Collect all keywords + (setq query nil) + (goto-char (point-min)) + (while (re-search-forward "[^　 \t\r\f\n]+" nil t) + (push (match-string 0) query)) + (when query + (list (list (regexp-opt query) + 0 0 'gnus-namazu-query-highlight-face))))) + (defun gnus-namazu/truncate-article-list (articles) (let ((hit (length articles))) (when (> hit gnus-large-newsgroup) @@ -404,19 +551,20 @@ options make any sense in this context." nil)))) articles)) +;;;###autoload (defun gnus-namazu-search (groups query) "Search QUERY through GROUPS with Namazu, and make a virtual group contains its results." (interactive (list (gnus-namazu/get-target-groups) - (gnus-namazu/read-query "Enter Keyword: "))) + (gnus-namazu/read-query "Enter query: "))) (gnus-namazu/setup) (let ((articles (gnus-namazu/search groups query))) (if articles (let ((real-groups groups) (vgroup - (apply 'format + (apply (function format) "nnvirtual:namazu-search?query=%s&groups=%s&id=%d%d%d" query (if groups (mapconcat 'identity groups ",") "ALL") @@ -426,6 +574,9 @@ and make a virtual group contains its results." (dolist (a articles) (add-to-list 'real-groups (gnus-namazu/article-group a)))) ;; Generate virtual group which includes all results. + (when (fboundp 'gnus-group-decoded-name) + (setq vgroup + (encode-coding-string vgroup gnus-namazu-coding-system))) (setq vgroup (gnus-group-read-ephemeral-group vgroup @@ -434,6 +585,9 @@ and make a virtual group contains its results." (gnus-namazu-target-groups ,groups) (gnus-namazu-current-query ,query)) t (cons (current-buffer) (current-window-configuration)) t)) + (when gnus-namazu-query-highlight + (gnus-group-set-parameter vgroup 'highlight-words + (gnus-namazu/highlight-words query))) ;; Generate new summary buffer which contains search results. (gnus-group-read-group t t vgroup @@ -447,6 +601,22 @@ and make a virtual group contains its results." '<))) (message "No entry.")))) +(let (current-load-list) + (defadvice gnus-offer-save-summaries + (before gnus-namazu-kill-summary-buffers activate compile) + "Advised by `gnus-namazu'. +In order to avoid annoying questions, kill summary buffers which +generated by `gnus-namazu' itself before `gnus-offer-save-summaries' +is called." + (let ((buffers (buffer-list))) + (while buffers + (when (with-current-buffer (car buffers) + (and (eq major-mode 'gnus-summary-mode) + (gnus-ephemeral-group-p gnus-newsgroup-name) + (string-match gnus-namazu/group-name-regexp + gnus-newsgroup-name))) + (kill-buffer (car buffers))) + (setq buffers (cdr buffers)))))) (defun gnus-namazu-insinuate () (add-hook @@ -458,6 +628,6 @@ and make a virtual group contains its results." (lambda () (define-key gnus-summary-mode-map "\C-c\C-n" 'gnus-namazu-search)))) - (provide 'gnus-namazu) + ;; gnus-namazu.el ends here.