X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=elmo%2Felmo-imap4.el;h=c597a153fcb870629688bf1c528027ef7d6a8250;hb=c6930bb696cf4a9e6f2d07c5620e4392f5a4773d;hp=c9ae6e2167d719926ce6742553667c9e2a38d7f5;hpb=24bfb6f5cbe757f3fd4d7412a0a2dd930fb32b95;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-imap4.el b/elmo/elmo-imap4.el index c9ae6e2..c597a15 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.") @@ -66,7 +66,7 @@ ;; ranges so that the command line is within that length, it should ;; split the request into multiple commands. The client should use ;; literals instead of long quoted strings, in order to keep the command -;; length down. +;; length down. ;; For its part, a server should allow for a command line of at least ;; 8000 octets. This provides plenty of leeway for accepting reasonable ;; length commands from clients. The server should send a BAD response @@ -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.") @@ -91,8 +91,10 @@ "Use cache in imap4 folder.") (defvar elmo-imap4-extra-namespace-alist - '(("^{.*/nntp}.*$" . ".")) ; Default is for UW's remote nntp mailbox... - "Extra namespace alist. A list of cons cell like: (REGEXP . DELIMITER).") + '(("^\\({.*/nntp}\\).*$" . ".")) ; Default is for UW's remote nntp mailbox... + "Extra namespace alist. +A list of cons cell like: (REGEXP . DELIMITER). +REGEXP should have a grouping for namespace prefix.") ;; ;;; internal variables ;; @@ -190,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 @@ -222,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))))) @@ -251,9 +260,9 @@ Debug information is inserted in the buffer \"*IMAP4 DEBUG*\"") ; "Send COMMAND to the SESSION and wait for response. ; Returns RESPONSE (parsed lisp object) of IMAP session." ; (elmo-imap4-read-response session -; (elmo-imap4-send-command -; session -; command))) +; (elmo-imap4-send-command +; session +; command))) (defun elmo-imap4-send-command-wait (session command) "Send COMMAND to the SESSION. @@ -342,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)) @@ -711,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. @@ -923,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)) @@ -1468,7 +1456,7 @@ 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) @@ -1535,7 +1523,8 @@ Return nil if no complete line has arrived." (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 @@ -1580,11 +1569,11 @@ Return nil if no complete line has arrived." (if (eq (length prefix) 0) (progn (setq default-delim delim) nil) (cons - (concat "^" + (concat "^\\(" (if (string= (downcase prefix) "inbox") "[Ii][Nn][Bb][Oo][Xx]" (regexp-quote prefix)) - ".*$") + "\\).*$") delim))) (elmo-imap4-nth i ns)))))) (if default-delim @@ -1782,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 @@ -1883,20 +1870,29 @@ 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 namespace-assoc + (match-end 1) + (string= (substring root (match-end 1)) + "")) + (concat root delim) + root)) result append-serv type) (setq result (elmo-imap4-response-get-selectable-mailbox-list (elmo-imap4-send-command-wait session (list "list " (elmo-imap4-mailbox root) " *")))) - (unless (string= (elmo-net-folder-user-internal folder) - elmo-imap4-default-user) + (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)))) (unless (eq (elmo-net-folder-auth-internal folder) (or elmo-imap4-default-authenticate-type 'clear)) @@ -1920,6 +1916,7 @@ Return nil if no complete line has arrived." type))))) (if one-level (let ((re-delim (regexp-quote delim)) + (case-fold-search nil) folder ret has-child-p) ;; Append delimiter (when (and root @@ -1970,6 +1967,9 @@ Return nil if no complete line has arrived." (elmo-imap4-folder-mailbox-internal folder) 'force 'notify-bye)))) +(luna-define-method elmo-folder-creatable-p ((folder elmo-imap4-folder)) + t) + (luna-define-method elmo-folder-writable-p ((folder elmo-imap4-folder)) t) @@ -2001,7 +2001,9 @@ Return nil if no complete line has arrived." (elmo-imap4-folder-mailbox-internal folder)) " " (elmo-imap4-mailbox - (elmo-imap4-folder-mailbox-internal new-folder)))))) + (elmo-imap4-folder-mailbox-internal new-folder)))) + (elmo-imap4-session-set-current-mailbox-internal + session (elmo-imap4-folder-mailbox-internal new-folder)))) (defun elmo-imap4-copy-messages (src-folder dst-folder numbers) (let ((session (elmo-imap4-get-session src-folder)) @@ -2072,7 +2074,8 @@ If optional argument REMOVE is non-nil, remove FLAG." (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")) + (imap-search-keys '("bcc" "body" "cc" "from" "subject" "to" + "larger" "smaller")) (total 0) (length (length from-msgs)) charset set-list end results) @@ -2205,14 +2208,16 @@ If optional argument REMOVE is non-nil, remove FLAG." folder session (nth 2 condition) from-msgs))) result (sort result '<)))))) -(luna-define-method elmo-folder-search ((folder elmo-imap4-folder) - condition &optional numbers) - (save-excursion - (let ((session (elmo-imap4-get-session folder))) - (elmo-imap4-session-select-mailbox - session - (elmo-imap4-folder-mailbox-internal folder)) - (elmo-imap4-search-internal folder session condition numbers)))) +(luna-define-method elmo-folder-search :around ((folder elmo-imap4-folder) + condition &optional numbers) + (if (elmo-folder-plugged-p folder) + (save-excursion + (let ((session (elmo-imap4-get-session folder))) + (elmo-imap4-session-select-mailbox + session + (elmo-imap4-folder-mailbox-internal folder)) + (elmo-imap4-search-internal folder session condition numbers))) + (luna-call-next-method))) (luna-define-method elmo-folder-msgdb-create-plugged ((folder elmo-imap4-folder) numbers &rest args) @@ -2225,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 @@ -2305,8 +2311,7 @@ If optional argument REMOVE is non-nil, remove FLAG." (defsubst elmo-imap4-folder-diff-plugged (folder) (let ((session (elmo-imap4-get-session folder)) - messages - response killed) + messages new unread response killed) ;;; (elmo-imap4-commit spec) (with-current-buffer (elmo-network-session-buffer session) (setq elmo-imap4-status-callback nil) @@ -2326,9 +2331,10 @@ If optional argument REMOVE is non-nil, remove FLAG." (setq messages (- messages (elmo-msgdb-killed-list-length killed)))) - (list (elmo-imap4-response-value response 'recent) - (elmo-imap4-response-value response 'unseen) - messages))) + (setq new (elmo-imap4-response-value response 'recent) + unread (elmo-imap4-response-value response 'unseen)) + (if (< unread new) (setq new unread)) + (list new unread messages))) (luna-define-method elmo-folder-diff-plugged ((folder elmo-imap4-folder)) (elmo-imap4-folder-diff-plugged folder)) @@ -2344,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) @@ -2353,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 (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. @@ -2428,7 +2450,7 @@ If optional argument REMOVE is non-nil, remove FLAG." (elmo-file-cache-path cache-file))))))) -(luna-define-method elmo-folder-create ((folder elmo-imap4-folder)) +(luna-define-method elmo-folder-create-plugged ((folder elmo-imap4-folder)) (elmo-imap4-send-command-wait (elmo-imap4-get-session folder) (list "create " @@ -2452,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) @@ -2524,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)))