-;;; elmo-imap4.el -- IMAP4 Interface for ELMO.
+;;; elmo-imap4.el --- IMAP4 Interface for ELMO.
-;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 1999,2000 Kenichi OKADA <okada@opaopa.org>
+;; Copyright (C) 2000 OKAZAKI Tetsurou <okazaki@be.to>
+;; Copyright (C) 2000 Daiki Ueno <ueno@unixuser.org>
;; Author: Yuuichi Teranishi <teranisi@gohome.org>
+;; Kenichi OKADA <okada@opaopa.org>
+;; OKAZAKI Tetsurou <okazaki@be.to>
+;; Daiki Ueno <ueno@unixuser.org>
;; Keywords: mail, net news
;; This file is part of ELMO (Elisp Library for Message Orchestration).
;;
;;; Commentary:
-;;
+;;
+;; Origin of IMAP parser part is imap.el, included in Gnus.
+;;
+;; Copyright (C) 1998, 1999, 2000
+;; Free Software Foundation, Inc.
+;; Author: Simon Josefsson <jas@pdc.kth.se>
+;;
(require 'elmo-vars)
(require 'elmo-util)
-(require 'elmo-msgdb)
(require 'elmo-date)
+(require 'elmo-msgdb)
(require 'elmo-cache)
+(require 'elmo)
+(require 'elmo-net)
(require 'utf7)
+(require 'elmo-mime)
;;; Code:
-(condition-case nil
- (progn
- (require 'sasl))
- (error))
-;; silence byte compiler.
-(eval-when-compile
- (require 'cl)
- (condition-case nil
- (progn
- (require 'starttls)
- (require 'sasl))
- (error))
- (defun-maybe sasl-cram-md5 (username passphrase challenge))
- (defun-maybe sasl-digest-md5-digest-response
- (digest-challenge username passwd serv-type host &optional realm))
- (defun-maybe starttls-negotiate (a))
- (defun-maybe elmo-generic-list-folder-unread (spec mark-alist unread-marks))
- (defsubst-maybe utf7-decode-string (string &optional imap) string))
-
-(defvar elmo-imap4-use-lock t
- "USE IMAP4 with locking process.")
+(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.
+\(Except `\\Deleted' flag\).")
+
+(defvar elmo-imap4-overview-fetch-chop-length 200
+ "*Number of overviews to fetch in one request.")
+
+;; c.f. rfc2683 3.2.1.5 Long Command Lines
;;
-;; internal variables
+;; "A client should limit the length of the command lines it generates
+;; to approximately 1000 octets (including all quoted strings but not
+;; including literals). If the client is unable to group things into
+;; 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.
+;; 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
+;; to a command that does not end within the server's maximum accepted
+;; command length. "
+
+;; To limit command line length, chop number set.
+(defvar elmo-imap4-number-set-chop-length 1000
+ "*Number of messages to specify as a number-set argument for one request.")
+
+(defvar elmo-imap4-force-login nil
+ "*Non-nil forces to try 'login' if there is no 'auth' capability in imapd.")
+
+(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.")
+
+(defvar elmo-imap4-use-modified-utf7 nil
+ "*Use mofidied UTF-7 (rfc2060) encoding for IMAP4 folder name.")
+
+(defvar elmo-imap4-use-cache t
+ "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).
+REGEXP should have a grouping for namespace prefix.")
+;;
+;;; internal variables
;;
(defvar elmo-imap4-seq-prefix "elmo-imap4")
(defvar elmo-imap4-seqno 0)
-(defvar elmo-imap4-connection-cache nil
- "Cache of imap connection.")
(defvar elmo-imap4-use-uid t
"Use UID as message number.")
-;; buffer local variable
-(defvar elmo-imap4-read-point 0)
+(defvar elmo-imap4-current-response nil)
+(defvar elmo-imap4-status nil)
+(defvar elmo-imap4-reached-tag "elmo-imap40")
-(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) ")
+;;; buffer local variables
+(defvar elmo-imap4-default-hierarchy-delimiter "/")
-;; buffer local variable
(defvar elmo-imap4-server-capability nil)
(defvar elmo-imap4-server-namespace nil)
-(defvar elmo-imap4-lock nil)
-
-;; For debugging.
+(defvar elmo-imap4-parsing nil) ; indicates parsing.
+
+(defvar elmo-imap4-fetch-callback nil)
+(defvar elmo-imap4-fetch-callback-data nil)
+(defvar elmo-imap4-status-callback nil)
+(defvar elmo-imap4-status-callback-data nil)
+
+(defvar elmo-imap4-server-diff-async-callback nil)
+(defvar elmo-imap4-server-diff-async-callback-data nil)
+
+;;; progress...(no use?)
+(defvar elmo-imap4-count-progress nil)
+(defvar elmo-imap4-count-progress-message nil)
+(defvar elmo-imap4-progress-count nil)
+
+;;; XXX Temporal implementation
+(defvar elmo-imap4-current-msgdb nil)
+(defvar elmo-imap4-seen-messages nil)
+
+(defvar elmo-imap4-local-variables
+ '(elmo-imap4-status
+ elmo-imap4-current-response
+ elmo-imap4-seqno
+ elmo-imap4-parsing
+ elmo-imap4-reached-tag
+ elmo-imap4-count-progress
+ elmo-imap4-count-progress-message
+ elmo-imap4-progress-count
+ elmo-imap4-fetch-callback
+ elmo-imap4-fetch-callback-data
+ elmo-imap4-status-callback
+ elmo-imap4-status-callback-data
+ elmo-imap4-current-msgdb
+ elmo-imap4-seen-messages))
+
+;;;;
+
+(defconst elmo-imap4-quoted-specials-list '(?\\ ?\"))
+
+(defconst elmo-imap4-non-atom-char-regex
+ (eval-when-compile
+ (concat "[^" "]!#$&'+,./0-9:;<=>?@A-Z[^_`a-z|}~-" "]")))
+
+(defconst elmo-imap4-non-text-char-regex
+ (eval-when-compile
+ (concat "[^"
+ "]\x01-\x09\x0b\x0c\x0e-\x1f\x7f !\"#$%&'()*+,./0-9:;<=>?@A-Z[\\^_`a-z{|}~-"
+ "]")))
+
+(defconst elmo-imap4-literal-threshold 1024
+ "Limitation of characters that can be used in a quoted string.")
+
+;; For debugging.
(defvar elmo-imap4-debug nil
- "Non-nil forces IMAP4 folder as debug mode.
+ "Non-nil forces IMAP4 folder as debug mode.
Debug information is inserted in the buffer \"*IMAP4 DEBUG*\"")
-(defsubst elmo-imap4-debug (message &rest args)
- (if elmo-imap4-debug
- (with-current-buffer (get-buffer-create "*IMAP4 DEBUG*")
- (goto-char (point-max))
- (insert (apply 'format message args) "\n"))))
-
-(defun elmo-imap4-flush-connection ()
- (interactive)
- (let ((cache elmo-imap4-connection-cache)
- buffer process)
- (while cache
- (setq buffer (car (cdr (car cache))))
- (if buffer (kill-buffer buffer))
- (setq process (car (cdr (cdr (car cache)))))
- (if process (delete-process process))
- (setq cache (cdr cache)))
- (setq elmo-imap4-connection-cache nil)))
-
-(defsubst elmo-imap4-get-process (spec)
- (elmo-imap4-connection-get-process (elmo-imap4-get-connection spec)))
-
-(defun elmo-imap4-process-folder-list (string)
- (with-temp-buffer
- (let ((case-fold-search t)
- mailbox-list val)
- (elmo-set-buffer-multibyte nil)
- (insert string)
- (goto-char (point-min))
- ;; XXX This doesn't consider literal name response.
- (while (re-search-forward
- "\\* LIST (\\([^)]*\\)) \"[^\"]*\" \\([^\n]*\\)$" nil t)
- (unless (string-match "noselect"
- (elmo-match-buffer 1))
- (setq val (elmo-match-buffer 2))
- (if (string-match "^\"\\(.*\\)\"$" val)
- (setq val (match-string 1 val)))
- (setq mailbox-list
- (append mailbox-list
- (list val)))))
- mailbox-list)))
-
-(defun elmo-imap4-list-folders (spec &optional hierarchy)
- (save-excursion
- (let* ((root (elmo-imap4-spec-folder spec))
- (process (elmo-imap4-get-process spec))
- (delim (or
- (cdr
- (elmo-string-matched-assoc root
- (save-excursion
- (set-buffer
- (process-buffer process))
- elmo-imap4-server-namespace)))
- "/"))
- response result append-serv ssl)
- ;; Append delimiter
- (if (and root
- (not (string= root ""))
- (not (string-match (concat "\\(.*\\)"
- (regexp-quote delim)
- "\\'")
- root)))
- (setq root (concat root delim)))
- (elmo-imap4-send-command (process-buffer process)
- process
- (format "list \"%s\" *" root))
- (setq response (elmo-imap4-read-response (process-buffer process)
- process))
- (setq result (elmo-imap4-process-folder-list response))
- (unless (string= (elmo-imap4-spec-username spec)
- elmo-default-imap4-user)
- (setq append-serv (concat ":" (elmo-imap4-spec-username spec))))
- (unless (string= (elmo-imap4-spec-hostname spec)
- elmo-default-imap4-server)
- (setq append-serv (concat append-serv "@" (elmo-imap4-spec-hostname
- spec))))
- (unless (eq (elmo-imap4-spec-port spec)
- elmo-default-imap4-port)
- (setq append-serv (concat append-serv ":"
- (int-to-string
- (elmo-imap4-spec-port spec)))))
- (unless (eq (setq ssl (elmo-imap4-spec-ssl spec))
- elmo-default-imap4-ssl)
- (if ssl
- (setq append-serv (concat append-serv "!")))
- (if (eq ssl 'starttls)
- (setq append-serv (concat append-serv "!"))))
- (mapcar '(lambda (fld)
- (concat "%" (elmo-imap4-decode-folder-string fld)
- (and append-serv
- (eval append-serv))))
- result))))
-
-(defun elmo-imap4-folder-exists-p (spec)
- (let ((process (elmo-imap4-get-process spec)))
- (elmo-imap4-send-command (process-buffer process)
- process
- (format "status \"%s\" (messages)"
- (elmo-imap4-spec-folder spec)))
- (elmo-imap4-read-response (process-buffer process) process)))
-
-(defun elmo-imap4-folder-creatable-p (spec)
- t)
-
-(defun elmo-imap4-create-folder-maybe (spec dummy)
- "Create folder if necessary."
- (if (not (elmo-imap4-folder-exists-p spec))
- (elmo-imap4-create-folder spec)))
-
-(defun elmo-imap4-create-folder (spec)
- (let ((process (elmo-imap4-get-process spec))
- (folder (elmo-imap4-spec-folder spec)))
- (when folder
-;; For UW imapd 4.6, this workaround is needed to create #mh mailbox.
-; (if (string-match "^\\(#mh/\\).*[^/]$" folder)
-; (setq folder (concat folder "/"))) ;; make directory
- (elmo-imap4-send-command (process-buffer process)
- process
- (format "create %s" folder))
- (if (null (elmo-imap4-read-response (process-buffer process)
- process))
- (error "Create folder %s failed" folder)
- t))))
-
-(defun elmo-imap4-delete-folder (spec)
- (let ((process (elmo-imap4-get-process spec))
- msgs)
- (when (elmo-imap4-spec-folder spec)
- (when (setq msgs (elmo-imap4-list-folder spec))
- (elmo-imap4-delete-msgs spec msgs))
- (elmo-imap4-send-command (process-buffer process) process "close")
- (elmo-imap4-read-response (process-buffer process) process)
- (elmo-imap4-send-command (process-buffer process)
- process
- (format "delete %s"
- (elmo-imap4-spec-folder spec)))
- (if (null (elmo-imap4-read-response (process-buffer process)
- process))
- (error "Delete folder %s failed" (elmo-imap4-spec-folder spec))
- t))))
-
-(defun elmo-imap4-rename-folder (old-spec new-spec)
- (let ((process (elmo-imap4-get-process old-spec)))
- (when (elmo-imap4-spec-folder old-spec)
- (elmo-imap4-send-command (process-buffer process) process "close")
- (elmo-imap4-read-response (process-buffer process) process)
- (elmo-imap4-send-command (process-buffer process)
- process
- (format "rename %s %s"
- (elmo-imap4-spec-folder old-spec)
- (elmo-imap4-spec-folder new-spec)))
- (if (null (elmo-imap4-read-response (process-buffer process) process))
- (error "Rename folder from %s to %s failed"
- (elmo-imap4-spec-folder old-spec)
- (elmo-imap4-spec-folder new-spec))
- t))))
-
-(defun elmo-imap4-max-of-folder (spec)
- (save-excursion
- (let* ((process (elmo-imap4-get-process spec))
- response)
- (elmo-imap4-send-command (process-buffer process)
- process
- (format "status \"%s\" (uidnext messages)"
- (elmo-imap4-spec-folder spec)))
- (setq response (elmo-imap4-read-response (process-buffer process)
- process))
- (when (and response (string-match
- "\\* STATUS [^(]* \\(([^)]*)\\)" response))
- (setq response (read (downcase (elmo-match-string 1 response))))
- (cons (- (cadr (memq 'uidnext response)) 1)
- (cadr (memq 'messages response)))))))
-
-(defun elmo-imap4-get-connection (spec)
- (let* ((user (elmo-imap4-spec-username spec))
- (server (elmo-imap4-spec-hostname spec))
- (port (elmo-imap4-spec-port spec))
- (auth (elmo-imap4-spec-auth spec))
- (ssl (elmo-imap4-spec-ssl spec))
- (user-at-host (format "%s@%s" user server))
- ret-val result buffer process proc-stat
- user-at-host-on-port)
- (if (not (elmo-plugged-p server port))
- (error "Unplugged"))
- (setq user-at-host-on-port
- (concat user-at-host ":" (int-to-string port)
- (if (eq ssl 'starttls) "!!" (if ssl "!"))))
- (setq ret-val (assoc user-at-host-on-port
- elmo-imap4-connection-cache))
- (if (and ret-val
- (or (eq (setq proc-stat
- (process-status (cadr (cdr ret-val))))
- 'closed)
- (eq proc-stat 'exit)))
- ;; connection is closed...
- (progn
- (kill-buffer (car (cdr ret-val)))
- (setq elmo-imap4-connection-cache
- (delete ret-val elmo-imap4-connection-cache))
- (setq ret-val nil)))
- (if ret-val
- (progn
- (setq ret-val (cdr ret-val)) ;; connection cache exists.
- ret-val)
- (setq result
- (elmo-imap4-open-connection server user auth port
- (elmo-get-passwd user-at-host)
- ssl))
- (if (null result)
- (error "Connection failed"))
- (elmo-imap4-debug "Connected to %s" user-at-host-on-port)
- (setq buffer (car result))
- (setq process (cdr result))
- (when (and process (null buffer))
- (elmo-remove-passwd user-at-host)
- (delete-process process)
- (error "Login failed"))
- (setq elmo-imap4-connection-cache
- (append elmo-imap4-connection-cache
- (list
- (cons user-at-host-on-port
- (setq ret-val (list buffer process
- ""; current-folder..
- ))))))
- ret-val)))
-
-(defun elmo-imap4-process-filter (process output)
- (save-match-data
+(defvar elmo-imap4-debug-inhibit-logging nil)
+
+;;; ELMO IMAP4 folder
+(eval-and-compile
+ (luna-define-class elmo-imap4-folder (elmo-net-folder)
+ (mailbox))
+ (luna-define-internal-accessors 'elmo-imap4-folder))
+
+;;; Session
+(eval-and-compile
+ (luna-define-class elmo-imap4-session (elmo-network-session)
+ (capability current-mailbox read-only))
+ (luna-define-internal-accessors 'elmo-imap4-session))
+
+;;; MIME-ELMO-IMAP Location
+(eval-and-compile
+ (luna-define-class mime-elmo-imap-location
+ (mime-imap-location)
+ (folder number rawbuf strategy))
+ (luna-define-internal-accessors 'mime-elmo-imap-location))
+
+;;; Debug
+(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
+ (utf7-decode-string string 'imap)
+ string))
+
+(defsubst elmo-imap4-encode-folder-string (string)
+ (if elmo-imap4-use-modified-utf7
+ (utf7-encode-string string 'imap)
+ string))
+
+;;; Response
+
+(defmacro elmo-imap4-response-continue-req-p (response)
+ "Returns non-nil if RESPONSE is '+' response."
+ (` (assq 'continue-req (, response))))
+
+(defmacro elmo-imap4-response-ok-p (response)
+ "Returns non-nil if RESPONSE is an 'OK' response."
+ (` (assq 'ok (, response))))
+
+(defmacro elmo-imap4-response-bye-p (response)
+ "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)))))
+
+(defsubst elmo-imap4-response-value-all (response symbol)
+ "Get all value of the SYMBOL from RESPONSE."
+ (let (matched)
+ (while response
+ (if (eq (car (car response)) symbol)
+ (setq matched (nconc matched (nth 1 (car response)))))
+ (setq response (cdr response)))
+ matched))
+
+(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)))))
+
+(defmacro elmo-imap4-response-bodydetail-text (response)
+ "Returns text of BODY[section]<partial>."
+ (` (nth 3 (assq 'bodydetail (, response)))))
+
+;;; 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.
+Returns RESPONSE (parsed lisp object) of IMAP session.
+If response is not `OK', causes error with IMAP response text."
+ (elmo-imap4-accept-ok session
+ (elmo-imap4-send-command
+ session
+ command)))
+
+(defun elmo-imap4-send-command (session command)
+ "Send COMMAND to the SESSION.
+Returns a TAG string which is assigned to the COMMAND."
+ (let* ((command-args (if (listp command)
+ command
+ (list command)))
+ (process (elmo-network-session-process-internal session))
+ cmdstr tag token kind)
(with-current-buffer (process-buffer process)
- (goto-char (point-max))
- (insert output)
- (forward-line -1)
- (beginning-of-line)
- (if (looking-at (concat
- "\\(^"
- elmo-imap4-seq-prefix
- (int-to-string elmo-imap4-seqno)
- "\\|^\\* OK\\|^\\* BYE\\'\\|^\\+\\)[^\n]*\n\\'"))
- (progn
- (setq elmo-imap4-lock nil) ; unlock process buffer.
- (elmo-imap4-debug "unlock(%d) %s" elmo-imap4-seqno output))
- (elmo-imap4-debug "continue(%d) %s" elmo-imap4-seqno output))
- (goto-char (point-max)))))
-
-(defun elmo-imap4-read-response (buffer process &optional not-command)
- (save-excursion
- (set-buffer buffer)
- (let ((case-fold-search nil)
- (response-string nil)
- (response-continue t)
- (return-value nil)
- match-end)
- (while response-continue
- (goto-char elmo-imap4-read-point)
- (while (not (search-forward "\r\n" nil t))
- (accept-process-output process)
- (goto-char elmo-imap4-read-point))
-
- (setq match-end (point))
- (setq response-string
- (buffer-substring elmo-imap4-read-point (- match-end 2)))
- (goto-char elmo-imap4-read-point)
- (if (looking-at (format "%s[0-9]+ OK.*$\\|\\+.*$"
- elmo-imap4-seq-prefix))
- (progn (setq response-continue nil)
- (setq elmo-imap4-read-point match-end)
- (setq return-value
- (if return-value
- (concat return-value "\n" response-string)
- response-string)))
- (if (looking-at (format "\\(. BYE.*\\|%s[0-9]+ \\(NO\\|BAD\\).*\\)$"
- elmo-imap4-seq-prefix))
- (progn (setq response-continue nil)
- (setq elmo-imap4-read-point match-end)
- (elmo-imap4-debug "error response: %s" response-string)
- (setq return-value nil))
- (setq elmo-imap4-read-point match-end)
- (if not-command
- (setq response-continue nil))
- (setq return-value
- (if return-value
- (concat return-value "\n" response-string)
- response-string)))
- (setq elmo-imap4-read-point match-end)))
- return-value)))
-
-(defun elmo-imap4-read-contents (buffer process)
- "Read OK response"
- (save-excursion
- (set-buffer buffer)
- (let ((case-fold-search nil)
- (response-string nil)
- match-end)
- (goto-char elmo-imap4-read-point)
- (while (not (re-search-forward
- (format "%s[0-9]+ \\(NO\\|BAD\\|OK\\).*$"
- elmo-imap4-seq-prefix)
- nil t))
- (accept-process-output process)
- (goto-char elmo-imap4-read-point))
- (beginning-of-line)
- (setq match-end (point))
- (setq response-string (buffer-substring
- elmo-imap4-read-point match-end))
- (if (eq (length response-string) 0)
- nil
- response-string))))
-
-(defun elmo-imap4-read-bytes (buffer process bytes)
- (save-excursion
- (set-buffer buffer)
- (let ((case-fold-search nil)
- (return-value nil)
- start gc-message)
- (setq start elmo-imap4-read-point);; starting point
- (while (< (point-max) (+ start bytes))
- (accept-process-output process))
- (setq return-value (buffer-substring
- start (+ start bytes)))
- (setq return-value (elmo-delete-cr return-value))
- (setq elmo-imap4-read-point bytes)
- return-value)))
-
-(defun elmo-imap4-read-body (buffer process bytes outbuf)
- (let (start gc-message ret-val)
- (with-current-buffer buffer
- (setq start elmo-imap4-read-point)
- (while (< (point-max) (+ start bytes))
- (accept-process-output process))
- (with-current-buffer outbuf
+ (setq tag (concat elmo-imap4-seq-prefix
+ (number-to-string
+ (setq elmo-imap4-seqno (+ 1 elmo-imap4-seqno)))))
+ (setq cmdstr (concat tag " "))
+ ;; (erase-buffer) No need.
+ (goto-char (point-min))
+ (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)"))
+ (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)))
+ ((listp token) ; unformatted
+ (setq kind (car token))
+ (cond ((eq kind 'atom)
+ (setq cmdstr (concat cmdstr (nth 1 token))))
+ ((eq kind 'quoted)
+ (setq cmdstr (concat
+ 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)
+ (cond ((stringp (nth 1 token))
+ (setq cmdstr (nth 1 token)))
+ ((bufferp (nth 1 token))
+ (with-current-buffer (nth 1 token)
+ (process-send-region
+ process
+ (point-min)
+ (+ (point-min) (nth 2 token)))))
+ (t
+ (error "Wrong argument for literal"))))
+ (t
+ (error "Unknown token kind %s" kind))))
+ (t
+ (error "Invalid argument")))
+ (setq command-args (cdr command-args)))
+ (if cmdstr
+ (process-send-string process cmdstr))
+ (process-send-string process "\r\n")
+ tag)))
+
+(defun elmo-imap4-send-string (session string)
+ "Send STRING to the SESSION."
+ (with-current-buffer (process-buffer
+ (elmo-network-session-process-internal session))
+ (setq elmo-imap4-current-response nil)
+ (goto-char (point-min))
+ (elmo-imap4-debug "<-- %s" string)
+ (process-send-string (elmo-network-session-process-internal session)
+ string)
+ (process-send-string (elmo-network-session-process-internal session)
+ "\r\n")))
+
+(defun elmo-imap4-read-response (session tag)
+ "Read parsed response from SESSION.
+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)
+ (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))
+ (accept-process-output (elmo-network-session-process-internal session)
+ 1)))
+ (elmo-imap4-debug "=>%s" (prin1-to-string elmo-imap4-current-response))
+ (setq elmo-imap4-parsing nil)
+ elmo-imap4-current-response))
+
+(defsubst elmo-imap4-read-untagged (process)
+ (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-current-response))
+
+(defun elmo-imap4-read-continue-req (session)
+ "Returns a text following to continue-req in SESSION.
+If response is not `+' response, returns nil."
+ (elmo-imap4-response-value
+ (elmo-imap4-read-untagged
+ (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."
+ (let (response)
+ (setq response
+ (elmo-imap4-read-untagged
+ (elmo-network-session-process-internal session)))
+ (or (elmo-imap4-response-continue-req-p response)
+ (error "IMAP error: %s"
+ (or (elmo-imap4-response-error-text response)
+ "No continut-req from server.")))))
+
+(defun elmo-imap4-read-ok (session tag)
+ "Returns non-nil if `OK' response of the command with TAG is arrived
+in SESSION. If response is not `OK' response, returns nil."
+ (elmo-imap4-response-ok-p
+ (elmo-imap4-read-response session tag)))
+
+(defun elmo-imap4-accept-ok (session tag)
+ "Accept only `OK' response from SESSION.
+If response is not `OK' response, causes error with IMAP response text."
+ (let ((response (elmo-imap4-read-response session tag)))
+ (if (elmo-imap4-response-ok-p response)
+ response
+ (if (elmo-imap4-response-bye-p 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)
+ section)
+ (if (and (stringp section)
+ (string= section "HEADER"))
+ ;; Even in the section mode, header fields should be saved to the
+ ;; raw buffer .
+ (with-current-buffer (mime-elmo-imap-location-rawbuf-internal location)
(erase-buffer)
- (insert-buffer-substring buffer start (+ start bytes))
- (setq ret-val (elmo-delete-cr-get-content-type)))
- (setq elmo-imap4-read-point (+ start bytes))
- ret-val)))
-
-(defun elmo-imap4-noop (connection)
- (let ((buffer (car connection))
- (process (cadr connection)))
- (save-excursion
- (elmo-imap4-send-command buffer
- process "noop")
- (elmo-imap4-read-response buffer process))))
-
-(defun elmo-imap4-commit (spec)
- (save-excursion
- (let ((connection (elmo-imap4-get-connection spec))
- response ret-val beg end)
- (and (not (null (elmo-imap4-spec-folder spec)))
- (if (not (string= (elmo-imap4-connection-get-cwf connection)
- (elmo-imap4-spec-folder spec)))
- (if (null (setq response
- (elmo-imap4-select-folder
- (elmo-imap4-spec-folder spec)
- connection)))
- (error "Select folder failed"))
- (if elmo-imap4-use-select-to-update-status
- (elmo-imap4-select-folder
- (elmo-imap4-spec-folder spec)
- connection)
- (elmo-imap4-check connection)))))))
-
-(defun elmo-imap4-check (connection)
- (let ((process (elmo-imap4-connection-get-process connection)))
- (save-excursion
- (elmo-imap4-send-command (process-buffer process)
- process "check")
- (elmo-imap4-read-response (process-buffer process) process))))
-
-(defun elmo-imap4-select-folder (folder connection)
- (let ((process (elmo-imap4-connection-get-process connection))
- response)
- (save-excursion
+ (elmo-message-fetch
+ (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)
+ (buffer-string))
+ (elmo-message-fetch
+ (mime-elmo-imap-location-folder-internal location)
+ (mime-elmo-imap-location-number-internal location)
+ (mime-elmo-imap-location-strategy-internal location)
+ section
+ nil 'unseen)))
+
+
+(luna-define-method mime-imap-location-bodystructure
+ ((location mime-elmo-imap-location))
+ (elmo-imap4-fetch-bodystructure
+ (mime-elmo-imap-location-folder-internal location)
+ (mime-elmo-imap-location-number-internal location)
+ (mime-elmo-imap-location-strategy-internal location)))
+
+(luna-define-method mime-imap-location-fetch-entity-p
+ ((location mime-elmo-imap-location) entity)
+ (or (not elmo-message-displaying) ; Fetching entity to save or force display.
+ ;; cache exists
+ (file-exists-p
+ (expand-file-name
+ (mmimap-entity-section (mime-entity-node-id-internal entity))
+ (elmo-fetch-strategy-cache-path
+ (mime-elmo-imap-location-strategy-internal location))))
+ ;; not too large to fetch.
+ (> elmo-message-fetch-threshold
+ (or (mime-imap-entity-size-internal entity) 0))))
+
+;;;
+
+(defun elmo-imap4-session-check (session)
+ (with-current-buffer (elmo-network-session-buffer session)
+ (setq elmo-imap4-fetch-callback nil)
+ (setq elmo-imap4-fetch-callback-data nil))
+ (elmo-imap4-send-command-wait session "check"))
+
+(defun elmo-imap4-atom-p (string)
+ "Return t if STRING is an atom defined in rfc2060."
+ (if (string= string "")
+ nil
+ (save-match-data
+ (not (string-match elmo-imap4-non-atom-char-regex string)))))
+
+(defun elmo-imap4-quotable-p (string)
+ "Return t if STRING can be formatted as a quoted defined in rfc2060."
+ (save-match-data
+ (not (string-match elmo-imap4-non-text-char-regex string))))
+
+(defun elmo-imap4-nil (string)
+ "Return a list represents the special atom \"NIL\" defined in rfc2060, \
+if STRING is nil.
+Otherwise return nil."
+ (if (eq string nil)
+ (list 'atom "NIL")))
+
+(defun elmo-imap4-atom (string)
+ "Return a list represents STRING as an atom defined in rfc2060.
+Return nil if STRING is not an atom. See `elmo-imap4-atom-p'."
+ (if (elmo-imap4-atom-p string)
+ (list 'atom string)))
+
+(defun elmo-imap4-quoted (string)
+ "Return a list represents STRING as a quoted defined in rfc2060.
+Return nil if STRING can not be formatted as a quoted. See `elmo-imap4-quotable-p'."
+ (if (elmo-imap4-quotable-p string)
+ (list 'quoted string)))
+
+(defun elmo-imap4-literal-1 (string-or-buffer length)
+ "Internal function for `elmo-imap4-literal' and `elmo-imap4-buffer-literal'.
+Return a list represents STRING-OR-BUFFER as a literal defined in rfc2060.
+STRING-OR-BUFFER must be an encoded string or a single-byte string or a single-byte buffer.
+LENGTH must be the number of octets for STRING-OR-BUFFER."
+ (list 'literal string-or-buffer length))
+
+(defun elmo-imap4-literal (string)
+ "Return a list represents STRING as a literal defined in rfc2060.
+STRING must be an encoded or a single-byte string."
+ (elmo-imap4-literal-1 string (length string)))
+
+(defun elmo-imap4-buffer-literal (buffer)
+ "Return a list represents BUFFER as a literal defined in rfc2060.
+BUFFER must be a single-byte buffer."
+ (elmo-imap4-literal-1 buffer (with-current-buffer buffer
+ (buffer-size))))
+
+(defun elmo-imap4-string-1 (string length)
+ "Internal function for `elmo-imap4-string' and `elmo-imap4-buffer-string'.
+Return a list represents STRING as a string defined in rfc2060.
+STRING must be an encoded or a single-byte string.
+LENGTH must be the number of octets for STRING."
+ (or (elmo-imap4-quoted string)
+ (elmo-imap4-literal-1 string length)))
+
+(defun elmo-imap4-string (string)
+ "Return a list represents STRING as a string defined in rfc2060.
+STRING must be an encoded or a single-byte string."
+ (let ((length (length string)))
+ (if (< elmo-imap4-literal-threshold length)
+ (elmo-imap4-literal-1 string length)
+ (elmo-imap4-string-1 string length))))
+
+(defun elmo-imap4-buffer-string (buffer)
+ "Return a list represents BUFFER as a string defined in rfc2060.
+BUFFER must be a single-byte buffer."
+ (let ((length (with-current-buffer buffer
+ (buffer-size))))
+ (if (< elmo-imap4-literal-threshold length)
+ (elmo-imap4-literal-1 buffer length)
+ (elmo-imap4-string-1 (with-current-buffer buffer
+ (buffer-string))
+ length))))
+
+(defun elmo-imap4-astring-1 (string length)
+ "Internal function for `elmo-imap4-astring' and `elmo-imap4-buffer-astring'.
+Return a list represents STRING as an astring defined in rfc2060.
+STRING must be an encoded or a single-byte string.
+LENGTH must be the number of octets for STRING."
+ (or (elmo-imap4-atom string)
+ (elmo-imap4-string-1 string length)))
+
+(defun elmo-imap4-astring (string)
+ "Return a list represents STRING as an astring defined in rfc2060.
+STRING must be an encoded or a single-byte string."
+ (let ((length (length string)))
+ (if (< elmo-imap4-literal-threshold length)
+ (elmo-imap4-literal-1 string length)
+ (elmo-imap4-astring-1 string length))))
+
+(defun elmo-imap4-buffer-astring (buffer)
+ "Return a list represents BUFFER as an astring defined in rfc2060.
+BUFFER must be a single-byte buffer."
+ (let ((length (with-current-buffer buffer
+ (buffer-size))))
+ (if (< elmo-imap4-literal-threshold length)
+ (elmo-imap4-literal-1 buffer length)
+ (elmo-imap4-astring-1 (with-current-buffer buffer
+ (buffer-string))
+ length))))
+
+(defun elmo-imap4-nstring (string)
+ "Return a list represents STRING as a nstring defined in rfc2060.
+STRING must be an encoded or a single-byte string."
+ (or (elmo-imap4-nil string)
+ (elmo-imap4-string string)))
+
+(defun elmo-imap4-buffer-nstring (buffer)
+ "Return a list represents BUFFER as a nstring defined in rfc2060.
+BUFFER must be a single-byte buffer."
+ (or (elmo-imap4-nil buffer)
+ (elmo-imap4-buffer-string buffer)))
+
+(defalias 'elmo-imap4-mailbox 'elmo-imap4-astring)
+(defalias 'elmo-imap4-field-body 'elmo-imap4-astring)
+(defalias 'elmo-imap4-userid 'elmo-imap4-astring)
+(defalias 'elmo-imap4-password 'elmo-imap4-astring)
+
+(defun elmo-imap4-format-quoted (string)
+ "Return STRING in a form of the quoted-string defined in rfc2060."
+ (concat "\""
+ (std11-wrap-as-quoted-pairs string elmo-imap4-quoted-specials-list)
+ "\""))
+
+(defsubst elmo-imap4-response-get-selectable-mailbox-list (response)
+ (delq nil
+ (mapcar
+ (lambda (entry)
+ (if (and (eq 'list (car entry))
+ (not (member "\\NoSelect" (nth 1 (nth 1 entry)))))
+ (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."
+ (if (elmo-fetch-strategy-use-cache strategy)
+ (elmo-object-load
+ (elmo-file-cache-expand-path
+ (elmo-fetch-strategy-cache-path strategy)
+ "bodystructure"))
+ (let ((session (elmo-imap4-get-session folder))
+ bodystructure)
+ (elmo-imap4-session-select-mailbox
+ session
+ (elmo-imap4-folder-mailbox-internal folder))
+ (with-current-buffer (elmo-network-session-buffer session)
+ (setq elmo-imap4-fetch-callback nil)
+ (setq elmo-imap4-fetch-callback-data nil))
+ (prog1 (setq bodystructure
+ (elmo-imap4-response-value
+ (elmo-imap4-response-value
+ (elmo-imap4-send-command-wait
+ session
+ (format
+ (if elmo-imap4-use-uid
+ "uid fetch %s bodystructure"
+ "fetch %s bodystructure")
+ number))
+ 'fetch)
+ 'bodystructure))
+ (when (elmo-fetch-strategy-save-cache strategy)
+ (elmo-file-cache-delete
+ (elmo-fetch-strategy-cache-path strategy))
+ (elmo-object-save
+ (elmo-file-cache-expand-path
+ (elmo-fetch-strategy-cache-path strategy)
+ "bodystructure")
+ bodystructure))))))
+
+;;; Backend methods.
+(luna-define-method elmo-create-folder-plugged ((folder elmo-imap4-folder))
+ (elmo-imap4-send-command-wait
+ (elmo-imap4-get-session folder)
+ (list "create " (elmo-imap4-mailbox
+ (elmo-imap4-folder-mailbox-internal folder)))))
+
+(defun elmo-imap4-get-session (folder &optional if-exists)
+ (elmo-network-get-session 'elmo-imap4-session
+ (concat
+ (if (elmo-folder-biff-internal folder)
+ "BIFF-")
+ "IMAP")
+ folder if-exists))
+
+(defun elmo-imap4-session-select-mailbox (session mailbox
+ &optional force no-error)
+ "Select MAILBOX in SESSION.
+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=
+ (elmo-imap4-session-current-mailbox-internal session)
+ mailbox)))
+ (let (response result)
(unwind-protect
- (progn
- (elmo-imap4-send-command (process-buffer process)
- process (format "select \"%s\""
- folder))
- (setq response (elmo-imap4-read-response
- (process-buffer process) process)))
- (if (null response)
+ (setq response
+ (elmo-imap4-read-response
+ session
+ (elmo-imap4-send-command
+ session
+ (list
+ "select "
+ (elmo-imap4-mailbox mailbox)))))
+ (if (setq result (elmo-imap4-response-ok-p response))
(progn
- (setcar (cddr connection) nil)
- (error "Select folder failed"))
- (setcar (cddr connection) folder))))
- response))
+ (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 (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)
- "get uidvalidity value from server and compare it with validity-file."
- (let* ((process (elmo-imap4-get-process spec))
- response)
- (save-excursion
- (elmo-imap4-send-command (process-buffer process)
- process
- (format "status \"%s\" (uidvalidity)"
- (elmo-imap4-spec-folder spec)))
- (setq response (elmo-imap4-read-response
- (process-buffer process) process))
- (if (string-match "UIDVALIDITY \\([0-9]+\\)" response)
- (string= (elmo-get-file-string validity-file)
- (elmo-match-string 1 response))
- nil))))
+;;; Not used.
+;;;(elmo-imap4-send-command-wait
+;;;(elmo-imap4-get-session spec)
+;;;(list "status "
+;;; (elmo-imap4-mailbox
+;;; (elmo-imap4-spec-mailbox spec))
+;;; " (uidvalidity)")))
+ )
(defun elmo-imap4-sync-validity (spec validity-file)
- "get uidvalidity value from server and save it to validity-file."
- (let* ((process (elmo-imap4-get-process spec))
- response)
- (save-excursion
- (elmo-imap4-send-command (process-buffer process)
- process
- (format "status \"%s\" (uidvalidity)"
- (elmo-imap4-spec-folder spec)))
- (setq response (elmo-imap4-read-response
- (process-buffer process) process))
- (if (string-match "UIDVALIDITY \\([0-9]+\\)" response)
- (progn
- (elmo-save-string
- (elmo-match-string 1 response)
- validity-file)
- t)
- nil))))
-
-(defsubst elmo-imap4-list (spec str)
- (save-excursion
- (let* ((connection (elmo-imap4-get-connection spec))
- (process (elmo-imap4-connection-get-process connection))
- response ret-val beg end)
- (and (elmo-imap4-spec-folder spec)
- (if (not (string= (elmo-imap4-connection-get-cwf connection)
- (elmo-imap4-spec-folder spec)))
- (if (null (setq response
- (elmo-imap4-select-folder
- (elmo-imap4-spec-folder spec)
- connection)))
- (error "Select folder failed"))
- ;; for status update.
- (if elmo-imap4-use-select-to-update-status
- (elmo-imap4-select-folder (elmo-imap4-spec-folder spec)
- connection)
- (unless (elmo-imap4-check connection)
- ;; Check failed...not selected??
- (elmo-imap4-select-folder (elmo-imap4-spec-folder spec)
- connection)))))
- (elmo-imap4-send-command (process-buffer process)
- process
- (format (if elmo-imap4-use-uid
- "uid search %s"
- "search %s") str))
- (setq response (elmo-imap4-read-response (process-buffer process)
- process))
- (if (and response (string-match "\\* SEARCH" response))
- (progn
- (setq response (substring response (match-end 0)))
- (if (string-match "\n" response)
- (progn
- (setq end (match-end 0))
- (setq ret-val (read (concat "(" (substring
- response
- 0 end) ")"))))
- (error "SEARCH failed"))))
- ret-val)))
-
-(defun elmo-imap4-list-folder (spec)
- (elmo-imap4-list spec "all"))
-
-(defun elmo-imap4-list-folder-unread (spec mark-alist unread-marks)
- (if (elmo-imap4-use-flag-p spec)
- (elmo-imap4-list spec "unseen")
- (elmo-generic-list-folder-unread spec mark-alist unread-marks)))
-
-(defun elmo-imap4-list-folder-important (spec overview)
- (and (elmo-imap4-use-flag-p spec)
- (elmo-imap4-list spec "flagged")))
-
-(defun elmo-imap4-search-internal (process buffer filter)
- (let ((search-key (elmo-filter-key filter))
- word response)
- (cond
- ((or (string= "since" search-key)
- (string= "before" search-key))
- (setq search-key (concat "sent" search-key))
- (elmo-imap4-send-command buffer process
- (format
- (if elmo-imap4-use-uid
- "uid search %s %s"
- " search %s %s")
- search-key
- (elmo-date-get-description
- (elmo-date-get-datevec
- (elmo-filter-value filter))))))
- (t
- (setq word (encode-mime-charset-string (elmo-filter-value filter)
- elmo-search-mime-charset))
- (elmo-imap4-send-command buffer process
- (format
- (if elmo-imap4-use-uid
- "uid search CHARSET %s%s %s {%d}"
- " search CHARSET %s%s %s {%d}")
- (symbol-name elmo-search-mime-charset)
- (if (eq (elmo-filter-type filter) 'unmatch)
- " not" "")
- (elmo-filter-key filter)
- (length word)))
- (if (null (elmo-imap4-read-response buffer process t))
- (error "Searching failed because of server capability??"))
- (elmo-imap4-send-string buffer process word)))
- (if (null (setq response (elmo-imap4-read-response buffer process)))
- (error "Search failed for %s" (elmo-filter-key filter)))
- (if (string-match "^\\* SEARCH\\([^\n]*\\)$" response)
- (read (concat "(" (elmo-match-string 1 response) ")"))
- (error "SEARCH failed"))))
-
-(defun elmo-imap4-search (spec condition &optional from-msgs)
- (save-excursion
- (let* ((connection (elmo-imap4-get-connection spec))
- (process (elmo-imap4-connection-get-process connection))
- response ret-val len word)
- (if (and (elmo-imap4-spec-folder spec)
- (not (string= (elmo-imap4-connection-get-cwf connection)
- (elmo-imap4-spec-folder spec)))
- (null (elmo-imap4-select-folder
- (elmo-imap4-spec-folder spec) connection)))
- (error "Select folder failed"))
- (while condition
- (setq response (elmo-imap4-search-internal process
- (process-buffer process)
- (car condition)))
- (setq ret-val (nconc ret-val response))
- (setq condition (cdr condition)))
- (if from-msgs
- (elmo-list-filter
- from-msgs
- (elmo-uniq-list (sort ret-val '<)))
- (elmo-uniq-list (sort ret-val '<))))))
-
-(defsubst elmo-imap4-value (value)
- (if (eq value 'NIL) nil
- value))
-
-(defmacro elmo-imap4-nth (pos list)
- (` (let ((value (nth (, pos) (, list))))
- (if (eq 'NIL value)
- nil
- value))))
-
-(defun elmo-imap4-use-flag-p (spec)
- (not (string-match elmo-imap4-disuse-server-flag-mailbox-regexp
- (elmo-imap4-spec-folder spec))))
-
-(defsubst elmo-imap4-make-address (name mbox host)
- (cond (name
- (concat name " <" mbox "@" host ">"))
- (t
- (concat mbox "@" host))))
+ ;; Not used.
+ )
-(static-cond
+(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)))
+
+(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
- ;; Cannot parse dot symbol, replace it.
+ (t
+ ;;; For Nemacs.
+ ;; Cannot parse dot symbol.
(defvar elmo-imap4-rfc822-size "RFC822_SIZE")
(defvar elmo-imap4-header-fields "HEADER_FIELDS")
- (defmacro elmo-imap4-replace-dot-symbols ()
- (goto-char (point-min))
- (while (re-search-forward "RFC822\\.SIZE" nil t)
- (replace-match elmo-imap4-rfc822-size))
- (goto-char (point-min))
- (while (re-search-forward "HEADER\\.FIELDS" nil t)
- (replace-match elmo-imap4-header-fields))
- (goto-char (point-min)))))
-
-(defsubst elmo-imap4-make-attributes-object (string)
- (save-match-data
- (elmo-set-work-buf
- (elmo-set-buffer-multibyte nil)
- (insert string)
- (goto-char (point-min))
- (let ((case-fold-search t))
- (goto-char (point-min))
- (while (re-search-forward "{\\([0-9]+\\)}\r\n" nil t)
- (let (str)
- (goto-char (+ (point)
- (string-to-int (elmo-match-buffer 1))))
- (setq str (save-match-data
- (elmo-replace-in-string
- (buffer-substring (match-end 0) (point))
- "\r" "")))
- (delete-region (match-beginning 0) (point))
- (insert (prin1-to-string str))))
- (goto-char (point-min))
- (elmo-imap4-replace-dot-symbols)
- (read (current-buffer))))))
-
-
-(defun elmo-imap4-parse-overview-string (string)
- (if (null string)
- (error "Getting overview failed"))
- (with-temp-buffer
- (let (ret-val beg attr number)
- (elmo-set-buffer-multibyte nil)
- (insert string)
- (goto-char (point-min))
- (setq beg (point))
- (if (re-search-forward "^\* \\([0-9]+\\) FETCH"
- nil t)
- (progn
- (setq beg (point))
- (unless elmo-imap4-use-uid
- (setq number (string-to-int (elmo-match-buffer 1))))
- (while (re-search-forward
- "^\* \\([0-9]+\\) FETCH"
- nil t)
- (setq attr (elmo-imap4-make-attributes-object
- (buffer-substring beg (match-beginning 0))))
- (setq beg (point))
- (unless elmo-imap4-use-uid
- (setq attr(nconc (list 'UID number) attr))
- (setq number (string-to-int (elmo-match-buffer 1))))
- (setq ret-val (cons attr ret-val)))
- ;; process last one...
- (setq attr (elmo-imap4-make-attributes-object
- (buffer-substring beg (point-max))))
- (unless elmo-imap4-use-uid
- (setq attr(nconc (list 'UID number) attr)))
- (setq ret-val (cons attr ret-val))))
- (nreverse ret-val))))
-
-(defun elmo-imap4-create-msgdb-from-overview-string (str
- folder
- new-mark
- already-mark
- seen-mark
- important-mark
- seen-list
- &optional numlist)
- (let ((case-fold-search t)
- (size-sym (intern elmo-imap4-rfc822-size))
- overview attr-list attr pair section
- number important message-id from-list from-string
- to-string cc-string
- number-alist mark-alist
- reference subject date-string size flags gmark seen
- index extras extra-fields sym value)
- (setq attr-list (elmo-imap4-parse-overview-string str))
- (while attr-list
- (setq attr (car attr-list))
- ;; Remove section data. (origin octed is not considered.(OK?))
- (setq section (cadr (memq 'BODY attr)))
- (if (vectorp section)
- (delq section attr))
- ;; number
- (setq number (cadr (memq 'UID attr)))
- (when (or (null numlist)
- (memq number numlist))
- (while attr
- (setq sym (car attr))
- (setq value (cadr attr))
- (setq attr (cdr (cdr attr)))
- (cond
- ((eq sym 'UID))
- ;; noop
- ((eq sym 'FLAGS)
- (setq flags value))
- ((eq sym size-sym)
- (setq size value))
- ((eq sym 'BODY)
- (setq extra-fields (elmo-collect-field-from-string value t)))
- ((eq sym 'ENVELOPE)
- ;; According to rfc2060,
- ;; 0 date, 1 subject, 2 from, 3 sender,
- ;; 4 reply-to, 5 to, 6 cc, 7 bcc, 8 in-reply-to, 9 message-id.
- (setq date-string (elmo-imap4-nth 0 value))
- (setq subject (elmo-mime-string (or (elmo-imap4-nth 1 value)
- elmo-no-subject)))
- (setq from-list (car (elmo-imap4-nth 2 value)))
- (setq from-string (or
- (and (or (elmo-imap4-nth 0 from-list)
- (elmo-imap4-nth 2 from-list)
- (elmo-imap4-nth 3 from-list))
- (elmo-delete-char
- ?\"
- (elmo-imap4-make-address
- (elmo-imap4-nth 0 from-list)
- (elmo-imap4-nth 2 from-list)
- (elmo-imap4-nth 3 from-list))
- 'uni))
- elmo-no-from))
- (setq to-string (mapconcat
- '(lambda (to)
- (elmo-imap4-make-address
- (elmo-imap4-nth 0 to)
- (elmo-imap4-nth 2 to)
- (elmo-imap4-nth 3 to)))
- (elmo-imap4-nth 5 value) ","))
- (setq cc-string (mapconcat
- '(lambda (cc)
- (elmo-imap4-make-address
- (elmo-imap4-nth 0 cc)
- (elmo-imap4-nth 2 cc)
- (elmo-imap4-nth 3 cc)))
- (elmo-imap4-nth 6 value) ","))
- (setq reference (elmo-msgdb-get-last-message-id
- (elmo-imap4-nth 8 value)))
- (setq message-id (elmo-imap4-nth 9 value)))))
- (when (setq pair (assoc "references" extra-fields))
- (setq extra-fields (delq pair extra-fields)))
- (unless reference
- (setq reference (elmo-msgdb-get-last-message-id (cdr pair))))
- (setq overview
- (elmo-msgdb-append-element
- overview
- (cons message-id
- (vector number
- reference
- (elmo-mime-string from-string)
- (elmo-mime-string subject)
- date-string
- to-string
- cc-string
- size
- extra-fields))))
- (if (memq 'Flagged flags)
- (elmo-msgdb-global-mark-set message-id important-mark))
- (setq number-alist
- (elmo-msgdb-number-add number-alist number message-id))
- (setq seen (member message-id seen-list))
- (if (setq gmark (or (elmo-msgdb-global-mark-get message-id)
- (if (elmo-cache-exists-p message-id) ;; XXX
- (if (or (memq 'Seen flags) seen)
- nil
- already-mark)
- (if (or (memq 'Seen flags) seen)
- (if elmo-imap4-use-cache
- seen-mark)
- new-mark))))
- (setq mark-alist (elmo-msgdb-mark-append
- mark-alist
- number
- ;; managing mark with message-id is evil.
- gmark))))
- (setq attr-list (cdr attr-list)))
- (list overview number-alist mark-alist)))
-
-(defun elmo-imap4-add-to-cont-list (cont-list msg)
- (let ((elist cont-list)
- (ret-val cont-list)
- entity found)
- (while (and elist (not found))
- (setq entity (car elist))
- (cond
- ((and (consp entity)
- (eq (+ 1 (cdr entity)) msg))
- (setcdr entity msg)
- (setq found t))
- ((and (integerp entity)
- (eq (+ 1 entity) msg))
- (setcar elist (cons entity msg))
- (setq found t))
- ((or (and (integerp entity) (eq entity msg))
- (and (consp entity)
- (<= (car entity) msg)
- (<= msg (cdr entity)))) ; included
- (setq found t))); noop
- (setq elist (cdr elist)))
- (if (not found)
- (setq ret-val (append cont-list (list msg))))
- ret-val))
+ (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))))))))))
(defun elmo-imap4-make-number-set-list (msg-list &optional chop-length)
"Make RFC2060's message set specifier from MSG-LIST.
Every SET-STRING does not contain number of messages longer than CHOP-LENGTH.
If CHOP-LENGTH is not specified, message set is not chopped."
(let (count cont-list set-list)
- (setq msg-list (sort msg-list '<))
+ (setq msg-list (sort (copy-sequence msg-list) '<))
(while msg-list
(setq cont-list nil)
(setq count 0)
(setq chop-length (length msg-list)))
(while (and (not (null msg-list))
(< count chop-length))
- (setq cont-list
- (elmo-imap4-add-to-cont-list
+ (setq cont-list
+ (elmo-number-set-append
cont-list (car msg-list)))
(incf count)
(setq msg-list (cdr msg-list)))
- (setq set-list
+ (setq set-list
(cons
(cons
count
(nreverse set-list)))
;;
-;; set mark
-;; read-mark -> "\\Seen"
-;; important -> "\\Flagged"
-;;
-;; (delete -> \\Deleted)
-(defun elmo-imap4-mark-set-on-msgs (spec msgs mark &optional unmark no-expunge)
- "SET flag of MSGS as MARK.
-If optional argument UNMARK is non-nil, unmark."
- (save-excursion
- (let* ((connection (elmo-imap4-get-connection spec))
- (process (elmo-imap4-connection-get-process connection))
- (msg-list (copy-sequence msgs))
- set-list ent)
- (if (and (elmo-imap4-spec-folder spec)
- (not (string= (elmo-imap4-connection-get-cwf connection)
- (elmo-imap4-spec-folder spec)))
- (null (elmo-imap4-select-folder
- (elmo-imap4-spec-folder spec) connection)))
- (error "Select folder failed"))
- (setq set-list (elmo-imap4-make-number-set-list msg-list))
- (when set-list
- (elmo-imap4-send-command (process-buffer process)
- process
- (format
- (if elmo-imap4-use-uid
- "uid store %s %sflags.silent (%s)"
- "store %s %sflags.silent (%s)")
- (cdr (car set-list))
- (if unmark "-" "+")
- mark))
- (unless (elmo-imap4-read-response (process-buffer process) process)
- (error "Store %s flag failed" mark))
- (unless no-expunge
- (elmo-imap4-send-command
- (process-buffer process) process "expunge")
- (unless (elmo-imap4-read-response (process-buffer process) process)
- (error "Expunge failed"))))
- t)))
-
-(defun elmo-imap4-mark-as-important (spec msgs)
- (and (elmo-imap4-use-flag-p spec)
- (elmo-imap4-mark-set-on-msgs spec msgs "\\Flagged" nil 'no-expunge)))
-
-(defun elmo-imap4-mark-as-read (spec msgs)
- (and (elmo-imap4-use-flag-p spec)
- (elmo-imap4-mark-set-on-msgs spec msgs "\\Seen" nil 'no-expunge)))
-
-(defun elmo-imap4-unmark-important (spec msgs)
- (and (elmo-imap4-use-flag-p spec)
- (elmo-imap4-mark-set-on-msgs spec msgs "\\Flagged" 'unmark
- 'no-expunge)))
-
-(defun elmo-imap4-mark-as-unread (spec msgs)
- (and (elmo-imap4-use-flag-p spec)
- (elmo-imap4-mark-set-on-msgs spec msgs "\\Seen" 'unmark 'no-expunge)))
-
-(defun elmo-imap4-delete-msgs (spec msgs)
- (elmo-imap4-mark-set-on-msgs spec msgs "\\Deleted"))
-
-(defun elmo-imap4-delete-msgs-no-expunge (spec msgs)
- (elmo-imap4-mark-set-on-msgs spec msgs "\\Deleted" nil 'no-expunge))
-
-(defun elmo-imap4-msgdb-create-as-numlist (spec numlist new-mark already-mark
- seen-mark important-mark
- seen-list)
- "Create msgdb for SPEC for NUMLIST."
- (elmo-imap4-msgdb-create spec numlist new-mark already-mark
- seen-mark important-mark seen-list t))
-
-(defun elmo-imap4-msgdb-create (spec numlist new-mark already-mark seen-mark
- important-mark seen-list &optional as-num)
- "Create msgdb for SPEC."
- (when numlist
- (save-excursion
- (let* ((connection (elmo-imap4-get-connection spec))
- (process (elmo-imap4-connection-get-process connection))
- (filter (and as-num numlist))
- (case-fold-search t)
- (extra-fields (if elmo-msgdb-extra-fields
- (concat " " (mapconcat
- 'identity
- elmo-msgdb-extra-fields " "))
- ""))
- rfc2060 count ret-val set-list ov-str length)
- (setq rfc2060 (with-current-buffer (process-buffer process)
- (if (memq 'imap4rev1 elmo-imap4-server-capability)
- t
- (if (memq 'imap4 elmo-imap4-server-capability)
- nil
- (error "No IMAP4 capability!!")))))
- (setq count 0)
- (setq length (length numlist))
- (setq set-list (elmo-imap4-make-number-set-list
- numlist
- elmo-imap4-overview-fetch-chop-length))
- (message "Getting overview...")
- (if (and (elmo-imap4-spec-folder spec)
- (not (string= (elmo-imap4-connection-get-cwf connection)
- (elmo-imap4-spec-folder spec)))
- (null (elmo-imap4-select-folder
- (elmo-imap4-spec-folder spec) connection)))
- (error "Select imap folder %s failed"
- (elmo-imap4-spec-folder spec)))
- (while set-list
- (elmo-imap4-send-command
- (process-buffer process)
- process
- ;; get overview entity from IMAP4
- (format
- (if rfc2060
- (concat
- (if elmo-imap4-use-uid "uid " "")
- "fetch %s (envelope body.peek[header.fields (references"
- extra-fields
- ")] rfc822.size flags)")
- (concat
- (if elmo-imap4-use-uid "uid " "")
- "fetch %s (envelope rfc822.size flags)"))
- (cdr (car set-list))))
- ;; process string while waiting for response
- (with-current-buffer (process-buffer process)
- (if ov-str
- (setq ret-val
- (elmo-msgdb-append
- ret-val
- (elmo-imap4-create-msgdb-from-overview-string
- ov-str
- (elmo-imap4-spec-folder spec)
- new-mark already-mark seen-mark important-mark
- seen-list filter)))))
- (setq count (+ count (car (car set-list))))
- (setq ov-str (elmo-imap4-read-contents (process-buffer process)
- process))
- (elmo-display-progress
- 'elmo-imap4-msgdb-create "Getting overview..."
- (/ (* count 100) length))
- (setq set-list (cdr set-list)))
- ;; process last one.
- (with-current-buffer (process-buffer process)
- (if ov-str
- (setq ret-val
- (elmo-msgdb-append
- ret-val
- (elmo-imap4-create-msgdb-from-overview-string
- ov-str
- (elmo-imap4-spec-folder spec)
- new-mark already-mark seen-mark important-mark
- seen-list filter)))))
- (message "Getting overview...done.")
- ret-val))))
-
-(defun elmo-imap4-parse-response (string)
- (if (string-match "^\\*\\(.*\\)$" string)
- (read (concat "(" (elmo-match-string 1 string) ")"))))
+;; app-data:
+;; cons of list
+;; 0: new-mark 1: already-mark 2: seen-mark 3: important-mark
+;; 4: seen-list
+;; and result of use-flag-p.
+(defsubst elmo-imap4-fetch-callback-1-subr (entity flags app-data)
+ "A msgdb entity callback function."
+ (let* ((use-flag (cdr app-data))
+ (app-data (car app-data))
+ (seen (member (car entity) (nth 4 app-data)))
+ mark)
+ (if (member "\\Flagged" flags)
+ (elmo-msgdb-global-mark-set (car entity) (nth 3 app-data)))
+ (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)))
+ (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
+ (list (list entity)
+ (list (cons (elmo-msgdb-overview-entity-get-number entity)
+ (car entity)))
+ (if mark
+ (list
+ (list (elmo-msgdb-overview-entity-get-number entity)
+ mark))))))))
+
+;; Current buffer is process buffer.
+(defun elmo-imap4-fetch-callback-1 (element app-data)
+ (elmo-imap4-fetch-callback-1-subr
+ (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"))
+ (elmo-msgdb-create-overview-from-buffer
+ (elmo-imap4-response-value element 'uid)
+ (elmo-imap4-response-value element 'rfc822size)))
+ (elmo-imap4-response-value element 'flags)
+ app-data))
(defun elmo-imap4-parse-capability (string)
(if (string-match "^\\*\\(.*\\)$" string)
- (read (concat "(" (downcase (elmo-match-string 1 string)) ")"))))
-
-(defun elmo-imap4-parse-namespace (obj)
- (let ((ns (cdr obj))
- (i 0)
- prefix delim
- cur namespace-alist)
- ;; 0: personal, 1: other, 2: shared
- (while (< i 3)
- (setq cur (elmo-imap4-nth i ns))
- (incf i)
- (while cur
- (setq prefix (elmo-imap4-nth 0 (car cur)))
- (setq delim (elmo-imap4-nth 1 (car cur)))
- (if (and prefix delim
- (string-match (concat "\\(.*\\)"
- (regexp-quote delim)
- "\\'")
- prefix))
- (setq prefix (substring prefix (match-beginning 1)(match-end 1))))
- (setq namespace-alist (nconc namespace-alist
- (list (cons
- (concat "^" (regexp-quote prefix)
- ".*$")
- delim))))
- (setq cur (cdr cur))))
- (append
- elmo-imap4-extra-namespace-alist
- (sort namespace-alist
- '(lambda (x y)
- (> (length (car x))
- (length (car y))))))))
-
-(defun elmo-imap4-open-connection (imap4-server user auth port passphrase ssl)
- "Open Imap connection and returns
-the list of (process session-buffer current-working-folder).
-Return nil if connection failed."
- (let ((process nil)
- (host imap4-server)
- process-buffer ret-val response capability)
- (catch 'done
- (as-binary-process
- (setq process-buffer
- (get-buffer-create (format " *IMAP session to %s:%d" host port)))
- (save-excursion
- (set-buffer process-buffer)
- (elmo-set-buffer-multibyte nil)
- (make-variable-buffer-local 'elmo-imap4-server-capability)
- (make-variable-buffer-local 'elmo-imap4-lock)
- (erase-buffer))
- (setq process
- (elmo-open-network-stream "IMAP" process-buffer host port ssl))
- (and (null process) (throw 'done nil))
- (set-process-filter process 'elmo-imap4-process-filter)
- ;; flush connections when exiting...
- (save-excursion
- (set-buffer process-buffer)
- (make-local-variable 'elmo-imap4-read-point)
- (setq elmo-imap4-read-point (point-min))
- (if (null (setq response
- (elmo-imap4-read-response process-buffer process t)))
- (throw 'done nil)
- (when (string-match "^\\* PREAUTH" response)
- (setq ret-val (cons process-buffer process))
- (throw 'done nil)))
- (elmo-imap4-send-command process-buffer process "capability")
- (setq elmo-imap4-server-capability
- (elmo-imap4-parse-capability
- (elmo-imap4-read-response process-buffer process)))
- (setq capability elmo-imap4-server-capability)
- (if (eq ssl 'starttls)
- (if (and (memq 'starttls capability)
- (progn
- (elmo-imap4-send-command process-buffer process "starttls")
- (setq response
- (elmo-imap4-read-response process-buffer process)))
-
- (string-match
- (concat "^\\(" elmo-imap4-seq-prefix
- (int-to-string elmo-imap4-seqno)
- "\\|\\*\\) OK")
- response))
- (starttls-negotiate process)
- (error "STARTTLS aborted")))
- (if (or (and (string= "auth" auth)
- (not (memq 'auth=login capability)))
- (and (string= "cram-md5" auth)
- (not (memq 'auth=cram-md5 capability)))
- (and (string= "digest-md5" auth)
- (not (memq 'auth=digest-md5 capability))))
- (if (or elmo-imap4-force-login
- (y-or-n-p
- (format
- "There's no %s capability in server. continue?" auth)))
- (setq auth "login")
- (error "Login aborted")))
- (cond
- ((string= "auth" auth)
- (elmo-imap4-send-command
- process-buffer process "authenticate login" 'no-lock)
- ;; Base64
- (when (null (elmo-imap4-read-response process-buffer process t))
- (setq ret-val (cons nil process))
- (throw 'done nil))
- (elmo-imap4-send-string
- process-buffer process (elmo-base64-encode-string user))
- (when (null (elmo-imap4-read-response process-buffer process t))
- (setq ret-val (cons nil process))
- (throw 'done nil))
- (elmo-imap4-send-string
- process-buffer process (elmo-base64-encode-string passphrase))
- (when (null (elmo-imap4-read-response process-buffer process))
- (setq ret-val (cons nil process))
- (throw 'done nil))
- (setq ret-val (cons process-buffer process)))
- ((string= "cram-md5" auth)
- (elmo-imap4-send-command
- process-buffer process "authenticate cram-md5" 'no-lock)
- (when (null (setq response
- (elmo-imap4-read-response
- process-buffer process t)))
- (setq ret-val (cons nil process))
- (throw 'done nil))
- (setq response (cadr (split-string response " ")))
- (elmo-imap4-send-string
- process-buffer process
- (elmo-base64-encode-string
- (sasl-cram-md5 user passphrase
- (elmo-base64-decode-string response))))
- (when (null (elmo-imap4-read-response process-buffer process))
- (setq ret-val (cons nil process))
- (throw 'done nil))
- (setq ret-val (cons process-buffer process)))
- ((string= "digest-md5" auth)
- (elmo-imap4-send-command
- process-buffer process "authenticate digest-md5" 'no-lock)
- (when (null (setq response
- (elmo-imap4-read-response
- process-buffer process t)))
- (setq ret-val (cons nil process))
- (throw 'done nil))
- (setq response (cadr (split-string response " ")))
- (elmo-imap4-send-string
- process-buffer process
- (elmo-base64-encode-string
- (sasl-digest-md5-digest-response
- (elmo-base64-decode-string response)
- user passphrase "imap" host)
- 'no-line-break))
- (when (null (elmo-imap4-read-response
- process-buffer process t))
- (setq ret-val (cons nil process))
- (throw 'done nil))
- (elmo-imap4-send-string process-buffer process "")
- (when (null (elmo-imap4-read-response process-buffer process))
- (setq ret-val (cons nil process))
- (throw 'done nil))
- (setq ret-val (cons process-buffer process)))
- (t ;; not auth... try login
- (elmo-imap4-send-command
- process-buffer process
- (format "login %s \"%s\"" user
- (elmo-replace-in-string passphrase
- "\"" "\\\\\""))
- nil 'no-log) ;; No LOGGING.
- (if (null (elmo-imap4-read-response process-buffer process))
- (setq ret-val (cons nil process))
- (setq ret-val (cons process-buffer process)))))
- ;; get namespace of server if possible.
- (when (memq 'namespace elmo-imap4-server-capability)
- (elmo-imap4-send-command process-buffer process "namespace")
- (setq elmo-imap4-server-namespace
- (elmo-imap4-parse-namespace
- (elmo-imap4-parse-response
- (elmo-imap4-read-response process-buffer process))))))))
- ret-val))
-
-(defun elmo-imap4-get-seqno ()
- (setq elmo-imap4-seqno (+ 1 elmo-imap4-seqno)))
-
-(defun elmo-imap4-setup-send-buffer (string)
- (let ((tmp-buf (get-buffer-create " *elmo-imap4-setup-send-buffer*")))
+ (elmo-read
+ (concat "(" (downcase (elmo-match-string 1 string)) ")"))))
+
+(defun elmo-imap4-clear-login (session)
+ (let ((elmo-imap4-debug-inhibit-logging t))
+ (or
+ (elmo-imap4-read-ok
+ session
+ (elmo-imap4-send-command
+ session
+ (list "login "
+ (elmo-imap4-userid (elmo-network-session-user-internal session))
+ " "
+ (elmo-imap4-password
+ (elmo-get-passwd (elmo-network-session-password-key session))))))
+ (signal 'elmo-authenticate-error '(elmo-imap4-clear-login)))))
+
+(defun elmo-imap4-auth-login (session)
+ (let ((tag (elmo-imap4-send-command session "authenticate login"))
+ (elmo-imap4-debug-inhibit-logging t))
+ (or (elmo-imap4-read-continue-req session)
+ (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
+ (elmo-imap4-send-string session
+ (elmo-base64-encode-string
+ (elmo-network-session-user-internal session)))
+ (or (elmo-imap4-read-continue-req session)
+ (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
+ (elmo-imap4-send-string session
+ (elmo-base64-encode-string
+ (elmo-get-passwd
+ (elmo-network-session-password-key session))))
+ (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)
+ (with-current-buffer buffer
+ (mapcar 'make-variable-buffer-local elmo-imap4-local-variables)
+ (setq elmo-imap4-seqno 0)
+ (setq elmo-imap4-status 'initial)))
+
+(luna-define-method elmo-network-initialize-session ((session
+ elmo-imap4-session))
+ (let ((process (elmo-network-session-process-internal session)))
+ (with-current-buffer (process-buffer process)
+ ;; 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)))
+ (accept-process-output process 1))
+ (set-process-filter process 'elmo-imap4-arrival-filter)
+ (set-process-sentinel process 'elmo-imap4-sentinel)
+;;; (while (and (memq (process-status process) '(open run))
+;;; (eq elmo-imap4-status 'initial))
+;;; (message "Waiting for server response...")
+;;; (accept-process-output process 1))
+;;; (message "")
+ (unless (memq elmo-imap4-status '(nonauth auth))
+ (signal 'elmo-open-error
+ (list 'elmo-network-initialize-session)))
+ (elmo-imap4-session-set-capability-internal
+ session
+ (elmo-imap4-response-value
+ (elmo-imap4-send-command-wait session "capability")
+ 'capability))
+ (when (eq (elmo-network-stream-type-symbol
+ (elmo-network-session-stream-type-internal session))
+ 'starttls)
+ (or (memq 'starttls
+ (elmo-imap4-session-capability-internal session))
+ (signal 'elmo-open-error
+ '(elmo-imap4-starttls-error)))
+ (elmo-imap4-send-command-wait session "starttls")
+ (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))
+ (with-current-buffer (process-buffer
+ (elmo-network-session-process-internal session))
+ (let* ((auth (elmo-network-session-auth-internal session))
+ (auth (if (listp auth) auth (list auth))))
+ (unless (or (eq elmo-imap4-status 'auth)
+ (null auth))
+ (cond
+ ((eq 'clear (car auth))
+ (elmo-imap4-clear-login session))
+ ((eq 'login (car auth))
+ (elmo-imap4-auth-login session))
+ (t
+ (let* ((elmo-imap4-debug-inhibit-logging t)
+ (sasl-mechanisms
+ (delq nil
+ (mapcar
+ '(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)))
+ (if (listp auth)
+ auth
+ (list auth)))))) ;)
+ client name step response tag
+ sasl-read-passphrase)
+ (unless mechanism
+ (if (or elmo-imap4-force-login
+ (y-or-n-p
+ (format
+ "There's no %s capability in server. continue?"
+ (elmo-list-to-string
+ (elmo-network-session-auth-internal session)))))
+ (setq mechanism (sasl-find-mechanism
+ sasl-mechanisms))
+ (signal 'elmo-authenticate-error
+ '(elmo-imap4-auth-no-mechanisms))))
+ (setq client
+ (sasl-make-client
+ mechanism
+ (elmo-network-session-user-internal session)
+ "imap"
+ (elmo-network-session-server-internal session)))
+;;; (if elmo-imap4-auth-user-realm
+;;; (sasl-client-set-property client 'realm elmo-imap4-auth-user-realm))
+ (setq name (sasl-mechanism-name mechanism)
+ step (sasl-next-step client nil))
+ (elmo-network-session-set-auth-internal
+ session
+ (intern (downcase name)))
+ (setq sasl-read-passphrase
+ (function
+ (lambda (prompt)
+ (elmo-get-passwd
+ (elmo-network-session-password-key session)))))
+ (setq tag
+ (elmo-imap4-send-command
+ session
+ (concat "AUTHENTICATE " name
+ (and (sasl-step-data step)
+ (concat
+ " "
+ (elmo-base64-encode-string
+ (sasl-step-data step)
+ 'no-lin-break))))))
+ (catch 'done
+ (while t
+ (setq response
+ (elmo-imap4-read-untagged
+ (elmo-network-session-process-internal session)))
+ (if (elmo-imap4-response-ok-p response)
+ (if (sasl-next-step client step)
+ ;; Bogus server?
+ (signal 'elmo-authenticate-error
+ (list (intern
+ (concat "elmo-imap4-auth-"
+ (downcase name)))))
+ ;; The authentication process is finished.
+ (throw 'done nil)))
+ (unless (elmo-imap4-response-continue-req-p response)
+ ;; response is NO or BAD.
+ (signal 'elmo-authenticate-error
+ (list (intern
+ (concat "elmo-imap4-auth-"
+ (downcase name))))))
+ (sasl-step-set-data
+ step
+ (elmo-base64-decode-string
+ (elmo-imap4-response-value response 'continue-req)))
+ (setq step (sasl-next-step client step))
+ (setq tag
+ (elmo-imap4-send-string
+ session
+ (if (sasl-step-data step)
+ (elmo-base64-encode-string (sasl-step-data step)
+ 'no-line-break)
+ ""))))))))))))
+
+(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))
+ (setq elmo-imap4-server-namespace
+ (elmo-imap4-response-value
+ (elmo-imap4-send-command-wait session "namespace")
+ 'namespace)))))
+
+(defun elmo-imap4-setup-send-buffer (&optional string)
+ (let ((send-buf (get-buffer-create " *elmo-imap4-setup-send-buffer*"))
+ (source-buf (unless string (current-buffer))))
(save-excursion
(save-match-data
- (set-buffer tmp-buf)
+ (set-buffer send-buf)
(erase-buffer)
(elmo-set-buffer-multibyte nil)
- (insert string)
+ (if string
+ (insert string)
+ (with-current-buffer source-buf
+ (copy-to-buffer send-buf (point-min) (point-max))))
(goto-char (point-min))
- (if (eq (re-search-forward "^$" nil t)
+ (if (eq (re-search-forward "^$" nil t)
(point-max))
(insert "\n"))
(goto-char (point-min))
(while (search-forward "\n" nil t)
(replace-match "\r\n"))))
- tmp-buf))
-
-(defun elmo-imap4-send-command (buffer process command &optional no-lock
- no-log)
- "Send COMMAND string to server with sequence number."
- (save-excursion
- (set-buffer buffer)
- (when (and elmo-imap4-use-lock
- elmo-imap4-lock)
- (elmo-imap4-debug "send: (%d) is still locking." elmo-imap4-seqno)
- (error "IMAP4 process is locked; Please try later (or plug again)"))
- (erase-buffer)
- (goto-char (point-min))
- (setq elmo-imap4-read-point (point))
- (unless no-lock
- ;; for debug.
- (if no-log
- (elmo-imap4-debug "lock(%d): (No-logging command)." (+ elmo-imap4-seqno 1))
- (elmo-imap4-debug "lock(%d): %s" (+ elmo-imap4-seqno 1) command))
- (setq elmo-imap4-lock t))
- (process-send-string process (concat (format "%s%d "
- elmo-imap4-seq-prefix
- (elmo-imap4-get-seqno))
- command))
- (process-send-string process "\r\n")))
-
-(defun elmo-imap4-send-string (buffer process string)
- "Send STRING to server."
- (save-excursion
- (set-buffer buffer)
- (erase-buffer)
- (goto-char (point-min))
- (setq elmo-imap4-read-point (point))
- (process-send-string process string)
- (process-send-string process "\r\n")))
-
-(defun elmo-imap4-read-part (folder msg part)
- (save-excursion
- (let* ((spec (elmo-folder-get-spec folder))
- (connection (elmo-imap4-get-connection spec))
- (process (elmo-imap4-connection-get-process connection))
- response ret-val bytes)
- (when (elmo-imap4-spec-folder spec)
- (when (not (string= (elmo-imap4-connection-get-cwf connection)
- (elmo-imap4-spec-folder spec)))
- (if (null (setq response
- (elmo-imap4-select-folder
- (elmo-imap4-spec-folder spec) connection)))
- (error "Select folder failed")))
- (elmo-imap4-send-command (process-buffer process)
- process
- (format
- (if elmo-imap4-use-uid
- "uid fetch %s body.peek[%s]"
- "fetch %s body.peek[%s]")
- msg part))
- (if (null (setq response (elmo-imap4-read-response
- (process-buffer process)
- process t)))
- (error "Fetch failed"))
- (save-match-data
- (while (string-match "^\\* OK" response)
- (if (null (setq response (elmo-imap4-read-response
- (process-buffer process)
- process t)))
- (error "Fetch failed"))))
- (save-match-data
- (if (string-match ".*{\\([0-9]+\\)}" response)
- (setq bytes
- (string-to-int
- (elmo-match-string 1 response)))
- (error "Fetch failed")))
- (if (null (setq response (elmo-imap4-read-bytes
- (process-buffer process) process bytes)))
- (error "Fetch message failed"))
- (setq ret-val response)
- (elmo-imap4-read-response (process-buffer process)
- process)) ;; ignore remaining..
- ret-val)))
-
-(defun elmo-imap4-prefetch-msg (spec msg outbuf)
- (elmo-imap4-read-msg spec msg outbuf 'unseen))
-
-(defun elmo-imap4-read-msg (spec msg outbuf
- &optional leave-seen-flag-untouched)
- (save-excursion
- (let* ((connection (elmo-imap4-get-connection spec))
- (process (elmo-imap4-connection-get-process connection))
- response ret-val bytes)
- (as-binary-process
- (when (elmo-imap4-spec-folder spec)
- (when (not (string= (elmo-imap4-connection-get-cwf connection)
- (elmo-imap4-spec-folder spec)))
- (if (null (setq response
- (elmo-imap4-select-folder
- (elmo-imap4-spec-folder spec)
- connection)))
- (error "Select folder failed")))
- (elmo-imap4-send-command (process-buffer process)
- process
- (format
- (if elmo-imap4-use-uid
- "uid fetch %s body%s[]"
- "fetch %s body%s[]")
- msg
- (if leave-seen-flag-untouched
- ".peek" "")))
- (if (null (setq response (elmo-imap4-read-response
- (process-buffer process)
- process t)))
- (error "Fetch failed"))
- (save-match-data
- (while (string-match "^\\* OK" response)
- (if (null (setq response (elmo-imap4-read-response
- (process-buffer process)
- process t)))
- (error "Fetch failed"))))
- (save-match-data
- (if (string-match ".*{\\([0-9]+\\)}" response)
- (setq bytes
- (string-to-int
- (elmo-match-string 1 response)))
- (error "Fetch failed")))
- (setq ret-val (elmo-imap4-read-body
- (process-buffer process)
- process bytes outbuf))
- (elmo-imap4-read-response (process-buffer process)
- process)) ;; ignore remaining..
- )
- ret-val)))
+ send-buf))
(defun elmo-imap4-setup-send-buffer-from-file (file)
- (let ((tmp-buf (get-buffer-create
+ (let ((tmp-buf (get-buffer-create
" *elmo-imap4-setup-send-buffer-from-file*")))
(save-excursion
(save-match-data
(as-binary-input-file
(insert-file-contents file))
(goto-char (point-min))
- (if (eq (re-search-forward "^$" nil t)
+ (if (eq (re-search-forward "^$" nil t)
(point-max))
- (insert "\n"))
+ (insert "\n"))
(goto-char (point-min))
(while (search-forward "\n" nil t)
(replace-match "\r\n"))))
tmp-buf))
-(defun elmo-imap4-delete-msgids (spec msgids)
- "If actual message-id is matched, then delete it."
- (let ((message-ids msgids)
- (i 0)
- (num (length msgids)))
- (while message-ids
- (setq i (+ 1 i))
- (message "Deleting message...%d/%d" i num)
- (elmo-imap4-delete-msg-by-id spec (car message-ids))
- (setq message-ids (cdr message-ids)))
- (let* ((connection (elmo-imap4-get-connection spec))
- (process (elmo-imap4-connection-get-process connection)))
- (elmo-imap4-send-command (process-buffer process)
- process "expunge")
- (if (null (elmo-imap4-read-response (process-buffer process)
- process))
- (error "Expunge failed")))))
-
-(defun elmo-imap4-delete-msg-by-id (spec msgid)
- (save-excursion
- (let* ((connection (elmo-imap4-get-connection spec))
- (process (elmo-imap4-connection-get-process connection))
- ;;(size (length string))
- response msgs)
- (if (and (elmo-imap4-spec-folder spec)
- (not (string= (elmo-imap4-connection-get-cwf connection)
- (elmo-imap4-spec-folder spec)))
- (null (elmo-imap4-select-folder
- (elmo-imap4-spec-folder spec)
- connection)))
- (error "Select folder failed"))
- (save-excursion
- (elmo-imap4-send-command (process-buffer process)
- process
- (format
- (if elmo-imap4-use-uid
- "uid search header message-id \"%s\""
- "search header message-id \"%s\"")
- msgid))
- (setq response (elmo-imap4-read-response
- (process-buffer process) process))
- (if (and response
- (string-match "^\\* SEARCH\\([^\n]*\\)$" response))
- (setq msgs (read (concat "(" (elmo-match-string 1 response) ")")))
- (error "SEARCH failed"))
- (elmo-imap4-delete-msgs-no-expunge spec msgs)))))
-
-(defun elmo-imap4-append-msg-by-id (spec msgid)
- (save-excursion
- (let* ((connection (elmo-imap4-get-connection spec))
- (process (elmo-imap4-connection-get-process connection))
- send-buf)
- (if (and (elmo-imap4-spec-folder spec)
- (not (string= (elmo-imap4-connection-get-cwf connection)
- (elmo-imap4-spec-folder spec)))
- (null (elmo-imap4-select-folder
- (elmo-imap4-spec-folder spec) connection)))
- (error "Select folder failed"))
- (save-excursion
- (setq send-buf (elmo-imap4-setup-send-buffer-from-file
- (elmo-cache-get-path msgid)))
- (set-buffer send-buf)
- (elmo-imap4-send-command (process-buffer process)
- process
- (format "append %s (\\Seen) {%d}"
- (elmo-imap4-spec-folder spec)
- (buffer-size)))
- (process-send-string process (buffer-string))
- (process-send-string process "\r\n") ; finished appending.
- )
- (kill-buffer send-buf)
- (if (null (elmo-imap4-read-response (process-buffer process)
- process))
- (error "Append failed")))
- t))
-
-(defun elmo-imap4-append-msg (spec string &optional msg no-see)
- (save-excursion
- (let* ((connection (elmo-imap4-get-connection spec))
- (process (elmo-imap4-connection-get-process connection))
- send-buf)
- (if (and (elmo-imap4-spec-folder spec)
- (not (string= (elmo-imap4-connection-get-cwf connection)
- (elmo-imap4-spec-folder spec)))
- (null (elmo-imap4-select-folder (elmo-imap4-spec-folder spec)
- connection)))
- (error "Select folder failed"))
+(luna-define-method elmo-delete-message-safe ((folder elmo-imap4-folder)
+ number msgid)
+ (let ((session (elmo-imap4-get-session folder))
+ candidates)
+ (elmo-imap4-session-select-mailbox
+ session
+ (elmo-imap4-folder-mailbox-internal folder))
+ (setq candidates
+ (elmo-imap4-response-value
+ (elmo-imap4-send-command-wait session
+ (list
+ (if elmo-imap4-use-uid
+ "uid search header message-id "
+ "search header message-id ")
+ (elmo-imap4-field-body msgid)))
+ 'search))
+ (if (memq number candidates)
+ (elmo-folder-delete-messages folder (list number)))))
+
+(defun elmo-imap4-server-diff-async-callback-1 (status data)
+ (funcall elmo-imap4-server-diff-async-callback
+ (list (elmo-imap4-response-value status 'recent)
+ (elmo-imap4-response-value status 'unseen)
+ (elmo-imap4-response-value status 'messages))
+ data))
+
+(defun elmo-imap4-server-diff-async (folder)
+ (let ((session (elmo-imap4-get-session folder)))
+ ;; We should `check' folder to obtain newest information here.
+ ;; But since there's no asynchronous check mechanism in elmo yet,
+ ;; checking is not done here.
+ (with-current-buffer (elmo-network-session-buffer session)
+ (setq elmo-imap4-status-callback
+ 'elmo-imap4-server-diff-async-callback-1)
+ (setq elmo-imap4-status-callback-data
+ elmo-imap4-server-diff-async-callback-data))
+ (elmo-imap4-send-command session
+ (list
+ "status "
+ (elmo-imap4-mailbox
+ (elmo-imap4-folder-mailbox-internal folder))
+ " (recent unseen messages)"))))
+
+(luna-define-method elmo-server-diff-async ((folder elmo-imap4-folder))
+ (let ((session (elmo-imap4-get-session folder)))
+ ;; 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)
+ (setq elmo-imap4-status-callback-data
+ elmo-imap4-server-diff-async-callback-data))
+ (elmo-imap4-send-command session
+ (list
+ "status "
+ (elmo-imap4-mailbox
+ (elmo-imap4-folder-mailbox-internal folder))
+ " (recent unseen messages)"))))
+
+;;; IMAP parser.
+
+(defvar elmo-imap4-server-eol "\r\n"
+ "The EOL string sent from the server.")
+
+(defvar elmo-imap4-client-eol "\r\n"
+ "The EOL string we send to the server.")
+
+(defvar elmo-imap4-display-literal-progress nil)
+
+(defun elmo-imap4-find-next-line ()
+ "Return point at end of current line, taking into account literals.
+Return nil if no complete line has arrived."
+ (when (re-search-forward (concat elmo-imap4-server-eol "\\|{\\([0-9]+\\)}"
+ elmo-imap4-server-eol)
+ nil t)
+ (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))))
+ nil)
+ (goto-char (+ (point) (string-to-number (match-string 1))))
+ (elmo-imap4-find-next-line))
+ (point))))
+
+(defun elmo-imap4-sentinel (process string)
+ (delete-process process))
+
+(defun elmo-imap4-arrival-filter (proc string)
+ "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)
+ (goto-char (point-min))
+ (while (setq end (elmo-imap4-find-next-line))
+ (save-restriction
+ (narrow-to-region (point-min) end)
+ (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))))))))
+
+;; IMAP parser.
+
+(defsubst elmo-imap4-forward ()
+ (or (eobp) (forward-char 1)))
+
+(defsubst elmo-imap4-parse-number ()
+ (when (looking-at "[0-9]+")
+ (prog1
+ (string-to-number (match-string 0))
+ (goto-char (match-end 0)))))
+
+(defsubst elmo-imap4-parse-literal ()
+ (when (looking-at "{\\([0-9]+\\)}\r\n")
+ (let ((pos (match-end 0))
+ (len (string-to-number (match-string 1))))
+ (if (< (point-max) (+ pos len))
+ nil
+ (goto-char (+ pos len))
+ (buffer-substring pos (+ pos len))))))
+;;; (list ' pos (+ pos len))))))
+
+(defsubst elmo-imap4-parse-string ()
+ (cond ((eq (char-after (point)) ?\")
+ (forward-char 1)
+ (let ((p (point)) (name ""))
+ (skip-chars-forward "^\"\\\\")
+ (setq name (buffer-substring p (point)))
+ (while (eq (char-after (point)) ?\\)
+ (setq p (1+ (point)))
+ (forward-char 2)
+ (skip-chars-forward "^\"\\\\")
+ (setq name (concat name (buffer-substring p (point)))))
+ (forward-char 1)
+ name))
+ ((eq (char-after (point)) ?{)
+ (elmo-imap4-parse-literal))))
+
+(defsubst elmo-imap4-parse-nil ()
+ (if (looking-at "NIL")
+ (goto-char (match-end 0))))
+
+(defsubst elmo-imap4-parse-nstring ()
+ (or (elmo-imap4-parse-string)
+ (and (elmo-imap4-parse-nil)
+ nil)))
+
+(defsubst elmo-imap4-parse-astring ()
+ (or (elmo-imap4-parse-string)
+ (buffer-substring (point)
+ (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
+ (goto-char (1- (match-end 0)))
+ (end-of-line)
+ (point)))))
+
+(defsubst elmo-imap4-parse-address ()
+ (let (address)
+ (when (eq (char-after (point)) ?\()
+ (elmo-imap4-forward)
+ (setq address (vector (prog1 (elmo-imap4-parse-nstring)
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-nstring)
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-nstring)
+ (elmo-imap4-forward))
+ (elmo-imap4-parse-nstring)))
+ (when (eq (char-after (point)) ?\))
+ (elmo-imap4-forward)
+ address))))
+
+(defsubst elmo-imap4-parse-address-list ()
+ (if (eq (char-after (point)) ?\()
+ (let (address addresses)
+ (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)
+ (setq address (elmo-imap4-parse-address)))
+ (setq addresses (cons address addresses)))
+ (when (eq (char-after (point)) ?\))
+ (elmo-imap4-forward)
+ (nreverse addresses)))
+ (assert (elmo-imap4-parse-nil))))
+
+(defsubst elmo-imap4-parse-mailbox ()
+ (let ((mailbox (elmo-imap4-parse-astring)))
+ (if (string-equal "INBOX" (upcase mailbox))
+ "INBOX"
+ mailbox)))
+
+(defun elmo-imap4-parse-greeting ()
+ "Parse a IMAP greeting."
+ (cond ((looking-at "\\* OK ")
+ (setq elmo-imap4-status 'nonauth))
+ ((looking-at "\\* PREAUTH ")
+ (setq elmo-imap4-status 'auth))
+ ((looking-at "\\* BYE ")
+ (setq elmo-imap4-status 'closed))))
+
+(defun elmo-imap4-parse-response ()
+ "Parse a IMAP command response."
+ (let (token)
+ (case (setq token (elmo-read (current-buffer)))
+ (+ (progn
+ (skip-chars-forward " ")
+ (list 'continue-req (buffer-substring (point) (point-max)))))
+ (* (case (prog1 (setq token (elmo-read (current-buffer)))
+ (elmo-imap4-forward))
+ (OK (elmo-imap4-parse-resp-text-code))
+ (NO (elmo-imap4-parse-resp-text-code))
+ (BAD (elmo-imap4-parse-resp-text-code))
+ (BYE (elmo-imap4-parse-bye))
+ (FLAGS (list 'flags
+ (elmo-imap4-parse-flag-list)))
+ (LIST (list 'list (elmo-imap4-parse-data-list)))
+ (LSUB (list 'lsub (elmo-imap4-parse-data-list)))
+ (SEARCH (list
+ 'search
+ (elmo-read (concat "("
+ (buffer-substring (point) (point-max))
+ ")"))))
+ (STATUS (elmo-imap4-parse-status))
+ ;; Added
+ (NAMESPACE (elmo-imap4-parse-namespace))
+ (CAPABILITY (list 'capability
+ (elmo-read
+ (concat "(" (downcase (buffer-substring
+ (point) (point-max)))
+ ")"))))
+ (ACL (elmo-imap4-parse-acl))
+ (t (case (prog1 (elmo-read (current-buffer))
+ (elmo-imap4-forward))
+ (EXISTS (list 'exists token))
+ (RECENT (list 'recent token))
+ (EXPUNGE (list 'expunge token))
+ (FETCH (elmo-imap4-parse-fetch token))
+ (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))
+ (elmo-imap4-forward))
+ (OK (progn
+ (setq elmo-imap4-parsing nil)
+ (setq token (symbol-name token))
+ (elmo-unintern token)
+ (elmo-imap4-debug "*%s* OK arrived" token)
+ (setq elmo-imap4-reached-tag token)
+ (list 'ok (elmo-imap4-parse-resp-text-code))))
+ (NO (progn
+ (setq elmo-imap4-parsing nil)
+ (setq token (symbol-name token))
+ (elmo-unintern token)
+ (elmo-imap4-debug "*%s* NO arrived" token)
+ (setq elmo-imap4-reached-tag token)
+ (let (code text)
+ (when (eq (char-after (point)) ?\[)
+ (setq code (buffer-substring (point)
+ (search-forward "]")))
+ (elmo-imap4-forward))
+ (setq text (buffer-substring (point) (point-max)))
+ (list 'no (list code text)))))
+ (BAD (progn
+ (setq elmo-imap4-parsing nil)
+ (elmo-imap4-debug "*%s* BAD arrived" token)
+ (setq token (symbol-name token))
+ (elmo-unintern token)
+ (setq elmo-imap4-reached-tag token)
+ (let (code text)
+ (when (eq (char-after (point)) ?\[)
+ (setq code (buffer-substring (point)
+ (search-forward "]")))
+ (elmo-imap4-forward))
+ (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)) ?\[)
+ (setq code (buffer-substring (point)
+ (search-forward "]")))
+ (elmo-imap4-forward))
+ (setq text (buffer-substring (point) (point-max)))
+ (list 'bye (list code text))))
+
+(defun elmo-imap4-parse-text ()
+ (goto-char (point-min))
+ (when (search-forward "[" nil t)
+ (search-forward "]")
+ (elmo-imap4-forward))
+ (list 'text (buffer-substring (point) (point-max))))
+
+(defun elmo-imap4-parse-resp-text-code ()
+ (when (eq (char-after (point)) ?\[)
+ (elmo-imap4-forward)
+ (cond ((search-forward "PERMANENTFLAGS " nil t)
+ (list 'permanentflags (elmo-imap4-parse-flag-list)))
+ ((search-forward "UIDNEXT " nil t)
+ (list 'uidnext (elmo-read (current-buffer))))
+ ((search-forward "UNSEEN " nil t)
+ (list 'unseen (elmo-read (current-buffer))))
+ ((looking-at "UIDVALIDITY \\([0-9]+\\)")
+ (list 'uidvalidity (match-string 1)))
+ ((search-forward "READ-ONLY" nil t)
+ (list 'read-only t))
+ ((search-forward "READ-WRITE" nil t)
+ (list 'read-write t))
+ ((search-forward "NEWNAME " nil t)
+ (let (oldname newname)
+ (setq oldname (elmo-imap4-parse-string))
+ (elmo-imap4-forward)
+ (setq newname (elmo-imap4-parse-string))
+ (list 'newname newname oldname)))
+ ((search-forward "TRYCREATE" nil t)
+ (list 'trycreate t))
+ ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
+ (list 'appenduid
+ (list (match-string 1)
+ (string-to-number (match-string 2)))))
+ ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
+ (list 'copyuid (list (match-string 1)
+ (match-string 2)
+ (match-string 3))))
+ ((search-forward "ALERT] " nil t)
+ (message "IMAP server information: %s"
+ (buffer-substring (point) (point-max))))
+ (t (list 'unknown)))))
+
+(defun elmo-imap4-parse-data-list ()
+ (let (flags delimiter mailbox)
+ (setq flags (elmo-imap4-parse-flag-list))
+ (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
+ (setq delimiter (match-string 1))
+ (goto-char (1+ (match-end 0)))
+ (when (setq mailbox (elmo-imap4-parse-mailbox))
+ (list mailbox flags delimiter)))))
+
+(defsubst elmo-imap4-parse-header-list ()
+ (when (eq (char-after (point)) ?\()
+ (let (strlist)
+ (while (not (eq (char-after (point)) ?\)))
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-astring) strlist))
+ (elmo-imap4-forward)
+ (nreverse strlist))))
+
+(defsubst elmo-imap4-parse-fetch-body-section ()
+ (let ((section
+ (buffer-substring (point)
+ (1-
+ (progn (re-search-forward "[] ]" nil t)
+ (point))))))
+ (if (eq (char-before) ? )
+ (prog1
+ (mapconcat 'identity
+ (cons section (elmo-imap4-parse-header-list)) " ")
+ (search-forward "]" nil t))
+ section)))
+
+(defun elmo-imap4-parse-fetch (response)
+ (when (eq (char-after (point)) ?\()
+ (let (element list)
+ (while (not (eq (char-after (point)) ?\)))
+ (elmo-imap4-forward)
+ (let ((token (elmo-imap4-fetch-read (current-buffer))))
+ (elmo-imap4-forward)
+ (setq element
+ (cond ((eq token 'UID)
+ (list 'uid (condition-case nil
+ (elmo-read (current-buffer))
+ (error nil))))
+ ((eq token 'FLAGS)
+ (list 'flags (elmo-imap4-parse-flag-list)))
+ ((eq token 'ENVELOPE)
+ (list 'envelope (elmo-imap4-parse-envelope)))
+ ((eq token 'INTERNALDATE)
+ (list 'internaldate (elmo-imap4-parse-string)))
+ ((eq token 'RFC822)
+ (list 'rfc822 (elmo-imap4-parse-nstring)))
+ ((eq token (intern elmo-imap4-rfc822-header))
+ (list 'rfc822header (elmo-imap4-parse-nstring)))
+ ((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))))
+ ((eq token 'BODY)
+ (if (eq (char-before) ?\[)
+ (list
+ 'bodydetail
+ (upcase (elmo-imap4-parse-fetch-body-section))
+ (and
+ (eq (char-after (point)) ?<)
+ (buffer-substring (1+ (point))
+ (progn
+ (search-forward ">" nil t)
+ (point))))
+ (progn (elmo-imap4-forward)
+ (elmo-imap4-parse-nstring)))
+ (list 'body (elmo-imap4-parse-body))))
+ ((eq token 'BODYSTRUCTURE)
+ (list 'bodystructure (elmo-imap4-parse-body)))))
+ (setq list (cons element list))))
+ (and elmo-imap4-fetch-callback
+ (funcall elmo-imap4-fetch-callback
+ list elmo-imap4-fetch-callback-data))
+ (list 'fetch list))))
+
+(defun elmo-imap4-parse-status ()
+ (let ((mailbox (elmo-imap4-parse-mailbox))
+ status)
+ (when (and mailbox (search-forward "(" nil t))
+ (while (not (eq (char-after (point)) ?\)))
+ (setq status
+ (cons
+ (let ((token (elmo-read (current-buffer))))
+ (cond ((eq token 'MESSAGES)
+ (list 'messages (elmo-read (current-buffer))))
+ ((eq token 'RECENT)
+ (list 'recent (elmo-read (current-buffer))))
+ ((eq token 'UIDNEXT)
+ (list 'uidnext (elmo-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))))
+ (t
+ (message
+ "Unknown status data %s in mailbox %s ignored"
+ token mailbox))))
+ status))
+ (skip-chars-forward " ")))
+ (and elmo-imap4-status-callback
+ (funcall elmo-imap4-status-callback
+ status
+ elmo-imap4-status-callback-data))
+ (list 'status status)))
+
+
+(defmacro elmo-imap4-value (value)
+ (` (if (eq (, value) 'NIL) nil
+ (, value))))
+
+(defmacro elmo-imap4-nth (pos list)
+ (` (let ((value (nth (, pos) (, list))))
+ (elmo-imap4-value value))))
+
+(defun elmo-imap4-parse-namespace ()
+ (list 'namespace
+ (nconc
+ (copy-sequence elmo-imap4-extra-namespace-alist)
+ (elmo-imap4-parse-namespace-subr
+ (elmo-read (concat "(" (buffer-substring
+ (point) (point-max))
+ ")"))))))
+
+(defun elmo-imap4-parse-namespace-subr (ns)
+ (let (prefix delim namespace-alist default-delim)
+ ;; 0: personal, 1: other, 2: shared
+ (dotimes (i 3)
+ (setq namespace-alist
+ (nconc namespace-alist
+ (delq nil
+ (mapcar
+ (lambda (namespace)
+ (setq prefix (elmo-imap4-nth 0 namespace)
+ delim (elmo-imap4-nth 1 namespace))
+ (if (and prefix delim
+ (string-match
+ (concat (regexp-quote delim) "\\'")
+ prefix))
+ (setq prefix (substring prefix 0
+ (match-beginning 0))))
+ (if (eq (length prefix) 0)
+ (progn (setq default-delim delim) nil)
+ (cons
+ (concat "^\\("
+ (if (string= (downcase prefix) "inbox")
+ "[Ii][Nn][Bb][Oo][Xx]"
+ (regexp-quote prefix))
+ "\\).*$")
+ delim)))
+ (elmo-imap4-nth i ns))))))
+ (if default-delim
+ (setq namespace-alist
+ (nconc namespace-alist
+ (list (cons "^.*$" default-delim)))))
+ namespace-alist))
+
+(defun elmo-imap4-parse-acl ()
+ (let ((mailbox (elmo-imap4-parse-mailbox))
+ identifier rights acl)
+ (while (eq (char-after (point)) ?\ )
+ (elmo-imap4-forward)
+ (setq identifier (elmo-imap4-parse-astring))
+ (elmo-imap4-forward)
+ (setq rights (elmo-imap4-parse-astring))
+ (setq acl (append acl (list (cons identifier rights)))))
+ (list 'acl acl mailbox)))
+
+(defun elmo-imap4-parse-flag-list ()
+ (let ((str (buffer-substring (+ (point) 1)
+ (progn (search-forward ")" nil t)
+ (- (point) 1)))))
+ (unless (eq (length str) 0)
+ (split-string str))))
+
+(defun elmo-imap4-parse-envelope ()
+ (when (eq (char-after (point)) ?\()
+ (elmo-imap4-forward)
+ (vector (prog1 (elmo-imap4-parse-nstring);; date
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-nstring);; subject
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-address-list);; from
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-address-list);; sender
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-address-list);; reply-to
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-address-list);; to
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-address-list);; cc
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-address-list);; bcc
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-nstring);; in-reply-to
+ (elmo-imap4-forward))
+ (prog1 (elmo-imap4-parse-nstring);; message-id
+ (elmo-imap4-forward)))))
+
+(defsubst elmo-imap4-parse-string-list ()
+ (cond ((eq (char-after (point)) ?\();; body-fld-param
+ (let (strlist str)
+ (elmo-imap4-forward)
+ (while (setq str (elmo-imap4-parse-string))
+ (push str strlist)
+ (elmo-imap4-forward))
+ (nreverse strlist)))
+ ((elmo-imap4-parse-nil)
+ nil)))
+
+(defun elmo-imap4-parse-body-extension ()
+ (if (eq (char-after (point)) ?\()
+ (let (b-e)
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-body-extension) b-e)
+ (while (eq (char-after (point)) ?\ )
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-body-extension) b-e))
+ (assert (eq (char-after (point)) ?\)))
+ (elmo-imap4-forward)
+ (nreverse b-e))
+ (or (elmo-imap4-parse-number)
+ (elmo-imap4-parse-nstring))))
+
+(defsubst elmo-imap4-parse-body-ext ()
+ (let (ext)
+ (when (eq (char-after (point)) ?\ );; body-fld-dsp
+ (elmo-imap4-forward)
+ (let (dsp)
+ (if (eq (char-after (point)) ?\()
+ (progn
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-string) dsp)
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-string-list) dsp)
+ (elmo-imap4-forward))
+ (assert (elmo-imap4-parse-nil)))
+ (push (nreverse dsp) ext))
+ (when (eq (char-after (point)) ?\ );; 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
+ (elmo-imap4-forward)
+ (setq ext (append (elmo-imap4-parse-body-extension) ext)))))
+ ext))
+
+(defun elmo-imap4-parse-body ()
+ (let (body)
+ (when (eq (char-after (point)) ?\()
+ (elmo-imap4-forward)
+ (if (eq (char-after (point)) ?\()
+ (let (subbody)
+ (while (and (eq (char-after (point)) ?\()
+ (setq subbody (elmo-imap4-parse-body)))
+ (push subbody body))
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-string) body);; media-subtype
+ (when (eq (char-after (point)) ?\ );; body-ext-mpart:
+ (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))
+ (setq body
+ (append (elmo-imap4-parse-body-ext) body)));; body-ext-...
+ (assert (eq (char-after (point)) ?\)))
+ (elmo-imap4-forward)
+ (nreverse body))
+
+ (push (elmo-imap4-parse-string) body);; media-type
+ (elmo-imap4-forward)
+ (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))
+ (if (eq (char-after (point)) ?\();; body-fld-param
+ (push (elmo-imap4-parse-string-list) body)
+ (push (and (elmo-imap4-parse-nil) nil) body))
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-nstring) body);; body-fld-id
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-nstring) body);; body-fld-desc
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-string) body);; body-fld-enc
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-number) body);; body-fld-octets
+
+ ;; ok, we're done parsing the required parts, what comes now is one
+ ;; of three things:
+ ;;
+ ;; envelope (then we're parsing body-type-msg)
+ ;; body-fld-lines (then we're parsing body-type-text)
+ ;; body-ext-1part (then we're parsing body-type-basic)
+ ;;
+ ;; 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)) ?\ )
+ (elmo-imap4-forward)
+ (let (lines)
+ (cond ((eq (char-after (point)) ?\();; body-type-msg:
+ (push (elmo-imap4-parse-envelope) body);; envelope
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-body) body);; body
+ (elmo-imap4-forward)
+ (push (elmo-imap4-parse-number) body));; body-fld-lines
+ ((setq lines (elmo-imap4-parse-number));; body-type-text:
+ (push lines body));; body-fld-lines
+ (t
+ (backward-char)))));; no match...
+
+ ;; ...and then parse the third one here...
+
+ (when (eq (char-after (point)) ?\ );; body-ext-1part:
+ (elmo-imap4-forward)
+ (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)))))
+
+(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)
+ (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))
+ 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))
+ ;; mailbox
+ (setq parse (elmo-parse-token name ":"))
+ (elmo-imap4-folder-set-mailbox-internal folder
+ (elmo-imap4-encode-folder-string
+ (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
+ elmo-imap4-folder))
+ (convert-standard-filename
+ (let ((mailbox (elmo-imap4-folder-mailbox-internal folder)))
+ (if (string= "inbox" (downcase mailbox))
+ (setq mailbox "inbox"))
+ (if (eq (string-to-char mailbox) ?/)
+ (setq mailbox (substring mailbox 1 (length mailbox))))
+ (expand-file-name
+ mailbox
+ (expand-file-name
+ (or (elmo-net-folder-user-internal folder) "nobody")
+ (expand-file-name (or (elmo-net-folder-server-internal folder)
+ "nowhere")
+ (expand-file-name
+ "imap"
+ elmo-msgdb-directory)))))))
+
+(luna-define-method elmo-folder-status-plugged ((folder
+ elmo-imap4-folder))
+ (elmo-imap4-folder-status-plugged folder))
+
+(defun elmo-imap4-folder-status-plugged (folder)
+ (let ((session (elmo-imap4-get-session folder))
+ (killed (elmo-msgdb-killed-list-load
+ (elmo-folder-msgdb-path folder)))
+ status)
+ (with-current-buffer (elmo-network-session-buffer session)
+ (setq elmo-imap4-status-callback nil)
+ (setq elmo-imap4-status-callback-data nil))
+ (setq status (elmo-imap4-response-value
+ (elmo-imap4-send-command-wait
+ session
+ (list "status "
+ (elmo-imap4-mailbox
+ (elmo-imap4-folder-mailbox-internal folder))
+ " (uidnext messages)"))
+ 'status))
+ (cons
+ (- (elmo-imap4-response-value status 'uidnext) 1)
+ (if killed
+ (-
+ (elmo-imap4-response-value status 'messages)
+ (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 nohide)
+ (elmo-imap4-list folder
+ (let ((max (elmo-msgdb-max-of-killed
+ (elmo-folder-killed-list-internal folder))))
+ (if (or nohide
+ (null (eq max 0)))
+ (format "uid %d:*" (1+ max))
+ "all"))))
+
+(luna-define-method elmo-folder-list-unreads-plugged
+ ((folder elmo-imap4-folder))
+ (elmo-imap4-list folder "unseen"))
+
+(luna-define-method elmo-folder-list-importants-plugged
+ ((folder elmo-imap4-folder))
+ (elmo-imap4-list folder "flagged"))
+
+(luna-define-method elmo-folder-use-flag-p ((folder elmo-imap4-folder))
+ (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)
+ (let* ((root (elmo-imap4-folder-mailbox-internal folder))
+ (session (elmo-imap4-get-session folder))
+ (prefix (elmo-folder-prefix-internal folder))
+ (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) " *"))))
+ (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))
+ (setq append-serv
+ (concat append-serv "/"
+ (symbol-name (elmo-net-folder-auth-internal folder)))))
+ (unless (string= (elmo-net-folder-server-internal folder)
+ elmo-imap4-default-server)
+ (setq append-serv (concat append-serv "@"
+ (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
+ (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-default-stream-type)
+ (if type
+ (setq append-serv (concat append-serv
+ (elmo-network-stream-type-spec-string
+ type)))))
+ (if one-level
+ (let ((re-delim (regexp-quote delim))
+ (case-fold-search nil)
+ 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))
+ (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)
+ (and append-serv
+ (eval append-serv))))
+ result))))
+
+(luna-define-method elmo-folder-exists-p-plugged ((folder elmo-imap4-folder))
+ (let ((session (elmo-imap4-get-session folder)))
+ (if (string=
+ (elmo-imap4-session-current-mailbox-internal session)
+ (elmo-imap4-folder-mailbox-internal folder))
+ t
+ (elmo-imap4-session-select-mailbox
+ session
+ (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)
+
+(luna-define-method elmo-folder-delete :before ((folder elmo-imap4-folder))
+ (let ((session (elmo-imap4-get-session folder))
+ msgs)
+ (when (elmo-imap4-folder-mailbox-internal folder)
+ (when (setq msgs (elmo-folder-list-messages folder))
+ (elmo-folder-delete-messages folder msgs))
+ (elmo-imap4-send-command-wait session "close")
+ (elmo-imap4-send-command-wait
+ session
+ (list "delete "
+ (elmo-imap4-mailbox
+ (elmo-imap4-folder-mailbox-internal folder)))))))
+
+(luna-define-method elmo-folder-rename-internal ((folder elmo-imap4-folder)
+ new-folder)
+ (let ((session (elmo-imap4-get-session folder)))
+ ;; make sure the folder is selected.
+ (elmo-imap4-session-select-mailbox session
+ (elmo-imap4-folder-mailbox-internal
+ folder))
+ (elmo-imap4-send-command-wait session "close")
+ (elmo-imap4-send-command-wait
+ session
+ (list "rename "
+ (elmo-imap4-mailbox
+ (elmo-imap4-folder-mailbox-internal folder))
+ " "
+ (elmo-imap4-mailbox
+ (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))
+ (set-list (elmo-imap4-make-number-set-list
+ numbers
+ elmo-imap4-number-set-chop-length))
+ succeeds)
+ (elmo-imap4-session-select-mailbox session
+ (elmo-imap4-folder-mailbox-internal
+ src-folder))
+ (while set-list
+ (if (elmo-imap4-send-command-wait session
+ (list
+ (format
+ (if elmo-imap4-use-uid
+ "uid copy %s "
+ "copy %s ")
+ (cdr (car set-list)))
+ (elmo-imap4-mailbox
+ (elmo-imap4-folder-mailbox-internal
+ dst-folder))))
+ (setq succeeds (append succeeds numbers)))
+ (setq set-list (cdr set-list)))
+ succeeds))
+
+(defun elmo-imap4-set-flag (folder numbers flag &optional remove)
+ "Set flag on messages.
+FOLDER is the ELMO folder structure.
+NUMBERS is the message numbers to be flagged.
+FLAG is the flag name.
+If optional argument REMOVE is non-nil, remove FLAG."
+ (let ((session (elmo-imap4-get-session folder))
+ response set-list)
+ (elmo-imap4-session-select-mailbox session
+ (elmo-imap4-folder-mailbox-internal
+ folder))
+ (setq set-list (elmo-imap4-make-number-set-list
+ numbers
+ elmo-imap4-number-set-chop-length))
+ (while set-list
+ (with-current-buffer (elmo-network-session-buffer session)
+ (setq elmo-imap4-fetch-callback nil)
+ (setq elmo-imap4-fetch-callback-data nil))
+ (unless (elmo-imap4-response-ok-p
+ (elmo-imap4-send-command-wait
+ session
+ (format
+ (if elmo-imap4-use-uid
+ "uid store %s %sflags.silent (%s)"
+ "store %s %sflags.silent (%s)")
+ (cdr (car set-list))
+ (if remove "-" "+")
+ flag)))
+ (setq response 'fail))
+ (setq set-list (cdr set-list)))
+ (not (eq response 'fail))))
+
+(luna-define-method elmo-folder-delete-messages-plugged
+ ((folder elmo-imap4-folder) numbers)
+ (let ((session (elmo-imap4-get-session folder)))
+ (elmo-imap4-set-flag folder numbers "\\Deleted")
+ (elmo-imap4-send-command-wait session "expunge")))
+
+(defmacro 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))
+ (imap-search-keys '("bcc" "body" "cc" "from" "subject" "to"
+ "larger" "smaller"))
+ (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)))
+ 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) )
+ numbers)))
+ (mapcar '(lambda (x) (delete x numbers)) rest)
+ numbers))
+ ((or (string= "since" search-key)
+ (string= "before" search-key))
+ (setq search-key (concat "sent" search-key)
+ set-list (elmo-imap4-make-number-set-list
+ from-msgs
+ elmo-imap4-number-set-chop-length)
+ end nil)
+ (while (not end)
+ (setq results
+ (append
+ results
+ (elmo-imap4-response-value
+ (elmo-imap4-send-command-wait
+ session
+ (format
+ (if elmo-imap4-use-uid
+ "uid search %s%s%s %s"
+ "search %s%s%s %s")
+ (if from-msgs
+ (concat
+ (if elmo-imap4-use-uid "uid ")
+ (cdr (car set-list))
+ " ")
+ "")
+ (if (eq (elmo-filter-type filter)
+ 'unmatch)
+ "not " "")
+ search-key
+ (elmo-date-get-description
+ (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)
+ (t
+ (setq charset
+ (if (eq (length (elmo-filter-value filter)) 0)
+ (setq charset 'us-ascii)
+ (elmo-imap4-detect-search-charset
+ (elmo-filter-value filter)))
+ set-list (elmo-imap4-make-number-set-list
+ from-msgs
+ elmo-imap4-number-set-chop-length)
+ end nil)
+ (while (not end)
+ (setq results
+ (append
+ results
+ (elmo-imap4-response-value
+ (elmo-imap4-send-command-wait
+ session
+ (list
+ (if elmo-imap4-use-uid "uid ")
+ "search "
+ "CHARSET "
+ (elmo-imap4-astring
+ (symbol-name charset))
+ " "
+ (if from-msgs
+ (concat
+ (if elmo-imap4-use-uid "uid ")
+ (cdr (car set-list))
+ " ")
+ "")
+ (if (eq (elmo-filter-type filter)
+ 'unmatch)
+ "not " "")
+ (format "%s%s "
+ (if (member
+ (elmo-filter-key filter)
+ imap-search-keys)
+ ""
+ "header ")
+ (elmo-filter-key filter))
+ (elmo-imap4-astring
+ (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))))
+
+(defun elmo-imap4-search-internal (folder session condition from-msgs)
+ (let (result)
+ (cond
+ ((vectorp condition)
+ (setq result (elmo-imap4-search-internal-primitive
+ folder session condition from-msgs)))
+ ((eq (car condition) 'and)
+ (setq result (elmo-imap4-search-internal folder session (nth 1 condition)
+ from-msgs)
+ result (elmo-list-filter result
+ (elmo-imap4-search-internal
+ folder session (nth 2 condition)
+ from-msgs))))
+ ((eq (car condition) 'or)
+ (setq result (elmo-imap4-search-internal
+ folder session (nth 1 condition) from-msgs)
+ result (elmo-uniq-list
+ (nconc result
+ (elmo-imap4-search-internal
+ folder session (nth 2 condition) from-msgs)))
+ result (sort result '<))))))
+
+(luna-define-method elmo-folder-search :around ((folder elmo-imap4-folder)
+ condition &optional numbers)
+ (if (elmo-folder-plugged-p folder)
(save-excursion
- (setq send-buf (elmo-imap4-setup-send-buffer string))
- (set-buffer send-buf)
- (elmo-imap4-send-command (process-buffer process)
- process
- (format "append %s %s{%d}"
- (elmo-imap4-spec-folder spec)
- (if no-see "" "(\\Seen) ")
- (buffer-size)))
- (if (null (elmo-imap4-read-response (process-buffer process)
- process))
- (error "Cannot append messages to this folder"))
- (process-send-string process (buffer-string))
- (process-send-string process "\r\n") ; finished appending.
- )
- (kill-buffer send-buf)
- (current-buffer)
- (if (null (elmo-imap4-read-response (process-buffer process)
- process))
- (error "Append failed")))
- t))
-
-(defun elmo-imap4-copy-msgs (dst-spec msgs src-spec &optional expunge-it same-number)
- "Equivalence of hostname, username is assumed."
- (save-excursion
- (let* ((src-folder (elmo-imap4-spec-folder src-spec))
- (dst-folder (elmo-imap4-spec-folder dst-spec))
- (connection (elmo-imap4-get-connection src-spec))
- (process (elmo-imap4-connection-get-process connection))
- (mlist msgs))
- (if (and src-folder
- (not (string= (elmo-imap4-connection-get-cwf connection)
- src-folder))
- (null (elmo-imap4-select-folder
- src-folder connection)))
- (error "Select folder failed"))
- (while mlist
- (elmo-imap4-send-command (process-buffer process)
- process
- (format
- (if elmo-imap4-use-uid
- "uid copy %s %s"
- "copy %s %s")
- (car mlist) dst-folder))
- (if (null (elmo-imap4-read-response (process-buffer process)
- process))
- (error "Copy failed")
- (setq mlist (cdr mlist))))
- (when expunge-it
- (elmo-imap4-send-command (process-buffer process)
- process "expunge")
- (if (null (elmo-imap4-read-response (process-buffer process)
- process))
- (error "Expunge failed")))
- t)))
-
-(defun elmo-imap4-server-diff (spec)
- "get server status"
- (save-excursion
- (let* ((connection (elmo-imap4-get-connection spec))
- (process (elmo-imap4-connection-get-process connection))
- response)
- ;; commit when same folder.
- (if (string= (elmo-imap4-connection-get-cwf connection)
- (elmo-imap4-spec-folder spec))
- (elmo-imap4-commit spec))
- (elmo-imap4-send-command (process-buffer process)
- process
- (format
- "status \"%s\" (unseen messages)"
- (elmo-imap4-spec-folder spec)))
- (setq response (elmo-imap4-read-response
- (process-buffer process) process))
- (when (string-match "\\* STATUS [^(]* \\(([^)]*)\\)" response)
- (setq response (read (downcase (elmo-match-string 1 response))))
- (cons (cadr (memq 'unseen response))
- (cadr (memq 'messages response)))))))
-
-(defun elmo-imap4-use-cache-p (spec number)
- elmo-imap4-use-cache)
+ (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)
+ (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))
+ (total 0)
+ (length (length numbers))
+ 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 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
+ 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"))
+ elmo-imap4-current-msgdb))))
+
+(luna-define-method elmo-folder-unmark-important-plugged
+ ((folder elmo-imap4-folder) numbers)
+ (elmo-imap4-set-flag folder numbers "\\Flagged" 'remove))
-(defun elmo-imap4-local-file-p (spec number)
- nil)
+(luna-define-method elmo-folder-mark-as-important-plugged
+ ((folder elmo-imap4-folder) numbers)
+ (elmo-imap4-set-flag folder numbers "\\Flagged"))
-(defun elmo-imap4-port-label (spec)
- (concat "imap4"
- (if (nth 6 spec) "!ssl" "")))
+(luna-define-method elmo-folder-unmark-read-plugged
+ ((folder elmo-imap4-folder) numbers)
+ (elmo-imap4-set-flag folder numbers "\\Seen" 'remove))
-(defsubst elmo-imap4-portinfo (spec)
- (list (elmo-imap4-spec-hostname spec) (elmo-imap4-spec-port spec)))
+(luna-define-method elmo-folder-mark-as-read-plugged
+ ((folder elmo-imap4-folder) numbers)
+ (elmo-imap4-set-flag folder numbers "\\Seen"))
-(defun elmo-imap4-plugged-p (spec)
- (apply 'elmo-plugged-p
- (append (elmo-imap4-portinfo spec)
- (list nil (quote (elmo-imap4-port-label spec))))))
+(luna-define-method elmo-message-use-cache-p ((folder elmo-imap4-folder)
+ number)
+ elmo-imap4-use-cache)
+
+(luna-define-method elmo-folder-message-appendable-p ((folder elmo-imap4-folder))
+ (if (elmo-folder-plugged-p folder)
+ (not (elmo-imap4-session-read-only-internal
+ (elmo-imap4-get-session folder)))
+ elmo-enable-disconnected-operation)) ; offline refile.
+
+(luna-define-method elmo-folder-check-plugged ((folder elmo-imap4-folder))
+ (let ((session (elmo-imap4-get-session folder 'if-exists)))
+ (when session
+ (if (string=
+ (elmo-imap4-session-current-mailbox-internal session)
+ (elmo-imap4-folder-mailbox-internal folder))
+ (if elmo-imap4-use-select-to-update-status
+ (elmo-imap4-session-select-mailbox
+ session
+ (elmo-imap4-folder-mailbox-internal folder)
+ 'force)
+ (elmo-imap4-session-check session))))))
+
+(defsubst elmo-imap4-folder-diff-plugged (folder)
+ (let ((session (elmo-imap4-get-session folder))
+ messages new unread response killed)
+;;; (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-send-command-wait session
+ (list
+ "status "
+ (elmo-imap4-mailbox
+ (elmo-imap4-folder-mailbox-internal
+ folder))
+ " (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)))
+ (if killed
+ (setq messages (- messages
+ (elmo-msgdb-killed-list-length
+ killed))))
+ (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))
+
+(luna-define-method elmo-folder-diff-async ((folder elmo-imap4-folder)
+ &optional number-alist)
+ (setq elmo-imap4-server-diff-async-callback
+ elmo-folder-diff-async-callback)
+ (setq elmo-imap4-server-diff-async-callback-data
+ elmo-folder-diff-async-callback-data)
+ (elmo-imap4-server-diff-async folder))
+
+(luna-define-method elmo-folder-open :around ((folder elmo-imap4-folder)
+ &optional load-msgdb)
+ (if (elmo-folder-plugged-p folder)
+ (let (session mailbox msgdb result response tag)
+ (condition-case err
+ (progn
+ (setq session (elmo-imap4-get-session folder)
+ mailbox (elmo-imap4-folder-mailbox-internal folder)
+ tag (elmo-imap4-send-command session
+ (list "select "
+ (elmo-imap4-mailbox
+ mailbox))))
+ (message "Selecting %s..."
+ (elmo-folder-name-internal folder))
+ (if load-msgdb
+ (setq msgdb (elmo-msgdb-load folder 'silent)))
+ (elmo-folder-set-killed-list-internal
+ folder
+ (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder)))
+ (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 (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 (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))))))
+ (luna-call-next-method)))
+
+;; elmo-folder-open-internal: do nothing.
+
+(luna-define-method elmo-find-fetch-strategy
+ ((folder elmo-imap4-folder) entity &optional ignore-cache)
+ (let ((number (elmo-msgdb-overview-entity-get-number entity))
+ cache-file size message-id)
+ (setq size (elmo-msgdb-overview-entity-get-size entity))
+ (setq message-id (elmo-msgdb-overview-entity-get-id entity))
+ (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
+ (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)))))))
+
+(luna-define-method elmo-folder-create-plugged ((folder elmo-imap4-folder))
+ (elmo-imap4-send-command-wait
+ (elmo-imap4-get-session folder)
+ (list "create "
+ (elmo-imap4-mailbox
+ (elmo-imap4-folder-mailbox-internal folder)))))
+
+(luna-define-method elmo-folder-append-buffer
+ ((folder elmo-imap4-folder) unread &optional number)
+ (if (elmo-folder-plugged-p folder)
+ (let ((session (elmo-imap4-get-session folder))
+ send-buffer result)
+ (elmo-imap4-session-select-mailbox session
+ (elmo-imap4-folder-mailbox-internal
+ folder))
+ (setq send-buffer (elmo-imap4-setup-send-buffer))
+ (unwind-protect
+ (setq result
+ (elmo-imap4-send-command-wait
+ session
+ (list
+ "append "
+ (elmo-imap4-mailbox (elmo-imap4-folder-mailbox-internal
+ folder))
+ (if unread " () " " (\\Seen) ")
+ (elmo-imap4-buffer-literal send-buffer))))
+ (kill-buffer send-buffer))
+ result)
+ ;; Unplugged
+ (if elmo-enable-disconnected-operation
+ (elmo-folder-append-buffer-dop folder unread number)
+ (error "Unplugged"))))
+
+(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 unread-marks
+ &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))
+ ;; Plugged
+ (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)
+ number)
+ (if (elmo-folder-plugged-p folder)
+ (not (elmo-imap4-session-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)
+; "")))
+
+(defsubst elmo-imap4-message-fetch (folder number strategy
+ section outbuf unseen)
+ (let ((session (elmo-imap4-get-session folder))
+ response)
+ (elmo-imap4-session-select-mailbox session
+ (elmo-imap4-folder-mailbox-internal
+ folder))
+ (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"))
+ (if (setq response (elmo-imap4-response-bodydetail-text
+ (elmo-imap4-response-value-all
+ response 'fetch)))
+ (with-current-buffer outbuf
+ (erase-buffer)
+ (insert response)
+ t))))
+
+(luna-define-method elmo-message-fetch-plugged ((folder elmo-imap4-folder)
+ number strategy
+ &optional section
+ outbuf unseen)
+ (elmo-imap4-message-fetch folder number strategy section outbuf unseen))
+
+(luna-define-method elmo-message-fetch-field ((folder elmo-imap4-folder)
+ number field)
+ (let ((session (elmo-imap4-get-session folder)))
+ (elmo-imap4-session-select-mailbox session
+ (elmo-imap4-folder-mailbox-internal
+ folder))
+ (with-current-buffer (elmo-network-session-buffer session)
+ (setq elmo-imap4-fetch-callback nil)
+ (setq elmo-imap4-fetch-callback-data nil))
+ (with-temp-buffer
+ (insert
+ (elmo-imap4-response-bodydetail-text
+ (elmo-imap4-response-value
+ (elmo-imap4-send-command-wait session
+ (concat
+ (if elmo-imap4-use-uid
+ "uid ")
+ (format
+ "fetch %s (body.peek[header.fields (%s)])"
+ number field)))
+ 'fetch)))
+ (elmo-delete-cr-buffer)
+ (goto-char (point-min))
+ (std11-field-body (symbol-name field)))))
-(defun elmo-imap4-set-plugged (spec plugged add)
- (apply 'elmo-set-plugged plugged
- (append (elmo-imap4-portinfo spec)
- (list nil nil (quote (elmo-imap4-port-label spec)) add))))
-(defalias 'elmo-imap4-sync-number-alist 'elmo-generic-sync-number-alist)
-(provide 'elmo-imap4)
+(require 'product)
+(product-provide (provide 'elmo-imap4) (require 'elmo-version))
;;; elmo-imap4.el ends here
projects / elisp / wanderlust.git / blobdiff