`elmo-condition-match'.
(elmo-msgdb-match-condition-primitive): New function.
* modb-entity.el (elmo-msgdb-message-match-condition): Removed
arguments `flags' and `numbers'.
(elmo-msgdb-match-condition-primitive): Abolished (merged to
`elmo-msgdb-message-match-condition').
(modb-buffer-entity-handler): New class.
* elmo.el (elmo-folder-search): Optimize condition to use
`elmo-condition-optimize'.
(elmo-message-buffer-match-condition): New function.
(elmo-message-match-condition): Use
`elmo-message-buffer-match-condition' instead of
`elmo-buffer-field-condition-match'.
* elmo-util.el (elmo-condition-match): New function.
(elmo-condition-optimize): Ditto.
(elmo-buffer-field-primitive-condition-match): Abolish.
(elmo-buffer-field-condition-match): Ditto.
* elmo-archive.el (elmo-archive-field-condition-match): Use
`elmo-message-buffer-match-condition' instead of
`elmo-buffer-field-condition-match'.
+2005-03-27 Hiroya Murata <lapis-lazuli@pop06.odn.ne.jp>
+
+ * modb.el (elmo-msgdb-match-condition): Rewrite with
+ `elmo-condition-match'.
+ (elmo-msgdb-match-condition-primitive): New function.
+
+ * modb-entity.el (elmo-msgdb-message-match-condition): Removed
+ arguments `flags' and `numbers'.
+ (elmo-msgdb-match-condition-primitive): Abolished (merged to
+ `elmo-msgdb-message-match-condition').
+ (modb-buffer-entity-handler): New class.
+
+ * elmo.el (elmo-folder-search): Optimize condition to use
+ `elmo-condition-optimize'.
+ (elmo-message-buffer-match-condition): New function.
+ (elmo-message-match-condition): Use
+ `elmo-message-buffer-match-condition' instead of
+ `elmo-buffer-field-condition-match'.
+
+ * elmo-util.el (elmo-condition-match): New function.
+ (elmo-condition-optimize): Ditto.
+ (elmo-buffer-field-primitive-condition-match): Abolish.
+ (elmo-buffer-field-condition-match): Ditto.
+
+ * elmo-archive.el (elmo-archive-field-condition-match): Use
+ `elmo-message-buffer-match-condition' instead of
+ `elmo-buffer-field-condition-match'.
+
2005-03-25 Hiroya Murata <lapis-lazuli@pop06.odn.ne.jp>
* elmo-flag.el (elmo-global-flags-initialize): Check the
(elmo-archive-call-method method args t))
(set-buffer-multibyte default-enable-multibyte-characters)
(decode-mime-charset-region (point-min)(point-max) elmo-mime-charset)
- (elmo-buffer-field-condition-match condition number number-list))))))
+ (elmo-message-buffer-match-condition condition number))))))
(luna-define-method elmo-folder-search ((folder elmo-archive-folder)
condition &optional from-msgs)
(goto-char (match-end 0))))
(t (error "Syntax error '%s'" (buffer-string)))))
+(defmacro elmo-filter-condition-p (filter)
+ `(or (vectorp ,filter) (consp ,filter)))
+
+(defmacro elmo-filter-type (filter)
+ `(aref ,filter 0))
+
+(defmacro elmo-filter-key (filter)
+ `(aref ,filter 1))
+
+(defmacro elmo-filter-value (filter)
+ `(aref ,filter 2))
+
+(defun elmo-condition-match (condition match-primitive args)
+ (cond
+ ((vectorp condition)
+ (if (eq (elmo-filter-type condition) 'unmatch)
+ (not (apply match-primitive condition args))
+ (apply match-primitive condition args)))
+ ((eq (car condition) 'and)
+ (let ((lhs (elmo-condition-match (nth 1 condition) match-primitive args)))
+ (cond
+ ((elmo-filter-condition-p lhs)
+ (let ((rhs (elmo-condition-match (nth 2 condition)
+ match-primitive args)))
+ (cond ((elmo-filter-condition-p rhs)
+ (list 'and lhs rhs))
+ (rhs
+ lhs))))
+ (lhs
+ (elmo-condition-match (nth 2 condition) match-primitive args)))))
+ ((eq (car condition) 'or)
+ (let ((lhs (elmo-condition-match (nth 1 condition) match-primitive args)))
+ (cond
+ ((elmo-filter-condition-p lhs)
+ (let ((rhs (elmo-condition-match (nth 2 condition)
+ match-primitive args)))
+ (cond ((elmo-filter-condition-p rhs)
+ (list 'or lhs rhs))
+ (rhs
+ t)
+ (t
+ lhs))))
+ (lhs
+ t)
+ (t
+ (elmo-condition-match (nth 2 condition) match-primitive args)))))))
+
+(defun elmo-condition-optimize (condition)
+ (cond
+ ((vectorp condition)
+ (or (cdr (assoc (elmo-filter-key condition)
+ '(("first" . 0)
+ ("last" . 0)
+ ("flag" . 1)
+ ("body" . 3))))
+ 2))
+ (t
+ (let ((weight-l (elmo-condition-optimize (nth 1 condition)))
+ (weight-r (elmo-condition-optimize (nth 2 condition))))
+ (if (> weight-l weight-r)
+ (let ((lhs (nth 1 condition)))
+ (setcar (nthcdr 1 condition) (nth 2 condition))
+ (setcar (nthcdr 2 condition) lhs)
+ weight-l)
+ weight-r)))))
+
;;;
(defsubst elmo-buffer-replace (regexp &optional newtext)
(goto-char (point-min))
(setq l1 (cdr l1)))
(cons diff1 (list l2)))))
-(defmacro elmo-filter-condition-p (filter)
- `(or (vectorp ,filter) (consp ,filter)))
-
-(defmacro elmo-filter-type (filter)
- `(aref ,filter 0))
-
-(defmacro elmo-filter-key (filter)
- `(aref ,filter 1))
-
-(defmacro elmo-filter-value (filter)
- `(aref ,filter 2))
-
-(defsubst elmo-buffer-field-primitive-condition-match (condition
- number
- number-list)
- (let (result)
- (goto-char (point-min))
- (cond
- ((string= (elmo-filter-key condition) "last")
- (setq result (<= (length (memq number number-list))
- (string-to-int (elmo-filter-value condition)))))
- ((string= (elmo-filter-key condition) "first")
- (setq result (< (- (length number-list)
- (length (memq number number-list)))
- (string-to-int (elmo-filter-value condition)))))
- ((string= (elmo-filter-key condition) "since")
- (let ((field-date (elmo-date-make-sortable-string
- (timezone-fix-time
- (std11-field-body "date")
- (current-time-zone) nil)))
- (specified-date (elmo-date-make-sortable-string
- (elmo-date-get-datevec
- (elmo-filter-value condition)))))
- (setq result
- (or (string= field-date specified-date)
- (string< specified-date field-date)))))
- ((string= (elmo-filter-key condition) "before")
- (setq result
- (string<
- (elmo-date-make-sortable-string
- (timezone-fix-time
- (std11-field-body "date")
- (current-time-zone) nil))
- (elmo-date-make-sortable-string
- (elmo-date-get-datevec
- (elmo-filter-value condition))))))
- ((string= (elmo-filter-key condition) "body")
- (and (re-search-forward "^$" nil t) ; goto body
- (setq result (search-forward (elmo-filter-value condition)
- nil t))))
- (t
- (dolist (fval (elmo-multiple-field-body (elmo-filter-key condition)))
- (if (eq (length fval) 0) (setq fval nil))
- (if fval (setq fval (eword-decode-string fval)))
- (setq result (or result
- (and fval (string-match
- (elmo-filter-value condition) fval)))))))
- (if (eq (elmo-filter-type condition) 'unmatch)
- (setq result (not result)))
- result))
-
-(defun elmo-buffer-field-condition-match (condition number number-list)
- (cond
- ((vectorp condition)
- (elmo-buffer-field-primitive-condition-match
- condition number number-list))
- ((eq (car condition) 'and)
- (and (elmo-buffer-field-condition-match
- (nth 1 condition) number number-list)
- (elmo-buffer-field-condition-match
- (nth 2 condition) number number-list)))
- ((eq (car condition) 'or)
- (or (elmo-buffer-field-condition-match
- (nth 1 condition) number number-list)
- (elmo-buffer-field-condition-match
- (nth 2 condition) number number-list)))))
-
(defmacro elmo-get-hash-val (string hashtable)
(static-if (fboundp 'unintern)
`(symbol-value (intern-soft ,string ,hashtable))
(setq results (elmo-msgdb-search msgdb condition numbers))
(if (listp results)
results
+ (elmo-condition-optimize condition)
+ (when (and (consp condition)
+ (eq (car condition) 'and)
+ (listp (setq results (elmo-msgdb-search msgdb
+ (nth 1 condition)
+ numbers))))
+ (setq numbers results
+ condition (nth 2 condition)))
(let ((len (length numbers))
matched)
(elmo-with-progress-display (> len elmo-display-progress-threshold)
(message "Searching...done")
(nreverse matched)))))
+(defun elmo-message-buffer-match-condition (condition number)
+ (let* ((handler (luna-make-entity 'modb-buffer-entity-handler))
+ (result (elmo-condition-match
+ condition
+ (lambda (condition handler entity)
+ (elmo-msgdb-message-match-condition handler
+ condition
+ entity))
+ (list
+ handler
+ (elmo-msgdb-make-message-entity
+ handler
+ :number number
+ :buffer (current-buffer))))))
+ (and result (not (elmo-filter-condition-p result)))))
+
(luna-define-method elmo-message-match-condition ((folder elmo-folder)
number condition
numbers)
(set-buffer-multibyte default-enable-multibyte-characters)
(decode-coding-region (point-min) (point-max)
elmo-mime-display-as-is-coding-system)
- (elmo-buffer-field-condition-match condition number numbers)))))
+ (elmo-message-buffer-match-condition condition number)))))
(luna-define-method elmo-folder-pack-numbers ((folder elmo-folder))
nil) ; default is noop.
;; Transitional interface.
(luna-define-generic elmo-msgdb-message-match-condition (handler
condition
- entity
- flags
- numbers)
+ entity)
"Return non-nil when the entity matches the condition.")
;; Generic implementation.
(copy-sequence (cdr entity)))))
(luna-define-method elmo-msgdb-message-match-condition
- ((handler modb-entity-handler) condition entity flags numbers)
- (cond
- ((vectorp condition)
- (elmo-msgdb-match-condition-primitive handler condition
- entity flags numbers))
- ((eq (car condition) 'and)
- (let ((lhs (elmo-msgdb-message-match-condition handler
- (nth 1 condition)
- entity flags numbers)))
- (cond
- ((elmo-filter-condition-p lhs)
- (let ((rhs (elmo-msgdb-message-match-condition
- handler (nth 2 condition) entity flags numbers)))
- (cond ((elmo-filter-condition-p rhs)
- (list 'and lhs rhs))
- (rhs
- lhs))))
- (lhs
- (elmo-msgdb-message-match-condition handler (nth 2 condition)
- entity flags numbers)))))
- ((eq (car condition) 'or)
- (let ((lhs (elmo-msgdb-message-match-condition handler (nth 1 condition)
- entity flags numbers)))
- (cond
- ((elmo-filter-condition-p lhs)
- (let ((rhs (elmo-msgdb-message-match-condition handler
- (nth 2 condition)
- entity flags numbers)))
- (cond ((elmo-filter-condition-p rhs)
- (list 'or lhs rhs))
- (rhs
- t)
- (t
- lhs))))
- (lhs
- t)
- (t
- (elmo-msgdb-message-match-condition handler
- (nth 2 condition)
- entity flags numbers)))))))
-
-;;
-(defun elmo-msgdb-match-condition-primitive (handler
- condition
- entity
- flags
- numbers)
- (catch 'unresolved
- (let ((key (elmo-filter-key condition))
- (case-fold-search t)
- result)
- (cond
- ((string= key "last")
- (setq result (<= (length (memq
- (elmo-msgdb-message-entity-number
- handler entity)
- numbers))
- (string-to-int (elmo-filter-value condition)))))
- ((string= key "first")
- (setq result (< (-
- (length numbers)
- (length (memq
- (elmo-msgdb-message-entity-number
- handler entity)
- numbers)))
- (string-to-int (elmo-filter-value condition)))))
- ((string= key "flag")
- (setq result
- (cond
- ((string= (elmo-filter-value condition) "any")
- (or (memq 'important flags)
- (memq 'answered flags)
- (memq 'unread flags)))
- ((string= (elmo-filter-value condition) "digest")
- (or (memq 'important flags)
- (memq 'unread flags)))
- ((string= (elmo-filter-value condition) "unread")
- (memq 'unread flags))
- ((string= (elmo-filter-value condition) "important")
- (memq 'important flags))
- ((string= (elmo-filter-value condition) "answered")
- (memq 'answered flags)))))
- ((string= key "from")
- (setq result (string-match
- (elmo-filter-value condition)
- (elmo-msgdb-message-entity-field
- handler entity 'from))))
- ((string= key "subject")
- (setq result (string-match
- (elmo-filter-value condition)
- (elmo-msgdb-message-entity-field
- handler entity 'subject))))
- ((string= key "to")
- (setq result (string-match
- (elmo-filter-value condition)
- (elmo-msgdb-message-entity-field
- handler entity 'to 'string))))
- ((string= key "cc")
- (setq result (string-match
- (elmo-filter-value condition)
- (elmo-msgdb-message-entity-field
- handler entity 'cc 'string))))
- ((or (string= key "since")
- (string= key "before"))
- (let ((field-date (elmo-msgdb-message-entity-field
- handler entity 'date))
- (specified-date
- (elmo-datevec-to-time
- (elmo-date-get-datevec
- (elmo-filter-value condition)))))
- (setq result (if (string= key "since")
- (not (elmo-time< field-date specified-date))
- (elmo-time< field-date specified-date)))))
- ((member key elmo-msgdb-extra-fields)
- (let ((extval (elmo-msgdb-message-entity-field handler
- entity
- (intern key)
- 'string)))
- (when (stringp extval)
- (setq result (string-match
- (elmo-filter-value condition)
- extval)))))
- (t
- (throw 'unresolved condition)))
- (if (eq (elmo-filter-type condition) 'unmatch)
- (not result)
- result))))
+ ((handler modb-entity-handler) condition entity)
+ (let ((key (elmo-filter-key condition))
+ (case-fold-search t)
+ field-value)
+ (cond
+ ((or (string= key "since")
+ (string= key "before"))
+ (let ((field-date (elmo-msgdb-message-entity-field
+ handler entity 'date))
+ (specified-date
+ (elmo-datevec-to-time
+ (elmo-date-get-datevec
+ (elmo-filter-value condition)))))
+ (if (string= key "since")
+ (not (elmo-time< field-date specified-date))
+ (elmo-time< field-date specified-date))))
+ ((setq field-value (elmo-msgdb-message-entity-field handler
+ entity
+ (intern key)
+ 'string))
+ (and (stringp field-value)
+ (string-match (elmo-filter-value condition) field-value)))
+ (t
+ condition))))
;; Standard implementation.
(elmo-msgdb-get-decoded-cache (car value))
(cdr value))))
+;; message buffer handler
+(eval-and-compile
+ (luna-define-class modb-buffer-entity-handler (modb-entity-handler)))
+
+(defvar modb-buffer-entity-specializer nil)
+(modb-set-field-converter 'modb-buffer-entity-specializer nil
+ 'date #'elmo-time-parse-date-string)
+
+(luna-define-method elmo-msgdb-make-message-entity
+ ((handler modb-buffer-entity-handler) args)
+ (cons handler (cons (or (plist-get args :number)
+ (plist-get args 'number))
+ (or (plist-get args :buffer)
+ (plist-get args 'buffer)
+ (current-buffer)))))
+
+(luna-define-method elmo-msgdb-message-entity-number
+ ((handler modb-buffer-entity-handler) entity)
+ (car (cdr entity)))
+
+(luna-define-method elmo-msgdb-message-entity-set-number
+ ((handler modb-buffer-entity-handler) entity number)
+ (and entity (setcar (cdr entity) number)))
+
+(luna-define-method elmo-msgdb-message-entity-field
+ ((handler modb-buffer-entity-handler) entity field &optional type)
+ (and entity
+ (let ((elmo-mime-charset
+ (or (modb-entity-handler-mime-charset-internal handler)
+ elmo-mime-charset)))
+ (modb-convert-field-value
+ modb-buffer-entity-specializer
+ field
+ (if (memq field '(number :number))
+ (car (cdr entity))
+ (with-current-buffer (cdr (cdr entity))
+ (let ((extractor (cdr (assq field
+ modb-entity-field-extractor-alist))))
+ (if extractor
+ (funcall extractor field)
+ (mapconcat
+ (lambda (field-body)
+ (mime-decode-field-body field-body (symbol-name field)
+ 'summary))
+ (elmo-multiple-field-body (symbol-name field))
+ "\n")))))
+ type))))
+
+(luna-define-method elmo-msgdb-message-match-condition :around
+ ((handler modb-buffer-entity-handler) condition entity)
+ (let ((key (elmo-filter-key condition))
+ (case-fold-search t))
+ (cond
+ ((string= (elmo-filter-key condition) "body")
+ (with-current-buffer (cdr (cdr entity))
+ (goto-char (point-min))
+ (and (re-search-forward "^$" nil t) ; goto body
+ (search-forward (elmo-filter-value condition) nil t))))
+ (t
+ (luna-call-next-method)))))
+
(require 'product)
(product-provide (provide 'modb-entity) (require 'elmo-version))
&optional numbers)
(let ((entity (elmo-msgdb-message-entity msgdb number)))
(if entity
- (elmo-msgdb-message-match-condition
- (elmo-message-entity-handler entity)
+ (elmo-condition-match
condition
- entity
- (elmo-msgdb-flags msgdb number)
- (or numbers (elmo-msgdb-list-messages msgdb)))
+ #'elmo-msgdb-match-condition-primitive
+ (list msgdb number entity
+ (or numbers (elmo-msgdb-list-messages msgdb))))
condition)))
+(defun elmo-msgdb-match-condition-primitive (condition msgdb number entity
+ population)
+ (let ((key (elmo-filter-key condition))
+ (case-fold-search t))
+ (cond
+ ((string= key "last")
+ (<= (length (memq number population))
+ (string-to-int (elmo-filter-value condition))))
+ ((string= key "first")
+ (< (- (length population)
+ (length (memq number population)))
+ (string-to-int (elmo-filter-value condition))))
+ ((string= key "flag")
+ (let ((flags (elmo-msgdb-flags msgdb number)))
+ (cond ((string= (elmo-filter-value condition) "any")
+ (and flags (not (equal flags '(cached)))))
+ ((string= (elmo-filter-value condition) "digest")
+ (catch 'found
+ (dolist (flag flags)
+ (when (or (memq flag elmo-digest-flags)
+ (elmo-global-flag-p flag))
+ (throw 'found t)))))
+ ((string= (elmo-filter-value condition) "read")
+ (not (memq 'read flags)))
+ (t
+ (memq (intern (elmo-filter-value condition)) flags)))))
+ (t
+ (elmo-msgdb-message-match-condition (elmo-message-entity-handler entity)
+ condition entity)))))
+
(luna-define-method elmo-msgdb-update-entity ((msgdb modb-generic)
entity values)
(when (elmo-msgdb-message-entity-update-fields
projects / elisp / wanderlust.git / commitdiff