git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-namazu.el

   1 ;;; gnus-namazu.el --- Search mail with Namazu.
   2
   3 ;; Copyright (C) 2000,2001 Tsuchiya Masatoshi <tsuchiya@namazu.org>
   4
   5 ;; Author: Tsuchiya Masatoshi <tsuchiya@namazu.org>
   6 ;; Keywords: mail searching namazu
   7
   8 ;;; Copyright:
   9
  10 ;; This file is a part of Semi-Gnus.
  11
  12 ;; This program is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program; if not, you can either send email to this
  24 ;; program's maintainer or write to: The Free Software Foundation,
  25 ;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.
  26
  27
  28 ;;; Commentary:
  29
  30 ;; This file defines the command to search mails with Namazu and
  31 ;; browse its results with Gnus.  This module requires the external
  32 ;; command Namazu.  Visit the following page for more information.
  33 ;;
  34 ;;     http://www.namazu.org/
  35
  36
  37 ;;; Install:
  38
  39 ;; (1) Make index of articles with Namzu before using this module.
  40 ;;
  41 ;;       % mkdir ~/News/namazu
  42 ;;       % cd ~/News/namazu
  43 ;;       % mknmz -a -c -h ~/Mail
  44 ;;
  45 ;; (2) Furthermore, put these expressions to your ~/.emacs, to set the
  46 ;;     path of the index files to `gnus-namazu-index-directory' and to
  47 ;;     initialize this module.
  48 ;;
  49 ;;       (setq gnus-namazu-index-directory (expand-file-name "~/Namazu"))
  50
  51 ;; If you would like to use this module in Gnus (not T-gnus), put this
  52 ;; file into the lisp/ directory in the Gnus source tree and run `make
  53 ;; install'.  And then, put the following expressions into your ~/.gnus.
  54 ;;
  55 ;;       (require 'gnus-namazu)
  56 ;;       (gnus-namazu-insinuate)
  57
  58
  59 ;;; Usage:
  60
  61 ;; In group buffer or in summary buffer, type C-c C-n query RET.
  62
  63
  64 ;;; Code:
  65
  66 (eval-when-compile (require 'cl))
  67 (require 'nnoo)
  68 (require 'nnheader)
  69 (require 'nnmail)
  70 (require 'gnus-sum)
  71
  72 ;; It is required for Mule 2.3.  See the file Mule23@1934.en.
  73 (eval-and-compile
  74   (autoload 'regexp-opt "regexp-opt"))
  75
  76 (defgroup gnus-namazu nil
  77   "Search nnmh and nnml groups in Gnus with Namazu."
  78   :group 'namazu
  79   :group 'gnus
  80   :prefix "gnus-namazu-")
  81
  82 (defcustom gnus-namazu-indexed-servers nil
  83   "*List of servers indexed with Namazu."
  84   :type '(repeat gnus-select-method)
  85   :group 'gnus-namazu)
  86
  87 (defcustom gnus-namazu-index-directory
  88   (if (boundp 'nnir-namazu-index-directory)
  89       (symbol-value 'nnir-namazu-index-directory)
  90     (expand-file-name "namazu" gnus-directory))
  91   "*Index directory of Namazu."
  92   :type 'directory
  93   :group 'gnus-namazu)
  94
  95 (defcustom gnus-namazu-command
  96   (cond
  97    ((boundp 'namazu-command)
  98     (symbol-value 'namazu-command))
  99    ((boundp 'nnir-namazu-program)
 100     (symbol-value 'nnir-namazu-program))
 101    (t "namazu"))
 102   "*Name of the executable file of Namazu."
 103   :group 'gnus-namazu
 104   :type 'string)
 105
 106 (defcustom gnus-namazu-additional-arguments nil
 107   "*Additional arguments of Namazu.
 108 The options `-q', `-a', and `-l' are always used, very few other
 109 options make any sense in this context."
 110   :type '(repeat string)
 111   :group 'gnus-namazu)
 112
 113 (defcustom gnus-namazu-field-keywords
 114   '("date" "from" "newsgroups" "size" "subject" "summary" "to" "uri")
 115   "*List of keywords to do field-search."
 116   :type '(repeat string)
 117   :group 'gnus-namazu)
 118
 119 (defcustom gnus-namazu-coding-system
 120   (if (>= emacs-major-version 20) 'euc-japan '*euc-japan*)
 121   "*Coding system for Namazu process."
 122   :type 'coding-system
 123   :group 'gnus-namazu)
 124
 125
 126 (defmacro gnus-namazu/make-article (group number)
 127   `(cons ,group ,number))
 128 (defmacro gnus-namazu/article-group  (x) `(car ,x))
 129 (defmacro gnus-namazu/article-number (x) `(cdr ,x))
 130
 131
 132 (defun gnus-namazu/setup ()
 133   (unless gnus-namazu-indexed-servers
 134     (setq gnus-namazu-indexed-servers
 135           (delq nil
 136                 (mapcar (lambda (method)
 137                           (when (memq (car method) '(nnml nnmh))
 138                             method))
 139                         (cons gnus-select-method
 140                               gnus-secondary-select-methods)))))
 141   (unless gnus-namazu-indexed-servers
 142     (error "%s" "Can't find either nnml backend or nnmh backend"))
 143   (unless (and (stringp gnus-namazu-index-directory)
 144                (file-directory-p gnus-namazu-index-directory)
 145                (file-readable-p
 146                 (expand-file-name "NMZ.i" gnus-namazu-index-directory)))
 147     (error "%s" "Can't find index.  Check `gnus-namazu-index-directory'")))
 148
 149
 150 ;; To suppress byte-compile warning.
 151 (eval-when-compile
 152   (defvar nnml-directory)
 153   (defvar nnmh-directory))
 154
 155 (defun gnus-namazu/server-directory (server)
 156   "Return the top directory of articles in SERVER."
 157   (and (memq (car server) '(nnml nnmh))
 158        (nnoo-change-server (car server) (nth 1 server) (nthcdr 2 server))
 159        (file-name-as-directory
 160         (expand-file-name (if (eq 'nnml (car server))
 161                               nnml-directory
 162                             nnmh-directory)))))
 163
 164
 165 ;;; Functions to call Namazu.
 166 (defsubst gnus-namazu/call-namazu (query)
 167   (let ((coding-system-for-read gnus-namazu-coding-system)
 168         (coding-system-for-write gnus-namazu-coding-system)
 169         (default-process-coding-system
 170           (cons gnus-namazu-coding-system gnus-namazu-coding-system))
 171         (process-environment
 172          (copy-sequence process-environment)))
 173     ;; Disable locale.
 174     (dolist (env process-environment)
 175       (when (string-match "\
 176 \\`\\(L\\(ANG\\|C_\\(ALL\\|CTYPE\\|COLLATE\\|TIME\\|NUMERIC\\|MONETARY\\|MESSAGES\\)\\)\\)=" env)
 177         (setenv (match-string 1 env) nil)))
 178     (setenv "LANG" "C")
 179     (apply 'call-process
 180            `(,gnus-namazu-command
 181              nil                        ; input from /dev/null
 182              t                          ; output
 183              nil                        ; don't redisplay
 184              "-q"                       ; don't be verbose
 185              "-a"                       ; show all matches
 186              "-l"                       ; use list format
 187              ,@gnus-namazu-additional-arguments
 188              ,query
 189              ,gnus-namazu-index-directory))))
 190
 191 (defun gnus-namazu/search (groups query)
 192   (with-temp-buffer
 193     (when (zerop (gnus-namazu/call-namazu query))
 194       (let* ((articles)
 195              (server-alist
 196               (delq nil
 197                     (let (dir)
 198                       (mapcar
 199                        (lambda (s)
 200                          (when (setq dir (gnus-namazu/server-directory s))
 201                            (cons (file-name-as-directory dir) s)))
 202                        gnus-namazu-indexed-servers))))
 203              (topdir-regexp
 204               (regexp-opt (mapcar 'car server-alist) t)))
 205         (goto-char (point-min))
 206         (while (not (eobp))
 207           (let (server group file)
 208             (and (looking-at topdir-regexp)
 209                  (setq server (cdr (assoc (match-string 1) server-alist))
 210                        file (buffer-substring-no-properties
 211                              (match-end 0) (point-at-eol)))
 212                  (string-match "/\\([0-9]+\\)$" file)
 213                  (progn
 214                    (setq group (substring file 0 (match-beginning 0))
 215                          file (match-string 1 file))
 216                    (setq group
 217                          (gnus-group-prefixed-name
 218                           (nnheader-replace-chars-in-string group ?/ ?.)
 219                           server))
 220                    (when (or (not groups)
 221                              (member group groups))
 222                      (push (gnus-namazu/make-article
 223                             group (string-to-number file))
 224                            articles)))))
 225           (forward-line 1))
 226         (nreverse articles)))))
 227
 228
 229 (defun gnus-namazu/get-target-groups ()
 230   (cond
 231    ((eq major-mode 'gnus-group-mode)
 232     ;; In Group buffer.
 233     (cond
 234      (current-prefix-arg
 235       (gnus-group-process-prefix current-prefix-arg))
 236      (gnus-group-marked
 237       (prog1 gnus-group-marked (gnus-group-unmark-all-groups)))))
 238    ((eq major-mode 'gnus-summary-mode)
 239     ;; In Summary buffer.
 240     (if current-prefix-arg
 241         (list (gnus-read-group "Group: "))
 242       (if (and (gnus-ephemeral-group-p gnus-newsgroup-name)
 243                (string-match "^nnvirtual:namazu-search" gnus-newsgroup-name))
 244           (cadr (assq 'gnus-namazu-target-groups
 245                       (gnus-info-method (gnus-get-info gnus-newsgroup-name))))
 246         (list gnus-newsgroup-name))))))
 247
 248 (defun gnus-namazu/get-current-query ()
 249   (and (eq major-mode 'gnus-summary-mode)
 250        (gnus-ephemeral-group-p gnus-newsgroup-name)
 251        (string-match "^nnvirtual:namazu-search" gnus-newsgroup-name)
 252        (cadr (assq 'gnus-namazu-current-query
 253                    (gnus-info-method (gnus-get-info gnus-newsgroup-name))))))
 254
 255 (defvar gnus-namazu/read-query-original-buffer nil)
 256 (defvar gnus-namazu/read-query-prompt nil)
 257 (defvar gnus-namazu/read-query-history nil)
 258
 259 (defun gnus-namazu/get-current-subject ()
 260   (and gnus-namazu/read-query-original-buffer
 261        (bufferp gnus-namazu/read-query-original-buffer)
 262        (with-current-buffer gnus-namazu/read-query-original-buffer
 263          (when (eq major-mode 'gnus-summary-mode)
 264            (let ((s (gnus-summary-article-subject)))
 265              ;; Remove typically prefixes of mailing lists.
 266              (when (string-match
 267                     "^\\(\\[[^]]*[0-9]+\\]\\|([^)]*[0-9]+)\\)\\s-*" s)
 268                (setq s (substring s (match-end 0))))
 269              (when (string-match
 270                     "^\\(Re\\(\\^?\\([0-9]+\\|\\[[0-9]+\\]\\)\\)?:\\s-*\\)+" s)
 271                (setq s (substring s (match-end 0))))
 272              (when (string-match "\\s-*(\\(re\\|was\\)\\b" s)
 273                (setq s (substring s 0 (match-beginning 0))))
 274              s)))))
 275
 276 (defun gnus-namazu/get-current-from ()
 277   (and gnus-namazu/read-query-original-buffer
 278        (bufferp gnus-namazu/read-query-original-buffer)
 279        (with-current-buffer gnus-namazu/read-query-original-buffer
 280          (when (eq major-mode 'gnus-summary-mode)
 281            (cadr (mail-extract-address-components
 282                   (mail-header-from
 283                    (gnus-summary-article-header))))))))
 284
 285 (defmacro gnus-namazu/minibuffer-prompt-end ()
 286   (if (fboundp 'minibuffer-prompt-end)
 287       '(minibuffer-prompt-end)
 288     '(point-min)))
 289
 290 (defun gnus-namazu/message (string &rest arguments)
 291   (let* ((s1 (concat
 292               gnus-namazu/read-query-prompt
 293               (buffer-substring (gnus-namazu/minibuffer-prompt-end)
 294                                 (point-max))))
 295          (s2 (apply (function format) string arguments))
 296          (w (- (window-width)
 297                (string-width s1)
 298                (string-width s2)
 299                1)))
 300     (message (if (>= w 0)
 301                  (concat s1 (make-string w ?\ ) s2)
 302                s2))
 303     (if (sit-for 0.3) (message s1))
 304     s2))
 305
 306 (defun gnus-namazu/complete-query ()
 307   (interactive)
 308   (let ((pos (point)))
 309     (cond
 310      ((and (re-search-backward "\\+\\([a-z]*\\)" nil t)
 311            (= pos (match-end 0)))
 312       (let* ((partial (match-string 1))
 313              (completions
 314               (all-completions
 315                partial
 316                (mapcar 'list gnus-namazu-field-keywords))))
 317         (cond
 318          ((null completions)
 319           (gnus-namazu/message "No completions of %s" partial))
 320          ((= 1 (length completions))
 321           (goto-char (match-beginning 1))
 322           (delete-region (match-beginning 1) (match-end 1))
 323           (insert (car completions) ":")
 324           (setq pos (point))
 325           (gnus-namazu/message "Completed"))
 326          (t
 327           (let ((x (try-completion partial (mapcar 'list completions))))
 328             (if (string= x partial)
 329                 (if (and (eq last-command
 330                              'gnus-namazu/field-keyword-completion)
 331                          completion-auto-help)
 332                     (with-output-to-temp-buffer "*Completions*"
 333                       (display-completion-list completions))
 334                   (gnus-namazu/message "Sole completion"))
 335               (goto-char (match-beginning 1))
 336               (delete-region (match-beginning 1) (match-end 1))
 337               (insert x)
 338               (setq pos (point))))))))
 339      ((and (looking-at "\\+subject:")
 340            (= pos (match-end 0)))
 341       (let ((s (gnus-namazu/get-current-subject)))
 342         (when s
 343           (goto-char pos)
 344           (insert "\"" s "\"")
 345           (setq pos (point)))))
 346      ((and (looking-at "\\+from:")
 347            (= pos (match-end 0)))
 348       (let ((f (gnus-namazu/get-current-from)))
 349         (when f
 350           (goto-char pos)
 351           (insert "\"" f "\"")
 352           (setq pos (point))))))
 353     (goto-char pos)))
 354
 355 (defvar gnus-namazu/read-query-map
 356   (let ((keymap (copy-keymap minibuffer-local-map)))
 357     (define-key keymap "\t" 'gnus-namazu/complete-query)
 358     keymap))
 359
 360 (defun gnus-namazu/read-query (prompt &optional initial)
 361   (let ((gnus-namazu/read-query-original-buffer (current-buffer))
 362         (gnus-namazu/read-query-prompt prompt))
 363     (unless initial
 364       (when (setq initial (gnus-namazu/get-current-query))
 365         (setq initial (cons initial 0))))
 366     (read-from-minibuffer prompt initial gnus-namazu/read-query-map nil
 367                           'gnus-namazu/read-query-history)))
 368
 369 (defun gnus-namazu/truncate-article-list (articles)
 370   (let ((hit (length articles)))
 371     (when (> hit gnus-large-newsgroup)
 372       (let* ((cursor-in-echo-area nil)
 373              (input
 374               (when (> hit gnus-large-newsgroup)
 375                 (read-from-minibuffer
 376                  (format
 377                   "Too many articles were retrieved.  How many articles (max %d): "
 378                   hit)
 379                  (cons (number-to-string gnus-large-newsgroup) 0)))))
 380         (unless (string-match "^[ \t]*$" input)
 381           (setcdr (nthcdr (min (1- (string-to-number input)) hit) articles)
 382                   nil))))
 383     articles))
 384
 385 (defun gnus-namazu-search (groups query)
 386   "Search QUERY through GROUPS with Namazu,
 387 and make a virtual group contains its results."
 388   (interactive
 389    (list
 390     (gnus-namazu/get-target-groups)
 391     (gnus-namazu/read-query "Enter Keyword: ")))
 392   (gnus-namazu/setup)
 393   (let ((articles (gnus-namazu/search groups query)))
 394     (if articles
 395         (let ((real-groups groups)
 396               (vgroup
 397                (apply 'format
 398                       "nnvirtual:namazu-search?query=%s&groups=%s&id=%d%d%d"
 399                       query
 400                       (if groups (mapconcat 'identity groups ",") "ALL")
 401                       (current-time))))
 402           (gnus-namazu/truncate-article-list articles)
 403           (unless real-groups
 404             (dolist (a articles)
 405               (add-to-list 'real-groups (gnus-namazu/article-group a))))
 406           ;; Generate virtual group which includes all results.
 407           (setq vgroup
 408                 (gnus-group-read-ephemeral-group
 409                  vgroup
 410                  `(nnvirtual ,vgroup
 411                              (nnvirtual-component-groups ,real-groups)
 412                              (gnus-namazu-target-groups ,groups)
 413                              (gnus-namazu-current-query ,query))
 414                  t (cons (current-buffer) (current-window-configuration)) t))
 415           ;; Generate new summary buffer which contains search results.
 416           (gnus-group-read-group
 417            t t vgroup
 418            (sort (delq nil ;; Ad-hoc fix, to avoid wrong-type-argument error.
 419                        (mapcar
 420                         (lambda (a)
 421                           (nnvirtual-reverse-map-article
 422                            (gnus-namazu/article-group a)
 423                            (gnus-namazu/article-number a)))
 424                         articles))
 425                  '<)))
 426       (message "No entry."))))
 427
 428
 429 (defun gnus-namazu-insinuate ()
 430   (add-hook
 431    'gnus-group-mode-hook
 432    (lambda ()
 433      (define-key gnus-group-mode-map "\C-c\C-n" 'gnus-namazu-search)))
 434   (add-hook
 435    'gnus-summary-mode-hook
 436    (lambda ()
 437      (define-key gnus-summary-mode-map "\C-c\C-n" 'gnus-namazu-search))))
 438
 439
 440 (provide 'gnus-namazu)
 441 ;; gnus-namazu.el ends here.