X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-imap4.el;h=795d27ff1eac77827c8145cf14c225a99003fc59;hb=7b1c7e63938a59f9e887f91104ac866dd2fdd573;hp=66f3d0b1d80208b4bf963298b563d80059a93d3a;hpb=1e366a559be4aec4ad4d3cf3e954b8e62a20d2f3;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-imap4.el b/elmo/elmo-imap4.el index 66f3d0b..795d27f 100644 --- a/elmo/elmo-imap4.el +++ b/elmo/elmo-imap4.el @@ -1,10 +1,15 @@ -;;; elmo-imap4.el -- IMAP4 Interface for ELMO. +;;; elmo-imap4.el --- IMAP4 Interface for ELMO. -;; Copyright 1998,1999,2000 Yuuichi Teranishi +;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi +;; Copyright (C) 1999,2000 Kenichi OKADA +;; Copyright (C) 2000 OKAZAKI Tetsurou +;; Copyright (C) 2000 Daiki Ueno ;; Author: Yuuichi Teranishi +;; Kenichi OKADA +;; OKAZAKI Tetsurou +;; Daiki Ueno ;; Keywords: mail, net news -;; Time-stamp: <00/03/14 19:40:38 teranisi> ;; This file is part of ELMO (Elisp Library for Message Orchestration). @@ -25,835 +30,726 @@ ;; ;;; Commentary: -;; +;; +;; Origin of IMAP parser part is imap.el, included in Gnus. +;; +;; Copyright (C) 1998, 1999, 2000 +;; Free Software Foundation, Inc. +;; Author: Simon Josefsson +;; (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 +;; +;; "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 +;;; 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*\"") +(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 (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 + (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-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]." + (` (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 (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. @@ -863,7 +759,7 @@ NUMBER is contained message number in SET-STRING. 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) @@ -871,12 +767,12 @@ If CHOP-LENGTH is not specified, message set is not chopped." (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 @@ -892,491 +788,281 @@ If CHOP-LENGTH is not specified, message set is not chopped." (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))))) + +(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 @@ -1385,204 +1071,1517 @@ Return nil if connection failed." (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)))) + (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 + (if (eq (length (car parse)) 0) + elmo-imap4-default-mailbox + (car parse)))) + ;; user + (setq parse (elmo-parse-prefixed-element ?: (cdr parse) "/")) + (elmo-net-folder-set-user-internal folder + (if (eq (length (car parse)) 0) + default-user + (car parse))) + ;; auth + (setq parse (elmo-parse-prefixed-element ?/ (cdr parse))) + (elmo-net-folder-set-auth-internal + folder + (if (eq (length (car parse)) 0) + (or elmo-imap4-default-authenticate-type 'clear) + (intern (car parse)))) + (unless (elmo-net-folder-server-internal folder) + (elmo-net-folder-set-server-internal folder default-server)) + (unless (elmo-net-folder-port-internal folder) + (elmo-net-folder-set-port-internal folder default-port)) + (unless (elmo-net-folder-stream-type-internal folder) + (elmo-net-folder-set-stream-type-internal + folder + (elmo-get-network-stream-type elmo-imap4-default-stream-type))) + folder)) + +;;; ELMO IMAP4 folder +(luna-define-method elmo-folder-expand-msgdb-path ((folder + 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)) + (delim (or + (cdr + (elmo-string-matched-assoc + root + (with-current-buffer (elmo-network-session-buffer session) + elmo-imap4-server-namespace))) + elmo-imap4-default-hierarchy-delimiter)) + ;; Append delimiter when root with namespace. + (root (if (and (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-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")) + (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 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)))) + (if load-msgdb + (setq msgdb (elmo-msgdb-load folder))) + (elmo-folder-set-killed-list-internal + folder + (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder))) + (setq response (elmo-imap4-read-response session tag))) + (quit + (if response + (elmo-imap4-session-set-current-mailbox-internal + session mailbox) + (and session + (elmo-imap4-session-set-current-mailbox-internal + session nil)))) + (error + (if response + (elmo-imap4-session-set-current-mailbox-internal + session mailbox) + (and session + (elmo-imap4-session-set-current-mailbox-internal + session nil))))) + (if load-msgdb + (elmo-folder-set-msgdb-internal + folder + (or msgdb (elmo-msgdb-load folder))))) + (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 ((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