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,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 (defvar gnus-namazu/group-alist nil
 166   "Associative list to map groups in lower case to official names.")
 167 (defconst gnus-namazu/group-name-regexp "\\`nnvirtual:namazu-search\\?")
 168
 169 ;; Multibyte group name:
 170 (and
 171  (fboundp 'gnus-group-decoded-name)
 172  (let ((gnus-group-name-charset-group-alist
 173         (list (cons gnus-namazu/group-name-regexp gnus-namazu-coding-system)))
 174        (query (decode-coding-string
 175                (string 27 36 66 52 65 59 122 27 40 66)
 176                (if (boundp 'MULE) '*iso-2022-jp* 'iso-2022-7bit))))
 177    (not (string-match query
 178                       (gnus-summary-buffer-name
 179                        (encode-coding-string
 180                         (concat "nnvirtual:namazu-search?query=" query)
 181                         gnus-namazu-coding-system)))))
 182  (let (current-load-list)
 183    (defadvice gnus-summary-buffer-name
 184      (before gnus-namazu-summary-buffer-name activate compile)
 185      "Advised by `gnus-namazu' to handle encoded group names."
 186      (ad-set-arg 0 (gnus-group-decoded-name (ad-get-arg 0))))))
 187
 188 (defmacro gnus-namazu/make-article (group number)
 189   `(cons ,group ,number))
 190 (defmacro gnus-namazu/article-group  (x) `(car ,x))
 191 (defmacro gnus-namazu/article-number (x) `(cdr ,x))
 192
 193 (defsubst gnus-namazu/indexed-servers ()
 194   "Choice appropriate servers from opened ones, and return thier list."
 195   (append
 196    (gnus-servers-using-backend 'nnml)
 197    (gnus-servers-using-backend 'nnmh)))
 198
 199 (defun gnus-namazu/setup ()
 200   (and (boundp 'gnus-group-name-charset-group-alist)
 201        (not (member (cons gnus-namazu/group-name-regexp
 202                           gnus-namazu-coding-system)
 203                     gnus-group-name-charset-group-alist))
 204        (let ((pair (assoc gnus-namazu/group-name-regexp
 205                           gnus-group-name-charset-group-alist)))
 206          (if pair
 207              (setcdr pair gnus-namazu-coding-system)
 208            (push (cons gnus-namazu/group-name-regexp
 209                        gnus-namazu-coding-system)
 210                  gnus-group-name-charset-group-alist))))
 211   (unless gnus-namazu-case-sensitive-filesystem
 212     ;; FIXME: The alist to map group names in lower case to real names
 213     ;; is reconstructed every when gnus-namazu/setup() is called.
 214     ;; This reconstruction make gnus-namazu-search() slow.
 215     (setq gnus-namazu/group-alist nil)
 216     (dolist (server (gnus-namazu/indexed-servers))
 217       (dolist (group (gnus-namazu/request-list server))
 218         (let ((name (gnus-group-prefixed-name group server)))
 219           (unless (assoc name gnus-namazu/group-alist)
 220             (push (cons (downcase name) name) gnus-namazu/group-alist)))))))
 221
 222 (defun gnus-namazu/shutdown ()
 223   (setq gnus-namazu/group-alist nil))
 224 (add-hook 'gnus-exit-gnus-hook 'gnus-namazu/shutdown)
 225
 226 (defun gnus-namazu/request-list (server)
 227   "Return groups of the server SERVER."
 228   (and (memq (car server) '(nnml nnmh))
 229        (nnoo-change-server (car server) (nth 1 server) (nthcdr 2 server))
 230        (gnus-request-list server)
 231        (mapcar (function car)
 232                (if (eq 'nnml (car server))
 233                    nnml-group-alist
 234                  nnmh-group-alist))))
 235
 236 (defun gnus-namazu/server-directory (server)
 237   "Return the top directory of the server SERVER."
 238   (and (memq (car server) '(nnml nnmh))
 239        (nnoo-change-server (car server) (nth 1 server) (nthcdr 2 server))
 240        (file-name-as-directory
 241         (expand-file-name (if (eq 'nnml (car server))
 242                               nnml-directory
 243                             nnmh-directory)))))
 244
 245 ;;; Functions to call Namazu.
 246 (defsubst gnus-namazu/normalize-results ()
 247   "Normalize file names returned by Namazu in this current buffer."
 248   (goto-char (point-min))
 249   (while (not (eobp))
 250     (when (if gnus-namazu-need-path-normalization
 251               (or (not (looking-at "/\\(.\\)|/"))
 252                   (replace-match "\\1:/"))
 253             (eq ?~ (char-after (point))))
 254       (insert (expand-file-name
 255                (buffer-substring (gnus-point-at-bol) (gnus-point-at-eol))))
 256       (delete-region (point) (gnus-point-at-eol)))
 257     (forward-line 1)))
 258
 259 (defsubst gnus-namazu/call-namazu (query)
 260   (let ((coding-system-for-read gnus-namazu-coding-system)
 261         (coding-system-for-write gnus-namazu-coding-system)
 262         (default-process-coding-system
 263           (cons gnus-namazu-coding-system gnus-namazu-coding-system))
 264         (file-name-coding-system gnus-namazu-coding-system)
 265         (pathname-coding-system gnus-namazu-coding-system))
 266     (apply 'call-process
 267            `(,gnus-namazu-command
 268              nil                        ; input from /dev/null
 269              t                          ; output
 270              nil                        ; don't redisplay
 271              "-q"                       ; don't be verbose
 272              "-a"                       ; show all matches
 273              "-l"                       ; use list format
 274              ,@gnus-namazu-additional-arguments
 275              ,query
 276              ,@gnus-namazu-index-directories))))
 277
 278 (defsubst gnus-namazu/group-prefixed-name (group method)
 279   "Return the whole name from GROUP and METHOD."
 280   (if gnus-namazu-case-sensitive-filesystem
 281       (gnus-group-prefixed-name group method)
 282     (let ((name (gnus-group-prefixed-name group method)))
 283       (or (cdr (assoc (downcase name) gnus-namazu/group-alist))
 284           name))))
 285
 286 (defun gnus-namazu/check-cache-group (str)
 287   "Get the news group from the partial path STR of the cached article."
 288   (if (gnus-use-long-file-name 'not-cache)
 289       str
 290     (catch 'found-group
 291       (dolist (group (gnus-namazu/cache-group-candidates
 292                       (nnheader-replace-chars-in-string str ?/ ?.)))
 293         (when (gnus-gethash group gnus-newsrc-hashtb)
 294           (throw 'found-group group))))))
 295
 296 (defun gnus-namazu/cache-group-candidates (str)
 297   "Regard the string STR as the partial path of the cached article and
 298 generate possible group names from it."
 299   (if (string-match "_\\(_\\(_\\)?\\)?" str)
 300       (let ((prefix (substring str 0 (match-beginning 0)))
 301             (suffix (substring str (match-end 0))))
 302         (cond
 303          ((match-beginning 2) ;; The number of discoverd underscores = 3
 304           (nconc
 305            (gnus-namazu/cache-group-candidates (concat prefix "/__" suffix))
 306            (gnus-namazu/cache-group-candidates (concat prefix ".._" suffix))))
 307          ((match-beginning 1) ;; The number of discoverd underscores = 2
 308           (nconc
 309            (gnus-namazu/cache-group-candidates (concat prefix "//" suffix))
 310            (gnus-namazu/cache-group-candidates (concat prefix ".." suffix))))
 311          (t ;; The number of discoverd underscores = 1
 312           (gnus-namazu/cache-group-candidates (concat prefix "/" suffix)))))
 313     (if (string-match "\\." str)
 314         ;; Handle the first occurence of period.
 315         (list (concat (substring str 0 (match-beginning 0))
 316                       ":"
 317                       (substring str (match-end 0)))
 318               str)
 319       (list str))))
 320
 321 (defun gnus-namazu/search (groups query)
 322   (with-temp-buffer
 323     (let ((exit-status (gnus-namazu/call-namazu query)))
 324       (unless (zerop exit-status)
 325         (error "Namazu finished abnormally: %d" exit-status))
 326       (let* ((articles)
 327              (server-alist
 328               (delq nil
 329                     (let (dir)
 330                       (mapcar
 331                        (lambda (s)
 332                          (when (setq dir (gnus-namazu/server-directory s))
 333                            (cons (file-name-as-directory dir) s)))
 334                        (gnus-namazu/indexed-servers)))))
 335              (topdir-regexp (regexp-opt (mapcar 'car server-alist)))
 336              (cache-regexp (concat
 337                             (regexp-quote
 338                              (file-name-as-directory
 339                               (expand-file-name gnus-cache-directory)))
 340                             "\\(.*\\)/\\([0-9]+\\)$")))
 341         (gnus-namazu/normalize-results)
 342         (goto-char (point-min))
 343         (while (not (eobp))
 344           (let (server group file)
 345             (and (or
 346                   ;; Check the discoverd file is the persistent article.
 347                   (and (looking-at cache-regexp)
 348                        (setq file (match-string-no-properties 2)
 349                              group (gnus-namazu/check-cache-group
 350                                     (match-string-no-properties 1))))
 351                   ;; Check the discovered file is managed by Gnus servers.
 352                   (and (looking-at topdir-regexp)
 353                        (setq file (buffer-substring-no-properties
 354                                    (match-end 0) (gnus-point-at-eol))
 355                              server (cdr (assoc (match-string-no-properties 0)
 356                                                 server-alist)))
 357                        ;; Check validity of the file name.
 358                        (string-match "/\\([0-9]+\\)\\'" file)
 359                        (progn
 360                          (setq group (substring file 0 (match-beginning 0))
 361                                file (match-string 1 file))
 362                          (setq group
 363                                (gnus-namazu/group-prefixed-name
 364                                 (nnheader-replace-chars-in-string group ?/ ?.)
 365                                 server)))))
 366                  (or (not groups)
 367                      (member group groups))
 368                  (push (gnus-namazu/make-article group (string-to-number file))
 369                        articles)))
 370           (forward-line 1))
 371         (nreverse articles)))))
 372
 373
 374 ;;; User Interface:
 375 (defun gnus-namazu/get-target-groups ()
 376   (cond
 377    ((eq major-mode 'gnus-group-mode)
 378     ;; In Group buffer.
 379     (cond
 380      (current-prefix-arg
 381       (gnus-group-process-prefix current-prefix-arg))
 382      (gnus-group-marked
 383       (prog1 gnus-group-marked (gnus-group-unmark-all-groups)))))
 384    ((eq major-mode 'gnus-summary-mode)
 385     ;; In Summary buffer.
 386     (if current-prefix-arg
 387         (list (gnus-read-group "Group: "))
 388       (if (and
 389            (gnus-ephemeral-group-p gnus-newsgroup-name)
 390            (string-match gnus-namazu/group-name-regexp gnus-newsgroup-name))
 391           (cadr (assq 'gnus-namazu-target-groups
 392                       (gnus-info-method (gnus-get-info gnus-newsgroup-name))))
 393         (list gnus-newsgroup-name))))))
 394
 395 (defun gnus-namazu/get-current-query ()
 396   (and (eq major-mode 'gnus-summary-mode)
 397        (gnus-ephemeral-group-p gnus-newsgroup-name)
 398        (string-match gnus-namazu/group-name-regexp gnus-newsgroup-name)
 399        (cadr (assq 'gnus-namazu-current-query
 400                    (gnus-info-method (gnus-get-info gnus-newsgroup-name))))))
 401
 402 (defvar gnus-namazu/read-query-original-buffer nil)
 403 (defvar gnus-namazu/read-query-prompt nil)
 404 (defvar gnus-namazu/read-query-history nil)
 405
 406 (defun gnus-namazu/get-current-subject ()
 407   (and gnus-namazu/read-query-original-buffer
 408        (bufferp gnus-namazu/read-query-original-buffer)
 409        (with-current-buffer gnus-namazu/read-query-original-buffer
 410          (when (eq major-mode 'gnus-summary-mode)
 411            (let ((s (gnus-summary-article-subject)))
 412              ;; Remove typically prefixes of mailing lists.
 413              (when (string-match
 414                     "^\\(\\[[^]]*[0-9]+\\]\\|([^)]*[0-9]+)\\)\\s-*" s)
 415                (setq s (substring s (match-end 0))))
 416              (when (string-match
 417                     "^\\(Re\\(\\^?\\([0-9]+\\|\\[[0-9]+\\]\\)\\)?:\\s-*\\)+" s)
 418                (setq s (substring s (match-end 0))))
 419              (when (string-match "\\s-*(\\(re\\|was\\)\\b" s)
 420                (setq s (substring s 0 (match-beginning 0))))
 421              s)))))
 422
 423 (defun gnus-namazu/get-current-from ()
 424   (and gnus-namazu/read-query-original-buffer
 425        (bufferp gnus-namazu/read-query-original-buffer)
 426        (with-current-buffer gnus-namazu/read-query-original-buffer
 427          (when (eq major-mode 'gnus-summary-mode)
 428            (cadr (mail-extract-address-components
 429                   (mail-header-from
 430                    (gnus-summary-article-header))))))))
 431
 432 (defmacro gnus-namazu/minibuffer-prompt-end ()
 433   (if (fboundp 'minibuffer-prompt-end)
 434       '(minibuffer-prompt-end)
 435     '(point-min)))
 436
 437 (defun gnus-namazu/message (string &rest arguments)
 438   (let* ((s1 (concat
 439               gnus-namazu/read-query-prompt
 440               (buffer-substring (gnus-namazu/minibuffer-prompt-end)
 441                                 (point-max))))
 442          (s2 (apply (function format) string arguments))
 443          (w (- (window-width)
 444                (string-width s1)
 445                (string-width s2)
 446                1)))
 447     (message (if (>= w 0)
 448                  (concat s1 (make-string w ?\ ) s2)
 449                s2))
 450     (if (sit-for 0.3) (message s1))
 451     s2))
 452
 453 (defun gnus-namazu/complete-query ()
 454   (interactive)
 455   (let ((pos (point)))
 456     (cond
 457      ((and (re-search-backward "\\+\\([a-z]*\\)" nil t)
 458            (= pos (match-end 0)))
 459       (let* ((partial (match-string 1))
 460              (completions
 461               (all-completions
 462                partial
 463                (mapcar 'list gnus-namazu-field-keywords))))
 464         (cond
 465          ((null completions)
 466           (gnus-namazu/message "No completions of %s" partial))
 467          ((= 1 (length completions))
 468           (goto-char (match-beginning 1))
 469           (delete-region (match-beginning 1) (match-end 1))
 470           (insert (car completions) ":")
 471           (setq pos (point))
 472           (gnus-namazu/message "Completed"))
 473          (t
 474           (let ((x (try-completion partial (mapcar 'list completions))))
 475             (if (string= x partial)
 476                 (if (and (eq last-command
 477                              'gnus-namazu/field-keyword-completion)
 478                          completion-auto-help)
 479                     (with-output-to-temp-buffer "*Completions*"
 480                       (display-completion-list completions))
 481                   (gnus-namazu/message "Sole completion"))
 482               (goto-char (match-beginning 1))
 483               (delete-region (match-beginning 1) (match-end 1))
 484               (insert x)
 485               (setq pos (point))))))))
 486      ((and (looking-at "\\+subject:")
 487            (= pos (match-end 0)))
 488       (let ((s (gnus-namazu/get-current-subject)))
 489         (when s
 490           (goto-char pos)
 491           (insert "\"" s "\"")
 492           (setq pos (point)))))
 493      ((and (looking-at "\\+from:")
 494            (= pos (match-end 0)))
 495       (let ((f (gnus-namazu/get-current-from)))
 496         (when f
 497           (goto-char pos)
 498           (insert "\"" f "\"")
 499           (setq pos (point))))))
 500     (goto-char pos)))
 501
 502 (defvar gnus-namazu/read-query-map
 503   (let ((keymap (copy-keymap minibuffer-local-map)))
 504     (define-key keymap "\t" 'gnus-namazu/complete-query)
 505     keymap))
 506
 507 (defun gnus-namazu/read-query (prompt &optional initial)
 508   (let ((gnus-namazu/read-query-original-buffer (current-buffer))
 509         (gnus-namazu/read-query-prompt prompt))
 510     (unless initial
 511       (when (setq initial (gnus-namazu/get-current-query))
 512         (setq initial (cons initial 0))))
 513     (read-from-minibuffer prompt initial gnus-namazu/read-query-map nil
 514                           'gnus-namazu/read-query-history)))
 515
 516 (defun gnus-namazu/highlight-words (query)
 517   (let ((strings)
 518         (start 0))
 519     (while (string-match
 520             "[ \t\r\f\n]*\\(\\(and\\|or\\|\\(not\\)\\)[ \t\r\f\n]+\\)?\
 521 \\(\\+[^ \t\r\f\n]+:\\)?\\(/\\([^/]+\\)/\\|\\(\"\\([^\"]+\\)\"\\|\
 522 {\\([^{}]+\\)}\\)\\|[^ \t\r\f\n]+\\)" query start)
 523       (setq start (match-end 0))
 524       (or (match-beginning 3)           ; NOT search
 525           (match-beginning 4)           ; Field search
 526           (match-beginning 6)           ; Regular expression search
 527           (if (match-beginning 7)       ; Phrase search
 528               (dolist (str (split-string
 529                             (if (match-beginning 8)
 530                                 (match-string 8 query)
 531                               (match-string 9 query))))
 532                 (when (> (length str) 0)
 533                   (push str strings)))
 534             (push (match-string 5 query) strings))))
 535     (and strings
 536          (list
 537           (list
 538            (regexp-opt (mapcar
 539                         (lambda (str)
 540                           (if (string-match "\\`\\*?\\([^\\*]*\\)\\*?\\'" str)
 541                               (match-string 1 str) str))
 542                         strings))
 543            0 0 'gnus-namazu-query-highlight-face)))))
 544
 545 (defun gnus-namazu/truncate-article-list (articles)
 546   (let ((hit (length articles)))
 547     (when (> hit gnus-large-newsgroup)
 548       (let* ((cursor-in-echo-area nil)
 549              (input
 550               (when (> hit gnus-large-newsgroup)
 551                 (read-from-minibuffer
 552                  (format
 553                   "Too many articles were retrieved.  How many articles (max %d): "
 554                   hit)
 555                  (cons (number-to-string gnus-large-newsgroup) 0)))))
 556         (unless (string-match "\\`[ \t]*\\'" input)
 557           (setcdr (nthcdr (min (1- (string-to-number input)) hit) articles)
 558                   nil))))
 559     articles))
 560
 561 ;;;###autoload
 562 (defun gnus-namazu-search (groups query)
 563   "Search QUERY through GROUPS with Namazu,
 564 and make a virtual group contains its results."
 565   (interactive
 566    (list
 567     (gnus-namazu/get-target-groups)
 568     (gnus-namazu/read-query "Enter query: ")))
 569   (gnus-namazu/setup)
 570   (let ((articles (gnus-namazu/search groups query)))
 571     (if articles
 572         (let ((real-groups groups)
 573               (vgroup
 574                (apply (function format)
 575                       "nnvirtual:namazu-search?query=%s&groups=%s&id=%d%d%d"
 576                       query
 577                       (if groups (mapconcat 'identity groups ",") "ALL")
 578                       (current-time))))
 579           (gnus-namazu/truncate-article-list articles)
 580           (unless real-groups
 581             (dolist (a articles)
 582               (add-to-list 'real-groups (gnus-namazu/article-group a))))
 583           ;; Generate virtual group which includes all results.
 584           (when (fboundp 'gnus-group-decoded-name)
 585             (setq vgroup
 586                   (encode-coding-string vgroup gnus-namazu-coding-system)))
 587           (setq vgroup
 588                 (gnus-group-read-ephemeral-group
 589                  vgroup
 590                  `(nnvirtual ,vgroup
 591                              (nnvirtual-component-groups ,real-groups)
 592                              (gnus-namazu-target-groups ,groups)
 593                              (gnus-namazu-current-query ,query))
 594                  t (cons (current-buffer) (current-window-configuration)) t))
 595           (when gnus-namazu-query-highlight
 596             (gnus-group-set-parameter vgroup 'highlight-words
 597                                       (gnus-namazu/highlight-words query)))
 598           ;; Generate new summary buffer which contains search results.
 599           (gnus-group-read-group
 600            t t vgroup
 601            (sort (delq nil ;; Ad-hoc fix, to avoid wrong-type-argument error.
 602                        (mapcar
 603                         (lambda (a)
 604                           (nnvirtual-reverse-map-article
 605                            (gnus-namazu/article-group a)
 606                            (gnus-namazu/article-number a)))
 607                         articles))
 608                  '<)))
 609       (message "No entry."))))
 610
 611 (defun gnus-namazu-insinuate ()
 612   (add-hook
 613    'gnus-group-mode-hook
 614    (lambda ()
 615      (define-key gnus-group-mode-map "\C-c\C-n" 'gnus-namazu-search)))
 616   (add-hook
 617    'gnus-summary-mode-hook
 618    (lambda ()
 619      (define-key gnus-summary-mode-map "\C-c\C-n" 'gnus-namazu-search))))
 620
 621 (provide 'gnus-namazu)
 622
 623 ;; gnus-namazu.el ends here.