:group 'elmo)
(defcustom modb-entity-field-extractor-alist
- '((ml-info . modb-entity-extract-mailing-list-info))
+ '((ml-info modb-entity-extract-mailing-list-info
+ modb-entity-ml-info-real-fields))
"*An alist of field name and function to extract field body from buffer."
- :type '(repeat (cons (symbol :tag "Field Name")
- (function :tag "Function")))
+ :type '(repeat (list (symbol :tag "Field Name")
+ (function :tag "Extractor")
+ (choice :tag "Real Field"
+ (repeat :tag "Field Name List" string)
+ (function :tag "Function"))))
:group 'elmo)
(defvar modb-entity-default-cache-internal nil)
;; 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)
(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)))
+ (elmo-map-recursive
+ (lambda (element)
+ (if (stringp element)
+ (elmo-msgdb-get-decoded-cache element)
+ element))
+ value))
(defun modb-entity-encode-string-recursive (field value)
- (cond ((stringp value)
+ (elmo-map-recursive
+ (lambda (element)
+ (if (stringp element)
(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)))
-
+ (encode-mime-charset-string element elmo-mime-charset))
+ element))
+ value))
(defun modb-entity-create-field-indices (slots)
(let ((index 0)
cc (mapconcat 'identity (elmo-multiple-field-body "cc") ","))
(unless (elmo-msgdb-message-entity-field handler entity 'size)
(if (setq size (elmo-field-body "content-length"))
- (setq size (string-to-int size))
+ (setq size (string-to-number size))
(setq size 0)))
(while extras
(if (setq field-body (elmo-field-body (car extras)))
(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))))
+ ((or (string= key "larger")
+ (string= key "smaller"))
+ (let ((bytes (elmo-msgdb-message-entity-field handler entity 'size))
+ (threshold (string-to-number (elmo-filter-value condition))))
+ (if (string= key "larger")
+ (> bytes threshold)
+ (< bytes threshold))))
+ ((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
(luna-define-method elmo-msgdb-create-message-entity-from-buffer
((handler modb-standard-entity-handler) number args)
- (let ((default-mime-charset default-mime-charset)
- entity content-type charset)
+ (let (entity)
(save-excursion
(set-buffer-multibyte default-enable-multibyte-characters)
- (and (setq content-type (elmo-decoded-field-body
- "content-type" 'summary))
- (setq charset (mime-content-type-parameter
- (mime-parse-Content-Type content-type) "charset"))
- (setq charset (intern-soft charset))
- (mime-charset-p charset)
- (setq default-mime-charset charset))
(setq entity
(modb-standard-make-message-entity
handler
(mime-decode-field-body field-body "cc" 'summary))
(elmo-multiple-field-body "cc") ",")
:content-type
- content-type
+ (elmo-decoded-field-body "content-type" 'summary)
:size
(let ((size (elmo-field-body "content-length")))
(if size
- (string-to-int size)
+ (string-to-number size)
(or (plist-get args :size) 0)))))))
(let (field-name field-body extractor)
(dolist (extra (cons "newsgroups" elmo-msgdb-extra-fields))
(setq field-name (intern (downcase extra))
- extractor (cdr (assq field-name
- modb-entity-field-extractor-alist))
+ extractor (nth 1 (assq field-name
+ modb-entity-field-extractor-alist))
field-body (if extractor
(funcall extractor field-name)
(elmo-decoded-field-body extra 'summary)))
;; mailing list info handling
-(defun modb-entity-extract-ml-info-from-x-sequence ()
- (let ((sequence (elmo-decoded-field-body "x-sequence" 'summary))
- name count)
- (when sequence
- (elmo-set-list '(name count) (split-string sequence " "))
- (cons name count))))
-
-(defun modb-entity-extract-ml-info-from-subject ()
- (let ((subject (elmo-decoded-field-body "subject" 'summary)))
- (when (and subject
- (string-match "^\\s(\\(\\S)+\\)[ :]\\([0-9]+\\)\\s)[ \t]*"
- subject))
- (cons (match-string 1 subject) (match-string 2 subject)))))
-
-(defun modb-entity-extract-ml-info-from-return-path ()
- (let ((return-path (elmo-decoded-field-body "return-path" 'summary)))
- (when (and return-path
- (string-match "^<\\([^@>]+\\)-return-\\([0-9]+\\)-"
- return-path))
- (cons (match-string 1 return-path)
- (match-string 2 return-path)))))
-
-(defun modb-entity-extract-ml-info-from-delivered-to ()
- (let ((delivered-to (elmo-decoded-field-body "delivered-to" 'summary)))
- (when (and delivered-to
- (string-match "^mailing list \\([^@]+\\)@" delivered-to))
- (cons (match-string 1 delivered-to) nil))))
-
-(defun modb-entity-extract-ml-info-from-mailing-list ()
- (let ((mailing-list (elmo-decoded-field-body "mailing-list" 'summary)))
- ;; *-help@, *-owner@, etc.
- (when (and mailing-list
- (string-match "\\(^\\|; \\)contact \\([^@]+\\)-[^-@]+@"
- mailing-list))
- (cons (match-string 2 mailing-list) nil))))
-
-(defvar modb-entity-extract-mailing-list-info-functions
- '(modb-entity-extract-ml-info-from-x-sequence
- modb-entity-extract-ml-info-from-subject
- modb-entity-extract-ml-info-from-return-path
- modb-entity-extract-ml-info-from-delivered-to
- modb-entity-extract-ml-info-from-mailing-list))
-
(defun modb-entity-extract-mailing-list-info (field)
- (let ((ml-name (elmo-decoded-field-body "x-ml-name" 'summary))
- (ml-count (or (elmo-decoded-field-body "x-mail-count" 'summary)
- (elmo-decoded-field-body "x-ml-count" 'summary)))
- (functions modb-entity-extract-mailing-list-info-functions)
- result)
- (while (and functions
- (or (null ml-name) (null ml-count)))
- (when (setq result (funcall (car functions)))
- (unless ml-name
- (setq ml-name (car result)))
- (unless ml-count
- (setq ml-count (cdr result))))
- (setq functions (cdr functions)))
- (when (or ml-name ml-count)
- (cons (and ml-name (car (split-string ml-name " ")))
- (and ml-count (string-to-int ml-count))))))
+ (let* ((getter (lambda (field)
+ (elmo-decoded-field-body (symbol-name field) 'summary)))
+ (name (elmo-find-list-match-value
+ elmo-mailing-list-name-spec-list
+ getter))
+ (count (elmo-find-list-match-value
+ elmo-mailing-list-count-spec-list
+ getter)))
+ (when (or name count)
+ (cons name (and count (string-to-number count))))))
+
+(defun modb-entity-ml-info-real-fields (field)
+ (elmo-uniq-list
+ (mapcar (lambda (entry)
+ (symbol-name (if (consp entry) (car entry) entry)))
+ (append elmo-mailing-list-name-spec-list
+ elmo-mailing-list-count-spec-list))))
(defun modb-entity-make-mailing-list-info-string (field value)
(when (car 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
+ (nth 1 (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