X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-imap4.el;h=f59cddb3800c5125abcff2b44a29163d790a3957;hb=9e39553b80115a949a7f04ddced4459a7797f8bd;hp=373726ddf106845d5d50e25fc221b09fd02216eb;hpb=366496cfdf25d8df2f76be499708b5f3d222718e;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-imap4.el b/elmo/elmo-imap4.el index 373726d..f59cddb 100644 --- a/elmo/elmo-imap4.el +++ b/elmo/elmo-imap4.el @@ -1,4 +1,4 @@ -;;; elmo-imap4.el -- IMAP4 Interface for ELMO. +;;; elmo-imap4.el --- IMAP4 Interface for ELMO. ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi ;; Copyright (C) 1999,2000 Kenichi OKADA @@ -30,7 +30,7 @@ ;; ;;; Commentary: -;; +;; ;; Origin of IMAP parser part is imap.el, included in Gnus. ;; ;; Copyright (C) 1998, 1999, 2000 @@ -109,6 +109,7 @@ ;;; XXX Temporal implementation (defvar elmo-imap4-current-msgdb nil) +(defvar elmo-imap4-seen-messages nil) (defvar elmo-imap4-local-variables '(elmo-imap4-status @@ -123,7 +124,8 @@ elmo-imap4-fetch-callback-data elmo-imap4-status-callback elmo-imap4-status-callback-data - elmo-imap4-current-msgdb)) + elmo-imap4-current-msgdb + elmo-imap4-seen-messages)) ;;;; @@ -246,7 +248,7 @@ If response is not `OK', causes error with IMAP response text." (defun elmo-imap4-send-command (session command) "Send COMMAND to the SESSION. -Returns a TAG string which is assigned to the COMAND." +Returns a TAG string which is assigned to the COMMAND." (let* ((command-args (if (listp command) command (list command))) @@ -259,10 +261,8 @@ Returns a TAG string which is assigned to the COMAND." (setq cmdstr (concat tag " ")) ;; (erase-buffer) No need. (goto-char (point-min)) - (if (elmo-imap4-response-bye-p elmo-imap4-current-response) - (signal 'elmo-imap4-bye-error - (list (elmo-imap4-response-error-text - elmo-imap4-current-response)))) + (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.)")) @@ -349,6 +349,15 @@ If response is not `+' response, returns nil." (elmo-network-session-process-internal session)) 'continue-req)) +(defun elmo-imap4-process-bye (session) + (with-current-buffer (elmo-network-session-buffer session) + (let ((r elmo-imap4-current-response)) + (setq elmo-imap4-current-response nil) + (elmo-network-close-session session) + (signal 'elmo-imap4-bye-error + (list (concat (elmo-imap4-response-error-text r)) + "Try Again"))))) + (defun elmo-imap4-accept-continue-req (session) "Returns non-nil if `+' (continue-req) response is arrived in SESSION. If response is not `+' response, cause an error." @@ -374,14 +383,11 @@ If response is not `OK' response, causes error with IMAP response text." (if (elmo-imap4-response-ok-p response) response (if (elmo-imap4-response-bye-p response) - (signal 'elmo-imap4-bye-error - (list (elmo-imap4-response-error-text response))) + (elmo-imap4-process-bye session) (error "IMAP error: %s" (or (elmo-imap4-response-error-text response) "No `OK' response from server.")))))) - - ;;; MIME-ELMO-IMAP Location (luna-define-method mime-imap-location-section-body ((location mime-elmo-imap-location) @@ -624,6 +630,7 @@ If optional argument FORCE is non-nil, select mailbox even if current mailbox is same as MAILBOX. If second optional argument NO-ERROR is non-nil, don't cause an error when selecting folder was failed. +If NO-ERROR is 'notify-bye, only BYE response is reported as error. Returns response value if selecting folder succeed. " (when (or force (not (string= @@ -646,10 +653,13 @@ Returns response value if selecting folder succeed. " session (nth 1 (assq 'read-only (assq 'ok response))))) (elmo-imap4-session-set-current-mailbox-internal session nil) - (unless no-error - (error (or - (elmo-imap4-response-error-text response) - (format "Select %s failed" mailbox)))))) + (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))))))) (and result response)))) (defun elmo-imap4-check-validity (spec validity-file) @@ -766,20 +776,25 @@ If CHOP-LENGTH is not specified, message set is not chopped." mark) (if (member "\\Flagged" flags) (elmo-msgdb-global-mark-set (car entity) (nth 3 app-data))) - (setq mark (or (elmo-msgdb-global-mark-get (car entity)) - (if (elmo-file-cache-status - (elmo-file-cache-get (car entity))) + (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))) - 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))))) + (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 @@ -843,7 +858,7 @@ If CHOP-LENGTH is not specified, message set is not chopped." (or (elmo-imap4-read-ok session tag) (signal 'elmo-authenticate-error '(elmo-imap4-auth-login))) (setq elmo-imap4-status 'auth))) - + (luna-define-method elmo-network-initialize-session-buffer :after ((session elmo-imap4-session) buffer) @@ -888,7 +903,7 @@ If CHOP-LENGTH is not specified, message set is not chopped." (starttls-negotiate process))))) (luna-define-method elmo-network-authenticate-session ((session - elmo-imap4-session)) + elmo-imap4-session)) (with-current-buffer (process-buffer (elmo-network-session-process-internal session)) (let* ((auth (elmo-network-session-auth-internal session)) @@ -1060,7 +1075,8 @@ If CHOP-LENGTH is not specified, message set is not chopped." (defun elmo-imap4-server-diff-async-callback-1 (status data) (funcall elmo-imap4-server-diff-async-callback - (cons (elmo-imap4-response-value status 'unseen) + (list (elmo-imap4-response-value status 'recent) + (elmo-imap4-response-value status 'unseen) (elmo-imap4-response-value status 'messages)) data)) @@ -1079,7 +1095,7 @@ If CHOP-LENGTH is not specified, message set is not chopped." "status " (elmo-imap4-mailbox (elmo-imap4-folder-mailbox-internal folder)) - " (unseen messages)")))) + " (recent unseen messages)")))) (luna-define-method elmo-server-diff-async ((folder elmo-imap4-folder)) (let ((session (elmo-imap4-get-session folder))) @@ -1095,7 +1111,7 @@ If CHOP-LENGTH is not specified, message set is not chopped." "status " (elmo-imap4-mailbox (elmo-imap4-folder-mailbox-internal folder)) - " (unseen messages)")))) + " (recent unseen messages)")))) ;;; IMAP parser. @@ -1294,7 +1310,7 @@ Return nil if no complete line has arrived." (concat "(" (downcase (buffer-substring (point) (point-max))) ")")))) - (ACL (elmo-imap4-parse-acl)) + (ACL (elmo-imap4-parse-acl)) (t (case (prog1 (elmo-read (current-buffer)) (elmo-imap4-forward)) (EXISTS (list 'exists token)) @@ -1340,7 +1356,7 @@ Return nil if no complete line has arrived." (setq text (buffer-substring (point) (point-max))) (list 'bad (list code text))))) (t (list 'garbage (buffer-string))))))))) - + (defun elmo-imap4-parse-bye () (let (code text) (when (eq (char-after (point)) ?\[) @@ -1468,7 +1484,7 @@ Return nil if no complete line has arrived." (list 'bodystructure (elmo-imap4-parse-body))))) (setq list (cons element list)))) (and elmo-imap4-fetch-callback - (funcall elmo-imap4-fetch-callback + (funcall elmo-imap4-fetch-callback list elmo-imap4-fetch-callback-data)) (list 'fetch list)))) @@ -1716,7 +1732,7 @@ Return nil if no complete line has arrived." (push (elmo-imap4-parse-nstring) body);; body-fld-md5 (setq body (append (elmo-imap4-parse-body-ext) body)));; body-ext-1part.. - + (assert (eq (char-after (point)) ?\))) (elmo-imap4-forward) (nreverse body))))) @@ -1724,59 +1740,50 @@ Return nil if no complete line has arrived." (luna-define-method elmo-folder-initialize :around ((folder elmo-imap4-folder) name) - (let ((default-user elmo-imap4-default-user) - (default-server elmo-imap4-default-server) - (default-port elmo-imap4-default-port) + (let ((default-user elmo-imap4-default-user) + (default-server elmo-imap4-default-server) + (default-port elmo-imap4-default-port) (elmo-network-stream-type-alist (if elmo-imap4-stream-type-alist (append elmo-imap4-stream-type-alist elmo-network-stream-type-alist) - elmo-network-stream-type-alist))) + elmo-network-stream-type-alist)) + parse) (when (string-match "\\(.*\\)@\\(.*\\)" default-server) ;; case: imap4-default-server is specified like ;; "hoge%imap.server@gateway". (setq default-user (elmo-match-string 1 default-server)) (setq default-server (elmo-match-string 2 default-server))) (setq name (luna-call-next-method)) - (when (string-match - "^\\([^:@!]*\\)\\(:[^/!]+\\)?\\(/[^/:@!]+\\)?" - name) - (progn - (if (match-beginning 1) - (progn - (elmo-imap4-folder-set-mailbox-internal - folder - (elmo-match-string 1 name)) - (if (eq (length (elmo-imap4-folder-mailbox-internal folder)) - 0) - ;; No information is specified other than folder type. - (elmo-imap4-folder-set-mailbox-internal - folder - elmo-imap4-default-mailbox))) - (elmo-imap4-folder-set-mailbox-internal - folder - elmo-imap4-default-mailbox)) - ;; Setup slots for elmo-net-folder. - (elmo-net-folder-set-user-internal - folder - (if (match-beginning 2) - (elmo-match-substring 2 name 1) - default-user)) - (elmo-net-folder-set-auth-internal - folder - (if (match-beginning 3) - (intern (elmo-match-substring 3 name 1)) - (or elmo-imap4-default-authenticate-type 'clear))) - (unless (elmo-net-folder-server-internal folder) - (elmo-net-folder-set-server-internal folder default-server)) - (unless (elmo-net-folder-port-internal folder) - (elmo-net-folder-set-port-internal folder default-port)) - (unless (elmo-net-folder-stream-type-internal folder) - (elmo-net-folder-set-stream-type-internal - folder - (elmo-get-network-stream-type - elmo-imap4-default-stream-type))) - folder)))) + ;; mailbox + (setq parse (elmo-parse-token name ":")) + (elmo-imap4-folder-set-mailbox-internal folder + (elmo-imap4-encode-folder-string + (if (eq (length (car parse)) 0) + elmo-imap4-default-mailbox + (car parse)))) + ;; user + (setq parse (elmo-parse-prefixed-element ?: (cdr parse) "/")) + (elmo-net-folder-set-user-internal folder + (if (eq (length (car parse)) 0) + default-user + (car parse))) + ;; auth + (setq parse (elmo-parse-prefixed-element ?/ (cdr parse))) + (elmo-net-folder-set-auth-internal + folder + (if (eq (length (car parse)) 0) + (or elmo-imap4-default-authenticate-type 'clear) + (intern (car parse)))) + (unless (elmo-net-folder-server-internal folder) + (elmo-net-folder-set-server-internal folder default-server)) + (unless (elmo-net-folder-port-internal folder) + (elmo-net-folder-set-port-internal folder default-port)) + (unless (elmo-net-folder-stream-type-internal folder) + (elmo-net-folder-set-stream-type-internal + folder + (elmo-get-network-stream-type elmo-imap4-default-stream-type))) + folder)) ;;; ELMO IMAP4 folder (luna-define-method elmo-folder-expand-msgdb-path ((folder @@ -1795,7 +1802,7 @@ Return nil if no complete line has arrived." "nowhere") (expand-file-name "imap" - elmo-msgdb-dir))))))) + elmo-msgdb-directory))))))) (luna-define-method elmo-folder-status-plugged ((folder elmo-imap4-folder)) @@ -1861,14 +1868,6 @@ Return nil if no complete line has arrived." elmo-imap4-server-namespace))) elmo-imap4-default-hierarchy-delimiter)) result append-serv type) - ;; Append delimiter - (if (and root - (not (string= root "")) - (not (string-match (concat "\\(.*\\)" - (regexp-quote delim) - "\\'") - root))) - (setq root (concat root delim))) (setq result (elmo-imap4-response-get-selectable-mailbox-list (elmo-imap4-send-command-wait session @@ -1897,41 +1896,39 @@ Return nil if no complete line has arrived." (elmo-network-stream-type-spec-string type))))) (if one-level - (let (folder folders ret) - (while (setq folders (car result)) - (if (prog1 - (string-match - (concat "^\\(" root "[^" delim "]" "+\\)" delim) - folders) - (setq folder (match-string 1 folders))) - (progn - (setq ret - (append ret - (list - (list - (concat - prefix - (elmo-imap4-decode-folder-string folder) - (and append-serv - (eval append-serv))))))) - (setq result - (delq - nil - (mapcar '(lambda (fld) - (unless - (string-match - (concat "^" (regexp-quote folder) delim) + (let ((re-delim (regexp-quote delim)) + folder ret has-child-p) + ;; Append delimiter + (when (and root + (not (string= root "")) + (not (string-match + (concat "\\(.*\\)" re-delim "\\'") + root))) + (setq root (concat root delim))) + (while (setq folder (car result)) + (when (string-match + (concat "^\\(" (regexp-quote root) "[^" re-delim "]" "+\\)" + re-delim) + folder) + (setq folder (match-string 1 folder))) + (setq has-child-p nil + result (delq + nil + (mapcar (lambda (fld) + (if (string-match + (concat "^" (regexp-quote folder) + "\\(" re-delim "\\|\\'\\)") fld) + (progn (setq has-child-p t) nil) fld)) - result)))) - (setq ret (append - ret - (list - (concat prefix - (elmo-imap4-decode-folder-string folders) - (and append-serv - (eval append-serv)))))) - (setq result (cdr result)))) + (cdr result))) + folder (concat prefix + (elmo-imap4-decode-folder-string folder) + (and append-serv + (eval append-serv))) + ret (append ret (if has-child-p + (list (list folder)) + (list folder))))) ret) (mapcar (lambda (fld) (concat prefix (elmo-imap4-decode-folder-string fld) @@ -1948,7 +1945,7 @@ Return nil if no complete line has arrived." (elmo-imap4-session-select-mailbox session (elmo-imap4-folder-mailbox-internal folder) - 'force 'no-error)))) + 'force 'notify-bye)))) (luna-define-method elmo-folder-writable-p ((folder elmo-imap4-folder)) t) @@ -2069,7 +2066,7 @@ If optional argument REMOVE is non-nil, remove FLAG." (concat (if elmo-imap4-use-uid "uid ") (cdr - (car + (car (elmo-imap4-make-number-set-list from-msgs))) " ") @@ -2176,6 +2173,7 @@ If optional argument REMOVE is non-nil, remove FLAG." ;; 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 @@ -2197,6 +2195,8 @@ If optional argument REMOVE is non-nil, remove FLAG." (/ (* 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 @@ -2253,7 +2253,7 @@ If optional argument REMOVE is non-nil, remove FLAG." (elmo-imap4-mailbox (elmo-imap4-folder-mailbox-internal folder)) - " (unseen messages)"))) + " (recent unseen messages)"))) (setq response (elmo-imap4-response-value response 'status)) (setq messages (elmo-imap4-response-value response 'messages)) (setq killed (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder))) @@ -2261,7 +2261,8 @@ If optional argument REMOVE is non-nil, remove FLAG." (setq messages (- messages (elmo-msgdb-killed-list-length killed)))) - (cons (elmo-imap4-response-value response 'unseen) + (list (elmo-imap4-response-value response 'recent) + (elmo-imap4-response-value response 'unseen) messages))) (luna-define-method elmo-folder-diff-plugged ((folder elmo-imap4-folder)) @@ -2412,7 +2413,9 @@ If optional argument REMOVE is non-nil, remove FLAG." (elmo-imap4-identical-system-p folder src-folder) (elmo-folder-plugged-p folder)) ;; Plugged - (elmo-imap4-copy-messages src-folder folder numbers) + (prog1 + (elmo-imap4-copy-messages src-folder folder numbers) + (elmo-progress-notify 'elmo-folder-move-messages (length numbers))) (luna-call-next-method))) (luna-define-method elmo-message-deletable-p ((folder elmo-imap4-folder)