X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-namazu.el;h=e0e3eb8f886d6d54f6aecb25450a624bd939acd2;hb=36bd162f4f7cd40453b8683e796730836c352b2a;hp=4707858649555694ce850a31f0f54fff643b993d;hpb=b62b5f8d7cd04f78f7d2c15dbb2d842de0ba8c53;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-namazu.el b/lisp/gnus-namazu.el index 4707858..e0e3eb8 100644 --- a/lisp/gnus-namazu.el +++ b/lisp/gnus-namazu.el @@ -31,29 +31,30 @@ ;; 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 ;; -;; (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. +;; 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: @@ -69,6 +70,17 @@ (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) + (defvar nnml-group-alist) + (defvar nnmh-directory) + (defvar nnmh-group-alist)) + (defgroup gnus-namazu nil "Search nnmh and nnml groups in Gnus with Namazu." @@ -76,26 +88,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) @@ -114,43 +123,100 @@ 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) + + +;;; 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: +(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)))) + (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) + +(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 @@ -158,21 +224,27 @@ 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) (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") + (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 @@ -183,11 +255,21 @@ 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 ((name (gnus-group-prefixed-name group method))) + (or (cdr (assoc (downcase name) gnus-namazu/group-alist)) + name)))) (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 @@ -196,22 +278,25 @@ 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)))) + (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) + ;; 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-group-prefixed-name + (gnus-namazu/group-prefixed-name (nnheader-replace-chars-in-string group ?/ ?.) server)) (when (or (not groups) @@ -223,6 +308,7 @@ options make any sense in this context." (nreverse articles))))) +;;; User Interface: (defun gnus-namazu/get-target-groups () (cond ((eq major-mode 'gnus-group-mode) @@ -237,7 +323,7 @@ options make any sense in this context." (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)) + (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)))))) @@ -245,7 +331,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)))))) @@ -374,24 +460,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") @@ -401,6 +488,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 @@ -422,7 +512,6 @@ and make a virtual group contains its results." '<))) (message "No entry.")))) - (defun gnus-namazu-insinuate () (add-hook 'gnus-group-mode-hook @@ -433,6 +522,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.