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         entity)
 131     (elmo-with-progress-display (elmo-folder-msgdb-create (length numbers))
 132         "Creating msgdb"
 133       (dolist (number numbers)
 134         (setq entity (elmo-search-engine-create-message-entity
 135                       (elmo-search-folder-engine-internal folder)
 136                       (elmo-msgdb-message-entity-handler new-msgdb)
 137                       folder number))
 138         (when entity
 139           (elmo-msgdb-append-entity new-msgdb entity '(new unread)))
 140         (elmo-progress-notify 'elmo-folder-msgdb-create)))
 141     new-msgdb))
 142
 143 (luna-define-method elmo-folder-message-file-p ((folder elmo-search-folder))
 144   nil)
 145
 146 (defun elmo-search-location-to-filename (location)
 147   (when (string-match "^file://" location)
 148     (let ((filename (substring location (match-end 0))))
 149       (expand-file-name
 150        (if (and elmo-search-use-drive-letter
 151                 (string-match "^/\\([A-Za-z]\\)[:|]/\\(.*\\)$" filename))
 152            (replace-match "\\1:/\\2" t nil filename)
 153          filename)))))
 154
 155 (luna-define-method elmo-message-file-name ((folder elmo-search-folder)
 156                                             number)
 157   (elmo-search-location-to-filename
 158    (elmo-map-message-location folder number)))
 159
 160 (luna-define-method elmo-folder-message-make-temp-file-p
 161   ((folder elmo-search-folder))
 162   nil)
 163
 164 (luna-define-method elmo-folder-diff ((folder elmo-search-folder))
 165   (cons nil nil))
 166
 167 (luna-define-method elmo-folder-message-make-temp-files ((folder
 168                                                           elmo-search-folder)
 169                                                          numbers
 170                                                          &optional
 171                                                          start-number)
 172   (let ((temp-dir (elmo-folder-make-temporary-directory folder))
 173         (cur-number (or start-number 0)))
 174     (dolist (number numbers)
 175       (elmo-copy-file
 176        (elmo-message-file-name folder number)
 177        (expand-file-name
 178         (number-to-string (if start-number cur-number number))
 179         temp-dir))
 180       (incf cur-number))
 181     temp-dir))
 182
 183 (luna-define-method elmo-map-message-fetch ((folder elmo-search-folder)
 184                                             location strategy
 185                                             &optional section unseen)
 186   (elmo-search-engine-fetch-message
 187    (elmo-search-folder-engine-internal folder)
 188    location))
 189
 190 (luna-define-method elmo-map-folder-list-message-locations
 191   ((folder elmo-search-folder))
 192   (elmo-search-engine-do-search
 193    (elmo-search-folder-engine-internal folder)
 194    (elmo-search-folder-pattern-internal folder)))
 195
 196 (luna-define-method elmo-folder-exists-p ((folder elmo-search-folder))
 197   (elmo-search-folder-pattern-internal folder))
 198
 199 (luna-define-method elmo-folder-have-subfolder-p ((folder elmo-search-folder))
 200   (null (elmo-search-folder-pattern-internal folder)))
 201
 202 (luna-define-method elmo-folder-list-subfolders ((folder elmo-search-folder)
 203                                                  &optional one-level)
 204   (mapcar
 205    (lambda (name) (elmo-recover-string-from-filename name))
 206    (directory-files (expand-file-name "search" elmo-msgdb-directory)
 207                     nil
 208                     (concat "^" (regexp-quote
 209                                  (elmo-folder-prefix-internal folder))))))
 210
 211 (luna-define-method elmo-folder-delete-messages ((folder elmo-search-folder)
 212                                                  numbers)
 213   (elmo-folder-kill-messages folder numbers)
 214   t)
 215
 216
 217 ;;; Search engine
 218
 219 ;; external program search engine
 220 (eval-and-compile
 221   (luna-define-class elmo-search-engine-extprog (elmo-search-engine)
 222                      (prog args charset parser))
 223   (luna-define-internal-accessors 'elmo-search-engine-extprog))
 224
 225 (luna-define-method elmo-search-engine-do-search
 226   ((engine elmo-search-engine-extprog) pattern)
 227   (with-temp-buffer
 228     (let ((charset (elmo-search-engine-extprog-charset-internal engine))
 229           (parser (or (elmo-search-engine-extprog-parser-internal engine)
 230                       #'elmo-search-parse-filename-list)))
 231       (apply 'call-process
 232              (elmo-search-engine-extprog-prog-internal engine)
 233              nil t t
 234              (delq
 235               nil
 236               (elmo-flatten
 237                (mapcar
 238                 (lambda (arg)
 239                   (cond ((stringp arg) arg)
 240                         ((eq arg 'pattern)
 241                          (if charset
 242                              (encode-mime-charset-string pattern charset)
 243                            pattern))
 244                         ((functionp arg)
 245                          (condition-case nil
 246                              (funcall arg engine pattern)
 247                            (wrong-number-of-arguments
 248                             (funcall arg engine))))
 249                         ((and (symbolp arg)
 250                               (boundp arg))
 251                          (symbol-value arg))))
 252                 (elmo-search-engine-extprog-args-internal engine)))))
 253       (funcall parser))))
 254
 255 ;; search engine for local files
 256 (eval-and-compile
 257   (luna-define-class elmo-search-engine-local-file
 258                      (elmo-search-engine-extprog))
 259   (luna-define-internal-accessors 'elmo-search-engine-local-file))
 260
 261 (defun elmo-search-parse-filename-list ()
 262   (let (bol locations)
 263     (goto-char (point-min))
 264     (while (not (eobp))
 265       (beginning-of-line)
 266       (when (and elmo-search-use-drive-letter
 267                  (looking-at "^\\([A-Za-z]\\)[:|]/"))
 268         (replace-match "/\\1:/")
 269         (beginning-of-line))
 270       (unless (looking-at "^file://")
 271         (insert "file://")
 272         (beginning-of-line))
 273       (setq bol (point))
 274       (end-of-line)
 275       (setq locations (cons (buffer-substring bol (point)) locations))
 276       (forward-line 1))
 277     (nreverse locations)))
 278
 279 (luna-define-method elmo-search-engine-create-message-entity
 280   ((engine elmo-search-engine-local-file) handler folder number)
 281   (let ((filename (elmo-message-file-name folder number))
 282         entity uid)
 283     (when (and filename
 284                (setq entity (elmo-msgdb-create-message-entity-from-file
 285                              handler number filename)))
 286       (unless (or (elmo-message-entity-field entity 'to)
 287                   (elmo-message-entity-field entity 'cc)
 288                   (not (string= (elmo-message-entity-field entity 'subject)
 289                                 elmo-no-subject)))
 290         (elmo-message-entity-set-field entity 'subject
 291                                        (file-name-nondirectory filename))
 292         (setq uid (nth 2 (file-attributes filename)))
 293         (elmo-message-entity-set-field entity 'from
 294                                        (concat
 295                                         (user-full-name uid)
 296                                         " <"(user-login-name uid) "@"
 297                                         (system-name) ">")))
 298       entity)))
 299
 300 (luna-define-method elmo-search-engine-fetch-message
 301   ((engine elmo-search-engine-local-file) location)
 302   (let ((filename (elmo-search-location-to-filename location)))
 303     (when (and filename (file-exists-p filename))
 304       (prog1
 305           (insert-file-contents-as-binary filename)
 306         (unless (or (std11-field-body "To")
 307                     (std11-field-body "Cc")
 308                     (std11-field-body "Subject"))
 309           (let (charset guess uid)
 310             (erase-buffer)
 311             (set-buffer-multibyte t)
 312             (insert-file-contents filename)
 313             (setq charset (detect-mime-charset-region (point-min)
 314                                                       (point-max)))
 315             (goto-char (point-min))
 316             (setq guess (mime-find-file-type filename))
 317             (setq uid (nth 2 (file-attributes filename)))
 318             (insert "From: " (concat (user-full-name uid)
 319                                      " <"(user-login-name uid) "@"
 320                                      (system-name) ">") "\n")
 321             (insert "Subject: " filename "\n")
 322             (insert "Content-Type: "
 323                     (concat (nth 0 guess) "/" (nth 1 guess))
 324                     "; charset=" (upcase (symbol-name charset))
 325                     "\nMIME-Version: 1.0\n\n")
 326             (encode-mime-charset-region (point-min) (point-max) charset)
 327             (set-buffer-multibyte nil)))))))
 328
 329 (provide 'elmo-search-local-file)
 330
 331 ;; namazu
 332 (defcustom elmo-search-namazu-default-index-path "~/Mail"
 333   "*Default index path for namazu.
 334 If the value is a list, all elements are used as index paths for namazu."
 335   :type '(choice (directory :tag "Index Path")
 336                  (repeat (directory :tag "Index Path")))
 337   :group 'elmo)
 338
 339 (defcustom elmo-search-namazu-index-alias-alist nil
 340   "*Alist of ALIAS and INDEX-PATH."
 341   :type '(repeat (cons (string :tag "Alias Name")
 342                        (choice (directory :tag "Index Path")
 343                                (repeat (directory :tag "Index Path")))))
 344   :group 'elmo)
 345
 346 (defun elmo-search-namazu-index (engine pattern)
 347   (let* ((param (elmo-search-engine-param-internal engine))
 348          (index (cond
 349                  ((cdr (assoc param elmo-search-namazu-index-alias-alist)))
 350                  ((and param (> (length param) 0))
 351                   param)
 352                  (t
 353                   elmo-search-namazu-default-index-path))))
 354     (if (listp index)
 355         (mapcar 'expand-file-name index)
 356       (expand-file-name index))))
 357
 358
 359 ;; grep
 360 (defun elmo-search-grep-target (engine pattern)
 361   (let ((dirname (expand-file-name (elmo-search-engine-param-internal engine)))
 362         (files (list null-device)))
 363     (dolist (filename (directory-files dirname))
 364       (unless (string-match "^\\.\\.?" filename)
 365         (setq files (cons (expand-file-name filename dirname) files))))
 366     files))
 367
 368
 369 ;;; Setup `elmo-search-engine-alist'
 370 (unless noninteractive
 371   (or (assq 'namazu elmo-search-engine-alist)
 372       (elmo-search-register-engine
 373        'namazu 'local-file
 374        :prog "namazu"
 375        :args '("--all" "--list" "--early" pattern elmo-search-namazu-index)
 376        :charset 'iso-2022-jp))
 377   (or (assq 'grep elmo-search-engine-alist)
 378       (elmo-search-register-engine
 379        'grep 'local-file
 380        :prog "grep"
 381        :args '("-l" "-e" pattern elmo-search-grep-target))))
 382
 383 (require 'product)
 384 (product-provide (provide 'elmo-search) (require 'elmo-version))
 385
 386 ;;; elmo-search.el ends here