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