(require 'elmo-net)
(require 'utf7)
(require 'elmo-mime)
+(require 'time-stamp)
(eval-when-compile (require 'cl))
"Extra namespace alist.
A list of cons cell like: (REGEXP . DELIMITER).
REGEXP should have a grouping for namespace prefix.")
+
+(defvar elmo-imap4-disabled-extensions nil
+ "List of server extensions that are disabled on the client side.")
+
;;
;;; internal variables
;;
(defconst elmo-imap4-folder-name-syntax
`(mailbox
- (?: [user "^[A-Za-z]"] (?/ [auth ".+"]))
+ (?: [user "^[A-Za-z0-9]"] (?/ [auth ".+"]))
,@elmo-net-folder-name-syntax))
;; For debugging.
(luna-define-internal-accessors 'elmo-imap4-session))
(defmacro elmo-imap4-session-capable-p (session capability)
- `(memq ,capability (elmo-imap4-session-capability-internal ,session)))
+ `(and (memq ,capability (elmo-imap4-session-capability-internal ,session))
+ (not (memq ,capability elmo-imap4-disabled-extensions))))
;;; MIME-ELMO-IMAP Location
(eval-and-compile
;;; Session commands.
-; (defun elmo-imap4-send-command-wait (session command)
-; "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)))
+;;;(defun elmo-imap4-send-command-wait (session command)
+;;; "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)))
(defun elmo-imap4-send-command-wait (session command)
"Send COMMAND to the SESSION.
(number-to-string
(setq elmo-imap4-seqno (+ 1 elmo-imap4-seqno)))))
(setq cmdstr (concat tag " "))
- ;; (erase-buffer) No need.
+;;; No need.
+;;; (erase-buffer)
(goto-char (point-min))
(when (elmo-imap4-response-bye-p elmo-imap4-current-response)
(elmo-imap4-process-bye session))
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))
(cond ((stringp token) ; formatted
(setq cmdstr (concat cmdstr token)))
(t
(error "Invalid argument")))
(setq command-args (cdr command-args)))
+ (elmo-imap4-debug "[%s] <- %s" (format-time-string "%T") cmdstr)
(process-send-string process (concat cmdstr "\r\n"))
tag)))
(elmo-network-session-process-internal session))
(setq elmo-imap4-current-response nil)
(goto-char (point-min))
- (elmo-imap4-debug "<-- %s" string)
+ (elmo-imap4-debug "[%s] <-- %s" (format-time-string "%T") string)
(process-send-string (elmo-network-session-process-internal session)
string)
(process-send-string (elmo-network-session-process-internal session)
'(open run))
(accept-process-output (elmo-network-session-process-internal session)
1)))
- (elmo-imap4-debug "=>%s" (prin1-to-string elmo-imap4-current-response))
+ (elmo-imap4-debug "[%s] => %s" (format-time-string "%T") (prin1-to-string elmo-imap4-current-response))
(setq elmo-imap4-parsing nil)
elmo-imap4-current-response))
(with-current-buffer (process-buffer process)
(while (not elmo-imap4-current-response)
(accept-process-output process 1))
- (elmo-imap4-debug "=>%s" (prin1-to-string elmo-imap4-current-response))
+ (elmo-imap4-debug "[%s] =>%s" (format-time-string "%T") (prin1-to-string elmo-imap4-current-response))
elmo-imap4-current-response))
(defun elmo-imap4-read-continue-req (session)
(format "Select %s failed" mailbox)))))))
(and result response))))
+(defun elmo-imap4-session-unselect-mailbox (session mailbox)
+ "Unselect MAILBOX in SESSION.
+Deselecting will exit selected state without causing silent
+EXPUNGE for deleted messages."
+ (if (elmo-imap4-session-capable-p session 'unselect)
+ (elmo-imap4-send-command-wait session "unselect")
+ (elmo-imap4-send-command-wait
+ session
+ (list "examine " (elmo-imap4-mailbox mailbox)))
+ (elmo-imap4-send-command-wait session "close")))
+
(defun elmo-imap4-check-validity (spec validity-file)
;;; Not used.
;;;(elmo-imap4-send-command-wait
;;;(elmo-imap4-get-session spec)
;;;(list "status "
-;;; (elmo-imap4-mailbox
-;;; (elmo-imap4-spec-mailbox spec))
-;;; " (uidvalidity)")))
+;;; (elmo-imap4-mailbox
+;;; (elmo-imap4-spec-mailbox spec))
+;;; " (uidvalidity)")))
)
(defun elmo-imap4-sync-validity (spec validity-file)
;; Not used.
)
+(defun elmo-imap4-elist (folder query tags)
+ (let ((session (elmo-imap4-get-session folder)))
+ (elmo-imap4-session-select-mailbox
+ session
+ (elmo-imap4-folder-mailbox-internal folder))
+ (let ((answer (elmo-imap4-response-value
+ (elmo-imap4-send-command-wait
+ session query) 'esearch))
+ tag result)
+ (while answer
+ (setq tag (intern (downcase (car answer))))
+ (cond ((eq tag 'uid)
+ nil)
+ ((memq tag tags)
+ (setq result
+ (append result
+ (if (eq tag 'all)
+ (sort
+ (elmo-number-set-to-number-list
+ (mapcar #'(lambda (x)
+ (let ((y (split-string x ":")))
+ (if (null (cdr y))
+ (string-to-number (car y))
+ (cons (string-to-number (car y))
+ (string-to-number (cadr y))))))
+ (split-string (cadr answer) "\,"))) '<)
+ (string-to-number (cadr answer))))))
+ (t nil))
+ (setq answer (cdr answer)))
+ result)))
+
(defun elmo-imap4-list (folder flag)
(let ((session (elmo-imap4-get-session folder)))
(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") flag))
- 'search)))
+ (if (elmo-imap4-session-capable-p session 'esearch)
+ (elmo-imap4-elist folder
+ (concat (if elmo-imap4-use-uid "uid " "")
+ "search return (all) " flag) '(all))
+ (elmo-imap4-response-value
+ (elmo-imap4-send-command-wait
+ session
+ (format (if elmo-imap4-use-uid "uid search %s"
+ "search %s") flag))
+ 'search))))
(defun elmo-imap4-session-flag-available-p (session flag)
(case flag
(t
(elmo-imap4-flag-to-imap-search-key flag))))
-(defun elmo-imap4-folder-list-flagged (folder flag)
+(defun elmo-imap4-folder-list-flagged (folder flag &optional type)
"List flagged message numbers in the FOLDER.
-FLAG is one of the `unread', `read', `important', `answered', `any'."
+FLAG is one of the `unread', `read', `important', `answered',
+`any'.
+When optional argument TYPE is symbol 'unmatch, negate search
+condition."
(let ((session (elmo-imap4-get-session folder))
- (criteria (elmo-imap4-flag-to-imap-criteria flag)))
+ (criteria (concat (if (eq type 'unmatch) "not " "")
+ (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))
+ (elmo-imap4-list folder criteria)
;; List flagged messages in the msgdb.
(elmo-msgdb-list-flagged (elmo-folder-msgdb folder) flag))))
(cond ((consp x)
(format "%s:%s" (car x) (cdr x)))
((integerp x)
- (int-to-string x))))
+ (number-to-string x))))
cont-list
","))
set-list)))
(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))
+;;; (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
(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)))
elmo-network-initialize-session-buffer :after ((session
elmo-imap4-session) buffer)
(with-current-buffer buffer
- (mapcar 'make-variable-buffer-local elmo-imap4-local-variables)
+ (mapc 'make-variable-buffer-local elmo-imap4-local-variables)
(setq elmo-imap4-seqno 0)
(setq elmo-imap4-status 'initial)))
(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))
+;;; (while (and (memq (process-status process) '(open run))
;;; (eq elmo-imap4-status 'initial))
;;; (message "Waiting for server response...")
;;; (accept-process-output process 1))
-;;; (message "")
+;;; (message "")
(unless (memq elmo-imap4-status '(nonauth auth))
(signal 'elmo-open-error
(list 'elmo-network-initialize-session)))
(sasl-mechanisms
(delq nil
(mapcar
- '(lambda (cap)
- (if (string-match "^auth=\\(.*\\)$"
- (symbol-name cap))
- (match-string 1 (upcase (symbol-name cap)))))
+ (lambda (cap)
+ (if (string-match "^auth=\\(.*\\)$"
+ (symbol-name cap))
+ (match-string 1 (upcase (symbol-name cap)))))
(elmo-imap4-session-capability-internal session))))
(mechanism
(sasl-find-mechanism
(delq nil
- (mapcar '(lambda (cap) (upcase (symbol-name cap)))
+ (mapcar (lambda (cap) (upcase (symbol-name cap)))
(if (listp auth)
auth
(list auth)))))) ;)
session
(intern (downcase name)))
(setq sasl-read-passphrase
- (function
- (lambda (prompt)
- (elmo-get-passwd
- (elmo-network-session-password-key session)))))
+ (lambda (prompt)
+ (elmo-get-passwd
+ (elmo-network-session-password-key session))))
(setq tag
(elmo-imap4-send-command
session
(if (sasl-step-data step)
(elmo-base64-encode-string (sasl-step-data step)
'no-line-break)
- ""))))))))))))
+ ""))))))))
+;; Some servers return reduced capabilities when client asks for them
+;; before login. It might be a good idea to ask them again, otherwise
+;; we can miss some useful feature.
+ (elmo-imap4-session-set-capability-internal
+ session
+ (elmo-imap4-response-value
+ (elmo-imap4-send-command-wait session "capability")
+ 'capability))))))
(luna-define-method elmo-network-setup-session ((session
elmo-imap4-session))
(luna-define-method elmo-server-diff-async ((folder elmo-imap4-folder))
(let ((session (elmo-imap4-get-session folder)))
- ;; commit.
- ;; (elmo-imap4-commit spec)
+;;; ;; commit.
+;;; (elmo-imap4-commit spec)
(with-current-buffer (elmo-network-session-buffer session)
(setq elmo-imap4-status-callback
'elmo-imap4-server-diff-async-callback-1)
"IMAP process filter."
(when (buffer-live-p (process-buffer proc))
(with-current-buffer (process-buffer proc)
- (elmo-imap4-debug "-> %s" string)
(goto-char (point-max))
(insert string)
(let (end)
(while (setq end (elmo-imap4-find-next-line))
(save-restriction
(narrow-to-region (point-min) end)
- (delete-backward-char (length elmo-imap4-server-eol))
+ (delete-char (- (length elmo-imap4-server-eol)))
(goto-char (point-min))
(unwind-protect
(case elmo-imap4-status
(elmo-imap4-forward)
(while (and (not (eq (char-after (point)) ?\)))
;; next line for MS Exchange bug
- (progn (and (eq (char-after (point)) ? ) (elmo-imap4-forward)) t)
+ (progn (and (eq (char-after (point)) (string-to-char " "))
+ (elmo-imap4-forward)) t)
(setq address (elmo-imap4-parse-address)))
(setq addresses (cons address addresses)))
(when (eq (char-after (point)) ?\))
(defun elmo-imap4-parse-response ()
"Parse a IMAP command response."
+ (elmo-imap4-debug "[%s] -> %s" (format-time-string "%T") (buffer-substring (point) (point-max)))
(let (token)
(case (setq token (read (current-buffer)))
(+ (progn
(read (concat "("
(buffer-substring (point) (point-max))
")"))))
+ (ESEARCH (list
+ 'esearch
+ (cddr (split-string (buffer-substring (point) (point-max)) " "))))
(STATUS (elmo-imap4-parse-status))
;; Added
(NAMESPACE (elmo-imap4-parse-namespace))
(1-
(progn (re-search-forward "[] ]" nil t)
(point))))))
- (if (eq (char-before) ? )
+ (if (eq (char-before) (string-to-char " "))
(prog1
(mapconcat 'identity
(cons section (elmo-imap4-parse-header-list)) " ")
(goto-char (match-end 1)))))
(UNSEEN
(list 'unseen (read (current-buffer))))
- (t
+ (t
(message
"Unknown status data %s in mailbox %s ignored"
token mailbox))))
(defun elmo-imap4-parse-acl ()
(let ((mailbox (elmo-imap4-parse-mailbox))
identifier rights acl)
- (while (eq (char-after (point)) ?\ )
+ (while (eq (char-after (point)) (string-to-char " "))
(elmo-imap4-forward)
(setq identifier (elmo-imap4-parse-astring))
(elmo-imap4-forward)
(let (b-e)
(elmo-imap4-forward)
(push (elmo-imap4-parse-body-extension) b-e)
- (while (eq (char-after (point)) ?\ )
+ (while (eq (char-after (point)) (string-to-char " "))
(elmo-imap4-forward)
(push (elmo-imap4-parse-body-extension) b-e))
(assert (eq (char-after (point)) ?\)))
(defsubst elmo-imap4-parse-body-ext ()
(let (ext)
- (when (eq (char-after (point)) ?\ );; body-fld-dsp
+ (when (eq (char-after (point)) (string-to-char " ")) ; body-fld-dsp
(elmo-imap4-forward)
(let (dsp)
(if (eq (char-after (point)) ?\()
(elmo-imap4-forward))
(assert (elmo-imap4-parse-nil)))
(push (nreverse dsp) ext))
- (when (eq (char-after (point)) ?\ );; body-fld-lang
+ (when (eq (char-after (point)) (string-to-char " ")) ; body-fld-lang
(elmo-imap4-forward)
(if (eq (char-after (point)) ?\()
(push (elmo-imap4-parse-string-list) ext)
(push (elmo-imap4-parse-nstring) ext))
- (while (eq (char-after (point)) ?\ );; body-extension
+ (while (eq (char-after (point)) (string-to-char " "));; body-extension
(elmo-imap4-forward)
(setq ext (append (elmo-imap4-parse-body-extension) ext)))))
ext))
(push subbody body))
(elmo-imap4-forward)
(push (elmo-imap4-parse-string) body);; media-subtype
- (when (eq (char-after (point)) ?\ );; body-ext-mpart:
+ (when (eq (char-after (point)) (string-to-char " ")) ; body-ext-mpart:
(elmo-imap4-forward)
(if (eq (char-after (point)) ?\();; body-fld-param
(push (elmo-imap4-parse-string-list) body)
(push (elmo-imap4-parse-string) body);; media-subtype
(elmo-imap4-forward)
;; next line for Sun SIMS bug
- (and (eq (char-after (point)) ? ) (elmo-imap4-forward))
+ (and (eq (char-after (point)) (string-to-char " "))
+ (elmo-imap4-forward))
(if (eq (char-after (point)) ?\();; body-fld-param
(push (elmo-imap4-parse-string-list) body)
(push (and (elmo-imap4-parse-nil) nil) body))
;; the problem is that the two first are in turn optionally followed
;; by the third. So we parse the first two here (if there are any)...
- (when (eq (char-after (point)) ?\ )
+ (when (eq (char-after (point)) (string-to-char " "))
(elmo-imap4-forward)
(let (lines)
(cond ((eq (char-after (point)) ?\();; body-type-msg:
;; ...and then parse the third one here...
- (when (eq (char-after (point)) ?\ );; body-ext-1part:
+ (when (eq (char-after (point)) (string-to-char " ")) ; body-ext-1part:
(elmo-imap4-forward)
(push (elmo-imap4-parse-nstring) body);; body-fld-md5
(setq body
(elmo-msgdb-killed-list-length killed))
(elmo-imap4-response-value status 'messages)))))
-(luna-define-method elmo-folder-list-messages-plugged ((folder
- elmo-imap4-folder)
- &optional
- enable-killed)
- (elmo-imap4-list folder
- (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")))
+(defun elmo-imap4-folder-list-range (folder min max)
+ (elmo-imap4-list
+ folder
+ (concat
+ (let ((killed (elmo-folder-killed-list-internal folder)))
+ (if (and killed
+ (eq (length killed) 1)
+ (consp (car killed))
+ (eq (car (car killed)) 1))
+ ;; What about elmo-imap4-use-uid?
+ (format "uid %d:%s" (cdr (car killed)) max)
+ (format "uid %s:%s" min max)))
+ " undeleted")))
+
+(luna-define-method elmo-folder-list-messages-plugged
+ ((folder elmo-imap4-folder) &optional enable-killed)
+ (let* ((old (elmo-msgdb-list-messages (elmo-folder-msgdb folder)))
+ (new (elmo-imap4-folder-list-range
+ folder (1+ (or (elmo-folder-get-info-max folder) 0)) "*"))
+ (united-old-new (elmo-union old new)))
+ (if (= (length united-old-new) (or (elmo-folder-get-info-length folder) 0))
+ united-old-new
+ (elmo-union new
+ (elmo-imap4-folder-list-range
+ folder
+ 1 (1+ (or (elmo-folder-get-info-max folder) 0)))))))
(luna-define-method elmo-folder-list-flagged-plugged
((folder elmo-imap4-folder) flag)
(elmo-net-folder-server-internal folder))))
(unless (eq (elmo-net-folder-port-internal folder) elmo-imap4-default-port)
(setq append-serv (concat append-serv ":"
- (int-to-string
+ (number-to-string
(elmo-net-folder-port-internal folder)))))
(setq type (elmo-net-folder-stream-type-internal folder))
(unless (eq (elmo-network-stream-type-symbol type)
(elmo-imap4-session-select-mailbox session
(elmo-imap4-folder-mailbox-internal
folder))
+ (elmo-imap4-session-unselect-mailbox session
+ (elmo-imap4-folder-mailbox-internal
+ folder))
(elmo-imap4-send-command-wait session "close")
(elmo-imap4-send-command-wait
session
(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))))
+(defun elmo-imap4-detect-search-charset (string)
+ (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))
(let* ((numbers (or from-msgs (elmo-folder-list-messages folder)))
(rest (nthcdr (string-to-number (elmo-filter-value filter) )
numbers)))
- (mapcar '(lambda (x) (delete x numbers)) rest)
+ (mapc (lambda (x) (delete x numbers)) rest)
numbers))
((string= "flag" search-key)
(elmo-imap4-folder-list-flagged
- folder (intern (elmo-filter-value filter))))
+ folder (intern (elmo-filter-value filter)) (elmo-filter-type filter)))
((or (string= "since" search-key)
(string= "before" search-key))
(setq search-key (concat "sent" search-key)
(defsubst elmo-imap4-folder-diff-plugged (folder)
(let ((session (elmo-imap4-get-session folder))
messages new unread response killed uidnext)
-;;; (elmo-imap4-commit spec)
+;;; (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))
(setq response
(elmo-imap4-read-response session tag))))
(progn
+ (let ((exists (assq 'exists response))) ; update message count,
+ (when exists ; so merge update can go
+ (elmo-folder-set-info-hashtb folder nil (cadr exists))))
(elmo-imap4-session-set-current-mailbox-internal
session mailbox)
(elmo-imap4-session-set-read-only-internal
(elmo-imap4-get-session folder)))
elmo-enable-disconnected-operation)) ; offline refile.
-;(luna-define-method elmo-message-fetch-unplugged
-; ((folder elmo-imap4-folder)
-; number strategy &optional section outbuf unseen)
-; (error "%d%s is not cached." number (if section
-; (format "(%s)" section)
-; "")))
+;;;(luna-define-method elmo-message-fetch-unplugged
+;;; ((folder elmo-imap4-folder)
+;;; number strategy &optional section outbuf unseen)
+;;; (error "%d%s is not cached." number (if section
+;;; (format "(%s)" section)
+;;; "")))
(defsubst elmo-imap4-message-fetch (folder number strategy
section outbuf unseen)
number strategy
&optional section
outbuf unseen)
+ (when elmo-imap4-set-seen-flag-explicitly
+ (elmo-imap4-set-flag folder (list number) "\\Seen"))
(elmo-imap4-message-fetch folder number strategy section outbuf unseen))
(luna-define-method elmo-message-fetch-field ((folder elmo-imap4-folder)
projects / elisp / wanderlust.git / blobdiff