elmo/elmo-search.el

   1 ;;; elmo-search.el --- Search by external program interface for ELMO.
   2
   3 ;; Copyright (C) 2005 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;;      Hiroya Murata <lapis-lazuli@pop06.odn.ne.jp>
   7 ;; Keywords: mail, net news
   8
   9 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25 ;;
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31 ;;
  32 (eval-when-compile (require 'cl))
  33
  34 (require 'elmo)
  35 (require 'elmo-map)
  36 (require 'mime-edit)
  37
  38 (defcustom elmo-search-use-drive-letter
  39   (memq system-type '(OS/2 emx windows-nt))
  40   "*If non-nil, do a drive letter conversion (e.g. /a|/ => a:/)."
  41   :type '(choice (const :tag "Not use" nil)
  42                  (other :tag "Use" t))
  43   :group 'elmo)
  44
  45 (defvar elmo-search-engine-alist nil
  46   "*An alist of search engines.
  47 Each element looks like (ENGINE CLASS PROPERTIES...)
  48 ENGINE is a symbol, the name of the search engine.
  49 CLASS is a symbol, the class name that performs a search.
  50 PROPERTIES is a plist, it configure an engine with the CLASS.")
  51
  52 (defcustom elmo-search-default-engine 'namazu
  53   "*Default search engine for elmo-search folder."
  54   :type 'symbol
  55   :group 'elmo)
  56
  57
  58 (defconst elmo-search-folder-name-syntax `(pattern (?\] param (?! engine))))
  59
  60
  61 ;; Search engine I/F
  62 (eval-and-compile
  63   (luna-define-class elmo-search-engine () (param))
  64   (luna-define-internal-accessors 'elmo-search-engine))
  65
  66 (luna-define-generic elmo-search-engine-do-search (engine pattern)
  67   "Search messages which is match PATTERN by ENGINE.")
  68
  69 (luna-define-generic elmo-search-engine-create-message-entity (engine
  70                                                                handler
  71                                                                folder number)
  72   "Create msgdb entity for the message in the FOLDER with NUMBER.")
  73
  74 (luna-define-generic elmo-search-engine-fetch-message (engine location)
  75   "Fetch a message into current buffer.
  76 ENGINE is the ELMO search engine structure.
  77 LOCATION is the location of the message.
  78 Returns non-nil if fetching was succeed.")
  79
  80 (defun elmo-make-search-engine (type &optional param)
  81   (let ((spec (or (cdr (assq type elmo-search-engine-alist))
  82                   (error "Undefined search engine `%s'" type))))
  83     (require (intern (format "elmo-search-%s" (car spec))))
  84     (apply 'luna-make-entity
  85            (intern (format "elmo-search-engine-%s" (car spec)))
  86            :param param
  87            (cdr spec))))
  88
  89 (defun elmo-search-register-engine (name class &rest properties)
  90   (let ((cell (assq name elmo-search-engine-alist))
  91         (spec (cons class properties)))
  92     (if cell
  93         (setcdr cell spec)
  94       (setq elmo-search-engine-alist
  95             (cons (cons name spec) elmo-search-engine-alist)))))
  96
  97 ;; ELMO search folder
  98 (eval-and-compile
  99   (luna-define-class elmo-search-folder (elmo-map-folder)
 100                      (engine pattern))
 101   (luna-define-internal-accessors 'elmo-search-folder))
 102
 103 (luna-define-method elmo-folder-initialize ((folder elmo-search-folder)
 104                                             name)
 105   (when (> (length name) 0)
 106     (let* ((tokens (car (elmo-parse-separated-tokens
 107                          name
 108                          elmo-search-folder-name-syntax)))
 109            (engine (cdr (assq 'engine tokens))))
 110       (elmo-search-folder-set-engine-internal
 111        folder
 112        (elmo-make-search-engine (if (> (length engine) 0)
 113                                     (intern engine)
 114                                   elmo-search-default-engine)
 115                                 (cdr (assq 'param tokens))))
 116       (elmo-search-folder-set-pattern-internal
 117        folder
 118        (cdr (assq 'pattern tokens)))))
 119   folder)
 120
 121 (luna-define-method elmo-folder-expand-msgdb-path ((folder elmo-search-folder))
 122   (expand-file-name
 123    (elmo-replace-string-as-filename
 124     (elmo-folder-name-internal folder))
 125    (expand-file-name "search" elmo-msgdb-directory)))
 126
 127 (luna-define-method elmo-folder-msgdb-create ((folder elmo-search-folder)
 128                                               numbers flag-table)
 129   (let ((new-msgdb (elmo-make-msgdb))
 130         (num (length numbers))
 131         entity)
 132     (message "Creating msgdb...")
 133     (elmo-with-progress-display (> num elmo-display-progress-threshold)
 134         (elmo-folder-msgdb-create num "Creating msgdb...")
 135       (dolist (number numbers)
 136         (setq entity (elmo-search-engine-create-message-entity
 137                       (elmo-search-folder-engine-internal folder)
 138                       (elmo-msgdb-message-entity-handler new-msgdb)
 139                       folder number))
 140         (when entity
 141           (elmo-msgdb-append-entity new-msgdb entity '(new unread)))
 142         (elmo-progress-notify 'elmo-folder-msgdb-create)))
 143     (message "Creating msgdb...done")
 144     new-msgdb))
 145
 146 (luna-define-method elmo-folder-message-file-p ((folder elmo-search-folder))
 147   nil)
 148
 149 (defun elmo-search-location-to-filename (location)
 150   (when (string-match "^file://" location)
 151     (let ((filename (substring location (match-end 0))))
 152       (expand-file-name
 153        (if (and elmo-search-use-drive-letter
 154                 (string-match "^/\\([A-Za-z]\\)[:|]/\\(.*\\)$" filename))
 155            (replace-match "\\1:/\\2" t nil filename)
 156          filename)))))
 157
 158 (luna-define-method elmo-message-file-name ((folder elmo-search-folder)
 159                                             number)
 160   (elmo-search-location-to-filename
 161    (elmo-map-message-location folder number)))
 162
 163 (luna-define-method elmo-folder-message-make-temp-file-p
 164   ((folder elmo-search-folder))
 165   nil)
 166
 167 (luna-define-method elmo-folder-diff ((folder elmo-search-folder))
 168   (cons nil nil))
 169
 170 (luna-define-method elmo-folder-message-make-temp-files ((folder
 171                                                           elmo-search-folder)
 172                                                          numbers
 173                                                          &optional
 174                                                          start-number)
 175   (let ((temp-dir (elmo-folder-make-temporary-directory folder))
 176         (cur-number (or start-number 0)))
 177     (dolist (number numbers)
 178       (elmo-copy-file
 179        (elmo-message-file-name folder number)
 180        (expand-file-name
 181         (number-to-string (if start-number cur-number number))
 182         temp-dir))
 183       (incf cur-number))
 184     temp-dir))
 185
 186 (luna-define-method elmo-map-message-fetch ((folder elmo-search-folder)
 187                                             location strategy
 188                                             &optional section unseen)
 189   (elmo-search-engine-fetch-message
 190    (elmo-search-folder-engine-internal folder)
 191    location))
 192
 193 (luna-define-method elmo-map-folder-list-message-locations
 194   ((folder elmo-search-folder))
 195   (elmo-search-engine-do-search
 196    (elmo-search-folder-engine-internal folder)
 197    (elmo-search-folder-pattern-internal folder)))
 198
 199 (luna-define-method elmo-folder-exists-p ((folder elmo-search-folder))
 200   (elmo-search-folder-pattern-internal folder))
 201
 202 (luna-define-method elmo-folder-have-subfolder-p ((folder elmo-search-folder))
 203   (null (elmo-search-folder-pattern-internal folder)))
 204
 205 (luna-define-method elmo-folder-list-subfolders ((folder elmo-search-folder)
 206                                                  &optional one-level)
 207   (mapcar
 208    (lambda (name) (elmo-recover-string-from-filename name))
 209    (directory-files (expand-file-name "search" elmo-msgdb-directory)
 210                     nil
 211                     (concat "^" (regexp-quote
 212                                  (elmo-folder-prefix-internal folder))))))
 213
 214 (luna-define-method elmo-folder-delete-messages ((folder elmo-search-folder)
 215                                                  numbers)
 216   (elmo-folder-kill-messages folder numbers)
 217   t)
 218
 219
 220 ;;; Search engine
 221
 222 ;; external program search engine
 223 (eval-and-compile
 224   (luna-define-class elmo-search-engine-extprog (elmo-search-engine)
 225                      (prog args charset parser))
 226   (luna-define-internal-accessors 'elmo-search-engine-extprog))
 227
 228 (luna-define-method elmo-search-engine-do-search
 229   ((engine elmo-search-engine-extprog) pattern)
 230   (with-temp-buffer
 231     (let ((charset (elmo-search-engine-extprog-charset-internal engine))
 232           (parser (or (elmo-search-engine-extprog-parser-internal engine)
 233                       #'elmo-search-parse-filename-list)))
 234       (apply 'call-process
 235              (elmo-search-engine-extprog-prog-internal engine)
 236              nil t t
 237              (delq
 238               nil
 239               (elmo-flatten
 240                (mapcar
 241                 (lambda (arg)
 242                   (cond ((stringp arg) arg)
 243                         ((eq arg 'pattern)
 244                          (if charset
 245                              (encode-mime-charset-string pattern charset)
 246                            pattern))
 247                         ((functionp arg)
 248                          (condition-case nil
 249                              (funcall arg engine pattern)
 250                            (wrong-number-of-arguments
 251                             (funcall arg engine))))
 252                         ((and (symbolp arg)
 253                               (boundp arg))
 254                          (symbol-value arg))))
 255                 (elmo-search-engine-extprog-args-internal engine)))))
 256       (funcall parser))))
 257
 258 ;; search engine for local files
 259 (eval-and-compile
 260   (luna-define-class elmo-search-engine-local-file
 261                      (elmo-search-engine-extprog))
 262   (luna-define-internal-accessors 'elmo-search-engine-local-file))
 263
 264 (defun elmo-search-parse-filename-list ()
 265   (let (bol locations)
 266     (goto-char (point-min))
 267     (while (not (eobp))
 268       (beginning-of-line)
 269       (when (and elmo-search-use-drive-letter
 270                  (looking-at "^\\([A-Za-z]\\)[:|]/"))
 271         (replace-match "/\\1:/")
 272         (beginning-of-line))
 273       (unless (looking-at "^file://")
 274         (insert "file://")
 275         (beginning-of-line))
 276       (setq bol (point))
 277       (end-of-line)
 278       (setq locations (cons (buffer-substring bol (point)) locations))
 279       (forward-line 1))
 280     (nreverse locations)))
 281
 282 (luna-define-method elmo-search-engine-create-message-entity
 283   ((engine elmo-search-engine-local-file) handler folder number)
 284   (let ((filename (elmo-message-file-name folder number))
 285         entity uid)
 286     (when (and filename
 287                (setq entity (elmo-msgdb-create-message-entity-from-file
 288                              handler number filename)))
 289       (unless (or (elmo-message-entity-field entity 'to)
 290                   (elmo-message-entity-field entity 'cc)
 291                   (not (string= (elmo-message-entity-field entity 'subject)
 292                                 elmo-no-subject)))
 293         (elmo-message-entity-set-field entity 'subject
 294                                        (file-name-nondirectory filename))
 295         (setq uid (nth 2 (file-attributes filename)))
 296         (elmo-message-entity-set-field entity 'from
 297                                        (concat
 298                                         (user-full-name uid)
 299                                         " <"(user-login-name uid) "@"
 300                                         (system-name) ">")))
 301       entity)))
 302
 303 (luna-define-method elmo-search-engine-fetch-message
 304   ((engine elmo-search-engine-local-file) location)
 305   (let ((filename (elmo-search-location-to-filename location)))
 306     (when (and filename (file-exists-p filename))
 307       (prog1
 308           (insert-file-contents-as-binary filename)
 309         (unless (or (std11-field-body "To")
 310                     (std11-field-body "Cc")
 311                     (std11-field-body "Subject"))
 312           (let (charset guess uid)
 313             (erase-buffer)
 314             (set-buffer-multibyte t)
 315             (insert-file-contents filename)
 316             (setq charset (detect-mime-charset-region (point-min)
 317                                                       (point-max)))
 318             (goto-char (point-min))
 319             (setq guess (mime-find-file-type filename))
 320             (setq uid (nth 2 (file-attributes filename)))
 321             (insert "From: " (concat (user-full-name uid)
 322                                      " <"(user-login-name uid) "@"
 323                                      (system-name) ">") "\n")
 324             (insert "Subject: " filename "\n")
 325             (insert "Content-Type: "
 326                     (concat (nth 0 guess) "/" (nth 1 guess))
 327                     "; charset=" (upcase (symbol-name charset))
 328                     "\nMIME-Version: 1.0\n\n")
 329             (encode-mime-charset-region (point-min) (point-max) charset)
 330             (set-buffer-multibyte nil)))))))
 331
 332 (provide 'elmo-search-local-file)
 333
 334 ;; namazu
 335 (defcustom elmo-search-namazu-default-index-path "~/Mail"
 336   "*Default index path for namazu.
 337 If the value is a list, all elements are used as index paths for namazu."
 338   :type '(choice (directory :tag "Index Path")
 339                  (repeat (directory :tag "Index Path")))
 340   :group 'elmo)
 341
 342 (defcustom elmo-search-namazu-index-alias-alist nil
 343   "*Alist of ALIAS and INDEX-PATH."
 344   :type '(repeat (cons (string :tag "Alias Name")
 345                        (choice (directory :tag "Index Path")
 346                                (repeat (directory :tag "Index Path")))))
 347   :group 'elmo)
 348
 349 (defun elmo-search-namazu-index (engine pattern)
 350   (let* ((param (elmo-search-engine-param-internal engine))
 351          (index (cond
 352                  ((cdr (assoc param elmo-search-namazu-index-alias-alist)))
 353                  ((and param (> (length param) 0))
 354                   param)
 355                  (t
 356                   elmo-search-namazu-default-index-path))))
 357     (if (listp index)
 358         (mapcar 'expand-file-name index)
 359       (expand-file-name index))))
 360
 361
 362 ;; grep
 363 (defun elmo-search-grep-target (engine pattern)
 364   (let ((dirname (expand-file-name (elmo-search-engine-param-internal engine)))
 365         (files (list null-device)))
 366     (dolist (filename (directory-files dirname))
 367       (unless (string-match "^\\.\\.?" filename)
 368         (setq files (cons (expand-file-name filename dirname) files))))
 369     files))
 370
 371
 372 ;;; Setup `elmo-search-engine-alist'
 373 (unless noninteractive
 374   (or (assq 'namazu elmo-search-engine-alist)
 375       (elmo-search-register-engine
 376        'namazu 'local-file
 377        :prog "namazu"
 378        :args '("--all" "--list" "--early" pattern elmo-search-namazu-index)
 379        :charset 'iso-2022-jp))
 380   (or (assq 'grep elmo-search-engine-alist)
 381       (elmo-search-register-engine
 382        'grep 'local-file
 383        :prog "grep"
 384        :args '("-l" "-e" pattern elmo-search-grep-target))))
 385
 386 (require 'product)
 387 (product-provide (provide 'elmo-search) (require 'elmo-version))
 388
 389 ;;; elmo-search.el ends here