X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-imap4.el;h=3b94ad7184188a1374fa26733ed7bc39a024858e;hb=b6a61bccbe09f078910368fe738a0b3a1a3e28bf;hp=ce4b708daf2dfd30a2c8e5968e802eb27ef921ae;hpb=4f64e5a159c23e9f43b2b7292602e17980213ed8;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-imap4.el b/elmo/elmo-imap4.el index ce4b708..3b94ad7 100644 --- a/elmo/elmo-imap4.el +++ b/elmo/elmo-imap4.el @@ -38,6 +38,7 @@ ;; Author: Simon Josefsson ;; +;;; Code: (require 'elmo-vars) (require 'elmo-util) (require 'elmo-date) @@ -47,8 +48,8 @@ (require 'elmo-net) (require 'utf7) (require 'elmo-mime) +(require 'time-stamp) -;;; Code: (eval-when-compile (require 'cl)) (defvar elmo-imap4-disuse-server-flag-mailbox-regexp "^#mh" ; UW imapd @@ -198,6 +199,9 @@ Debug information is inserted in the buffer \"*IMAP4 DEBUG*\"") (capability current-mailbox read-only flags)) (luna-define-internal-accessors 'elmo-imap4-session)) +(defmacro elmo-imap4-session-capable-p (session capability) + `(memq ,capability (elmo-imap4-session-capability-internal ,session))) + ;;; MIME-ELMO-IMAP Location (eval-and-compile (luna-define-class mime-elmo-imap-location @@ -207,8 +211,8 @@ Debug information is inserted in the buffer \"*IMAP4 DEBUG*\"") ;;; Debug (defmacro elmo-imap4-debug (message &rest args) - (` (if elmo-imap4-debug - (elmo-imap4-debug-1 (, message) (,@ args))))) + `(if elmo-imap4-debug + (elmo-imap4-debug-1 ,message ,@args))) (defun elmo-imap4-debug-1 (message &rest args) (with-current-buffer (get-buffer-create "*IMAP4 DEBUG*") @@ -231,23 +235,23 @@ Debug information is inserted in the buffer \"*IMAP4 DEBUG*\"") (defmacro elmo-imap4-response-continue-req-p (response) "Returns non-nil if RESPONSE is '+' response." - (` (assq 'continue-req (, response)))) + `(assq 'continue-req ,response)) (defmacro elmo-imap4-response-ok-p (response) "Returns non-nil if RESPONSE is an 'OK' response." - (` (assq 'ok (, response)))) + `(assq 'ok ,response)) (defmacro elmo-imap4-response-bye-p (response) "Returns non-nil if RESPONSE is an 'BYE' response." - (` (assq 'bye (, response)))) + `(assq 'bye ,response)) (defmacro elmo-imap4-response-garbage-p (response) "Returns non-nil if RESPONSE is an 'garbage' response." - (` (assq 'garbage (, response)))) + `(assq 'garbage ,response)) (defmacro elmo-imap4-response-value (response symbol) "Get value of the SYMBOL from RESPONSE." - (` (nth 1 (assq (, symbol) (, response))))) + `(nth 1 (assq ,symbol ,response))) (defsubst elmo-imap4-response-value-all (response symbol) "Get all value of the SYMBOL from RESPONSE." @@ -260,23 +264,23 @@ Debug information is inserted in the buffer \"*IMAP4 DEBUG*\"") (defmacro elmo-imap4-response-error-text (response) "Returns text of NO, BAD, BYE response." - (` (nth 1 (or (elmo-imap4-response-value (, response) 'no) - (elmo-imap4-response-value (, response) 'bad) - (elmo-imap4-response-value (, response) 'bye))))) + `(nth 1 (or (elmo-imap4-response-value ,response 'no) + (elmo-imap4-response-value ,response 'bad) + (elmo-imap4-response-value ,response 'bye)))) (defmacro elmo-imap4-response-bodydetail-text (response) "Returns text of BODY[section]." - (` (nth 3 (assq 'bodydetail (, response))))) + `(nth 3 (assq 'bodydetail ,response))) ;;; Session commands. -; (defun elmo-imap4-send-command-wait (session command) -; "Send COMMAND to the SESSION and wait for response. -; Returns RESPONSE (parsed lisp object) of IMAP session." -; (elmo-imap4-read-response session -; (elmo-imap4-send-command -; session -; command))) +;;;(defun elmo-imap4-send-command-wait (session command) +;;; "Send COMMAND to the SESSION and wait for response. +;;;Returns RESPONSE (parsed lisp object) of IMAP session." +;;; (elmo-imap4-read-response session +;;; (elmo-imap4-send-command +;;; session +;;; command))) (defun elmo-imap4-send-command-wait (session command) "Send COMMAND to the SESSION. @@ -300,7 +304,8 @@ Returns a TAG string which is assigned to the COMMAND." (number-to-string (setq elmo-imap4-seqno (+ 1 elmo-imap4-seqno))))) (setq cmdstr (concat tag " ")) - ;; (erase-buffer) No need. +;;; No need. +;;; (erase-buffer) (goto-char (point-min)) (when (elmo-imap4-response-bye-p elmo-imap4-current-response) (elmo-imap4-process-bye session)) @@ -311,7 +316,6 @@ Returns a TAG string which is assigned to the COMMAND." session)) (message "Waiting for IMAP response...done")) (setq elmo-imap4-parsing t) - (elmo-imap4-debug "<-(%s)- %s" tag command) (while (setq token (car command-args)) (cond ((stringp token) ; formatted (setq cmdstr (concat cmdstr token))) @@ -324,20 +328,18 @@ Returns a TAG string which is assigned to the COMMAND." cmdstr (elmo-imap4-format-quoted (nth 1 token))))) ((eq kind 'literal) - (if (memq 'literal+ - (elmo-imap4-session-capability-internal - session)) + (if (elmo-imap4-session-capable-p session 'literal+) ;; rfc2088 (progn (setq cmdstr (concat cmdstr - (format "{%d+}" (nth 2 token)))) + (format "{%d+}" (nth 2 token)) + "\r\n")) (process-send-string process cmdstr) - (process-send-string process "\r\n") (setq cmdstr nil)) (setq cmdstr (concat cmdstr - (format "{%d}" (nth 2 token)))) + (format "{%d}" (nth 2 token)) + "\r\n")) (process-send-string process cmdstr) - (process-send-string process "\r\n") (setq cmdstr nil) (elmo-imap4-accept-continue-req session)) (cond ((stringp (nth 1 token)) @@ -355,9 +357,8 @@ Returns a TAG string which is assigned to the COMMAND." (t (error "Invalid argument"))) (setq command-args (cdr command-args))) - (if cmdstr - (process-send-string process cmdstr)) - (process-send-string process "\r\n") + (elmo-imap4-debug "[%s] <- %s" (time-stamp-hh:mm:ss) cmdstr) + (process-send-string process (concat cmdstr "\r\n")) tag))) (defun elmo-imap4-send-string (session string) @@ -366,7 +367,7 @@ Returns a TAG string which is assigned to the COMMAND." (elmo-network-session-process-internal session)) (setq elmo-imap4-current-response nil) (goto-char (point-min)) - (elmo-imap4-debug "<-- %s" string) + (elmo-imap4-debug "[%s] <-- %s" (time-stamp-hh:mm:ss) string) (process-send-string (elmo-network-session-process-internal session) string) (process-send-string (elmo-network-session-process-internal session) @@ -391,7 +392,7 @@ TAG is the tag of the command" '(open run)) (accept-process-output (elmo-network-session-process-internal session) 1))) - (elmo-imap4-debug "=>%s" (prin1-to-string elmo-imap4-current-response)) + (elmo-imap4-debug "[%s] =>%s" (time-stamp-hh:mm:ss) (prin1-to-string elmo-imap4-current-response)) (setq elmo-imap4-parsing nil) elmo-imap4-current-response)) @@ -399,7 +400,7 @@ TAG is the tag of the command" (with-current-buffer (process-buffer process) (while (not elmo-imap4-current-response) (accept-process-output process 1)) - (elmo-imap4-debug "=>%s" (prin1-to-string elmo-imap4-current-response)) + (elmo-imap4-debug "[%s] =>%s" (time-stamp-hh:mm:ss) (prin1-to-string elmo-imap4-current-response)) elmo-imap4-current-response)) (defun elmo-imap4-read-continue-req (session) @@ -737,26 +738,61 @@ Returns response value if selecting folder succeed. " ;;;(elmo-imap4-send-command-wait ;;;(elmo-imap4-get-session spec) ;;;(list "status " -;;; (elmo-imap4-mailbox -;;; (elmo-imap4-spec-mailbox spec)) -;;; " (uidvalidity)"))) +;;; (elmo-imap4-mailbox +;;; (elmo-imap4-spec-mailbox spec)) +;;; " (uidvalidity)"))) ) (defun elmo-imap4-sync-validity (spec validity-file) ;; Not used. ) +(defun elmo-imap4-elist (folder query tags) + (let ((session (elmo-imap4-get-session folder))) + (elmo-imap4-session-select-mailbox + session + (elmo-imap4-folder-mailbox-internal folder)) + (let ((answer (elmo-imap4-response-value + (elmo-imap4-send-command-wait + session query) 'esearch)) + tag result) + (while answer + (setq tag (intern (downcase (car answer)))) + (cond ((eq tag 'uid) + nil) + ((memq tag tags) + (setq result + (append result + (if (eq tag 'all) + (sort + (elmo-number-set-to-number-list + (mapcar #'(lambda (x) + (let ((y (split-string x ":"))) + (if (null (cdr y)) + (string-to-number (car y)) + (cons (string-to-number (car y)) + (string-to-number (cadr y)))))) + (split-string (cadr answer) "\,"))) '<) + (string-to-number (cadr answer)))))) + (t nil)) + (setq answer (cdr answer))) + result))) + (defun elmo-imap4-list (folder flag) (let ((session (elmo-imap4-get-session folder))) (elmo-imap4-session-select-mailbox session (elmo-imap4-folder-mailbox-internal folder)) - (elmo-imap4-response-value - (elmo-imap4-send-command-wait - session - (format (if elmo-imap4-use-uid "uid search %s" - "search %s") flag)) - 'search))) + (if (elmo-imap4-session-capable-p session 'esearch) + (elmo-imap4-elist folder + (concat (if elmo-imap4-use-uid "uid " "") + "search return (all) " flag) '(all)) + (elmo-imap4-response-value + (elmo-imap4-send-command-wait + session + (format (if elmo-imap4-use-uid "uid search %s" + "search %s") flag)) + 'search)))) (defun elmo-imap4-session-flag-available-p (session flag) (case flag @@ -822,16 +858,7 @@ FLAG is one of the `unread', `read', `important', `answered', `any'." (let ((session (elmo-imap4-get-session folder)) (criteria (elmo-imap4-flag-to-imap-criteria flag))) (if (elmo-imap4-session-flag-available-p session flag) - (progn - (elmo-imap4-session-select-mailbox - session - (elmo-imap4-folder-mailbox-internal folder)) - (elmo-imap4-response-value - (elmo-imap4-send-command-wait - session - (format (if elmo-imap4-use-uid "uid search %s" - "search %s") criteria)) - 'search)) + (elmo-imap4-list folder criteria) ;; List flagged messages in the msgdb. (elmo-msgdb-list-flagged (elmo-folder-msgdb folder) flag)))) @@ -870,7 +897,7 @@ If CHOP-LENGTH is not specified, message set is not chopped." (cond ((consp x) (format "%s:%s" (car x) (cdr x))) ((integerp x) - (int-to-string x)))) + (number-to-string x)))) cont-list ",")) set-list))) @@ -885,8 +912,8 @@ If CHOP-LENGTH is not specified, message set is not chopped." (flag-table (car app-data)) (msg-id (elmo-message-entity-field entity 'message-id)) saved-flags flag-list) -;; (when (elmo-string-member-ignore-case "\\Flagged" flags) -;; (elmo-msgdb-global-mark-set msg-id elmo-msgdb-important-mark)) +;;; (when (elmo-string-member-ignore-case "\\Flagged" flags) +;;; (elmo-msgdb-global-mark-set msg-id elmo-msgdb-important-mark)) (setq saved-flags (elmo-flag-table-get flag-table msg-id) flag-list (if use-flag @@ -927,7 +954,8 @@ If CHOP-LENGTH is not specified, message set is not chopped." (elmo-imap4-response-value element 'uid) :size (elmo-imap4-response-value element 'rfc822size))) (elmo-imap4-response-value element 'flags) - app-data))) + app-data) + (elmo-progress-notify 'elmo-folder-msgdb-create))) (defun elmo-imap4-parse-capability (string) (if (string-match "^\\*\\(.*\\)$" string) @@ -935,6 +963,8 @@ If CHOP-LENGTH is not specified, message set is not chopped." (concat "(" (downcase (elmo-match-string 1 string)) ")")))) (defun elmo-imap4-clear-login (session) + (when (elmo-imap4-session-capable-p session 'logindisabled) + (signal 'elmo-authenticate-error '(elmo-imap4-clear-login))) (let ((elmo-imap4-debug-inhibit-logging t)) (or (elmo-imap4-read-ok @@ -970,7 +1000,7 @@ If CHOP-LENGTH is not specified, message set is not chopped." elmo-network-initialize-session-buffer :after ((session elmo-imap4-session) buffer) (with-current-buffer buffer - (mapcar 'make-variable-buffer-local elmo-imap4-local-variables) + (mapc 'make-variable-buffer-local elmo-imap4-local-variables) (setq elmo-imap4-seqno 0) (setq elmo-imap4-status 'initial))) @@ -981,17 +1011,17 @@ If CHOP-LENGTH is not specified, message set is not chopped." ;; Skip garbage output from process before greeting. (while (and (memq (process-status process) '(open run)) (goto-char (point-max)) - (forward-line -1) - (not (elmo-imap4-parse-greeting))) + (or (/= (forward-line -1) 0) + (not (elmo-imap4-parse-greeting)))) (accept-process-output process 1)) (erase-buffer) (set-process-filter process 'elmo-imap4-arrival-filter) (set-process-sentinel process 'elmo-imap4-sentinel) -;;; (while (and (memq (process-status process) '(open run)) +;;; (while (and (memq (process-status process) '(open run)) ;;; (eq elmo-imap4-status 'initial)) ;;; (message "Waiting for server response...") ;;; (accept-process-output process 1)) -;;; (message "") +;;; (message "") (unless (memq elmo-imap4-status '(nonauth auth)) (signal 'elmo-open-error (list 'elmo-network-initialize-session))) @@ -1003,8 +1033,7 @@ If CHOP-LENGTH is not specified, message set is not chopped." (when (eq (elmo-network-stream-type-symbol (elmo-network-session-stream-type-internal session)) 'starttls) - (or (memq 'starttls - (elmo-imap4-session-capability-internal session)) + (or (elmo-imap4-session-capable-p session 'starttls) (signal 'elmo-open-error '(elmo-imap4-starttls-error))) (elmo-imap4-send-command-wait session "starttls") @@ -1033,15 +1062,15 @@ If CHOP-LENGTH is not specified, message set is not chopped." (sasl-mechanisms (delq nil (mapcar - '(lambda (cap) - (if (string-match "^auth=\\(.*\\)$" - (symbol-name cap)) - (match-string 1 (upcase (symbol-name cap))))) + (lambda (cap) + (if (string-match "^auth=\\(.*\\)$" + (symbol-name cap)) + (match-string 1 (upcase (symbol-name cap))))) (elmo-imap4-session-capability-internal session)))) (mechanism (sasl-find-mechanism (delq nil - (mapcar '(lambda (cap) (upcase (symbol-name cap))) + (mapcar (lambda (cap) (upcase (symbol-name cap))) (if (listp auth) auth (list auth)))))) ;) @@ -1072,10 +1101,9 @@ If CHOP-LENGTH is not specified, message set is not chopped." session (intern (downcase name))) (setq sasl-read-passphrase - (function - (lambda (prompt) - (elmo-get-passwd - (elmo-network-session-password-key session))))) + (lambda (prompt) + (elmo-get-passwd + (elmo-network-session-password-key session)))) (setq tag (elmo-imap4-send-command session @@ -1122,7 +1150,7 @@ If CHOP-LENGTH is not specified, message set is not chopped." (luna-define-method elmo-network-setup-session ((session elmo-imap4-session)) (with-current-buffer (elmo-network-session-buffer session) - (when (memq 'namespace (elmo-imap4-session-capability-internal session)) + (when (elmo-imap4-session-capable-p session 'namespace) (setq elmo-imap4-server-namespace (elmo-imap4-response-value (elmo-imap4-send-command-wait session "namespace") @@ -1212,8 +1240,8 @@ If CHOP-LENGTH is not specified, message set is not chopped." (luna-define-method elmo-server-diff-async ((folder elmo-imap4-folder)) (let ((session (elmo-imap4-get-session folder))) - ;; commit. - ;; (elmo-imap4-commit spec) +;;; ;; 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) @@ -1234,7 +1262,7 @@ If CHOP-LENGTH is not specified, message set is not chopped." (defvar elmo-imap4-client-eol "\r\n" "The EOL string we send to the server.") -(defvar elmo-imap4-display-literal-progress nil) +(defvar elmo-imap4-literal-progress-reporter nil) (defun elmo-imap4-find-next-line () "Return point at end of current line, taking into account literals. @@ -1245,16 +1273,11 @@ Return nil if no complete line has arrived." (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)))) + (when elmo-imap4-literal-progress-reporter + (elmo-progress-notify + 'elmo-retrieve-message + :set (- (point-max) (point)) + :total (string-to-number (match-string 1)))) nil) (goto-char (+ (point) (string-to-number (match-string 1)))) (elmo-imap4-find-next-line)) @@ -1267,7 +1290,6 @@ Return nil if no complete line has arrived." "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) @@ -1278,22 +1300,19 @@ Return nil if no complete line has arrived." (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)))))))) + (case elmo-imap4-status + (initial + (setq elmo-imap4-current-response + (list + (list 'greeting (elmo-imap4-parse-greeting))))) + ((auth nonauth selected 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. @@ -1370,7 +1389,8 @@ Return nil if no complete line has arrived." (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) + (progn (and (eq (char-after (point)) (string-to-char " ")) + (elmo-imap4-forward)) t) (setq address (elmo-imap4-parse-address))) (setq addresses (cons address addresses))) (when (eq (char-after (point)) ?\)) @@ -1395,6 +1415,7 @@ Return nil if no complete line has arrived." (defun elmo-imap4-parse-response () "Parse a IMAP command response." + (elmo-imap4-debug "[%s] -> %s" (time-stamp-hh:mm:ss) (buffer-substring (point) (point-max))) (let (token) (case (setq token (read (current-buffer))) (+ (progn @@ -1415,6 +1436,9 @@ Return nil if no complete line has arrived." (read (concat "(" (buffer-substring (point) (point-max)) ")")))) + (ESEARCH (list + 'esearch + (cddr (split-string (buffer-substring (point) (point-max)) " " "\,")))) (STATUS (elmo-imap4-parse-status)) ;; Added (NAMESPACE (elmo-imap4-parse-namespace)) @@ -1546,7 +1570,7 @@ Return nil if no complete line has arrived." (1- (progn (re-search-forward "[] ]" nil t) (point)))))) - (if (eq (char-before) ? ) + (if (eq (char-before) (string-to-char " ")) (prog1 (mapconcat 'identity (cons section (elmo-imap4-parse-header-list)) " ") @@ -1609,22 +1633,23 @@ Return nil if no complete line has arrived." (setq status (cons (let ((token (read (current-buffer)))) - (cond ((eq token 'MESSAGES) - (list 'messages (read (current-buffer)))) - ((eq token 'RECENT) - (list 'recent (read (current-buffer)))) - ((eq token 'UIDNEXT) - (list 'uidnext (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 (read (current-buffer)))) - (t - (message - "Unknown status data %s in mailbox %s ignored" - token mailbox)))) + (case (intern (upcase (symbol-name token))) + (MESSAGES + (list 'messages (read (current-buffer)))) + (RECENT + (list 'recent (read (current-buffer)))) + (UIDNEXT + (list 'uidnext (read (current-buffer)))) + (UIDVALIDITY + (and (looking-at " \\([0-9]+\\)") + (prog1 (list 'uidvalidity (match-string 1)) + (goto-char (match-end 1))))) + (UNSEEN + (list 'unseen (read (current-buffer)))) + (t + (message + "Unknown status data %s in mailbox %s ignored" + token mailbox)))) status)) (skip-chars-forward " "))) (and elmo-imap4-status-callback @@ -1635,12 +1660,13 @@ Return nil if no complete line has arrived." (defmacro elmo-imap4-value (value) - (` (if (eq (, value) 'NIL) nil - (, value)))) + `(if (eq ,value 'NIL) + nil + ,value)) (defmacro elmo-imap4-nth (pos list) - (` (let ((value (nth (, pos) (, list)))) - (elmo-imap4-value value)))) + `(let ((value (nth ,pos ,list))) + (elmo-imap4-value value))) (defun elmo-imap4-parse-namespace () (list 'namespace @@ -1687,7 +1713,7 @@ Return nil if no complete line has arrived." (defun elmo-imap4-parse-acl () (let ((mailbox (elmo-imap4-parse-mailbox)) identifier rights acl) - (while (eq (char-after (point)) ?\ ) + (while (eq (char-after (point)) (string-to-char " ")) (elmo-imap4-forward) (setq identifier (elmo-imap4-parse-astring)) (elmo-imap4-forward) @@ -1742,7 +1768,7 @@ Return nil if no complete line has arrived." (let (b-e) (elmo-imap4-forward) (push (elmo-imap4-parse-body-extension) b-e) - (while (eq (char-after (point)) ?\ ) + (while (eq (char-after (point)) (string-to-char " ")) (elmo-imap4-forward) (push (elmo-imap4-parse-body-extension) b-e)) (assert (eq (char-after (point)) ?\))) @@ -1753,7 +1779,7 @@ Return nil if no complete line has arrived." (defsubst elmo-imap4-parse-body-ext () (let (ext) - (when (eq (char-after (point)) ?\ );; body-fld-dsp + (when (eq (char-after (point)) (string-to-char " ")) ; body-fld-dsp (elmo-imap4-forward) (let (dsp) (if (eq (char-after (point)) ?\() @@ -1765,12 +1791,12 @@ Return nil if no complete line has arrived." (elmo-imap4-forward)) (assert (elmo-imap4-parse-nil))) (push (nreverse dsp) ext)) - (when (eq (char-after (point)) ?\ );; body-fld-lang + (when (eq (char-after (point)) (string-to-char " ")) ; 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 + (while (eq (char-after (point)) (string-to-char " "));; body-extension (elmo-imap4-forward) (setq ext (append (elmo-imap4-parse-body-extension) ext))))) ext)) @@ -1786,7 +1812,7 @@ Return nil if no complete line has arrived." (push subbody body)) (elmo-imap4-forward) (push (elmo-imap4-parse-string) body);; media-subtype - (when (eq (char-after (point)) ?\ );; body-ext-mpart: + (when (eq (char-after (point)) (string-to-char " ")) ; body-ext-mpart: (elmo-imap4-forward) (if (eq (char-after (point)) ?\();; body-fld-param (push (elmo-imap4-parse-string-list) body) @@ -1802,7 +1828,8 @@ Return nil if no complete line has arrived." (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)) + (and (eq (char-after (point)) (string-to-char " ")) + (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)) @@ -1825,7 +1852,7 @@ Return nil if no complete line has arrived." ;; 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)) ?\ ) + (when (eq (char-after (point)) (string-to-char " ")) (elmo-imap4-forward) (let (lines) (cond ((eq (char-after (point)) ?\();; body-type-msg: @@ -1841,7 +1868,7 @@ Return nil if no complete line has arrived." ;; ...and then parse the third one here... - (when (eq (char-after (point)) ?\ );; body-ext-1part: + (when (eq (char-after (point)) (string-to-char " ")) ; body-ext-1part: (elmo-imap4-forward) (push (elmo-imap4-parse-nstring) body);; body-fld-md5 (setq body @@ -1942,20 +1969,37 @@ Return nil if no complete line has arrived." (elmo-msgdb-killed-list-length killed)) (elmo-imap4-response-value status 'messages))))) +(defun elmo-imap4-folder-list-range (folder min max) + (elmo-imap4-list + folder + (concat + (let ((killed + (elmo-folder-killed-list-internal + folder))) + (if (and killed + (eq (length killed) 1) + (consp (car killed)) + (eq (car (car killed)) 1)) +;; What about elmo-imap4-use-uid? + (format "uid %d:%s" (cdr (car killed)) max) + (format "uid %s:%s" min max))) + " undeleted"))) + (luna-define-method elmo-folder-list-messages-plugged ((folder - elmo-imap4-folder) - &optional - enable-killed) - (elmo-imap4-list folder - (let ((killed - (elmo-folder-killed-list-internal - folder))) - (if (and killed - (eq (length killed) 1) - (consp (car killed)) - (eq (car (car killed)) 1)) - (format "uid %d:*" (cdr (car killed))) - "all")))) + elmo-imap4-folder) + &optional + enable-killed) + + (let* ((old (elmo-msgdb-list-messages (elmo-folder-msgdb folder))) + (new (elmo-imap4-folder-list-range folder + (1+ (or (elmo-folder-get-info-max folder) 0)) "*")) + (united-old-new (elmo-union old new))) + (if (= (length united-old-new) (or (elmo-folder-get-info-length folder) 0)) + united-old-new + (elmo-union new + (elmo-imap4-folder-list-range + folder + 1 (1+ (or (elmo-folder-get-info-max folder) 0))))))) (luna-define-method elmo-folder-list-flagged-plugged ((folder elmo-imap4-folder) flag) @@ -2018,7 +2062,7 @@ Return nil if no complete line has arrived." (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 + (number-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) @@ -2039,13 +2083,13 @@ Return nil if no complete line has arrived." 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 + (setq has-child-p + (when (string-match + (concat "^\\(" (regexp-quote root) "[^" re-delim "]" "+\\)" + re-delim) + folder) + (setq folder (match-string 1 folder)))) + (setq result (delq nil (mapcar (lambda (fld) (if (string-match @@ -2092,8 +2136,9 @@ Return nil if no complete line has arrived." t) (luna-define-method elmo-folder-delete ((folder elmo-imap4-folder)) - (let ((msgs (and (elmo-folder-exists-p folder) - (elmo-folder-list-messages folder)))) + (let* ((exists (elmo-folder-exists-p folder)) + (msgs (and exists + (elmo-folder-list-messages folder)))) (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? " (if (> (length msgs) 0) (format "%d msg(s) exists. " (length msgs)) @@ -2102,7 +2147,9 @@ Return nil if no complete line has arrived." (let ((session (elmo-imap4-get-session folder))) (when (elmo-imap4-folder-mailbox-internal folder) (when msgs (elmo-folder-delete-messages-internal folder msgs)) - (elmo-imap4-send-command-wait session "close") + ;; close selected mailbox except one with \Noselect attribute + (when exists + (elmo-imap4-send-command-wait session "close")) (elmo-imap4-send-command-wait session (list "delete " @@ -2194,18 +2241,24 @@ If optional argument REMOVE is non-nil, remove FLAG." (luna-define-method elmo-folder-delete-messages-plugged ((folder elmo-imap4-folder) numbers) - (let ((session (elmo-imap4-get-session folder))) + (let ((session (elmo-imap4-get-session folder)) + (expunge + (or (null (elmo-imap4-list folder "deleted")) + (y-or-n-p + "There's hidden deleted messages, expunge anyway?")))) (elmo-imap4-session-select-mailbox session (elmo-imap4-folder-mailbox-internal folder)) (unless (elmo-imap4-set-flag folder numbers "\\Deleted") (error "Failed to set deleted flag")) - (elmo-imap4-send-command session "expunge"))) + (when expunge + (elmo-imap4-send-command session "expunge")) + t)) -(defmacro elmo-imap4-detect-search-charset (string) - (` (with-temp-buffer - (insert (, string)) - (detect-mime-charset-region (point-min) (point-max))))) +(defun 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)) @@ -2214,19 +2267,18 @@ If optional argument REMOVE is non-nil, remove FLAG." (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))) + (string-to-number (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) ) + (rest (nthcdr (string-to-number (elmo-filter-value filter) ) numbers))) - (mapcar '(lambda (x) (delete x numbers)) rest) + (mapc (lambda (x) (delete x numbers)) rest) numbers)) ((string= "flag" search-key) (elmo-imap4-folder-list-flagged @@ -2263,11 +2315,6 @@ If optional argument REMOVE is non-nil, remove FLAG." (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) @@ -2315,11 +2362,6 @@ If optional argument REMOVE is non-nil, remove FLAG." (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)))) @@ -2350,11 +2392,15 @@ If optional argument REMOVE is non-nil, remove FLAG." condition &optional numbers) (if (elmo-folder-plugged-p folder) (save-excursion - (let ((session (elmo-imap4-get-session folder))) + (let ((session (elmo-imap4-get-session folder)) + ret) + (message "Searching...") (elmo-imap4-session-select-mailbox session (elmo-imap4-folder-mailbox-internal folder)) - (elmo-imap4-search-internal folder session condition numbers))) + (setq ret (elmo-imap4-search-internal folder session condition numbers)) + (message "Searching...done") + ret)) (luna-call-next-method))) (luna-define-method elmo-folder-msgdb-create-plugged @@ -2368,53 +2414,45 @@ If optional argument REMOVE is non-nil, remove FLAG." "Message-Id" "References" "In-Reply-To") (mapcar #'capitalize (elmo-msgdb-extra-fields 'non-virtual))))) (total 0) - (length (length numbers)) print-length print-depth rfc2060 set-list) - (setq rfc2060 (memq 'imap4rev1 - (elmo-imap4-session-capability-internal - session))) - (message "Getting overview...") - (elmo-imap4-session-select-mailbox - session (elmo-imap4-folder-mailbox-internal folder)) - (setq set-list (elmo-imap4-make-number-set-list - numbers - elmo-imap4-overview-fetch-chop-length)) - ;; Setup callback. - (with-current-buffer (elmo-network-session-buffer session) - (setq elmo-imap4-current-msgdb (elmo-make-msgdb) - elmo-imap4-seen-messages nil - elmo-imap4-fetch-callback 'elmo-imap4-fetch-callback-1 - elmo-imap4-fetch-callback-data (cons flag-table folder)) - (while set-list - (elmo-imap4-send-command-wait - session - ;; get overview entity from IMAP4 - (format "%sfetch %s (%s rfc822.size flags)" - (if elmo-imap4-use-uid "uid " "") - (cdr (car set-list)) - (if rfc2060 - (format "body.peek[header.fields %s]" headers) - (format "%s" headers)))) - (when (> length elmo-display-progress-threshold) - (setq total (+ total (car (car set-list)))) - (elmo-display-progress - 'elmo-imap4-msgdb-create "Getting overview..." - (/ (* total 100) length))) - (setq set-list (cdr set-list))) - (message "Getting overview...done") - (when elmo-imap4-seen-messages - (elmo-imap4-set-flag folder elmo-imap4-seen-messages "\\Seen")) - ;; cannot setup the global flag while retrieval. - (dolist (number (elmo-msgdb-list-messages elmo-imap4-current-msgdb)) - (elmo-global-flags-set (elmo-msgdb-flags elmo-imap4-current-msgdb - number) - folder number - (elmo-message-entity-field - (elmo-msgdb-message-entity - elmo-imap4-current-msgdb number) - 'message-id))) - elmo-imap4-current-msgdb)))) + (setq rfc2060 (elmo-imap4-session-capable-p session 'imap4rev1)) + (elmo-with-progress-display (elmo-folder-msgdb-create (length numbers)) + "Creating msgdb" + (elmo-imap4-session-select-mailbox + session (elmo-imap4-folder-mailbox-internal folder)) + (setq set-list (elmo-imap4-make-number-set-list + numbers + elmo-imap4-overview-fetch-chop-length)) + ;; Setup callback. + (with-current-buffer (elmo-network-session-buffer session) + (setq elmo-imap4-current-msgdb (elmo-make-msgdb) + elmo-imap4-seen-messages nil + elmo-imap4-fetch-callback 'elmo-imap4-fetch-callback-1 + elmo-imap4-fetch-callback-data (cons flag-table folder)) + (while set-list + (elmo-imap4-send-command-wait + session + ;; get overview entity from IMAP4 + (format "%sfetch %s (%s rfc822.size flags)" + (if elmo-imap4-use-uid "uid " "") + (cdr (car set-list)) + (if rfc2060 + (format "body.peek[header.fields %s]" headers) + (format "%s" headers)))) + (setq set-list (cdr set-list))) + (when elmo-imap4-seen-messages + (elmo-imap4-set-flag folder elmo-imap4-seen-messages "\\Seen")) + ;; cannot setup the global flag while retrieval. + (dolist (number (elmo-msgdb-list-messages elmo-imap4-current-msgdb)) + (elmo-global-flags-set (elmo-msgdb-flags elmo-imap4-current-msgdb + number) + folder number + (elmo-message-entity-field + (elmo-msgdb-message-entity + elmo-imap4-current-msgdb number) + 'message-id))) + elmo-imap4-current-msgdb))))) (luna-define-method elmo-folder-set-flag-plugged ((folder elmo-imap4-folder) numbers flag) @@ -2456,7 +2494,7 @@ If optional argument REMOVE is non-nil, remove FLAG." (defsubst elmo-imap4-folder-diff-plugged (folder) (let ((session (elmo-imap4-get-session folder)) messages new unread response killed uidnext) -;;; (elmo-imap4-commit spec) +;;; (elmo-imap4-commit spec) (with-current-buffer (elmo-network-session-buffer session) (setq elmo-imap4-status-callback nil) (setq elmo-imap4-status-callback-data nil)) @@ -2521,6 +2559,9 @@ If optional argument REMOVE is non-nil, remove FLAG." (setq response (elmo-imap4-read-response session tag)))) (progn + (let ((exists (assq 'exists response))) ; update message count, + (when exists ; so merge update can go + (elmo-folder-set-info-hashtb folder nil (cadr exists)))) (elmo-imap4-session-set-current-mailbox-internal session mailbox) (elmo-imap4-session-set-read-only-internal @@ -2647,12 +2688,12 @@ If optional argument REMOVE is non-nil, remove FLAG." (eval-when-compile (defmacro elmo-imap4-identical-system-p (folder1 folder2) "Return t if FOLDER1 and FOLDER2 are in the same IMAP4 system." - (` (and (string= (elmo-net-folder-server-internal (, folder1)) - (elmo-net-folder-server-internal (, folder2))) - (eq (elmo-net-folder-port-internal (, folder1)) - (elmo-net-folder-port-internal (, folder2))) - (string= (elmo-net-folder-user-internal (, folder1)) - (elmo-net-folder-user-internal (, folder2))))))) + `(and (string= (elmo-net-folder-server-internal ,folder1) + (elmo-net-folder-server-internal ,folder2)) + (eq (elmo-net-folder-port-internal ,folder1) + (elmo-net-folder-port-internal ,folder2)) + (string= (elmo-net-folder-user-internal ,folder1) + (elmo-net-folder-user-internal ,folder2))))) (luna-define-method elmo-folder-next-message-number-plugged ((folder elmo-imap4-folder)) @@ -2676,16 +2717,18 @@ If optional argument REMOVE is non-nil, remove FLAG." response (elmo-imap4-response-value response 'status)) (elmo-imap4-response-value response 'uidnext))) -(luna-define-method elmo-folder-append-messages :around - ((folder elmo-imap4-folder) src-folder numbers &optional same-number) - (if (and (eq (elmo-folder-type-internal src-folder) 'imap4) - (elmo-imap4-identical-system-p folder src-folder) - (elmo-folder-plugged-p folder)) +(defun elmo-folder-append-messages-imap4-imap4 (dst-folder + src-folder + numbers + same-number) + (if (and (elmo-imap4-identical-system-p dst-folder src-folder) + (elmo-folder-plugged-p dst-folder)) ;; Plugged (prog1 - (elmo-imap4-copy-messages src-folder folder numbers) + (elmo-imap4-copy-messages src-folder dst-folder numbers) (elmo-progress-notify 'elmo-folder-move-messages (length numbers))) - (luna-call-next-method))) + (elmo-folder-append-messages dst-folder src-folder numbers same-number + 'elmo-folder-append-messages-imap4-imap4))) (luna-define-method elmo-message-deletable-p ((folder elmo-imap4-folder) number) @@ -2694,12 +2737,12 @@ If optional argument REMOVE is non-nil, remove FLAG." (elmo-imap4-get-session folder))) elmo-enable-disconnected-operation)) ; offline refile. -;(luna-define-method elmo-message-fetch-unplugged -; ((folder elmo-imap4-folder) -; number strategy &optional section outbuf unseen) -; (error "%d%s is not cached." number (if section -; (format "(%s)" section) -; ""))) +;;;(luna-define-method elmo-message-fetch-unplugged +;;; ((folder elmo-imap4-folder) +;;; number strategy &optional section outbuf unseen) +;;; (error "%d%s is not cached." number (if section +;;; (format "(%s)" section) +;;; ""))) (defsubst elmo-imap4-message-fetch (folder number strategy section outbuf unseen) @@ -2711,24 +2754,19 @@ If optional argument REMOVE is non-nil, remove FLAG." (with-current-buffer (elmo-network-session-buffer session) (setq elmo-imap4-fetch-callback nil) (setq elmo-imap4-fetch-callback-data nil)) - (unless elmo-inhibit-display-retrieval-progress - (setq elmo-imap4-display-literal-progress t)) - (unwind-protect - (setq response - (elmo-imap4-send-command-wait session - (format - (if elmo-imap4-use-uid - "uid fetch %s body%s[%s]" - "fetch %s body%s[%s]") - number - (if unseen ".peek" "") - (or section "") - ))) - (setq elmo-imap4-display-literal-progress nil)) - (unless elmo-inhibit-display-retrieval-progress - (elmo-display-progress 'elmo-imap4-display-literal-progress - "Retrieving..." 100) ; remove progress bar. - (message "Retrieving...done")) + (elmo-with-progress-display (elmo-retrieve-message + (elmo-message-field folder number :size) + elmo-imap4-literal-progress-reporter) + "Retrieving" + (setq response + (elmo-imap4-send-command-wait session + (format + (if elmo-imap4-use-uid + "uid fetch %s body%s[%s]" + "fetch %s body%s[%s]") + number + (if unseen ".peek" "") + (or section ""))))) (if (setq response (elmo-imap4-response-bodydetail-text (elmo-imap4-response-value-all response 'fetch)))