(require 'elmo-vars)
(require 'elmo-util)
-(eval-and-compile (luna-define-class modb-entity-handler))
+(eval-and-compile
+ (luna-define-class modb-entity-handler () (mime-charset))
+ (luna-define-internal-accessors 'modb-entity-handler))
(defcustom modb-entity-default-handler 'modb-legacy-entity-handler
"Default entity handler."
(setq modb-entity-default-cache-internal
(luna-make-entity modb-entity-default-handler)))))
+(luna-define-generic modb-entity-handler-list-parameters (handler)
+ "Return a parameter list of HANDLER.")
+
(luna-define-generic elmo-msgdb-make-message-entity (handler &rest args)
"Make a message entity using HANDLER.")
;; 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))
+
(luna-define-method elmo-msgdb-create-message-entity-from-file
((handler modb-entity-handler) number file)
(let (insert-file-contents-pre-hook ; To avoid autoconv-xmas...
(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-class-name other))
+ (catch 'mismatch
+ (dolist (slot (modb-entity-handler-list-parameters handler))
+ (when (not (equal (luna-slot-value handler slot)
+ (luna-slot-value other slot)))
+ (throw 'mismatch nil)))
+ t)))
+
+(defun modb-entity-handler-dump-parameters (handler)
+ "Return parameters for reconstruct HANDLER as plist."
+ (apply #'nconc
+ (mapcar (lambda (slot)
+ (let ((value (luna-slot-value handler slot)))
+ (when value
+ (list (intern (concat ":" (symbol-name slot)))
+ value))))
+ (modb-entity-handler-list-parameters handler))))
;; field in/out converter
(defun modb-set-field-converter (converter type &rest specs)
(symbol-name field))))
(defun modb-entity-parse-address-string (field value)
- (if (stringp value)
- (elmo-parse-addresses value)
- value))
+ (modb-entity-encode-string-recursive
+ field
+ (if (stringp value)
+ (elmo-parse-addresses value)
+ value)))
(defun modb-entity-make-address-string (field value)
- (if (stringp value)
- value
- (mapconcat 'identity value ", ")))
+ (let ((value (modb-entity-decode-string-recursive field value)))
+ (if (stringp value)
+ value
+ (mapconcat 'identity value ", "))))
+
+(defun modb-entity-decode-string-recursive (field value)
+ (cond ((stringp value)
+ (elmo-msgdb-get-decoded-cache value))
+ ((consp value)
+ (setcar value (modb-entity-decode-string-recursive field (car value)))
+ (setcdr value (modb-entity-decode-string-recursive field (cdr value)))
+ value)
+ (t
+ value)))
+
+(defun modb-entity-encode-string-recursive (field value)
+ (cond ((stringp value)
+ (elmo-with-enable-multibyte
+ (encode-mime-charset-string value elmo-mime-charset)))
+ ((consp value)
+ (setcar value (modb-entity-encode-string-recursive field (car value)))
+ (setcdr value (modb-entity-encode-string-recursive field (cdr value)))
+ value)
+ (t
+ value)))
(defun modb-entity-create-field-indices (slots)
(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.
(defvar modb-standard-entity-normalizer nil)
(modb-set-field-converter 'modb-standard-entity-normalizer nil
- 'date #'modb-entity-parse-date-string
- 'to #'modb-entity-parse-address-string
- 'cc #'modb-entity-parse-address-string
- t nil)
+ 'messgae-id nil
+ 'number nil
+ 'date #'modb-entity-parse-date-string
+ 'to #'modb-entity-parse-address-string
+ 'cc #'modb-entity-parse-address-string
+ 'references nil
+ 'size nil
+ 'score nil
+ t #'modb-entity-encode-string-recursive)
(defvar modb-standard-entity-specializer nil)
-(modb-set-field-converter 'modb-standard-entity-specializer nil t nil)
+(modb-set-field-converter 'modb-standard-entity-specializer nil
+ 'messgae-id nil
+ 'number nil
+ 'date nil
+ 'references nil
+ 'size nil
+ 'score nil
+ t #'modb-entity-decode-string-recursive)
(modb-set-field-converter 'modb-standard-entity-specializer 'string
+ 'messgae-id nil
+ 'number nil
'date #'modb-entity-make-date-string
'to #'modb-entity-make-address-string
'cc #'modb-entity-make-address-string
+ 'references nil
+ 'size nil
+ 'score nil
'ml-info #'modb-entity-make-mailing-list-info-string
- t nil)
+ t #'modb-entity-decode-string-recursive)
(defmacro modb-standard-entity-field-index (field)
`(cdr (assq ,field modb-standard-entity-field-indices)))
(when entity
(let (index)
(unless as-is
- (setq value (modb-convert-field-value modb-standard-entity-normalizer
- field value)))
+ (let ((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))
(setcar (cdr entity) value))
((setq index (modb-standard-entity-field-index field))
(luna-define-method elmo-msgdb-message-entity-field
((handler modb-standard-entity-handler) entity field &optional type)
(and entity
- (let (index)
+ (let ((elmo-mime-charset
+ (modb-entity-handler-mime-charset handler))
+ index)
(modb-convert-field-value
modb-standard-entity-specializer
field
(copy-sequence modb-standard-entity-field-slots))
(mapcar 'car
(aref
- (cdr entity)
+ (cdr (cdr entity))
(modb-standard-entity-field-index :extra)))
'(message-id)))
(elmo-msgdb-message-entity-set-field
(defun modb-entity-make-mailing-list-info-string (field value)
(when (car value)
(format (if (cdr value) "(%s %05.0f)" "(%s)")
- (car value) (cdr value))))
+ (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