;; 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.
+(luna-define-method initialize-instance :after ((handler modb-entity-handler)
+ &rest init-args)
+ (unless (modb-entity-handler-mime-charset-internal handler)
+ (modb-entity-handler-set-mime-charset-internal handler elmo-mime-charset))
+ handler)
+
(luna-define-method modb-entity-handler-list-parameters
((handler modb-entity-handler))
(list 'mime-charset))
(setq updated t)))
updated))
+;; helper functions
+(defsubst modb-entity-handler-mime-charset (handler)
+ (or (modb-entity-handler-mime-charset-internal handler)
+ elmo-mime-charset))
+
(defun modb-entity-handler-equal-p (handler other)
"Return non-nil, if OTHER hanlder is equal this HANDLER."
(and (eq (luna-class-name handler)
(luna-define-method elmo-msgdb-message-entity-set-number
((handler modb-legacy-entity-handler) entity number)
- (and entity (aset (cdr entity) 0 number))
- entity)
+ (and entity (aset (cdr entity) 0 number)))
(luna-define-method elmo-msgdb-message-entity-field
((handler modb-legacy-entity-handler) entity field &optional type)
(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.
(let (index)
(unless as-is
(let ((elmo-mime-charset
- (or (modb-entity-handler-mime-charset-internal (car entity))
- elmo-mime-charset)))
+ (modb-entity-handler-mime-charset (car entity))))
(setq value (modb-convert-field-value modb-standard-entity-normalizer
field value))))
(cond ((memq field '(message-id :message-id))
((handler modb-standard-entity-handler) entity field &optional type)
(and entity
(let ((elmo-mime-charset
- (or (modb-entity-handler-mime-charset-internal handler)
- elmo-mime-charset))
+ (modb-entity-handler-mime-charset handler))
index)
(modb-convert-field-value
modb-standard-entity-specializer
(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
+ (modb-entity-handler-mime-charset handler)))
+ (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))
projects / elisp / wanderlust.git / blobdiff