+(luna-define-method elmo-delete-message-safe ((folder elmo-imap4-folder)
+ number msgid)
+ (let ((session (elmo-imap4-get-session folder))
+ candidates)
+ (elmo-imap4-session-select-mailbox
+ session
+ (elmo-imap4-folder-mailbox-internal folder))
+ (setq candidates
+ (elmo-imap4-response-value
+ (elmo-imap4-send-command-wait session
+ (list
+ (if elmo-imap4-use-uid
+ "uid search header message-id "
+ "search header message-id ")
+ (elmo-imap4-field-body msgid)))
+ 'search))
+ (if (memq number candidates)
+ (elmo-folder-delete-messages folder (list number)))))
+
+(defun elmo-imap4-server-diff-async-callback-1 (status data)
+ (funcall elmo-imap4-server-diff-async-callback
+ (list (elmo-imap4-response-value status 'recent)
+ (elmo-imap4-response-value status 'unseen)
+ (elmo-imap4-response-value status 'messages))
+ data))
+
+(defun elmo-imap4-server-diff-async (folder)
+ (let ((session (elmo-imap4-get-session folder)))
+ ;; We should `check' folder to obtain newest information here.
+ ;; But since there's no asynchronous check mechanism in elmo yet,
+ ;; checking is not done here.
+ (with-current-buffer (elmo-network-session-buffer session)
+ (setq elmo-imap4-status-callback
+ 'elmo-imap4-server-diff-async-callback-1)
+ (setq elmo-imap4-status-callback-data
+ elmo-imap4-server-diff-async-callback-data))
+ (elmo-imap4-send-command session
+ (list
+ "status "
+ (elmo-imap4-mailbox
+ (elmo-imap4-folder-mailbox-internal folder))
+ " (recent unseen messages)"))))
+
+(luna-define-method elmo-server-diff-async ((folder elmo-imap4-folder))
+ (let ((session (elmo-imap4-get-session folder)))
+ ;; commit.
+ ;; (elmo-imap4-commit spec)
+ (with-current-buffer (elmo-network-session-buffer session)
+ (setq elmo-imap4-status-callback
+ 'elmo-imap4-server-diff-async-callback-1)
+ (setq elmo-imap4-status-callback-data
+ elmo-imap4-server-diff-async-callback-data))
+ (elmo-imap4-send-command session
+ (list
+ "status "
+ (elmo-imap4-mailbox
+ (elmo-imap4-folder-mailbox-internal folder))
+ " (recent unseen messages)"))))
+
+;;; IMAP parser.
+
+(defvar elmo-imap4-server-eol "\r\n"
+ "The EOL string sent from the server.")
+
+(defvar elmo-imap4-client-eol "\r\n"
+ "The EOL string we send to the server.")
+
+(defvar elmo-imap4-display-literal-progress nil)
+
+(defun elmo-imap4-find-next-line ()
+ "Return point at end of current line, taking into account literals.
+Return nil if no complete line has arrived."
+ (when (re-search-forward (concat elmo-imap4-server-eol "\\|{\\([0-9]+\\)}"
+ elmo-imap4-server-eol)
+ nil t)
+ (if (match-string 1)
+ (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
+ (progn
+ (if (and elmo-imap4-display-literal-progress
+ (> (string-to-number (match-string 1))
+ (min elmo-display-retrieval-progress-threshold 100)))
+ (elmo-display-progress
+ 'elmo-imap4-display-literal-progress
+ (format "Retrieving (%d/%d bytes)..."
+ (- (point-max) (point))
+ (string-to-number (match-string 1)))
+ (/ (- (point-max) (point))
+ (/ (string-to-number (match-string 1)) 100))))
+ nil)
+ (goto-char (+ (point) (string-to-number (match-string 1))))
+ (elmo-imap4-find-next-line))
+ (point))))
+
+(defun elmo-imap4-sentinel (process string)
+ (delete-process process))
+
+(defun elmo-imap4-arrival-filter (proc string)
+ "IMAP process filter."
+ (when (buffer-live-p (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
+ (elmo-imap4-debug "-> %s" string)
+ (goto-char (point-max))
+ (insert string)
+ (let (end)
+ (goto-char (point-min))
+ (while (setq end (elmo-imap4-find-next-line))
+ (save-restriction
+ (narrow-to-region (point-min) end)
+ (delete-backward-char (length elmo-imap4-server-eol))
+ (goto-char (point-min))
+ (unwind-protect
+ (cond ((eq elmo-imap4-status 'initial)
+ (setq elmo-imap4-current-response
+ (list
+ (list 'greeting (elmo-imap4-parse-greeting)))))
+ ((or (eq elmo-imap4-status 'auth)
+ (eq elmo-imap4-status 'nonauth)
+ (eq elmo-imap4-status 'selected)
+ (eq elmo-imap4-status 'examine))
+ (setq elmo-imap4-current-response
+ (cons
+ (elmo-imap4-parse-response)
+ elmo-imap4-current-response)))
+ (t
+ (message "Unknown state %s in arrival filter"
+ elmo-imap4-status))))
+ (delete-region (point-min) (point-max))))))))
+
+;; IMAP parser.
+
+(defsubst elmo-imap4-forward ()
+ (or (eobp) (forward-char 1)))
+
+(defsubst elmo-imap4-parse-number ()
+ (when (looking-at "[0-9]+")
+ (prog1
+ (string-to-number (match-string 0))
+ (goto-char (match-end 0)))))
+
+(defsubst elmo-imap4-parse-literal ()
+ (when (looking-at "{\\([0-9]+\\)}\r\n")
+ (let ((pos (match-end 0))
+ (len (string-to-number (match-string 1))))
+ (if (< (point-max) (+ pos len))
+ nil
+ (goto-char (+ pos len))
+ (buffer-substring pos (+ pos len))))))
+;;; (list ' pos (+ pos len))))))
+
+(defsubst elmo-imap4-parse-string ()
+ (cond ((eq (char-after (point)) ?\")
+ (forward-char 1)
+ (let ((p (point)) (name ""))
+ (skip-chars-forward "^\"\\\\")
+ (setq name (buffer-substring p (point)))
+ (while (eq (char-after (point)) ?\\)
+ (setq p (1+ (point)))
+ (forward-char 2)
+ (skip-chars-forward "^\"\\\\")
+ (setq name (concat name (buffer-substring p (point)))))
+ (forward-char 1)
+ name))
+ ((eq (char-after (point)) ?{)
+ (elmo-imap4-parse-literal))))
+
+(defsubst elmo-imap4-parse-nil ()
+ (if (looking-at "NIL")
+ (goto-char (match-end 0))))
+
+(defsubst elmo-imap4-parse-nstring ()
+ (or (elmo-imap4-parse-string)
+ (and (elmo-imap4-parse-nil)
+ nil)))
+
+(defsubst elmo-imap4-parse-astring ()
+ (or (elmo-imap4-parse-string)
+ (buffer-substring (point)
+ (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
+ (goto-char (1- (match-end 0)))
+ (end-of-line)
+ (point)))))
+
+(defsubst elmo-imap4-parse-address ()
+ (let (address)
+ (when (eq (char-after (point)) ?\()
+ (elmo-imap4-forward)
+ (setq address (vector (prog1 (elmo-imap4-parse-nstring)
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-nstring)
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-nstring)
+ (elmo-imap4-forward))
+ (elmo-imap4-parse-nstring)))
+ (when (eq (char-after (point)) ?\))
+ (elmo-imap4-forward)
+ address))))
+
+(defsubst elmo-imap4-parse-address-list ()
+ (if (eq (char-after (point)) ?\()
+ (let (address addresses)
+ (elmo-imap4-forward)
+ (while (and (not (eq (char-after (point)) ?\)))
+ ;; next line for MS Exchange bug
+ (progn (and (eq (char-after (point)) ? ) (elmo-imap4-forward)) t)
+ (setq address (elmo-imap4-parse-address)))
+ (setq addresses (cons address addresses)))
+ (when (eq (char-after (point)) ?\))
+ (elmo-imap4-forward)
+ (nreverse addresses)))
+ (assert (elmo-imap4-parse-nil))))
+
+(defsubst elmo-imap4-parse-mailbox ()
+ (let ((mailbox (elmo-imap4-parse-astring)))
+ (if (string-equal "INBOX" (upcase mailbox))
+ "INBOX"
+ mailbox)))
+
+(defun elmo-imap4-parse-greeting ()
+ "Parse a IMAP greeting."
+ (cond ((looking-at "\\* OK ")
+ (setq elmo-imap4-status 'nonauth))
+ ((looking-at "\\* PREAUTH ")
+ (setq elmo-imap4-status 'auth))
+ ((looking-at "\\* BYE ")
+ (setq elmo-imap4-status 'closed))))
+
+(defun elmo-imap4-parse-response ()
+ "Parse a IMAP command response."
+ (let (token)
+ (case (setq token (elmo-read (current-buffer)))
+ (+ (progn
+ (skip-chars-forward " ")
+ (list 'continue-req (buffer-substring (point) (point-max)))))
+ (* (case (prog1 (setq token (elmo-read (current-buffer)))
+ (elmo-imap4-forward))
+ (OK (elmo-imap4-parse-resp-text-code))
+ (NO (elmo-imap4-parse-resp-text-code))
+ (BAD (elmo-imap4-parse-resp-text-code))
+ (BYE (elmo-imap4-parse-bye))
+ (FLAGS (list 'flags
+ (elmo-imap4-parse-flag-list)))
+ (LIST (list 'list (elmo-imap4-parse-data-list)))
+ (LSUB (list 'lsub (elmo-imap4-parse-data-list)))
+ (SEARCH (list
+ 'search
+ (elmo-read (concat "("
+ (buffer-substring (point) (point-max))
+ ")"))))
+ (STATUS (elmo-imap4-parse-status))
+ ;; Added
+ (NAMESPACE (elmo-imap4-parse-namespace))
+ (CAPABILITY (list 'capability
+ (elmo-read
+ (concat "(" (downcase (buffer-substring
+ (point) (point-max)))
+ ")"))))
+ (ACL (elmo-imap4-parse-acl))
+ (t (case (prog1 (elmo-read (current-buffer))
+ (elmo-imap4-forward))
+ (EXISTS (list 'exists token))
+ (RECENT (list 'recent token))
+ (EXPUNGE (list 'expunge token))
+ (FETCH (elmo-imap4-parse-fetch token))
+ (t (list 'garbage (buffer-string)))))))
+ (t (if (not (string-match elmo-imap4-seq-prefix (symbol-name token)))
+ (list 'garbage (buffer-string))
+ (case (prog1 (elmo-read (current-buffer))
+ (elmo-imap4-forward))
+ (OK (progn
+ (setq elmo-imap4-parsing nil)
+ (setq token (symbol-name token))
+ (elmo-unintern token)
+ (elmo-imap4-debug "*%s* OK arrived" token)
+ (setq elmo-imap4-reached-tag token)
+ (list 'ok (elmo-imap4-parse-resp-text-code))))
+ (NO (progn
+ (setq elmo-imap4-parsing nil)
+ (setq token (symbol-name token))
+ (elmo-unintern token)
+ (elmo-imap4-debug "*%s* NO arrived" token)
+ (setq elmo-imap4-reached-tag token)
+ (let (code text)
+ (when (eq (char-after (point)) ?\[)
+ (setq code (buffer-substring (point)
+ (search-forward "]")))
+ (elmo-imap4-forward))
+ (setq text (buffer-substring (point) (point-max)))
+ (list 'no (list code text)))))
+ (BAD (progn
+ (setq elmo-imap4-parsing nil)
+ (elmo-imap4-debug "*%s* BAD arrived" token)
+ (setq token (symbol-name token))
+ (elmo-unintern token)
+ (setq elmo-imap4-reached-tag token)
+ (let (code text)
+ (when (eq (char-after (point)) ?\[)
+ (setq code (buffer-substring (point)
+ (search-forward "]")))
+ (elmo-imap4-forward))
+ (setq text (buffer-substring (point) (point-max)))
+ (list 'bad (list code text)))))
+ (t (list 'garbage (buffer-string)))))))))
+
+(defun elmo-imap4-parse-bye ()
+ (let (code text)
+ (when (eq (char-after (point)) ?\[)
+ (setq code (buffer-substring (point)
+ (search-forward "]")))
+ (elmo-imap4-forward))
+ (setq text (buffer-substring (point) (point-max)))
+ (list 'bye (list code text))))
+
+(defun elmo-imap4-parse-text ()
+ (goto-char (point-min))
+ (when (search-forward "[" nil t)
+ (search-forward "]")
+ (elmo-imap4-forward))
+ (list 'text (buffer-substring (point) (point-max))))
+
+(defun elmo-imap4-parse-resp-text-code ()
+ (when (eq (char-after (point)) ?\[)
+ (elmo-imap4-forward)
+ (cond ((search-forward "PERMANENTFLAGS " nil t)
+ (list 'permanentflags (elmo-imap4-parse-flag-list)))
+ ((search-forward "UIDNEXT " nil t)
+ (list 'uidnext (elmo-read (current-buffer))))
+ ((search-forward "UNSEEN " nil t)
+ (list 'unseen (elmo-read (current-buffer))))
+ ((looking-at "UIDVALIDITY \\([0-9]+\\)")
+ (list 'uidvalidity (match-string 1)))
+ ((search-forward "READ-ONLY" nil t)
+ (list 'read-only t))
+ ((search-forward "READ-WRITE" nil t)
+ (list 'read-write t))
+ ((search-forward "NEWNAME " nil t)
+ (let (oldname newname)
+ (setq oldname (elmo-imap4-parse-string))
+ (elmo-imap4-forward)
+ (setq newname (elmo-imap4-parse-string))
+ (list 'newname newname oldname)))
+ ((search-forward "TRYCREATE" nil t)
+ (list 'trycreate t))
+ ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
+ (list 'appenduid
+ (list (match-string 1)
+ (string-to-number (match-string 2)))))
+ ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
+ (list 'copyuid (list (match-string 1)
+ (match-string 2)
+ (match-string 3))))
+ ((search-forward "ALERT] " nil t)
+ (message "IMAP server information: %s"
+ (buffer-substring (point) (point-max))))
+ (t (list 'unknown)))))
+
+(defun elmo-imap4-parse-data-list ()
+ (let (flags delimiter mailbox)
+ (setq flags (elmo-imap4-parse-flag-list))
+ (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
+ (setq delimiter (match-string 1))
+ (goto-char (1+ (match-end 0)))
+ (when (setq mailbox (elmo-imap4-parse-mailbox))
+ (list mailbox flags delimiter)))))
+
+(defsubst elmo-imap4-parse-header-list ()
+ (when (eq (char-after (point)) ?\()
+ (let (strlist)
+ (while (not (eq (char-after (point)) ?\)))
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-astring) strlist))
+ (elmo-imap4-forward)
+ (nreverse strlist))))
+
+(defsubst elmo-imap4-parse-fetch-body-section ()
+ (let ((section
+ (buffer-substring (point)
+ (1-
+ (progn (re-search-forward "[] ]" nil t)
+ (point))))))
+ (if (eq (char-before) ? )
+ (prog1
+ (mapconcat 'identity
+ (cons section (elmo-imap4-parse-header-list)) " ")
+ (search-forward "]" nil t))
+ section)))
+
+(defun elmo-imap4-parse-fetch (response)
+ (when (eq (char-after (point)) ?\()
+ (let (element list)
+ (while (not (eq (char-after (point)) ?\)))
+ (elmo-imap4-forward)
+ (let ((token (elmo-imap4-fetch-read (current-buffer))))
+ (elmo-imap4-forward)
+ (setq element
+ (cond ((eq token 'UID)
+ (list 'uid (condition-case nil
+ (elmo-read (current-buffer))
+ (error nil))))
+ ((eq token 'FLAGS)
+ (list 'flags (elmo-imap4-parse-flag-list)))
+ ((eq token 'ENVELOPE)
+ (list 'envelope (elmo-imap4-parse-envelope)))
+ ((eq token 'INTERNALDATE)
+ (list 'internaldate (elmo-imap4-parse-string)))
+ ((eq token 'RFC822)
+ (list 'rfc822 (elmo-imap4-parse-nstring)))
+ ((eq token (intern elmo-imap4-rfc822-header))
+ (list 'rfc822header (elmo-imap4-parse-nstring)))
+ ((eq token (intern elmo-imap4-rfc822-text))
+ (list 'rfc822text (elmo-imap4-parse-nstring)))
+ ((eq token (intern elmo-imap4-rfc822-size))
+ (list 'rfc822size (elmo-read (current-buffer))))
+ ((eq token 'BODY)
+ (if (eq (char-before) ?\[)
+ (list
+ 'bodydetail
+ (upcase (elmo-imap4-parse-fetch-body-section))
+ (and
+ (eq (char-after (point)) ?<)
+ (buffer-substring (1+ (point))
+ (progn
+ (search-forward ">" nil t)
+ (point))))
+ (progn (elmo-imap4-forward)
+ (elmo-imap4-parse-nstring)))
+ (list 'body (elmo-imap4-parse-body))))
+ ((eq token 'BODYSTRUCTURE)
+ (list 'bodystructure (elmo-imap4-parse-body)))))
+ (setq list (cons element list))))
+ (and elmo-imap4-fetch-callback
+ (funcall elmo-imap4-fetch-callback
+ list elmo-imap4-fetch-callback-data))
+ (list 'fetch list))))
+
+(defun elmo-imap4-parse-status ()
+ (let ((mailbox (elmo-imap4-parse-mailbox))
+ status)
+ (when (and mailbox (search-forward "(" nil t))
+ (while (not (eq (char-after (point)) ?\)))
+ (setq status
+ (cons
+ (let ((token (elmo-read (current-buffer))))
+ (cond ((eq token 'MESSAGES)
+ (list 'messages (elmo-read (current-buffer))))
+ ((eq token 'RECENT)
+ (list 'recent (elmo-read (current-buffer))))
+ ((eq token 'UIDNEXT)
+ (list 'uidnext (elmo-read (current-buffer))))
+ ((eq token 'UIDVALIDITY)
+ (and (looking-at " \\([0-9]+\\)")
+ (prog1 (list 'uidvalidity (match-string 1))
+ (goto-char (match-end 1)))))
+ ((eq token 'UNSEEN)
+ (list 'unseen (elmo-read (current-buffer))))
+ (t
+ (message
+ "Unknown status data %s in mailbox %s ignored"
+ token mailbox))))
+ status))))
+ (and elmo-imap4-status-callback
+ (funcall elmo-imap4-status-callback
+ status
+ elmo-imap4-status-callback-data))
+ (list 'status status)))
+
+
+(defmacro elmo-imap4-value (value)
+ (` (if (eq (, value) 'NIL) nil
+ (, value))))
+
+(defmacro elmo-imap4-nth (pos list)
+ (` (let ((value (nth (, pos) (, list))))
+ (elmo-imap4-value value))))
+
+(defun elmo-imap4-parse-namespace ()
+ (list 'namespace
+ (nconc
+ (copy-sequence elmo-imap4-extra-namespace-alist)
+ (elmo-imap4-parse-namespace-subr
+ (elmo-read (concat "(" (buffer-substring
+ (point) (point-max))
+ ")"))))))
+
+(defun elmo-imap4-parse-namespace-subr (ns)
+ (let (prefix delim namespace-alist default-delim)
+ ;; 0: personal, 1: other, 2: shared
+ (dotimes (i 3)
+ (setq namespace-alist
+ (nconc namespace-alist
+ (delq nil
+ (mapcar
+ (lambda (namespace)
+ (setq prefix (elmo-imap4-nth 0 namespace)
+ delim (elmo-imap4-nth 1 namespace))
+ (if (and prefix delim
+ (string-match
+ (concat (regexp-quote delim) "\\'")
+ prefix))
+ (setq prefix (substring prefix 0
+ (match-beginning 0))))
+ (if (eq (length prefix) 0)
+ (progn (setq default-delim delim) nil)
+ (cons
+ (concat "^\\("
+ (if (string= (downcase prefix) "inbox")
+ "[Ii][Nn][Bb][Oo][Xx]"
+ (regexp-quote prefix))
+ "\\).*$")
+ delim)))
+ (elmo-imap4-nth i ns))))))
+ (if default-delim
+ (setq namespace-alist
+ (nconc namespace-alist
+ (list (cons "^.*$" default-delim)))))
+ namespace-alist))
+
+(defun elmo-imap4-parse-acl ()
+ (let ((mailbox (elmo-imap4-parse-mailbox))
+ identifier rights acl)
+ (while (eq (char-after (point)) ?\ )
+ (elmo-imap4-forward)
+ (setq identifier (elmo-imap4-parse-astring))
+ (elmo-imap4-forward)
+ (setq rights (elmo-imap4-parse-astring))
+ (setq acl (append acl (list (cons identifier rights)))))
+ (list 'acl acl mailbox)))
+
+(defun elmo-imap4-parse-flag-list ()
+ (let ((str (buffer-substring (+ (point) 1)
+ (progn (search-forward ")" nil t)
+ (- (point) 1)))))
+ (unless (eq (length str) 0)
+ (split-string str))))
+
+(defun elmo-imap4-parse-envelope ()
+ (when (eq (char-after (point)) ?\()
+ (elmo-imap4-forward)
+ (vector (prog1 (elmo-imap4-parse-nstring);; date
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-nstring);; subject
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-address-list);; from
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-address-list);; sender
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-address-list);; reply-to
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-address-list);; to
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-address-list);; cc
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-address-list);; bcc
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-nstring);; in-reply-to
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-nstring);; message-id
+ (elmo-imap4-forward)))))
+
+(defsubst elmo-imap4-parse-string-list ()
+ (cond ((eq (char-after (point)) ?\();; body-fld-param
+ (let (strlist str)
+ (elmo-imap4-forward)
+ (while (setq str (elmo-imap4-parse-string))
+ (push str strlist)
+ (elmo-imap4-forward))
+ (nreverse strlist)))
+ ((elmo-imap4-parse-nil)
+ nil)))
+
+(defun elmo-imap4-parse-body-extension ()
+ (if (eq (char-after (point)) ?\()
+ (let (b-e)
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-body-extension) b-e)
+ (while (eq (char-after (point)) ?\ )
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-body-extension) b-e))
+ (assert (eq (char-after (point)) ?\)))
+ (elmo-imap4-forward)
+ (nreverse b-e))
+ (or (elmo-imap4-parse-number)
+ (elmo-imap4-parse-nstring))))
+
+(defsubst elmo-imap4-parse-body-ext ()
+ (let (ext)
+ (when (eq (char-after (point)) ?\ );; body-fld-dsp
+ (elmo-imap4-forward)
+ (let (dsp)
+ (if (eq (char-after (point)) ?\()
+ (progn
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-string) dsp)
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-string-list) dsp)
+ (elmo-imap4-forward))
+ (assert (elmo-imap4-parse-nil)))
+ (push (nreverse dsp) ext))
+ (when (eq (char-after (point)) ?\ );; body-fld-lang
+ (elmo-imap4-forward)
+ (if (eq (char-after (point)) ?\()
+ (push (elmo-imap4-parse-string-list) ext)
+ (push (elmo-imap4-parse-nstring) ext))
+ (while (eq (char-after (point)) ?\ );; body-extension
+ (elmo-imap4-forward)
+ (setq ext (append (elmo-imap4-parse-body-extension) ext)))))
+ ext))
+
+(defun elmo-imap4-parse-body ()
+ (let (body)
+ (when (eq (char-after (point)) ?\()
+ (elmo-imap4-forward)
+ (if (eq (char-after (point)) ?\()
+ (let (subbody)
+ (while (and (eq (char-after (point)) ?\()
+ (setq subbody (elmo-imap4-parse-body)))
+ (push subbody body))
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-string) body);; media-subtype
+ (when (eq (char-after (point)) ?\ );; body-ext-mpart:
+ (elmo-imap4-forward)
+ (if (eq (char-after (point)) ?\();; body-fld-param
+ (push (elmo-imap4-parse-string-list) body)
+ (push (and (elmo-imap4-parse-nil) nil) body))
+ (setq body
+ (append (elmo-imap4-parse-body-ext) body)));; body-ext-...
+ (assert (eq (char-after (point)) ?\)))
+ (elmo-imap4-forward)
+ (nreverse body))
+
+ (push (elmo-imap4-parse-string) body);; media-type
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-string) body);; media-subtype
+ (elmo-imap4-forward)
+ ;; next line for Sun SIMS bug
+ (and (eq (char-after (point)) ? ) (elmo-imap4-forward))
+ (if (eq (char-after (point)) ?\();; body-fld-param
+ (push (elmo-imap4-parse-string-list) body)
+ (push (and (elmo-imap4-parse-nil) nil) body))
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-nstring) body);; body-fld-id
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-nstring) body);; body-fld-desc
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-string) body);; body-fld-enc
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-number) body);; body-fld-octets
+
+ ;; ok, we're done parsing the required parts, what comes now is one
+ ;; of three things:
+ ;;
+ ;; envelope (then we're parsing body-type-msg)
+ ;; body-fld-lines (then we're parsing body-type-text)
+ ;; body-ext-1part (then we're parsing body-type-basic)
+ ;;
+ ;; the problem is that the two first are in turn optionally followed
+ ;; by the third. So we parse the first two here (if there are any)...
+
+ (when (eq (char-after (point)) ?\ )
+ (elmo-imap4-forward)
+ (let (lines)
+ (cond ((eq (char-after (point)) ?\();; body-type-msg:
+ (push (elmo-imap4-parse-envelope) body);; envelope
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-body) body);; body
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-number) body));; body-fld-lines
+ ((setq lines (elmo-imap4-parse-number));; body-type-text:
+ (push lines body));; body-fld-lines
+ (t
+ (backward-char)))));; no match...
+
+ ;; ...and then parse the third one here...
+
+ (when (eq (char-after (point)) ?\ );; body-ext-1part:
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-nstring) body);; body-fld-md5
+ (setq body
+ (append (elmo-imap4-parse-body-ext) body)));; body-ext-1part..
+
+ (assert (eq (char-after (point)) ?\)))
+ (elmo-imap4-forward)
+ (nreverse body)))))
+
+(luna-define-method elmo-folder-initialize :around ((folder
+ elmo-imap4-folder)
+ name)
+ (let ((default-user elmo-imap4-default-user)
+ (default-server elmo-imap4-default-server)
+ (default-port elmo-imap4-default-port)
+ (elmo-network-stream-type-alist
+ (if elmo-imap4-stream-type-alist
+ (append elmo-imap4-stream-type-alist
+ elmo-network-stream-type-alist)
+ elmo-network-stream-type-alist))
+ parse)
+ (when (string-match "\\(.*\\)@\\(.*\\)" default-server)
+ ;; case: imap4-default-server is specified like
+ ;; "hoge%imap.server@gateway".
+ (setq default-user (elmo-match-string 1 default-server))
+ (setq default-server (elmo-match-string 2 default-server)))
+ (setq name (luna-call-next-method))
+ ;; mailbox
+ (setq parse (elmo-parse-token name ":"))
+ (elmo-imap4-folder-set-mailbox-internal folder
+ (elmo-imap4-encode-folder-string
+ (if (eq (length (car parse)) 0)
+ elmo-imap4-default-mailbox
+ (car parse))))
+ ;; user
+ (setq parse (elmo-parse-prefixed-element ?: (cdr parse) "/"))
+ (elmo-net-folder-set-user-internal folder
+ (if (eq (length (car parse)) 0)
+ default-user
+ (car parse)))
+ ;; auth
+ (setq parse (elmo-parse-prefixed-element ?/ (cdr parse)))
+ (elmo-net-folder-set-auth-internal
+ folder
+ (if (eq (length (car parse)) 0)
+ (or elmo-imap4-default-authenticate-type 'clear)
+ (intern (car parse))))
+ (unless (elmo-net-folder-server-internal folder)
+ (elmo-net-folder-set-server-internal folder default-server))
+ (unless (elmo-net-folder-port-internal folder)
+ (elmo-net-folder-set-port-internal folder default-port))
+ (unless (elmo-net-folder-stream-type-internal folder)
+ (elmo-net-folder-set-stream-type-internal
+ folder
+ (elmo-get-network-stream-type elmo-imap4-default-stream-type)))
+ folder))
+
+;;; ELMO IMAP4 folder
+(luna-define-method elmo-folder-expand-msgdb-path ((folder
+ elmo-imap4-folder))
+ (convert-standard-filename
+ (let ((mailbox (elmo-imap4-folder-mailbox-internal folder)))
+ (if (string= "inbox" (downcase mailbox))
+ (setq mailbox "inbox"))
+ (if (eq (string-to-char mailbox) ?/)
+ (setq mailbox (substring mailbox 1 (length mailbox))))
+ (expand-file-name
+ mailbox
+ (expand-file-name
+ (or (elmo-net-folder-user-internal folder) "nobody")
+ (expand-file-name (or (elmo-net-folder-server-internal folder)
+ "nowhere")
+ (expand-file-name
+ "imap"
+ elmo-msgdb-directory)))))))
+
+(luna-define-method elmo-folder-status-plugged ((folder
+ elmo-imap4-folder))
+ (elmo-imap4-folder-status-plugged folder))
+
+(defun elmo-imap4-folder-status-plugged (folder)
+ (let ((session (elmo-imap4-get-session folder))
+ (killed (elmo-msgdb-killed-list-load
+ (elmo-folder-msgdb-path folder)))
+ status)
+ (with-current-buffer (elmo-network-session-buffer session)
+ (setq elmo-imap4-status-callback nil)
+ (setq elmo-imap4-status-callback-data nil))
+ (setq status (elmo-imap4-response-value
+ (elmo-imap4-send-command-wait
+ session
+ (list "status "
+ (elmo-imap4-mailbox
+ (elmo-imap4-folder-mailbox-internal folder))
+ " (uidnext messages)"))
+ 'status))
+ (cons
+ (- (elmo-imap4-response-value status 'uidnext) 1)
+ (if killed
+ (-
+ (elmo-imap4-response-value status 'messages)
+ (elmo-msgdb-killed-list-length killed))
+ (elmo-imap4-response-value status 'messages)))))
+
+(luna-define-method elmo-folder-list-messages-plugged ((folder
+ elmo-imap4-folder)
+ &optional nohide)
+ (elmo-imap4-list folder
+ (let ((max (elmo-msgdb-max-of-killed
+ (elmo-folder-killed-list-internal folder))))
+ (if (or nohide
+ (null (eq max 0)))
+ (format "uid %d:*" (1+ max))
+ "all"))))
+
+(luna-define-method elmo-folder-list-unreads-plugged
+ ((folder elmo-imap4-folder))
+ (elmo-imap4-list folder "unseen"))
+
+(luna-define-method elmo-folder-list-importants-plugged
+ ((folder elmo-imap4-folder))
+ (elmo-imap4-list folder "flagged"))
+
+(luna-define-method elmo-folder-use-flag-p ((folder elmo-imap4-folder))
+ (not (string-match elmo-imap4-disuse-server-flag-mailbox-regexp
+ (elmo-imap4-folder-mailbox-internal folder))))
+
+(luna-define-method elmo-folder-list-subfolders ((folder elmo-imap4-folder)
+ &optional one-level)
+ (let* ((root (elmo-imap4-folder-mailbox-internal folder))
+ (session (elmo-imap4-get-session folder))
+ (prefix (elmo-folder-prefix-internal folder))
+ (delim (or
+ (cdr
+ (elmo-string-matched-assoc
+ root
+ (with-current-buffer (elmo-network-session-buffer session)
+ elmo-imap4-server-namespace)))
+ elmo-imap4-default-hierarchy-delimiter))
+ ;; Append delimiter when root with namespace.
+ (root (if (and (match-end 1)
+ (string= (substring root (match-end 1))
+ ""))
+ (concat root delim)
+ root))
+ result append-serv type)
+ (setq result (elmo-imap4-response-get-selectable-mailbox-list
+ (elmo-imap4-send-command-wait
+ session
+ (list "list " (elmo-imap4-mailbox root) " *"))))
+ (unless (string= (elmo-net-folder-user-internal folder)
+ elmo-imap4-default-user)
+ (setq append-serv (concat ":" (elmo-net-folder-user-internal folder))))
+ (unless (eq (elmo-net-folder-auth-internal folder)
+ (or elmo-imap4-default-authenticate-type 'clear))
+ (setq append-serv
+ (concat append-serv "/"
+ (symbol-name (elmo-net-folder-auth-internal folder)))))
+ (unless (string= (elmo-net-folder-server-internal folder)
+ elmo-imap4-default-server)
+ (setq append-serv (concat append-serv "@"
+ (elmo-net-folder-server-internal folder))))
+ (unless (eq (elmo-net-folder-port-internal folder) elmo-imap4-default-port)
+ (setq append-serv (concat append-serv ":"
+ (int-to-string
+ (elmo-net-folder-port-internal folder)))))
+ (setq type (elmo-net-folder-stream-type-internal folder))
+ (unless (eq (elmo-network-stream-type-symbol type)
+ elmo-imap4-default-stream-type)
+ (if type
+ (setq append-serv (concat append-serv
+ (elmo-network-stream-type-spec-string
+ type)))))
+ (if one-level
+ (let ((re-delim (regexp-quote delim))
+ (case-fold-search nil)
+ folder ret has-child-p)
+ ;; Append delimiter
+ (when (and root
+ (not (string= root ""))
+ (not (string-match
+ (concat "\\(.*\\)" re-delim "\\'")
+ root)))
+ (setq root (concat root delim)))
+ (while (setq folder (car result))
+ (when (string-match
+ (concat "^\\(" (regexp-quote root) "[^" re-delim "]" "+\\)"
+ re-delim)
+ folder)
+ (setq folder (match-string 1 folder)))
+ (setq has-child-p nil
+ result (delq
+ nil
+ (mapcar (lambda (fld)
+ (if (string-match
+ (concat "^" (regexp-quote folder)
+ "\\(" re-delim "\\|\\'\\)")
+ fld)
+ (progn (setq has-child-p t) nil)
+ fld))
+ (cdr result)))
+ folder (concat prefix
+ (elmo-imap4-decode-folder-string folder)
+ (and append-serv
+ (eval append-serv)))
+ ret (append ret (if has-child-p
+ (list (list folder))
+ (list folder)))))
+ ret)
+ (mapcar (lambda (fld)
+ (concat prefix (elmo-imap4-decode-folder-string fld)
+ (and append-serv
+ (eval append-serv))))
+ result))))
+
+(luna-define-method elmo-folder-exists-p-plugged ((folder elmo-imap4-folder))
+ (let ((session (elmo-imap4-get-session folder)))
+ (if (string=
+ (elmo-imap4-session-current-mailbox-internal session)
+ (elmo-imap4-folder-mailbox-internal folder))
+ t
+ (elmo-imap4-session-select-mailbox
+ session
+ (elmo-imap4-folder-mailbox-internal folder)
+ 'force 'notify-bye))))
+
+(luna-define-method elmo-folder-writable-p ((folder elmo-imap4-folder))
+ t)
+
+(luna-define-method elmo-folder-delete :before ((folder elmo-imap4-folder))
+ (let ((session (elmo-imap4-get-session folder))
+ msgs)
+ (when (elmo-imap4-folder-mailbox-internal folder)
+ (when (setq msgs (elmo-folder-list-messages folder))
+ (elmo-folder-delete-messages folder msgs))
+ (elmo-imap4-send-command-wait session "close")
+ (elmo-imap4-send-command-wait
+ session
+ (list "delete "
+ (elmo-imap4-mailbox
+ (elmo-imap4-folder-mailbox-internal folder)))))))
+
+(luna-define-method elmo-folder-rename-internal ((folder elmo-imap4-folder)
+ new-folder)
+ (let ((session (elmo-imap4-get-session folder)))
+ ;; make sure the folder is selected.
+ (elmo-imap4-session-select-mailbox session
+ (elmo-imap4-folder-mailbox-internal
+ folder))
+ (elmo-imap4-send-command-wait session "close")
+ (elmo-imap4-send-command-wait
+ session
+ (list "rename "
+ (elmo-imap4-mailbox
+ (elmo-imap4-folder-mailbox-internal folder))
+ " "
+ (elmo-imap4-mailbox
+ (elmo-imap4-folder-mailbox-internal new-folder))))))
+
+(defun elmo-imap4-copy-messages (src-folder dst-folder numbers)
+ (let ((session (elmo-imap4-get-session src-folder))
+ (set-list (elmo-imap4-make-number-set-list
+ numbers
+ elmo-imap4-number-set-chop-length))
+ succeeds)
+ (elmo-imap4-session-select-mailbox session
+ (elmo-imap4-folder-mailbox-internal
+ src-folder))
+ (while set-list
+ (if (elmo-imap4-send-command-wait session
+ (list
+ (format
+ (if elmo-imap4-use-uid
+ "uid copy %s "
+ "copy %s ")
+ (cdr (car set-list)))
+ (elmo-imap4-mailbox
+ (elmo-imap4-folder-mailbox-internal
+ dst-folder))))
+ (setq succeeds (append succeeds numbers)))
+ (setq set-list (cdr set-list)))
+ succeeds))
+
+(defun elmo-imap4-set-flag (folder numbers flag &optional remove)
+ "Set flag on messages.
+FOLDER is the ELMO folder structure.
+NUMBERS is the message numbers to be flagged.
+FLAG is the flag name.
+If optional argument REMOVE is non-nil, remove FLAG."
+ (let ((session (elmo-imap4-get-session folder))
+ response set-list)
+ (elmo-imap4-session-select-mailbox session
+ (elmo-imap4-folder-mailbox-internal
+ folder))
+ (setq set-list (elmo-imap4-make-number-set-list
+ numbers
+ elmo-imap4-number-set-chop-length))
+ (while set-list
+ (with-current-buffer (elmo-network-session-buffer session)
+ (setq elmo-imap4-fetch-callback nil)
+ (setq elmo-imap4-fetch-callback-data nil))
+ (unless (elmo-imap4-response-ok-p
+ (elmo-imap4-send-command-wait
+ session
+ (format
+ (if elmo-imap4-use-uid
+ "uid store %s %sflags.silent (%s)"
+ "store %s %sflags.silent (%s)")
+ (cdr (car set-list))
+ (if remove "-" "+")
+ flag)))
+ (setq response 'fail))
+ (setq set-list (cdr set-list)))
+ (not (eq response 'fail))))
+
+(luna-define-method elmo-folder-delete-messages-plugged
+ ((folder elmo-imap4-folder) numbers)
+ (let ((session (elmo-imap4-get-session folder)))
+ (elmo-imap4-set-flag folder numbers "\\Deleted")
+ (elmo-imap4-send-command-wait session "expunge")))
+
+(defmacro elmo-imap4-detect-search-charset (string)
+ (` (with-temp-buffer
+ (insert (, string))
+ (detect-mime-charset-region (point-min) (point-max)))))
+
+(defun elmo-imap4-search-internal-primitive (folder session filter from-msgs)
+ (let ((search-key (elmo-filter-key filter))
+ (imap-search-keys '("bcc" "body" "cc" "from" "subject" "to"))
+ (total 0)
+ (length (length from-msgs))
+ charset set-list end results)
+ (message "Searching...")
+ (cond
+ ((string= "last" search-key)
+ (let ((numbers (or from-msgs (elmo-folder-list-messages folder))))
+ (nthcdr (max (- (length numbers)
+ (string-to-int (elmo-filter-value filter)))
+ 0)
+ numbers)))
+ ((string= "first" search-key)
+ (let* ((numbers (or from-msgs (elmo-folder-list-messages folder)))
+ (rest (nthcdr (string-to-int (elmo-filter-value filter) )
+ numbers)))
+ (mapcar '(lambda (x) (delete x numbers)) rest)
+ numbers))
+ ((or (string= "since" search-key)
+ (string= "before" search-key))
+ (setq search-key (concat "sent" search-key)
+ set-list (elmo-imap4-make-number-set-list
+ from-msgs
+ elmo-imap4-number-set-chop-length)
+ end nil)
+ (while (not end)
+ (setq results
+ (append
+ results
+ (elmo-imap4-response-value
+ (elmo-imap4-send-command-wait
+ session
+ (format
+ (if elmo-imap4-use-uid
+ "uid search %s%s%s %s"
+ "search %s%s%s %s")
+ (if from-msgs
+ (concat
+ (if elmo-imap4-use-uid "uid ")
+ (cdr (car set-list))
+ " ")
+ "")
+ (if (eq (elmo-filter-type filter)
+ 'unmatch)
+ "not " "")
+ search-key
+ (elmo-date-get-description
+ (elmo-date-get-datevec
+ (elmo-filter-value filter)))))
+ 'search)))
+ (when (> length elmo-display-progress-threshold)
+ (setq total (+ total (car (car set-list))))
+ (elmo-display-progress
+ 'elmo-imap4-search "Searching..."
+ (/ (* total 100) length)))
+ (setq set-list (cdr set-list)
+ end (null set-list)))
+ results)
+ (t
+ (setq charset
+ (if (eq (length (elmo-filter-value filter)) 0)
+ (setq charset 'us-ascii)
+ (elmo-imap4-detect-search-charset
+ (elmo-filter-value filter)))
+ set-list (elmo-imap4-make-number-set-list
+ from-msgs
+ elmo-imap4-number-set-chop-length)
+ end nil)
+ (while (not end)
+ (setq results
+ (append
+ results
+ (elmo-imap4-response-value
+ (elmo-imap4-send-command-wait
+ session
+ (list
+ (if elmo-imap4-use-uid "uid ")
+ "search "
+ "CHARSET "
+ (elmo-imap4-astring
+ (symbol-name charset))
+ " "
+ (if from-msgs
+ (concat
+ (if elmo-imap4-use-uid "uid ")
+ (cdr (car set-list))
+ " ")
+ "")
+ (if (eq (elmo-filter-type filter)
+ 'unmatch)
+ "not " "")
+ (format "%s%s "
+ (if (member
+ (elmo-filter-key filter)
+ imap-search-keys)
+ ""
+ "header ")
+ (elmo-filter-key filter))
+ (elmo-imap4-astring
+ (encode-mime-charset-string
+ (elmo-filter-value filter) charset))))
+ 'search)))
+ (when (> length elmo-display-progress-threshold)
+ (setq total (+ total (car (car set-list))))
+ (elmo-display-progress
+ 'elmo-imap4-search "Searching..."
+ (/ (* total 100) length)))
+ (setq set-list (cdr set-list)
+ end (null set-list)))
+ results))))
+
+(defun elmo-imap4-search-internal (folder session condition from-msgs)
+ (let (result)
+ (cond
+ ((vectorp condition)
+ (setq result (elmo-imap4-search-internal-primitive
+ folder session condition from-msgs)))
+ ((eq (car condition) 'and)
+ (setq result (elmo-imap4-search-internal folder session (nth 1 condition)
+ from-msgs)
+ result (elmo-list-filter result
+ (elmo-imap4-search-internal
+ folder session (nth 2 condition)
+ from-msgs))))
+ ((eq (car condition) 'or)
+ (setq result (elmo-imap4-search-internal
+ folder session (nth 1 condition) from-msgs)
+ result (elmo-uniq-list
+ (nconc result
+ (elmo-imap4-search-internal
+ folder session (nth 2 condition) from-msgs)))
+ result (sort result '<))))))
+
+(luna-define-method elmo-folder-search :around ((folder elmo-imap4-folder)
+ condition &optional numbers)
+ (if (elmo-folder-plugged-p folder)