X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-namazu.el;h=91707e67909f6e62126b33719d804f6e51f2345a;hb=9b741e050b400987d68ff761c6cc3276c932839c;hp=9955af9654a37504f00f6f28305d937a3187e069;hpb=79852e056de4179f9bb7c5621e04d8d37d7cac11;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-namazu.el b/lisp/gnus-namazu.el index 9955af9..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,33 +25,39 @@ ;;; 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: -;; (1) Make index of articles with Namzu before using this module. +;; Make index of articles with Namzu before using this module. ;; ;; % mkdir ~/News/namazu -;; % cd ~/News/namazu -;; % mknmz -a -c -h ~/Mail +;; % mknmz -a -h -O ~/News/namazu ~/Mail ~/News/cache ;; -;; (2) Furthermore, put these expressions to your ~/.emacs, to set the -;; path of the index files to `gnus-namazu-index-directory' and to -;; initialize this module. +;; 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-directory (expand-file-name "~/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: @@ -68,7 +72,17 @@ (require 'nnheader) (require 'nnmail) (require 'gnus-sum) -(require 'std11) + +;; 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) + (defvar nnml-group-alist) + (defvar nnmh-directory) + (defvar nnmh-group-alist)) (defgroup gnus-namazu nil @@ -77,26 +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-directory - (if (boundp 'nnir-namazu-index-directory) - (symbol-value 'nnir-namazu-index-directory) - (expand-file-name "namazu" gnus-directory)) +(defcustom gnus-namazu-index-directories + (list + (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 'directory + :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) @@ -115,43 +126,99 @@ options make any sense in this context." :group 'gnus-namazu) (defcustom gnus-namazu-coding-system - (if (>= emacs-major-version 20) 'euc-japan '*euc-japan*) + (if (memq system-type '(windows-nt OS/2 emx)) + (if (boundp 'MULE) '*sjis* 'shift_jis) + (if (boundp 'MULE) '*euc-japan* 'euc-japan)) "*Coding system for Namazu process." :type 'coding-system :group 'gnus-namazu) +(defcustom gnus-namazu-need-path-normalization + (eq system-type 'windows-nt) + "*Non-nil means that outputs of namazu may contain a not normalized path." + :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")) - (unless (and (stringp gnus-namazu-index-directory) - (file-directory-p gnus-namazu-index-directory) - (file-readable-p - (expand-file-name "NMZ.i" gnus-namazu-index-directory))) - (error "%s" "Can't find index. Check `gnus-namazu-index-directory'"))) - - -;; To suppress byte-compile warning. -(eval-when-compile - (defvar nnml-directory) - (defvar nnmh-directory)) + (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 @@ -159,21 +226,30 @@ options make any sense in this context." nnml-directory nnmh-directory))))) - ;;; 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 + (or (not (looking-at "/\\(.\\)|/")) + (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))) + (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)) - (process-environment - (copy-sequence process-environment))) - ;; Disable locale. - (dolist (env process-environment) - (when (string-match "\ -\\`\\(L\\(ANG\\|C_\\(ALL\\|CTYPE\\|COLLATE\\|TIME\\|NUMERIC\\|MONETARY\\|MESSAGES\\)\\)\\)=" env) - (setenv (match-string 1 env) nil))) - (setenv "LANG" "C") + 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 @@ -184,11 +260,61 @@ options make any sense in this context." "-l" ; use list format ,@gnus-namazu-additional-arguments ,query - ,gnus-namazu-index-directory)))) + ,@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 @@ -197,33 +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) @@ -237,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)))))) @@ -246,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)))))) @@ -276,7 +417,7 @@ options make any sense in this context." (bufferp gnus-namazu/read-query-original-buffer) (with-current-buffer gnus-namazu/read-query-original-buffer (when (eq major-mode 'gnus-summary-mode) - (cadr (std11-extract-address-components + (cadr (mail-extract-address-components (mail-header-from (gnus-summary-article-header)))))))) @@ -305,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 @@ -364,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) @@ -375,24 +546,25 @@ options make any sense in this context." "Too many articles were retrieved. How many articles (max %d): " hit) (cons (number-to-string gnus-large-newsgroup) 0))))) - (unless (string-match "^[ \t]*$" input) + (unless (string-match "\\`[ \t]*\\'" input) (setcdr (nthcdr (min (1- (string-to-number input)) hit) articles) 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") @@ -402,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 @@ -410,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 @@ -423,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 @@ -434,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.