X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-imap4.el;h=0cc8e37afc0c25582f30c1289840b0872d68d8b5;hb=93025ed9d6792ef40793910e2a2b7ac46029b5cb;hp=88144eeaac2231282129d48868604eca4261e635;hpb=22f1357f5a11a36e08357c91a93eef37acfd7498;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-imap4.el b/elmo/elmo-imap4.el index 88144ee..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,9 +49,11 @@ (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 (For STATUS command).") + (defvar elmo-imap4-overview-fetch-chop-length 200 "*Number of overviews to fetch in one request.") @@ -161,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. @@ -180,6 +198,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 @@ -189,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*") @@ -201,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." @@ -242,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. @@ -306,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)) @@ -327,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) @@ -435,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))) @@ -610,8 +636,9 @@ BUFFER must be a single-byte buffer." (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 @@ -742,21 +769,57 @@ Returns response value if selecting folder succeed. " "\\seen" (elmo-imap4-session-flags-internal session)) (elmo-string-member-ignore-case "\\flagged" (elmo-imap4-session-flags-internal session)))) - (t (elmo-string-member-ignore-case - (concat "\\" (symbol-name flag)) - (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 (case flag - (read "seen") - (unread "unseen") - (important "flagged") - (any "or answered or unseen flagged") - (digest "or unseen flagged") - (t (symbol-name flag))))) + (criteria (elmo-imap4-flag-to-imap-criteria flag))) (if (elmo-imap4-session-flag-available-p session flag) (progn (elmo-imap4-session-select-mailbox @@ -827,7 +890,8 @@ If CHOP-LENGTH is not specified, message set is not chopped." flag-list (if use-flag (append - (and (elmo-string-member-ignore-case "\\Recent" flags) + (and (memq 'new saved-flags) + (not (elmo-string-member-ignore-case "\\Seen" flags)) '(new)) (and (elmo-string-member-ignore-case "\\Flagged" flags) '(important)) @@ -855,16 +919,15 @@ If CHOP-LENGTH is not specified, message set is not chopped." (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")) + ;; 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))) + app-data) + (elmo-progress-notify 'elmo-folder-msgdb-create))) (defun elmo-imap4-parse-capability (string) (if (string-match "^\\*\\(.*\\)$" string) @@ -872,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 @@ -918,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)) @@ -939,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") @@ -1058,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") @@ -1071,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 @@ -1170,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. @@ -1181,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)) @@ -1214,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. @@ -1545,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 @@ -1571,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 @@ -1787,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) @@ -1798,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 @@ -1886,30 +1942,25 @@ Return nil if no complete line has arrived." &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")))) - -(luna-define-method elmo-folder-list-unreads-plugged - ((folder elmo-imap4-folder)) - (elmo-imap4-folder-list-flagged folder 'unread)) - -(luna-define-method elmo-folder-list-importants-plugged - ((folder elmo-imap4-folder)) - (elmo-imap4-folder-list-flagged folder 'important)) - -(luna-define-method elmo-folder-list-answereds-plugged - ((folder elmo-imap4-folder)) - (elmo-imap4-folder-list-flagged folder 'answered)) + (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)) - t) + (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) @@ -1924,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)) @@ -1935,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 @@ -1972,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 @@ -1989,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 @@ -1997,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)))) @@ -2020,8 +2089,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)) @@ -2029,13 +2099,16 @@ Return nil if no complete line has arrived." (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 folder msgs)) - (elmo-imap4-send-command-wait session "close") + (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-folder-mailbox-internal folder))))) + (elmo-imap4-session-set-current-mailbox-internal session nil)) (elmo-msgdb-delete-path folder) t))) @@ -2096,6 +2169,7 @@ If optional argument REMOVE is non-nil, remove FLAG." (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 @@ -2120,18 +2194,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))))) + `(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)) @@ -2140,17 +2220,16 @@ 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) numbers)) @@ -2189,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) @@ -2241,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)))) @@ -2276,11 +2345,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 @@ -2288,82 +2361,65 @@ If optional argument REMOVE is non-nil, remove FLAG." (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 (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)))) - -(luna-define-method elmo-folder-unflag-important-plugged - ((folder elmo-imap4-folder) numbers) - (elmo-imap4-set-flag folder numbers "\\Flagged" 'remove)) - -(luna-define-method elmo-folder-flag-as-important-plugged - ((folder elmo-imap4-folder) numbers) - (elmo-imap4-set-flag folder numbers "\\Flagged")) - -(luna-define-method elmo-folder-unflag-read-plugged - ((folder elmo-imap4-folder) numbers) - (elmo-imap4-set-flag folder numbers "\\Seen" 'remove)) - -(luna-define-method elmo-folder-flag-as-read-plugged - ((folder elmo-imap4-folder) numbers) - (elmo-imap4-set-flag folder numbers "\\Seen")) - -(luna-define-method elmo-folder-unflag-answered-plugged - ((folder elmo-imap4-folder) numbers) - (elmo-imap4-set-flag folder numbers "\\Answered" 'remove)) - -(luna-define-method elmo-folder-flag-as-answered-plugged - ((folder elmo-imap4-folder) numbers) - (elmo-imap4-set-flag folder numbers "\\Answered")) + (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) @@ -2411,7 +2467,7 @@ If optional argument REMOVE is non-nil, remove FLAG." (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))) - ;; + ;; (when killed (when (and (consp (car killed)) (eq (car (car killed)) 1)) @@ -2493,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-message-entity-number entity)) - cache-file size message-id) - (setq size (elmo-message-entity-field entity 'size)) - (setq message-id (elmo-message-entity-field entity 'message-id)) - (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 @@ -2547,6 +2592,18 @@ 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) &optional flags number) (if (elmo-folder-plugged-p folder) @@ -2565,21 +2622,13 @@ If optional argument REMOVE is non-nil, remove FLAG." (elmo-imap4-mailbox (elmo-imap4-folder-mailbox-internal folder)) (if (and flags (elmo-folder-use-flag-p folder)) - (concat " (" - (mapconcat - 'identity - (append - (and (memq 'important flags) - '("\\Flagged")) - (and (not (memq 'unread flags)) - '("\\Seen")) - (and (memq 'answered flags) - '("\\Answered"))) - " ") - ") ") + (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 @@ -2589,23 +2638,47 @@ 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))))))) - -(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)) + `(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) @@ -2631,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) @@ -2694,6 +2763,7 @@ If optional argument REMOVE is non-nil, remove FLAG." 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))