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

   1 ;;; gnus-namazu.el --- Search mail with Namazu. -*- coding: iso-2022-7bit; -*-
   2
   3 ;; Copyright (C) 2000,2001,2002 TSUCHIYA Masatoshi <tsuchiya@namazu.org>
   4
   5 ;; Author: TSUCHIYA Masatoshi <tsuchiya@namazu.org>
   6 ;; Keywords: mail searching namazu
   7
   8 ;; This file is a part of Semi-Gnus.
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program; if not, you can either send email to this
  22 ;; program's maintainer or write to: The Free Software Foundation,
  23 ;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.
  24
  25
  26 ;;; Commentary:
  27
  28 ;; This file defines the command to search mails and persistent
  29 ;; articles with Namazu and browse its results with Gnus.  This module
  30 ;; requires the external command, Namazu.  Visit the following page
  31 ;; for more information.
  32 ;;
  33 ;;     http://namazu.org/
  34
  35
  36 ;;; Install:
  37
  38 ;; Make index of articles with Namzu before using this module.
  39 ;;
  40 ;;       % mkdir ~/News/namazu
  41 ;;       % mknmz -a -h -O ~/News/namazu ~/Mail ~/News/cache
  42 ;;
  43 ;; The first command makes the directory for index files, and the
  44 ;; second command generates index files of mails and persistent
  45 ;; articles.
  46 ;;
  47 ;; When you put index files of Namazu into the directory other than
  48 ;; the default one (~/News/namazu), it is necessary to put this
  49 ;; expression to your ~/.gnus, in order to set the path of index files
  50 ;; to `gnus-namazu-index-directories'.
  51 ;;
  52 ;;      (setq gnus-namazu-index-directories
  53 ;;            (list (expand-file-name "~/namazu")))
  54 ;;
  55 ;; If you would like to use this module in Gnus (not T-gnus), put this
  56 ;; file into the lisp/ directory in the Gnus source tree and run `make
  57 ;; install'.  And then, put the following expressions into your ~/.gnus.
  58 ;;
  59 ;;      (require 'gnus-namazu)
  60 ;;      (gnus-namazu-insinuate)
  61
  62
  63 ;;; Usage:
  64
  65 ;; In group buffer or in summary buffer, type C-c C-n query RET.
  66
  67
  68 ;;; Code:
  69
  70 (eval-when-compile (require 'cl))
  71 (require 'nnoo)
  72 (require 'nnheader)
  73 (require 'nnmail)
  74 (require 'gnus-sum)
  75
  76 ;; It is required for Mule 2.3.  See the file Mule23@1934.en.
  77 (eval-and-compile
  78   (autoload 'regexp-opt "regexp-opt"))
  79
  80 ;; To suppress byte-compile warning.
  81 (eval-when-compile
  82   (defvar nnml-directory)
  83   (defvar nnml-group-alist)
  84   (defvar nnmh-directory)
  85   (defvar nnmh-group-alist))
  86
  87
  88 (defgroup gnus-namazu nil
  89   "Search nnmh and nnml groups in Gnus with Namazu."
  90   :group 'namazu
  91   :group 'gnus
  92   :prefix "gnus-namazu-")
  93
  94 (defcustom gnus-namazu-index-directories
  95   (list
  96    (or (and (boundp 'gnus-namazu-index-directory)
  97             (symbol-value 'gnus-namazu-index-directory))
  98        (and (boundp 'nnir-namazu-index-directory)
  99             (symbol-value 'nnir-namazu-index-directory))
 100        (expand-file-name "namazu" gnus-directory)))
 101   "*Index directory of Namazu."
 102   :type '(repeat directory)
 103   :group 'gnus-namazu)
 104
 105 (defcustom gnus-namazu-command
 106   (or (and (boundp 'namazu-command)
 107            (symbol-value 'namazu-command))
 108       (and (boundp 'nnir-namazu-program)
 109            (symbol-value 'nnir-namazu-program))
 110       "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 (boundp 'MULE) '*sjis* 'shift_jis)
 131     (if (boundp 'MULE) '*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 (defcustom gnus-namazu-case-sensitive-filesystem
 143   (not (eq system-type 'windows-nt))
 144   "*Non-nil means that the using file system distinguishes cases of characters."
 145   :type 'boolean
 146   :group 'gnus-namazu)
 147
 148 (defcustom gnus-namazu-query-highlight t
 149   "Non-nil means that queried words is highlighted."
 150   :type 'boolean
 151   :group 'gnus-namazu)
 152
 153 (defface gnus-namazu-query-highlight-face
 154   '((((type tty pc) (class color))
 155      (:background "magenta4" :foreground "cyan1"))
 156     (((class color) (background light))
 157      (:background "magenta4" :foreground "lightskyblue1"))
 158     (((class color) (background dark))
 159      (:background "palevioletred2" :foreground "brown4"))
 160     (t (:inverse-video t)))
 161   "Face used for namazu query matching words."
 162   :group 'gnus-namazu)
 163
 164 ;;; Internal Variable:
 165 (defconst gnus-namazu/group-name-regexp "\\`nnvirtual:namazu-search\\?")
 166
 167 ;; Multibyte group name:
 168 (and
 169  (fboundp 'gnus-group-decoded-name)
 170  (let ((gnus-group-name-charset-group-alist
 171         (list (cons gnus-namazu/group-name-regexp gnus-namazu-coding-system)))
 172        (query (decode-coding-string
 173                (string 27 36 66 52 65 59 122 27 40 66)
 174                (if (boundp 'MULE) '*iso-2022-jp* 'iso-2022-7bit))))
 175    (not (string-match query
 176                       (gnus-summary-buffer-name
 177                        (encode-coding-string
 178                         (concat "nnvirtual:namazu-search?query=" query)
 179                         gnus-namazu-coding-system)))))
 180  (let (current-load-list)
 181    (defadvice gnus-summary-buffer-name
 182      (before gnus-namazu-summary-buffer-name activate compile)
 183      "Advised by `gnus-namazu' to handle encoded group names."
 184      (ad-set-arg 0 (gnus-group-decoded-name (ad-get-arg 0))))))
 185
 186 (defmacro gnus-namazu/make-article (group number)
 187   `(cons ,group ,number))
 188 (defmacro gnus-namazu/article-group  (x) `(car ,x))
 189 (defmacro gnus-namazu/article-number (x) `(cdr ,x))
 190
 191 (defsubst gnus-namazu/indexed-servers ()
 192   "Choice appropriate servers from opened ones, and return thier list."
 193   (append
 194    (gnus-servers-using-backend 'nnml)
 195    (gnus-servers-using-backend 'nnmh)))
 196
 197 (defun gnus-namazu/setup ()
 198   (and (boundp 'gnus-group-name-charset-group-alist)
 199        (not (member (cons gnus-namazu/group-name-regexp
 200                           gnus-namazu-coding-system)
 201                     gnus-group-name-charset-group-alist))
 202        (let ((pair (assoc gnus-namazu/group-name-regexp
 203                           gnus-group-name-charset-group-alist)))
 204          (if pair
 205              (setcdr pair gnus-namazu-coding-system)
 206            (push (cons gnus-namazu/group-name-regexp
 207                        gnus-namazu-coding-system)
 208                  gnus-group-name-charset-group-alist)))))
 209
 210 (defun gnus-namazu/request-list (server)
 211   "Return groups of the server SERVER."
 212   (and (memq (car server) '(nnml nnmh))
 213        (nnoo-change-server (car server) (nth 1 server) (nthcdr 2 server))
 214        (gnus-request-list server)
 215        (mapcar (function car)
 216                (if (eq 'nnml (car server))
 217                    nnml-group-alist
 218                  nnmh-group-alist))))
 219
 220 (defun gnus-namazu/server-directory (server)
 221   "Return the top directory of the server SERVER."
 222   (and (memq (car server) '(nnml nnmh))
 223        (nnoo-change-server (car server) (nth 1 server) (nthcdr 2 server))
 224        (file-name-as-directory
 225         (expand-file-name (if (eq 'nnml (car server))
 226                               nnml-directory
 227                             nnmh-directory)))))
 228
 229 ;;; Functions to call Namazu.
 230 (defsubst gnus-namazu/normalize-results ()
 231   "Normalize file names returned by Namazu in this current buffer."
 232   (goto-char (point-min))
 233   (while (not (eobp))
 234     (when (if gnus-namazu-need-path-normalization
 235               (or (not (looking-at "/\\(.\\)|/"))
 236                   (replace-match "\\1:/"))
 237             (eq ?~ (char-after (point))))
 238       (insert (expand-file-name
 239                (buffer-substring (gnus-point-at-bol) (gnus-point-at-eol))))
 240       (delete-region (point) (gnus-point-at-eol)))
 241     (forward-line 1)))
 242
 243 (defsubst gnus-namazu/call-namazu (query)
 244   (let ((coding-system-for-read gnus-namazu-coding-system)
 245         (coding-system-for-write gnus-namazu-coding-system)
 246         (input-coding-system gnus-namazu-coding-system)
 247         (output-coding-system gnus-namazu-coding-system)
 248         (default-process-coding-system
 249           (cons gnus-namazu-coding-system gnus-namazu-coding-system))
 250         program-coding-system-alist
 251         (file-name-coding-system gnus-namazu-coding-system)
 252         (pathname-coding-system gnus-namazu-coding-system))
 253     (apply 'call-process
 254            `(,gnus-namazu-command
 255              nil                        ; input from /dev/null
 256              t                          ; output
 257              nil                        ; don't redisplay
 258              "-q"                       ; don't be verbose
 259              "-a"                       ; show all matches
 260              "-l"                       ; use list format
 261              ,@gnus-namazu-additional-arguments
 262              ,query
 263              ,@gnus-namazu-index-directories))))
 264
 265 (defsubst gnus-namazu/group-prefixed-name (group method)
 266   "Return the whole name from GROUP and METHOD."
 267   (if gnus-namazu-case-sensitive-filesystem
 268       (gnus-group-prefixed-name group method)
 269     (let* ((orig (gnus-group-prefixed-name group method))
 270            (name (downcase orig)))
 271       (catch 'found-group
 272         (mapatoms (lambda (sym)
 273                     (when (string= name (downcase (symbol-name sym)))
 274                       (throw 'found-group (symbol-name sym))))
 275                   gnus-newsrc-hashtb)
 276         orig))))
 277
 278 (defun gnus-namazu/check-cache-group (str)
 279   "Get the news group from the partial path STR of the cached article."
 280   (if (gnus-use-long-file-name 'not-cache)
 281       str
 282     (catch 'found-group
 283       (dolist (group (gnus-namazu/cache-group-candidates
 284                       (nnheader-replace-chars-in-string str ?/ ?.)))
 285         (when (gnus-gethash group gnus-newsrc-hashtb)
 286           (throw 'found-group group))))))
 287
 288 (defun gnus-namazu/cache-group-candidates (str)
 289   "Regard the string STR as the partial path of the cached article and
 290 generate possible group names from it."
 291   (if (string-match "_\\(_\\(_\\)?\\)?" str)
 292       (let ((prefix (substring str 0 (match-beginning 0)))
 293             (suffix (substring str (match-end 0))))
 294         (cond
 295          ((match-beginning 2) ;; The number of discoverd underscores = 3
 296           (nconc
 297            (gnus-namazu/cache-group-candidates (concat prefix "/__" suffix))
 298            (gnus-namazu/cache-group-candidates (concat prefix ".._" suffix))))
 299          ((match-beginning 1) ;; The number of discoverd underscores = 2
 300           (nconc
 301            (gnus-namazu/cache-group-candidates (concat prefix "//" suffix))
 302            (gnus-namazu/cache-group-candidates (concat prefix ".." suffix))))
 303          (t ;; The number of discoverd underscores = 1
 304           (gnus-namazu/cache-group-candidates (concat prefix "/" suffix)))))
 305     (if (string-match "\\." str)
 306         ;; Handle the first occurence of period.
 307         (list (concat (substring str 0 (match-beginning 0))
 308                       ":"
 309                       (substring str (match-end 0)))
 310               str)
 311       (list str))))
 312
 313 (defun gnus-namazu/search (groups query)
 314   (with-temp-buffer
 315     (let ((exit-status (gnus-namazu/call-namazu query)))
 316       (unless (zerop exit-status)
 317         (error "Namazu finished abnormally: %d" exit-status))
 318       (let* ((articles)
 319              (server-alist
 320               (delq nil
 321                     (let (dir)
 322                       (mapcar
 323                        (lambda (s)
 324                          (when (setq dir (gnus-namazu/server-directory s))
 325                            (cons (file-name-as-directory dir) s)))
 326                        (gnus-namazu/indexed-servers)))))
 327              (topdir-regexp (regexp-opt (mapcar 'car server-alist)))
 328              (cache-regexp (concat
 329                             (regexp-quote
 330                              (file-name-as-directory
 331                               (expand-file-name gnus-cache-directory)))
 332                             "\\(.*\\)/\\([0-9]+\\)$")))
 333         (gnus-namazu/normalize-results)
 334         (goto-char (point-min))
 335         (while (not (eobp))
 336           (let (server group file)
 337             (and (or
 338                   ;; Check the discoverd file is the persistent article.
 339                   (and (looking-at cache-regexp)
 340                        (setq file (match-string-no-properties 2)
 341                              group (gnus-namazu/check-cache-group
 342                                     (match-string-no-properties 1))))
 343                   ;; Check the discovered file is managed by Gnus servers.
 344                   (and (looking-at topdir-regexp)
 345                        (setq file (buffer-substring-no-properties
 346                                    (match-end 0) (gnus-point-at-eol))
 347                              server (cdr (assoc (match-string-no-properties 0)
 348                                                 server-alist)))
 349                        ;; Check validity of the file name.
 350                        (string-match "/\\([0-9]+\\)\\'" file)
 351                        (progn
 352                          (setq group (substring file 0 (match-beginning 0))
 353                                file (match-string 1 file))
 354                          (setq group
 355                                (gnus-namazu/group-prefixed-name
 356                                 (nnheader-replace-chars-in-string group ?/ ?.)
 357                                 server)))))
 358                  (or (not groups)
 359                      (member group groups))
 360                  (push (gnus-namazu/make-article group (string-to-number file))
 361                        articles)))
 362           (forward-line 1))
 363         (nreverse articles)))))
 364
 365
 366 ;;; User Interface:
 367 (defun gnus-namazu/get-target-groups ()
 368   (cond
 369    ((eq major-mode 'gnus-group-mode)
 370     ;; In Group buffer.
 371     (cond
 372      (current-prefix-arg
 373       (gnus-group-process-prefix current-prefix-arg))
 374      (gnus-group-marked
 375       (prog1 gnus-group-marked (gnus-group-unmark-all-groups)))))
 376    ((eq major-mode 'gnus-summary-mode)
 377     ;; In Summary buffer.
 378     (if current-prefix-arg
 379         (list (gnus-read-group "Group: "))
 380       (if (and
 381            (gnus-ephemeral-group-p gnus-newsgroup-name)
 382            (string-match gnus-namazu/group-name-regexp gnus-newsgroup-name))
 383           (cadr (assq 'gnus-namazu-target-groups
 384                       (gnus-info-method (gnus-get-info gnus-newsgroup-name))))
 385         (list gnus-newsgroup-name))))))
 386
 387 (defun gnus-namazu/get-current-query ()
 388   (and (eq major-mode 'gnus-summary-mode)
 389        (gnus-ephemeral-group-p gnus-newsgroup-name)
 390        (string-match gnus-namazu/group-name-regexp gnus-newsgroup-name)
 391        (cadr (assq 'gnus-namazu-current-query
 392                    (gnus-info-method (gnus-get-info gnus-newsgroup-name))))))
 393
 394 (defvar gnus-namazu/read-query-original-buffer nil)
 395 (defvar gnus-namazu/read-query-prompt nil)
 396 (defvar gnus-namazu/read-query-history nil)
 397
 398 (defun gnus-namazu/get-current-subject ()
 399   (and gnus-namazu/read-query-original-buffer
 400        (bufferp gnus-namazu/read-query-original-buffer)
 401        (with-current-buffer gnus-namazu/read-query-original-buffer
 402          (when (eq major-mode 'gnus-summary-mode)
 403            (let ((s (gnus-summary-article-subject)))
 404              ;; Remove typically prefixes of mailing lists.
 405              (when (string-match
 406                     "^\\(\\[[^]]*[0-9]+\\]\\|([^)]*[0-9]+)\\)\\s-*" s)
 407                (setq s (substring s (match-end 0))))
 408              (when (string-match
 409                     "^\\(Re\\(\\^?\\([0-9]+\\|\\[[0-9]+\\]\\)\\)?:\\s-*\\)+" s)
 410                (setq s (substring s (match-end 0))))
 411              (when (string-match "\\s-*(\\(re\\|was\\)\\b" s)
 412                (setq s (substring s 0 (match-beginning 0))))
 413              s)))))
 414
 415 (defun gnus-namazu/get-current-from ()
 416   (and gnus-namazu/read-query-original-buffer
 417        (bufferp gnus-namazu/read-query-original-buffer)
 418        (with-current-buffer gnus-namazu/read-query-original-buffer
 419          (when (eq major-mode 'gnus-summary-mode)
 420            (cadr (mail-extract-address-components
 421                   (mail-header-from
 422                    (gnus-summary-article-header))))))))
 423
 424 (defmacro gnus-namazu/minibuffer-prompt-end ()
 425   (if (fboundp 'minibuffer-prompt-end)
 426       '(minibuffer-prompt-end)
 427     '(point-min)))
 428
 429 (defun gnus-namazu/message (string &rest arguments)
 430   (let* ((s1 (concat
 431               gnus-namazu/read-query-prompt
 432               (buffer-substring (gnus-namazu/minibuffer-prompt-end)
 433                                 (point-max))))
 434          (s2 (apply (function format) string arguments))
 435          (w (- (window-width)
 436                (string-width s1)
 437                (string-width s2)
 438                1)))
 439     (message (if (>= w 0)
 440                  (concat s1 (make-string w ?\ ) s2)
 441                s2))
 442     (if (sit-for 0.3) (message s1))
 443     s2))
 444
 445 (defun gnus-namazu/complete-query ()
 446   (interactive)
 447   (let ((pos (point)))
 448     (cond
 449      ((and (re-search-backward "\\+\\([-a-z]*\\)" nil t)
 450            (= pos (match-end 0)))
 451       (let* ((partial (match-string 1))
 452              (completions
 453               (all-completions
 454                partial
 455                (mapcar 'list gnus-namazu-field-keywords))))
 456         (cond
 457          ((null completions)
 458           (gnus-namazu/message "No completions of %s" partial))
 459          ((= 1 (length completions))
 460           (goto-char (match-beginning 1))
 461           (delete-region (match-beginning 1) (match-end 1))
 462           (insert (car completions) ":")
 463           (setq pos (point))
 464           (gnus-namazu/message "Completed"))
 465          (t
 466           (let ((x (try-completion partial (mapcar 'list completions))))
 467             (if (string= x partial)
 468                 (if (and (eq last-command
 469                              'gnus-namazu/field-keyword-completion)
 470                          completion-auto-help)
 471                     (with-output-to-temp-buffer "*Completions*"
 472                       (display-completion-list completions))
 473                   (gnus-namazu/message "Sole completion"))
 474               (goto-char (match-beginning 1))
 475               (delete-region (match-beginning 1) (match-end 1))
 476               (insert x)
 477               (setq pos (point))))))))
 478      ((and (looking-at "\\+subject:")
 479            (= pos (match-end 0)))
 480       (let ((s (gnus-namazu/get-current-subject)))
 481         (when s
 482           (goto-char pos)
 483           (insert "\"" s "\"")
 484           (setq pos (point)))))
 485      ((and (looking-at "\\+from:")
 486            (= pos (match-end 0)))
 487       (let ((f (gnus-namazu/get-current-from)))
 488         (when f
 489           (goto-char pos)
 490           (insert "\"" f "\"")
 491           (setq pos (point))))))
 492     (goto-char pos)))
 493
 494 (defvar gnus-namazu/read-query-map
 495   (let ((keymap (copy-keymap minibuffer-local-map)))
 496     (define-key keymap "\t" 'gnus-namazu/complete-query)
 497     keymap))
 498
 499 (defun gnus-namazu/read-query (prompt &optional initial)
 500   (let ((gnus-namazu/read-query-original-buffer (current-buffer))
 501         (gnus-namazu/read-query-prompt prompt))
 502     (unless initial
 503       (when (setq initial (gnus-namazu/get-current-query))
 504         (setq initial (cons initial 0))))
 505     (read-from-minibuffer prompt initial gnus-namazu/read-query-map nil
 506                           'gnus-namazu/read-query-history)))
 507
 508 (defun gnus-namazu/highlight-words (query)
 509   (with-temp-buffer
 510     (insert " " query)
 511     ;; Remove tokens for NOT search
 512     (goto-char (point-min))
 513     (while (re-search-forward "[\e$B!!\e(B \t\r\f\n]+not[\e$B!!\e(B \t\r\f\n]+\
 514 \\([^\e$B!!\e(B \t\r\f\n\"{(/]+\\|\"[^\"]+\"\\|{[^}]+}\\|([^)]+)\\|/[^/]+/\\)+" nil t)
 515       (delete-region (match-beginning 0) (match-end 0)))
 516     ;; Remove tokens for Field search
 517     (goto-char (point-min))
 518     (while (re-search-forward "[\e$B!!\e(B \t\r\f\n]+\\+[^\e$B!!\e(B \t\r\f\n:]+:\
 519 \\([^\e$B!!\e(B \t\r\f\n\"{(/]+\\|\"[^\"]+\"\\|{[^}]+}\\|([^)]+)\\|/[^/]+/\\)+" nil t)
 520       (delete-region (match-beginning 0) (match-end 0)))
 521     ;; Remove tokens for Regexp search
 522     (goto-char (point-min))
 523     (while (re-search-forward "/[^/]+/" nil t)
 524       (delete-region (match-beginning 0) (match-end 0)))
 525     ;; Remove brackets, double quote, asterisk and operators
 526     (goto-char (point-min))
 527     (while (re-search-forward "\\([(){}\"*]\\|\\b\\(and\\|or\\)\\b\\)" nil t)
 528       (delete-region (match-beginning 0) (match-end 0)))
 529     ;; Collect all keywords
 530     (setq query nil)
 531     (goto-char (point-min))
 532     (while (re-search-forward "[^\e$B!!\e(B \t\r\f\n]+" nil t)
 533       (push (match-string 0) query))
 534     (when query
 535       (list (list (regexp-opt query)
 536                   0 0 'gnus-namazu-query-highlight-face)))))
 537
 538 (defun gnus-namazu/truncate-article-list (articles)
 539   (let ((hit (length articles)))
 540     (when (and (integerp gnus-large-newsgroup)
 541                (> hit gnus-large-newsgroup))
 542       (let* ((cursor-in-echo-area nil)
 543              (input
 544               (when (> hit gnus-large-newsgroup)
 545                 (read-from-minibuffer
 546                  (format
 547                   "Too many articles were retrieved.  How many articles (max %d): "
 548                   hit)
 549                  (cons (number-to-string gnus-large-newsgroup) 0)))))
 550         (unless (string-match "\\`[ \t]*\\'" input)
 551           (setcdr (nthcdr (min (1- (string-to-number input)) hit) articles)
 552                   nil))))
 553     articles))
 554
 555 ;;;###autoload
 556 (defun gnus-namazu-search (groups query)
 557   "Search QUERY through GROUPS with Namazu,
 558 and make a virtual group contains its results."
 559   (interactive
 560    (list
 561     (gnus-namazu/get-target-groups)
 562     (gnus-namazu/read-query "Enter query: ")))
 563   (gnus-namazu/setup)
 564   (let ((articles (gnus-namazu/search groups query)))
 565     (if articles
 566         (let ((real-groups groups)
 567               (vgroup
 568                (apply (function format)
 569                       "nnvirtual:namazu-search?query=%s&groups=%s&id=%d%d%d"
 570                       query
 571                       (if groups (mapconcat 'identity groups ",") "ALL")
 572                       (current-time))))
 573           (gnus-namazu/truncate-article-list articles)
 574           (unless real-groups
 575             (dolist (a articles)
 576               (add-to-list 'real-groups (gnus-namazu/article-group a))))
 577           ;; Generate virtual group which includes all results.
 578           (when (fboundp 'gnus-group-decoded-name)
 579             (setq vgroup
 580                   (encode-coding-string vgroup gnus-namazu-coding-system)))
 581           (setq vgroup
 582                 (gnus-group-read-ephemeral-group
 583                  vgroup
 584                  `(nnvirtual ,vgroup
 585                              (nnvirtual-component-groups ,real-groups)
 586                              (gnus-namazu-target-groups ,groups)
 587                              (gnus-namazu-current-query ,query))
 588                  t (cons (current-buffer) (current-window-configuration)) t))
 589           (when gnus-namazu-query-highlight
 590             (gnus-group-set-parameter vgroup 'highlight-words
 591                                       (gnus-namazu/highlight-words query)))
 592           ;; Generate new summary buffer which contains search results.
 593           (gnus-group-read-group
 594            t t vgroup
 595            (sort (delq nil ;; Ad-hoc fix, to avoid wrong-type-argument error.
 596                        (mapcar
 597                         (lambda (a)
 598                           (nnvirtual-reverse-map-article
 599                            (gnus-namazu/article-group a)
 600                            (gnus-namazu/article-number a)))
 601                         articles))
 602                  '<)))
 603       (message "No entry."))))
 604
 605 (let (current-load-list)
 606   (defadvice gnus-offer-save-summaries
 607     (before gnus-namazu-kill-summary-buffers activate compile)
 608     "Advised by `gnus-namazu'.
 609 In order to avoid annoying questions, kill summary buffers which
 610 generated by `gnus-namazu' itself before `gnus-offer-save-summaries'
 611 is called."
 612     (let ((buffers (buffer-list)))
 613       (while buffers
 614         (when (with-current-buffer (car buffers)
 615                 (and (eq major-mode 'gnus-summary-mode)
 616                      (gnus-ephemeral-group-p gnus-newsgroup-name)
 617                      (string-match gnus-namazu/group-name-regexp
 618                                    gnus-newsgroup-name)))
 619           (kill-buffer (car buffers)))
 620         (setq buffers (cdr buffers))))))
 621
 622 (defun gnus-namazu-insinuate ()
 623   (add-hook
 624    'gnus-group-mode-hook
 625    (lambda ()
 626      (define-key gnus-group-mode-map "\C-c\C-n" 'gnus-namazu-search)))
 627   (add-hook
 628    'gnus-summary-mode-hook
 629    (lambda ()
 630      (define-key gnus-summary-mode-map "\C-c\C-n" 'gnus-namazu-search))))
 631
 632 (provide 'gnus-namazu)
 633
 634 ;; gnus-namazu.el ends here.