X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-namazu.el;h=91707e67909f6e62126b33719d804f6e51f2345a;hb=9b741e050b400987d68ff761c6cc3276c932839c;hp=37fdd8638ef2433815fc4edd318b6ab4c67e9e71;hpb=2be776e3e25c3932ecd45f878a732753c942f7a3;p=elisp%2Fgnus.git-

diff --git a/lisp/gnus-namazu.el b/lisp/gnus-namazu.el
index 37fdd86..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 <tsuchiya@namazu.org>
+;; Copyright (C) 2000,2001,2002 TSUCHIYA Masatoshi <tsuchiya@namazu.org>
 
-;; Author: Tsuchiya Masatoshi <tsuchiya@namazu.org>
+;; Author: TSUCHIYA Masatoshi <tsuchiya@namazu.org>
 ;; 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,9 +25,10 @@
 
 ;;; 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://namazu.org/
 
@@ -39,7 +38,11 @@
 ;; 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
+;;
+;; 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
@@ -142,27 +145,38 @@ options make any sense in this context."
   :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:
-(defvar gnus-namazu/group-alist nil
-  "Associative list to map groups in lower case to official names.")
 (defconst gnus-namazu/group-name-regexp "\\`nnvirtual:namazu-search\\?")
 
 ;; Multibyte group name:
-(add-to-list 'gnus-group-name-charset-group-alist
-	     (cons gnus-namazu/group-name-regexp gnus-namazu-coding-system))
 (and
  (fboundp 'gnus-group-decoded-name)
- (let ((group
-	(concat "nnvirtual:namazu-search?query="
-		(decode-coding-string
-		 (string 27 36 66 52 65 59 122 27 40 66)
-		 (if (boundp 'MULE) '*iso-2022-jp* 'iso-2022-7bit)))))
-   (/= (length (string-to-char-list (concat "*Summary " group "*")))
-       (length
-	(string-to-char-list
-	 (gnus-summary-buffer-name
-	  (encode-coding-string group gnus-namazu-coding-system))))))
+ (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)
@@ -181,20 +195,17 @@ options make any sense in this context."
    (gnus-servers-using-backend 'nnmh)))
 
 (defun gnus-namazu/setup ()
-  (unless gnus-namazu-case-sensitive-filesystem
-    ;; FIXME: The alist to map group names in lower case to real names
-    ;; is reconstructed every when gnus-namazu/setup() is called.
-    ;; This reconstruction make gnus-namazu-search() slow.
-    (setq gnus-namazu/group-alist nil)
-    (dolist (server (gnus-namazu/indexed-servers))
-      (dolist (group (gnus-namazu/request-list server))
-	(let ((name (gnus-group-prefixed-name group server)))
-	  (unless (assoc name gnus-namazu/group-alist)
-	    (push (cons (downcase name) name) gnus-namazu/group-alist)))))))
-
-(defun gnus-namazu/shutdown ()
-  (setq gnus-namazu/group-alist nil))
-(add-hook 'gnus-exit-gnus-hook 'gnus-namazu/shutdown)
+  (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."
@@ -232,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
@@ -252,9 +266,49 @@ options make any sense in this context."
   "Return the whole name from GROUP and METHOD."
   (if gnus-namazu-case-sensitive-filesystem
       (gnus-group-prefixed-name group method)
-    (let ((name (gnus-group-prefixed-name group method)))
-      (or (cdr (assoc (downcase name) gnus-namazu/group-alist))
-	  name))))
+    (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
@@ -270,31 +324,41 @@ options make any sense in this context."
 			 (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))))
+	     (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)
-		 ;; Check a discovered file is managed by Gnus servers.
-		 (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))
-		   (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)))))
 
@@ -313,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 gnus-namazu/group-name-regexp 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))))))
@@ -381,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
@@ -440,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)
@@ -490,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
@@ -503,6 +601,23 @@ 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
    'gnus-group-mode-hook