X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-imap4.el;h=1dacabe3bf6213d5c48ba5899295edf7e6b94368;hb=63ea8dd728fab75ceafe73274909e3da6e96a41a;hp=72946a6fe77564dd9f7b9fb7baf0bad1197778c5;hpb=0c694764b1b504129beb2b790c6b7c0e2a4890b3;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-imap4.el b/elmo/elmo-imap4.el index 72946a6..1dacabe 100644 --- a/elmo/elmo-imap4.el +++ b/elmo/elmo-imap4.el @@ -53,7 +53,7 @@ (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).") +\(Except `\\Deleted' flag\).") (defvar elmo-imap4-overview-fetch-chop-length 200 "*Number of overviews to fetch in one request.") @@ -82,7 +82,7 @@ (defvar elmo-imap4-use-select-to-update-status nil "*Some imapd have to send select command to update status. -(ex. UW imapd 4.5-BETA?). For these imapd, you must set this variable t.") +\(ex. UW imapd 4.5-BETA?\). For these imapd, you must set this variable t.") (defvar elmo-imap4-use-modified-utf7 nil "*Use mofidied UTF-7 (rfc2060) encoding for IMAP4 folder name.") @@ -92,7 +92,7 @@ (defvar elmo-imap4-extra-namespace-alist '(("^\\({.*/nntp}\\).*$" . ".")) ; Default is for UW's remote nntp mailbox... - "Extra namespace alist. + "Extra namespace alist. A list of cons cell like: (REGEXP . DELIMITER). REGEXP should have a grouping for namespace prefix.") ;; @@ -192,13 +192,16 @@ Debug information is inserted in the buffer \"*IMAP4 DEBUG*\"") (luna-define-internal-accessors 'mime-elmo-imap-location)) ;;; Debug -(defsubst elmo-imap4-debug (message &rest args) - (if elmo-imap4-debug - (with-current-buffer (get-buffer-create "*IMAP4 DEBUG*") - (goto-char (point-max)) - (if elmo-imap4-debug-inhibit-logging - (insert "NO LOGGING\n") - (insert (apply 'format message args) "\n"))))) +(defmacro elmo-imap4-debug (message &rest 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*") + (goto-char (point-max)) + (if elmo-imap4-debug-inhibit-logging + (insert "NO LOGGING\n") + (insert (apply 'format message args) "\n")))) (defsubst elmo-imap4-decode-folder-string (string) (if elmo-imap4-use-modified-utf7 @@ -224,6 +227,10 @@ Debug information is inserted in the buffer \"*IMAP4 DEBUG*\"") "Returns non-nil if RESPONSE is an 'BYE' response." (` (assq 'bye (, response)))) +(defmacro elmo-imap4-response-garbage-p (response) + "Returns non-nil if RESPONSE is an 'garbage' response." + (` (assq 'garbage (, response)))) + (defmacro elmo-imap4-response-value (response symbol) "Get value of the SYMBOL from RESPONSE." (` (nth 1 (assq (, symbol) (, response))))) @@ -344,7 +351,14 @@ TAG is the tag of the command" (with-current-buffer (process-buffer (elmo-network-session-process-internal session)) (while (not (or (string= tag elmo-imap4-reached-tag) - (elmo-imap4-response-bye-p elmo-imap4-current-response))) + (elmo-imap4-response-bye-p elmo-imap4-current-response) + (when (elmo-imap4-response-garbage-p + elmo-imap4-current-response) + (message "Garbage response: %s" + (elmo-imap4-response-value + elmo-imap4-current-response + 'garbage)) + t))) (when (memq (process-status (elmo-network-session-process-internal session)) '(open run)) @@ -682,9 +696,9 @@ Returns response value if selecting folder succeed. " (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) @@ -713,43 +727,10 @@ Returns response value if selecting folder succeed. " "search %s") flag)) 'search))) -(static-cond - ((fboundp 'float) - ;; Emacs can parse dot symbol. - (defvar elmo-imap4-rfc822-size "RFC822\.SIZE") - (defvar elmo-imap4-rfc822-text "RFC822\.TEXT") - (defvar elmo-imap4-rfc822-header "RFC822\.HEADER") - (defvar elmo-imap4-rfc822-size "RFC822\.SIZE") - (defvar elmo-imap4-header-fields "HEADER\.FIELDS") - (defmacro elmo-imap4-replace-dot-symbols ()) ;; noop - (defalias 'elmo-imap4-fetch-read 'read) - ) - (t - ;;; For Nemacs. - ;; Cannot parse dot symbol. - (defvar elmo-imap4-rfc822-size "RFC822_SIZE") - (defvar elmo-imap4-header-fields "HEADER_FIELDS") - (defvar elmo-imap4-rfc822-size "RFC822_SIZE") - (defvar elmo-imap4-rfc822-text "RFC822_TEXT") - (defvar elmo-imap4-rfc822-header "RFC822_HEADER") - (defvar elmo-imap4-header-fields "HEADER_FIELDS") - (defun elmo-imap4-fetch-read (buffer) - (with-current-buffer buffer - (let ((beg (point)) - token) - (when (re-search-forward "[[ ]" nil t) - (goto-char (match-beginning 0)) - (setq token (buffer-substring beg (point))) - (cond ((string= token "RFC822.SIZE") - (intern elmo-imap4-rfc822-size)) - ((string= token "RFC822.HEADER") - (intern elmo-imap4-rfc822-header)) - ((string= token "RFC822.TEXT") - (intern elmo-imap4-rfc822-text)) - ((string= token "HEADER\.FIELDS") - (intern elmo-imap4-header-fields)) - (t (goto-char beg) - (elmo-read (current-buffer)))))))))) +(defvar elmo-imap4-rfc822-size "RFC822\.SIZE") +(defvar elmo-imap4-rfc822-text "RFC822\.TEXT") +(defvar elmo-imap4-rfc822-header "RFC822\.HEADER") +(defvar elmo-imap4-header-fields "HEADER\.FIELDS") (defun elmo-imap4-make-number-set-list (msg-list &optional chop-length) "Make RFC2060's message set specifier from MSG-LIST. @@ -849,7 +830,7 @@ If CHOP-LENGTH is not specified, message set is not chopped." (defun elmo-imap4-parse-capability (string) (if (string-match "^\\*\\(.*\\)$" string) - (elmo-read + (read (concat "(" (downcase (elmo-match-string 1 string)) ")")))) (defun elmo-imap4-clear-login (session) @@ -925,7 +906,12 @@ If CHOP-LENGTH is not specified, message set is not chopped." (signal 'elmo-open-error '(elmo-imap4-starttls-error))) (elmo-imap4-send-command-wait session "starttls") - (starttls-negotiate process))))) + (starttls-negotiate process) + (elmo-imap4-session-set-capability-internal + session + (elmo-imap4-response-value + (elmo-imap4-send-command-wait session "capability") + 'capability)))))) (luna-define-method elmo-network-authenticate-session ((session elmo-imap4-session)) @@ -1308,11 +1294,11 @@ Return nil if no complete line has arrived." (defun elmo-imap4-parse-response () "Parse a IMAP command response." (let (token) - (case (setq token (elmo-read (current-buffer))) + (case (setq token (read (current-buffer))) (+ (progn (skip-chars-forward " ") (list 'continue-req (buffer-substring (point) (point-max))))) - (* (case (prog1 (setq token (elmo-read (current-buffer))) + (* (case (prog1 (setq token (read (current-buffer))) (elmo-imap4-forward)) (OK (elmo-imap4-parse-resp-text-code)) (NO (elmo-imap4-parse-resp-text-code)) @@ -1324,19 +1310,19 @@ Return nil if no complete line has arrived." (LSUB (list 'lsub (elmo-imap4-parse-data-list))) (SEARCH (list 'search - (elmo-read (concat "(" + (read (concat "(" (buffer-substring (point) (point-max)) ")")))) (STATUS (elmo-imap4-parse-status)) ;; Added (NAMESPACE (elmo-imap4-parse-namespace)) (CAPABILITY (list 'capability - (elmo-read + (read (concat "(" (downcase (buffer-substring (point) (point-max))) ")")))) (ACL (elmo-imap4-parse-acl)) - (t (case (prog1 (elmo-read (current-buffer)) + (t (case (prog1 (read (current-buffer)) (elmo-imap4-forward)) (EXISTS (list 'exists token)) (RECENT (list 'recent token)) @@ -1345,7 +1331,7 @@ Return nil if no complete line has arrived." (t (list 'garbage (buffer-string))))))) (t (if (not (string-match elmo-imap4-seq-prefix (symbol-name token))) (list 'garbage (buffer-string)) - (case (prog1 (elmo-read (current-buffer)) + (case (prog1 (read (current-buffer)) (elmo-imap4-forward)) (OK (progn (setq elmo-imap4-parsing nil) @@ -1404,9 +1390,9 @@ Return nil if no complete line has arrived." (cond ((search-forward "PERMANENTFLAGS " nil t) (list 'permanentflags (elmo-imap4-parse-flag-list))) ((search-forward "UIDNEXT " nil t) - (list 'uidnext (elmo-read (current-buffer)))) + (list 'uidnext (read (current-buffer)))) ((search-forward "UNSEEN " nil t) - (list 'unseen (elmo-read (current-buffer)))) + (list 'unseen (read (current-buffer)))) ((looking-at "UIDVALIDITY \\([0-9]+\\)") (list 'uidvalidity (match-string 1))) ((search-forward "READ-ONLY" nil t) @@ -1470,12 +1456,12 @@ Return nil if no complete line has arrived." (let (element list) (while (not (eq (char-after (point)) ?\))) (elmo-imap4-forward) - (let ((token (elmo-imap4-fetch-read (current-buffer)))) + (let ((token (read (current-buffer)))) (elmo-imap4-forward) (setq element (cond ((eq token 'UID) (list 'uid (condition-case nil - (elmo-read (current-buffer)) + (read (current-buffer)) (error nil)))) ((eq token 'FLAGS) (list 'flags (elmo-imap4-parse-flag-list))) @@ -1490,7 +1476,7 @@ Return nil if no complete line has arrived." ((eq token (intern elmo-imap4-rfc822-text)) (list 'rfc822text (elmo-imap4-parse-nstring))) ((eq token (intern elmo-imap4-rfc822-size)) - (list 'rfc822size (elmo-read (current-buffer)))) + (list 'rfc822size (read (current-buffer)))) ((eq token 'BODY) (if (eq (char-before) ?\[) (list @@ -1520,24 +1506,25 @@ Return nil if no complete line has arrived." (while (not (eq (char-after (point)) ?\))) (setq status (cons - (let ((token (elmo-read (current-buffer)))) + (let ((token (read (current-buffer)))) (cond ((eq token 'MESSAGES) - (list 'messages (elmo-read (current-buffer)))) + (list 'messages (read (current-buffer)))) ((eq token 'RECENT) - (list 'recent (elmo-read (current-buffer)))) + (list 'recent (read (current-buffer)))) ((eq token 'UIDNEXT) - (list 'uidnext (elmo-read (current-buffer)))) + (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 (elmo-read (current-buffer)))) + (list 'unseen (read (current-buffer)))) (t (message "Unknown status data %s in mailbox %s ignored" token mailbox)))) - status)))) + status)) + (skip-chars-forward " "))) (and elmo-imap4-status-callback (funcall elmo-imap4-status-callback status @@ -1558,9 +1545,9 @@ Return nil if no complete line has arrived." (nconc (copy-sequence elmo-imap4-extra-namespace-alist) (elmo-imap4-parse-namespace-subr - (elmo-read (concat "(" (buffer-substring - (point) (point-max)) - ")")))))) + (read (concat "(" (buffer-substring + (point) (point-max)) + ")")))))) (defun elmo-imap4-parse-namespace-subr (ns) (let (prefix delim namespace-alist default-delim) @@ -1784,9 +1771,7 @@ Return nil if no complete line has arrived." (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)))) + (car parse))) ;; user (setq parse (elmo-parse-prefixed-element ?: (cdr parse) "/")) (elmo-net-folder-set-user-internal folder @@ -1885,15 +1870,16 @@ Return nil if no complete line has arrived." (let* ((root (elmo-imap4-folder-mailbox-internal folder)) (session (elmo-imap4-get-session folder)) (prefix (elmo-folder-prefix-internal folder)) - (delim (or - (cdr + (namespace-assoc (elmo-string-matched-assoc root (with-current-buffer (elmo-network-session-buffer session) elmo-imap4-server-namespace))) + (delim (or (cdr namespace-assoc) elmo-imap4-default-hierarchy-delimiter)) ;; Append delimiter when root with namespace. - (root (if (and (match-end 1) + (root (if (and namespace-assoc + (match-end 1) (string= (substring root (match-end 1)) "")) (concat root delim) @@ -2244,6 +2230,7 @@ If optional argument REMOVE is non-nil, remove FLAG." elmo-msgdb-extra-fields)) (total 0) (length (length numbers)) + print-length print-depth rfc2060 set-list) (setq rfc2060 (memq 'imap4rev1 (elmo-imap4-session-capability-internal @@ -2363,7 +2350,7 @@ If optional argument REMOVE is non-nil, remove FLAG." (luna-define-method elmo-folder-open :around ((folder elmo-imap4-folder) &optional load-msgdb) (if (elmo-folder-plugged-p folder) - (let (session mailbox msgdb response tag) + (let (session mailbox msgdb result response tag) (condition-case err (progn (setq session (elmo-imap4-get-session folder) @@ -2372,30 +2359,46 @@ If optional argument REMOVE is non-nil, remove FLAG." (list "select " (elmo-imap4-mailbox mailbox)))) + (message "Selecting %s..." + (elmo-folder-name-internal folder)) (if load-msgdb - (setq msgdb (elmo-msgdb-load folder))) + (setq msgdb (elmo-msgdb-load folder 'silent))) (elmo-folder-set-killed-list-internal folder (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder))) - (setq response (elmo-imap4-read-response session tag))) + (if (setq result (elmo-imap4-response-ok-p + (setq response + (elmo-imap4-read-response session tag)))) + (progn + (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))))) + (elmo-imap4-session-set-current-mailbox-internal session nil) + (if (elmo-imap4-response-bye-p response) + (elmo-imap4-process-bye session) + (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 + folder msgdb)) (quit - (if response + (if (elmo-imap4-response-ok-p response) (elmo-imap4-session-set-current-mailbox-internal session mailbox) (and session (elmo-imap4-session-set-current-mailbox-internal session nil)))) (error - (if response + (if (elmo-imap4-response-ok-p response) (elmo-imap4-session-set-current-mailbox-internal session mailbox) (and session (elmo-imap4-session-set-current-mailbox-internal - session nil))))) - (if load-msgdb - (elmo-folder-set-msgdb-internal - folder - (or msgdb (elmo-msgdb-load folder))))) + session nil)))))) (luna-call-next-method))) ;; elmo-folder-open-internal: do nothing. @@ -2471,7 +2474,7 @@ If optional argument REMOVE is non-nil, remove FLAG." "append " (elmo-imap4-mailbox (elmo-imap4-folder-mailbox-internal folder)) - (if unread " " " (\\Seen) ") + (if unread " () " " (\\Seen) ") (elmo-imap4-buffer-literal send-buffer)))) (kill-buffer send-buffer)) result) @@ -2543,7 +2546,7 @@ If optional argument REMOVE is non-nil, remove FLAG." (unless elmo-inhibit-display-retrieval-progress (elmo-display-progress 'elmo-imap4-display-literal-progress "Retrieving..." 100) ; remove progress bar. - (message "Retrieving...done.")) + (message "Retrieving...done")) (if (setq response (elmo-imap4-response-bodydetail-text (elmo-imap4-response-value-all response 'fetch)))