X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=elmo%2Felmo-imap4.el;h=0cc8e37afc0c25582f30c1289840b0872d68d8b5;hb=e1aca9586e3b40cb9e143e8009f97bc786325f7a;hp=378a572e7f392633338104b14b28f3a64c55d5de;hpb=e68565651b2b6fc9539a95da15382145088353a5;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-imap4.el b/elmo/elmo-imap4.el index 378a572..0cc8e37 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) @@ -48,12 +49,10 @@ (require 'utf7) (require 'elmo-mime) -;;; Code: (eval-when-compile (require 'cl)) (defvar elmo-imap4-disuse-server-flag-mailbox-regexp "^#mh" ; UW imapd - "Regexp to match IMAP4 mailbox names whose message flags on server should be ignored. -\(Except `\\Deleted' flag\).") + "Regexp to match IMAP4 mailbox names whose message flags on server should be ignored (For STATUS command).") (defvar elmo-imap4-overview-fetch-chop-length 200 "*Number of overviews to fetch in one request.") @@ -165,6 +164,21 @@ REGEXP should have a grouping for namespace prefix.") (defconst elmo-imap4-literal-threshold 1024 "Limitation of characters that can be used in a quoted string.") +(defconst elmo-imap4-flag-specs '((important "\\Flagged") + (read "\\Seen") + (unread "\\Seen" 'remove) + (answered "\\Answered") + ;; draft-melnikov-imap-keywords-03.txt + (forwarded "$Forwarded") + (work "$Work") + (personal "$Personal") + (shouldreply "$ShouldReply"))) + +(defconst elmo-imap4-folder-name-syntax + `(mailbox + (?: [user "^[A-Za-z]"] (?/ [auth ".+"])) + ,@elmo-net-folder-name-syntax)) + ;; For debugging. (defvar elmo-imap4-debug nil "Non-nil forces IMAP4 folder as debug mode. @@ -181,9 +195,12 @@ Debug information is inserted in the buffer \"*IMAP4 DEBUG*\"") ;;; Session (eval-and-compile (luna-define-class elmo-imap4-session (elmo-network-session) - (capability current-mailbox read-only)) + (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 @@ -193,8 +210,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*") @@ -205,35 +222,35 @@ Debug information is inserted in the buffer \"*IMAP4 DEBUG*\"") (defsubst elmo-imap4-decode-folder-string (string) (if elmo-imap4-use-modified-utf7 - (utf7-decode-string string 'imap) + (utf7-decode string 'imap) string)) (defsubst elmo-imap4-encode-folder-string (string) (if elmo-imap4-use-modified-utf7 - (utf7-encode-string string 'imap) + (utf7-encode string 'imap) string)) ;;; Response (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." @@ -246,13 +263,13 @@ 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. @@ -291,8 +308,11 @@ Returns a TAG string which is assigned to the COMMAND." (when (elmo-imap4-response-bye-p elmo-imap4-current-response) (elmo-imap4-process-bye session)) (setq elmo-imap4-current-response nil) - (if elmo-imap4-parsing - (error "IMAP process is running. Please wait (or plug again)")) + (when elmo-imap4-parsing + (message "Waiting for IMAP response...") + (accept-process-output (elmo-network-session-process-internal + 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)) @@ -307,12 +327,20 @@ Returns a TAG string which is assigned to the COMMAND." cmdstr (elmo-imap4-format-quoted (nth 1 token))))) ((eq kind 'literal) - (setq cmdstr (concat cmdstr - (format "{%d}" (nth 2 token)))) - (process-send-string process cmdstr) - (process-send-string process "\r\n") - (setq cmdstr nil) - (elmo-imap4-accept-continue-req session) + (if (elmo-imap4-session-capable-p session 'literal+) + ;; rfc2088 + (progn + (setq cmdstr (concat cmdstr + (format "{%d+}" (nth 2 token)) + "\r\n")) + (process-send-string process cmdstr) + (setq cmdstr nil)) + (setq cmdstr (concat cmdstr + (format "{%d}" (nth 2 token)) + "\r\n")) + (process-send-string process cmdstr) + (setq cmdstr nil) + (elmo-imap4-accept-continue-req session)) (cond ((stringp (nth 1 token)) (setq cmdstr (nth 1 token))) ((bufferp (nth 1 token)) @@ -328,9 +356,7 @@ 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") + (process-send-string process (concat cmdstr "\r\n")) tag))) (defun elmo-imap4-send-string (session string) @@ -354,7 +380,7 @@ TAG is the tag of the command" (elmo-imap4-response-bye-p elmo-imap4-current-response) (when (elmo-imap4-response-garbage-p elmo-imap4-current-response) - (message "Garbage response: %s" + (message "Garbage response: %s" (elmo-imap4-response-value elmo-imap4-current-response 'garbage)) @@ -436,21 +462,20 @@ If response is not `OK' response, causes error with IMAP response text." (mime-elmo-imap-location-folder-internal location) (mime-elmo-imap-location-number-internal location) (mime-elmo-imap-location-strategy-internal location) - section - (current-buffer) - 'unseen) + 'unseen + section) (buffer-string)) - (elmo-message-fetch + (elmo-message-fetch-string (mime-elmo-imap-location-folder-internal location) (mime-elmo-imap-location-number-internal location) (mime-elmo-imap-location-strategy-internal location) - section - nil 'unseen))) + 'unseen + section))) (luna-define-method mime-imap-location-bodystructure ((location mime-elmo-imap-location)) - (elmo-imap4-fetch-bodystructure + (elmo-message-fetch-bodystructure (mime-elmo-imap-location-folder-internal location) (mime-elmo-imap-location-number-internal location) (mime-elmo-imap-location-strategy-internal location))) @@ -474,7 +499,7 @@ If response is not `OK' response, causes error with IMAP response text." (with-current-buffer (elmo-network-session-buffer session) (setq elmo-imap4-fetch-callback nil) (setq elmo-imap4-fetch-callback-data nil)) - (elmo-imap4-send-command-wait session "check")) + (elmo-imap4-send-command session "check")) (defun elmo-imap4-atom-p (string) "Return t if STRING is an atom defined in rfc2060." @@ -607,12 +632,13 @@ BUFFER must be a single-byte buffer." (mapcar (lambda (entry) (if (and (eq 'list (car entry)) - (not (member "\\NoSelect" (nth 1 (nth 1 entry))))) + (not (elmo-string-member-ignore-case "\\Noselect" (nth 1 (nth 1 entry))))) (car (nth 1 entry)))) response))) -(defun elmo-imap4-fetch-bodystructure (folder number strategy) - "Fetch BODYSTRUCTURE for the message in the FOLDER with NUMBER using STRATEGY." +(luna-define-method elmo-message-fetch-bodystructure ((folder + elmo-imap4-folder) + number strategy) (if (elmo-fetch-strategy-use-cache strategy) (elmo-object-load (elmo-file-cache-expand-path @@ -690,15 +716,19 @@ Returns response value if selecting folder succeed. " (elmo-imap4-session-set-current-mailbox-internal session mailbox) (elmo-imap4-session-set-read-only-internal session - (nth 1 (assq 'read-only (assq 'ok response))))) + (nth 1 (assq 'read-only (assq 'ok response)))) + (elmo-imap4-session-set-flags-internal + session + (nth 1 (or (assq 'permanentflags response) + (assq 'flags response))))) (elmo-imap4-session-set-current-mailbox-internal session nil) (if (and (eq no-error 'notify-bye) (elmo-imap4-response-bye-p response)) (elmo-imap4-process-bye session) (unless no-error - (error (or - (elmo-imap4-response-error-text response) - (format "Select %s failed" mailbox))))))) + (error "%s" + (or (elmo-imap4-response-error-text response) + (format "Select %s failed" mailbox))))))) (and result response)))) (defun elmo-imap4-check-validity (spec validity-file) @@ -727,6 +757,83 @@ Returns response value if selecting folder succeed. " "search %s") flag)) 'search))) +(defun elmo-imap4-session-flag-available-p (session flag) + (case flag + ((read unread) (elmo-string-member-ignore-case + "\\seen" (elmo-imap4-session-flags-internal session))) + (important + (elmo-string-member-ignore-case + "\\flagged" (elmo-imap4-session-flags-internal session))) + (digest + (or (elmo-string-member-ignore-case + "\\seen" (elmo-imap4-session-flags-internal session)) + (elmo-string-member-ignore-case + "\\flagged" (elmo-imap4-session-flags-internal session)))) + (answered + (elmo-string-member-ignore-case + (concat "\\" (symbol-name flag)) + (elmo-imap4-session-flags-internal session))) + (t + (member "\\*" (elmo-imap4-session-flags-internal session))))) + +(defun elmo-imap4-flag-to-imap-search-key (flag) + (case flag + (read "seen") + (unread "unseen") + (important "flagged") + (answered "answered") + (new "new") + (t (concat + "keyword " + (or (car (cdr (assq flag elmo-imap4-flag-specs))) + (symbol-name flag)))))) + +(defun elmo-imap4-flag-to-imap-criteria (flag) + (case flag + ((any digest) + (let ((criteria "flagged") + (global-flags (delq 'important (elmo-get-global-flags t t)))) + (dolist (flag (delete 'new + (delete 'cached + (copy-sequence + (case flag + (any + elmo-preserved-flags) + (digest + elmo-digest-flags)))))) + (setq criteria (concat "or " + (elmo-imap4-flag-to-imap-search-key flag) + " " + criteria))) + (while global-flags + (setq criteria (concat "or keyword " + (symbol-name (car global-flags)) + " " + criteria)) + (setq global-flags (cdr global-flags))) + criteria)) + (t + (elmo-imap4-flag-to-imap-search-key flag)))) + +(defun elmo-imap4-folder-list-flagged (folder flag) + "List flagged message numbers in the FOLDER. +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)) + ;; List flagged messages in the msgdb. + (elmo-msgdb-list-flagged (elmo-folder-msgdb folder) flag)))) + (defvar elmo-imap4-rfc822-size "RFC822\.SIZE") (defvar elmo-imap4-rfc822-text "RFC822\.TEXT") (defvar elmo-imap4-rfc822-header "RFC822\.HEADER") @@ -770,63 +877,57 @@ If CHOP-LENGTH is not specified, message set is not chopped." ;; ;; app-data: -;; cons of list -;; 0: new-mark 1: already-mark 2: seen-mark 3: important-mark -;; 4: seen-list -;; and result of use-flag-p. +;; cons of flag-table and folder structure (defsubst elmo-imap4-fetch-callback-1-subr (entity flags app-data) "A msgdb entity callback function." - (let* ((use-flag (cdr app-data)) - (app-data (car app-data)) - (seen (member (car entity) (nth 4 app-data))) - mark) - (if (member "\\Flagged" flags) - (elmo-msgdb-global-mark-set (car entity) (nth 3 app-data))) - (if (setq mark (elmo-msgdb-global-mark-get (car entity))) - (unless (member "\\Seen" flags) - (setq elmo-imap4-seen-messages - (cons - (elmo-msgdb-overview-entity-get-number entity) - elmo-imap4-seen-messages))) - (setq mark (or (if (elmo-file-cache-status - (elmo-file-cache-get (car entity))) - (if (or seen - (and use-flag - (member "\\Seen" flags))) - nil - (nth 1 app-data)) - (if (or seen - (and use-flag - (member "\\Seen" flags))) - (if elmo-imap4-use-cache - (nth 2 app-data)) - (nth 0 app-data)))))) - (setq elmo-imap4-current-msgdb - (elmo-msgdb-append - elmo-imap4-current-msgdb - (list (list entity) - (list (cons (elmo-msgdb-overview-entity-get-number entity) - (car entity))) - (if mark - (list - (list (elmo-msgdb-overview-entity-get-number entity) - mark)))))))) + (let ((use-flag (elmo-folder-use-flag-p (cdr app-data))) + (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)) + (setq saved-flags (elmo-flag-table-get flag-table msg-id) + flag-list + (if use-flag + (append + (and (memq 'new saved-flags) + (not (elmo-string-member-ignore-case "\\Seen" flags)) + '(new)) + (and (elmo-string-member-ignore-case "\\Flagged" flags) + '(important)) + (and (not (elmo-string-member-ignore-case "\\Seen" flags)) + '(unread)) + (and (elmo-string-member-ignore-case "\\Answered" flags) + '(answered)) + (and (elmo-file-cache-exists-p msg-id) + '(cached))) + saved-flags)) + (when (and (or (memq 'important flag-list) + (memq 'answered flag-list)) + (memq 'unread flag-list)) + (setq elmo-imap4-seen-messages + (cons (elmo-message-entity-number entity) + elmo-imap4-seen-messages))) + (elmo-msgdb-append-entity elmo-imap4-current-msgdb + entity + flag-list))) ;; Current buffer is process buffer. (defun elmo-imap4-fetch-callback-1 (element app-data) - (elmo-imap4-fetch-callback-1-subr - (with-temp-buffer - (insert (or (elmo-imap4-response-bodydetail-text element) - "")) - ;; Delete CR. - (goto-char (point-min)) - (while (search-forward "\r\n" nil t) - (replace-match "\n")) - (elmo-msgdb-create-overview-from-buffer - (elmo-imap4-response-value element 'uid) - (elmo-imap4-response-value element 'rfc822size))) - (elmo-imap4-response-value element 'flags) - app-data)) + (let ((handler (elmo-msgdb-message-entity-handler elmo-imap4-current-msgdb))) + (elmo-imap4-fetch-callback-1-subr + (with-temp-buffer + (insert (or (elmo-imap4-response-bodydetail-text element) + "")) + ;; Replace all CRLF with LF. + (elmo-delete-cr-buffer) + (elmo-msgdb-create-message-entity-from-buffer + handler + (elmo-imap4-response-value element 'uid) + :size (elmo-imap4-response-value element 'rfc822size))) + (elmo-imap4-response-value element 'flags) + app-data) + (elmo-progress-notify 'elmo-folder-msgdb-create))) (defun elmo-imap4-parse-capability (string) (if (string-match "^\\*\\(.*\\)$" string) @@ -834,6 +935,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 @@ -880,9 +983,10 @@ 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)) @@ -901,8 +1005,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") @@ -1020,7 +1123,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") @@ -1033,7 +1136,7 @@ If CHOP-LENGTH is not specified, message set is not chopped." (save-match-data (set-buffer send-buf) (erase-buffer) - (elmo-set-buffer-multibyte nil) + (set-buffer-multibyte nil) (if string (insert string) (with-current-buffer source-buf @@ -1132,7 +1235,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. @@ -1143,16 +1246,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)) @@ -1176,22 +1274,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. @@ -1507,22 +1602,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 @@ -1533,12 +1629,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 @@ -1749,9 +1846,7 @@ Return nil if no complete line has arrived." (elmo-imap4-forward) (nreverse body))))) -(luna-define-method elmo-folder-initialize :around ((folder - elmo-imap4-folder) - name) +(luna-define-method elmo-folder-initialize ((folder elmo-imap4-folder) name) (let ((default-user elmo-imap4-default-user) (default-server elmo-imap4-default-server) (default-port elmo-imap4-default-port) @@ -1760,39 +1855,38 @@ Return nil if no complete line has arrived." (append elmo-imap4-stream-type-alist elmo-network-stream-type-alist) elmo-network-stream-type-alist)) - parse) + tokens) (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)) + (setq tokens (car (elmo-parse-separated-tokens + name + elmo-imap4-folder-name-syntax))) ;; mailbox - (setq parse (elmo-parse-token name ":")) (elmo-imap4-folder-set-mailbox-internal folder (elmo-imap4-encode-folder-string - (car parse))) + (cdr (assq 'mailbox tokens)))) ;; 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))) + (or (cdr (assq 'user tokens)) + default-user)) ;; 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))) + (let ((auth (cdr (assq 'auth tokens)))) + (or (and auth (intern auth)) + elmo-imap4-default-authenticate-type + 'clear))) + ;; network + (elmo-net-folder-set-parameters + folder + tokens + (list :server default-server + :port default-port + :stream-type + (elmo-get-network-stream-type elmo-imap4-default-stream-type))) folder)) ;;; ELMO IMAP4 folder @@ -1804,15 +1898,16 @@ Return nil if no complete line has arrived." (setq mailbox "inbox")) (if (eq (string-to-char mailbox) ?/) (setq mailbox (substring mailbox 1 (length mailbox)))) - (expand-file-name - mailbox + ;; don't use expand-file-name (e.g. %~/something) + (concat (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))))))) + elmo-msgdb-directory))) + "/" mailbox)))) (luna-define-method elmo-folder-status-plugged ((folder elmo-imap4-folder)) @@ -1844,22 +1939,24 @@ Return nil if no complete line has arrived." (luna-define-method elmo-folder-list-messages-plugged ((folder elmo-imap4-folder) - &optional nohide) + &optional + enable-killed) (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")) + (concat + (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")) + " undeleted"))) + +(luna-define-method elmo-folder-list-flagged-plugged + ((folder elmo-imap4-folder) flag) + (elmo-imap4-folder-list-flagged folder flag)) (luna-define-method elmo-folder-use-flag-p ((folder elmo-imap4-folder)) (not (string-match elmo-imap4-disuse-server-flag-mailbox-regexp @@ -1878,6 +1975,7 @@ Return nil if no complete line has arrived." (delim (or (cdr namespace-assoc) elmo-imap4-default-hierarchy-delimiter)) ;; Append delimiter when root with namespace. + (root-nodelim root) (root (if (and namespace-assoc (match-end 1) (string= (substring root (match-end 1)) @@ -1889,11 +1987,23 @@ Return nil if no complete line has arrived." (elmo-imap4-send-command-wait session (list "list " (elmo-imap4-mailbox root) " *")))) + ;; The response of Courier-imap doesn't contain a specified folder itself. + (unless (member root result) + (setq result + (append result + (elmo-imap4-response-get-selectable-mailbox-list + (elmo-imap4-send-command-wait + session + (list "list \"\" " (elmo-imap4-mailbox + root-nodelim))))))) (when (or (not (string= (elmo-net-folder-user-internal folder) elmo-imap4-default-user)) (not (eq (elmo-net-folder-auth-internal folder) (or elmo-imap4-default-authenticate-type 'clear)))) - (setq append-serv (concat ":" (elmo-net-folder-user-internal folder)))) + (setq append-serv (concat ":" + (elmo-quote-syntactical-element + (elmo-net-folder-user-internal folder) + 'user elmo-imap4-folder-name-syntax)))) (unless (eq (elmo-net-folder-auth-internal folder) (or elmo-imap4-default-authenticate-type 'clear)) (setq append-serv @@ -1926,13 +2036,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 @@ -1943,7 +2053,9 @@ Return nil if no complete line has arrived." fld)) (cdr result))) folder (concat prefix - (elmo-imap4-decode-folder-string folder) + (elmo-quote-syntactical-element + (elmo-imap4-decode-folder-string folder) + 'mailbox elmo-imap4-folder-name-syntax) (and append-serv (eval append-serv))) ret (append ret (if has-child-p @@ -1951,7 +2063,10 @@ Return nil if no complete line has arrived." (list folder))))) ret) (mapcar (lambda (fld) - (concat prefix (elmo-imap4-decode-folder-string fld) + (concat prefix + (elmo-quote-syntactical-element + (elmo-imap4-decode-folder-string fld) + 'mailbox elmo-imap4-folder-name-syntax) (and append-serv (eval append-serv)))) result)))) @@ -1973,18 +2088,29 @@ Return nil if no complete line has arrived." (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-delete ((folder elmo-imap4-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)) + "") + (elmo-folder-name-internal folder))) + (let ((session (elmo-imap4-get-session folder))) + (when (elmo-imap4-folder-mailbox-internal folder) + (when msgs (elmo-folder-delete-messages-internal folder msgs)) + ;; 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 " + (elmo-imap4-mailbox + (elmo-imap4-folder-mailbox-internal folder))))) + (elmo-imap4-session-set-current-mailbox-internal session nil)) + (elmo-msgdb-delete-path folder) + t))) (luna-define-method elmo-folder-rename-internal ((folder elmo-imap4-folder) new-folder) @@ -2040,59 +2166,76 @@ If optional argument REMOVE is non-nil, remove FLAG." (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)))) + (when (or (elmo-string-member-ignore-case + flag + (elmo-imap4-session-flags-internal session)) + (member "\\*" (elmo-imap4-session-flags-internal session)) + (string= flag "\\Deleted")) ; XXX Humm.. + (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"))) + (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")) + (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))))) + `(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" - "larger" "smaller")) + "larger" "smaller" "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) numbers)) + ((string= "flag" search-key) + (elmo-imap4-folder-list-flagged + folder (intern (elmo-filter-value filter)))) ((or (string= "since" search-key) (string= "before" search-key)) (setq search-key (concat "sent" search-key) @@ -2125,11 +2268,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) @@ -2177,11 +2315,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)))) @@ -2212,78 +2345,81 @@ 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 - ((folder elmo-imap4-folder) numbers &rest args) + ((folder elmo-imap4-folder) numbers flag-table) (when numbers (let ((session (elmo-imap4-get-session folder)) (headers - (append - '("Subject" "From" "To" "Cc" "Date" - "Message-Id" "References" "In-Reply-To") - elmo-msgdb-extra-fields)) + (elmo-uniq-list + (append + '("Subject" "From" "To" "Cc" "Date" + "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 nil - elmo-imap4-seen-messages nil - elmo-imap4-fetch-callback 'elmo-imap4-fetch-callback-1 - elmo-imap4-fetch-callback-data (cons args - (elmo-folder-use-flag-p - 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")) - elmo-imap4-current-msgdb)))) - -(luna-define-method elmo-folder-unmark-important-plugged - ((folder elmo-imap4-folder) numbers) - (elmo-imap4-set-flag folder numbers "\\Flagged" 'remove)) - -(luna-define-method elmo-folder-mark-as-important-plugged - ((folder elmo-imap4-folder) numbers) - (elmo-imap4-set-flag folder numbers "\\Flagged")) - -(luna-define-method elmo-folder-unmark-read-plugged - ((folder elmo-imap4-folder) numbers) - (elmo-imap4-set-flag folder numbers "\\Seen" 'remove)) - -(luna-define-method elmo-folder-mark-as-read-plugged - ((folder elmo-imap4-folder) numbers) - (elmo-imap4-set-flag folder numbers "\\Seen")) + (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) + (let ((spec (cdr (assq flag elmo-imap4-flag-specs)))) + (elmo-imap4-set-flag folder numbers (or (car spec) + (capitalize (symbol-name flag))) + (nth 1 spec)))) + +(luna-define-method elmo-folder-unset-flag-plugged ((folder elmo-imap4-folder) + numbers flag) + (let ((spec (cdr (assq flag elmo-imap4-flag-specs)))) + (elmo-imap4-set-flag folder numbers (or (car spec) + (capitalize (symbol-name flag))) + (not (nth 1 spec))))) (luna-define-method elmo-message-use-cache-p ((folder elmo-imap4-folder) number) @@ -2310,11 +2446,15 @@ 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) + messages new unread response killed uidnext) ;;; (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)) + (if elmo-imap4-use-select-to-update-status + (elmo-imap4-session-select-mailbox + session + (elmo-imap4-folder-mailbox-internal folder))) (setq response (elmo-imap4-send-command-wait session (list @@ -2322,14 +2462,18 @@ If optional argument REMOVE is non-nil, remove FLAG." (elmo-imap4-mailbox (elmo-imap4-folder-mailbox-internal folder)) - " (recent unseen messages)"))) + " (recent unseen messages uidnext)"))) (setq response (elmo-imap4-response-value response 'status)) (setq messages (elmo-imap4-response-value response 'messages)) + (setq uidnext (elmo-imap4-response-value response 'uidnext)) (setq killed (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder))) - (if killed - (setq messages (- messages - (elmo-msgdb-killed-list-length - killed)))) + ;; + (when killed + (when (and (consp (car killed)) + (eq (car (car killed)) 1)) + (setq messages (- uidnext (cdr (car killed)) 1))) + (setq messages (- messages + (elmo-msgdb-killed-list-length (cdr killed))))) (setq new (elmo-imap4-response-value response 'recent) unread (elmo-imap4-response-value response 'unseen)) (if (< unread new) (setq new unread)) @@ -2338,8 +2482,7 @@ If optional argument REMOVE is non-nil, remove FLAG." (luna-define-method elmo-folder-diff-plugged ((folder elmo-imap4-folder)) (elmo-imap4-folder-diff-plugged folder)) -(luna-define-method elmo-folder-diff-async ((folder elmo-imap4-folder) - &optional number-alist) +(luna-define-method elmo-folder-diff-async ((folder elmo-imap4-folder)) (setq elmo-imap4-server-diff-async-callback elmo-folder-diff-async-callback) (setq elmo-imap4-server-diff-async-callback-data @@ -2361,7 +2504,7 @@ If optional argument REMOVE is non-nil, remove FLAG." (message "Selecting %s..." (elmo-folder-name-internal folder)) (if load-msgdb - (setq msgdb (elmo-msgdb-load folder 'silent))) + (setq msgdb (elmo-folder-msgdb-load folder 'silent))) (elmo-folder-set-killed-list-internal folder (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder))) @@ -2373,13 +2516,17 @@ If optional argument REMOVE is non-nil, remove FLAG." session mailbox) (elmo-imap4-session-set-read-only-internal session - (nth 1 (assq 'read-only (assq 'ok response))))) + (nth 1 (assq 'read-only (assq 'ok response)))) + (elmo-imap4-session-set-flags-internal + session + (nth 1 (or (assq 'permanentflags response) + (assq 'flags response))))) (elmo-imap4-session-set-current-mailbox-internal session nil) (if (elmo-imap4-response-bye-p response) (elmo-imap4-process-bye session) - (error (or - (elmo-imap4-response-error-text response) - (format "Select %s failed" mailbox))))) + (error "%s" + (or (elmo-imap4-response-error-text response) + (format "Select %s failed" mailbox))))) (message "Selecting %s...done" (elmo-folder-name-internal folder)) (elmo-folder-set-msgdb-internal @@ -2402,52 +2549,41 @@ If optional argument REMOVE is non-nil, remove FLAG." ;; elmo-folder-open-internal: do nothing. -(luna-define-method elmo-find-fetch-strategy - ((folder elmo-imap4-folder) entity &optional ignore-cache) - (let ((number (elmo-msgdb-overview-entity-get-number entity)) - cache-file size message-id) - (setq size (elmo-msgdb-overview-entity-get-size entity)) - (setq message-id (elmo-msgdb-overview-entity-get-id entity)) - (setq cache-file (elmo-file-cache-get message-id)) - (if (or ignore-cache - (null (elmo-file-cache-status cache-file))) - (if (and elmo-message-fetch-threshold - (integerp size) - (>= size elmo-message-fetch-threshold) - (or (not elmo-message-fetch-confirm) - (not (prog1 (y-or-n-p +(luna-define-method elmo-find-fetch-strategy ((folder elmo-imap4-folder) number + &optional + ignore-cache + require-entireness) + (let ((entity (elmo-message-entity folder number))) + (if (null entity) + (elmo-make-fetch-strategy 'entire) + (let* ((size (elmo-message-entity-field entity 'size)) + (message-id (elmo-message-entity-field entity 'message-id)) + (cache-file (elmo-file-cache-get message-id)) + (use-cache (and (not ignore-cache) + (elmo-message-use-cache-p folder number) + (if require-entireness + (eq (elmo-file-cache-status cache-file) + 'entire) + (elmo-file-cache-status cache-file))))) + (elmo-make-fetch-strategy + (if use-cache + (elmo-file-cache-status cache-file) + (if (and (not require-entireness) + elmo-message-fetch-threshold + (integerp size) + (>= size elmo-message-fetch-threshold) + (or (not elmo-message-fetch-confirm) + (not (prog1 + (y-or-n-p (format "Fetch entire message at once? (%dbytes)" size)) - (message ""))))) - ;; Fetch message as imap message. - (elmo-make-fetch-strategy 'section - nil - (elmo-message-use-cache-p - folder number) - (elmo-file-cache-path - cache-file)) - ;; Don't use existing cache and fetch entire message at once. - (elmo-make-fetch-strategy 'entire nil - (elmo-message-use-cache-p - folder number) - (elmo-file-cache-path cache-file))) - ;; Cache found and use it. - (if (not ignore-cache) - (if (eq (elmo-file-cache-status cache-file) 'section) - ;; Fetch message with imap message. - (elmo-make-fetch-strategy 'section - t - (elmo-message-use-cache-p - folder number) - (elmo-file-cache-path - cache-file)) - (elmo-make-fetch-strategy 'entire - t - (elmo-message-use-cache-p - folder number) - (elmo-file-cache-path - cache-file))))))) + (message ""))))) + 'section + 'entire)) + use-cache + (elmo-message-use-cache-p folder number) + (elmo-file-cache-path cache-file)))))) (luna-define-method elmo-folder-create-plugged ((folder elmo-imap4-folder)) (elmo-imap4-send-command-wait @@ -2456,8 +2592,20 @@ If optional argument REMOVE is non-nil, remove FLAG." (elmo-imap4-mailbox (elmo-imap4-folder-mailbox-internal folder))))) +(defun elmo-imap4-flags-to-imap (flags) + "Convert FLAGS to the IMAP flag string." + (let ((imap-flag (if (not (memq 'unread flags)) "\\Seen"))) + (dolist (flag flags) + (unless (memq flag '(new read unread cached)) + (setq imap-flag + (concat imap-flag + (if imap-flag " ") + (or (car (cdr (assq flag elmo-imap4-flag-specs))) + (capitalize (symbol-name flag))))))) + imap-flag)) + (luna-define-method elmo-folder-append-buffer - ((folder elmo-imap4-folder) unread &optional number) + ((folder elmo-imap4-folder) &optional flags number) (if (elmo-folder-plugged-p folder) (let ((session (elmo-imap4-get-session folder)) send-buffer result) @@ -2473,36 +2621,64 @@ If optional argument REMOVE is non-nil, remove FLAG." "append " (elmo-imap4-mailbox (elmo-imap4-folder-mailbox-internal folder)) - (if unread " () " " (\\Seen) ") + (if (and flags (elmo-folder-use-flag-p folder)) + (concat " (" (elmo-imap4-flags-to-imap flags) ") ") + " () ") (elmo-imap4-buffer-literal send-buffer)))) (kill-buffer send-buffer)) + (when result + (elmo-folder-preserve-flags + folder (elmo-msgdb-get-message-id-from-buffer) flags)) result) ;; Unplugged (if elmo-enable-disconnected-operation - (elmo-folder-append-buffer-dop folder unread number) + (elmo-folder-append-buffer-dop folder flags number) (error "Unplugged")))) (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))))))) - -(luna-define-method elmo-folder-append-messages :around - ((folder elmo-imap4-folder) src-folder numbers unread-marks - &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)) + `(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)) + (let ((session (elmo-imap4-get-session folder)) + messages new unread response killed uidnext) + (with-current-buffer (elmo-network-session-buffer session) + (setq elmo-imap4-status-callback nil) + (setq elmo-imap4-status-callback-data nil)) + (if elmo-imap4-use-select-to-update-status + (elmo-imap4-session-select-mailbox + session + (elmo-imap4-folder-mailbox-internal folder))) + (setq response + (elmo-imap4-send-command-wait session + (list + "status " + (elmo-imap4-mailbox + (elmo-imap4-folder-mailbox-internal + folder)) + " (uidnext)")) + response (elmo-imap4-response-value response 'status)) + (elmo-imap4-response-value response 'uidnext))) + +(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) @@ -2528,30 +2704,26 @@ 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))) (with-current-buffer outbuf (erase-buffer) (insert response) + (elmo-delete-cr-buffer) t)))) (luna-define-method elmo-message-fetch-plugged ((folder elmo-imap4-folder) @@ -2585,7 +2757,13 @@ If optional argument REMOVE is non-nil, remove FLAG." (goto-char (point-min)) (std11-field-body (symbol-name field))))) +(luna-define-method elmo-folder-search-requires-msgdb-p ((folder + elmo-imap4-folder) + condition) + nil) +(autoload 'elmo-global-flags-set "elmo-flag") +(autoload 'elmo-get-global-flags "elmo-flag") (require 'product) (product-provide (provide 'elmo-imap4) (require 'elmo-version))