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