X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-imap4.el;h=022048ec89784754cac797b677d4474899a05b1e;hb=10518221da70c6e7ffc66352ee6a3e1036bd5133;hp=c90ead48f56cf20b8feb93c32a6a7ffe95df5c04;hpb=b4d6477123dc6b4abb061a544937f953eacee692;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-imap4.el b/elmo/elmo-imap4.el index c90ead4..022048e 100644 --- a/elmo/elmo-imap4.el +++ b/elmo/elmo-imap4.el @@ -1,8 +1,14 @@ ;;; 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 ;; This file is part of ELMO (Elisp Library for Message Orchestration). @@ -41,25 +47,7 @@ (require 'utf7) ;;; 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 number-alist mark-alist unread-marks)) - (defun-maybe elmo-generic-folder-diff (spec folder number-list)) - (defsubst-maybe utf7-decode-string (string &optional imap) string)) +(eval-when-compile (require 'cl)) (defvar elmo-imap4-use-lock t "USE IMAP4 with locking process.") @@ -118,13 +106,6 @@ elmo-imap4-status-callback-data elmo-imap4-current-msgdb)) -(defvar elmo-imap4-authenticator-alist - '((login elmo-imap4-auth-login) - (cram-md5 elmo-imap4-auth-cram-md5) - (digest-md5 elmo-imap4-auth-digest-md5) - (plain elmo-imap4-login)) - "Definition of authenticators.") - ;;;; (defconst elmo-imap4-quoted-specials-list '(?\\ ?\")) @@ -381,6 +362,9 @@ If response is not `OK' response, causes error with IMAP response text." ;;; (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) @@ -545,6 +529,10 @@ BUFFER must be a single-byte buffer." (unless (string= (elmo-imap4-spec-username spec) elmo-default-imap4-user) (setq append-serv (concat ":" (elmo-imap4-spec-username spec)))) + (unless (eq (elmo-imap4-spec-auth spec) + elmo-default-imap4-authenticate-type) + (setq append-serv + (concat append-serv "/" (symbol-name (elmo-imap4-spec-auth spec))))) (unless (string= (elmo-imap4-spec-hostname spec) elmo-default-imap4-server) (setq append-serv (concat append-serv "@" (elmo-imap4-spec-hostname @@ -561,11 +549,40 @@ BUFFER must be a single-byte buffer." (setq append-serv (concat append-serv (elmo-network-stream-type-spec-string type))))) - (mapcar (lambda (fld) - (concat "%" (elmo-imap4-decode-folder-string fld) - (and append-serv - (eval append-serv)))) - result))) + (if hierarchy + (let (folder folders ret) + (while (setq folders (car result)) + (if (prog1 + (string-match + (concat "^\\(" root "[^" delim "]" "+\\)" delim) + folders) + (setq folder (match-string 1 folders))) + (progn + (setq ret + (append ret (list (list + (concat "%" (elmo-imap4-decode-folder-string folder) + (and append-serv + (eval append-serv))))))) + (setq result + (delq nil + (mapcar '(lambda (fld) + (unless + (string-match + (concat "^" (regexp-quote folder)) + fld) + fld)) + result)))) + (setq ret (append ret (list + (concat "%" (elmo-imap4-decode-folder-string folders) + (and append-serv + (eval append-serv)))))) + (setq result (cdr result)))) + ret) + (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 ((session (elmo-imap4-get-session spec))) @@ -597,23 +614,24 @@ BUFFER must be a single-byte buffer." (when (elmo-imap4-spec-mailbox spec) (when (setq msgs (elmo-imap4-list-folder spec)) (elmo-imap4-delete-msgs spec msgs)) - ;; (elmo-imap4-send-command-wait session "close") + (elmo-imap4-send-command-wait session "close") (elmo-imap4-send-command-wait session (list "delete " (elmo-imap4-mailbox (elmo-imap4-spec-mailbox spec))))))) (defun elmo-imap4-rename-folder (old-spec new-spec) -;;;(elmo-imap4-send-command-wait session "close") - (elmo-imap4-send-command-wait - (elmo-imap4-get-session old-spec) - (list "rename " - (elmo-imap4-mailbox - (elmo-imap4-spec-mailbox old-spec)) - " " - (elmo-imap4-mailbox - (elmo-imap4-spec-mailbox new-spec))))) - + (let ((session (elmo-imap4-get-session old-spec))) + (elmo-imap4-send-command-wait session "close") + (elmo-imap4-send-command-wait + session + (list "rename " + (elmo-imap4-mailbox + (elmo-imap4-spec-mailbox old-spec)) + " " + (elmo-imap4-mailbox + (elmo-imap4-spec-mailbox new-spec)))))) + (defun elmo-imap4-max-of-folder (spec) (let ((session (elmo-imap4-get-session spec)) (killed (and elmo-use-killed-list @@ -643,7 +661,7 @@ BUFFER must be a single-byte buffer." (if elmo-use-server-diff (elmo-imap4-server-diff spec) (elmo-generic-folder-diff spec folder number-list))) - + (defun elmo-imap4-get-session (spec &optional if-exists) (elmo-network-get-session 'elmo-imap4-session @@ -1025,20 +1043,28 @@ If optional argument UNMARK is non-nil, unmark." ;; ;; app-data: +;; cons of list ;; 0: new-mark 1: already-mark 2: seen-mark 3: important-mark -;; 4: seen-list 5: as-number +;; 4: seen-list +;; and result of use-flag-p. (defun elmo-imap4-fetch-callback-1 (entity flags app-data) "A msgdb entity callback function." - (let ((seen (member (car entity) (nth 4 app-data))) - mark) + (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))) (setq mark (or (elmo-msgdb-global-mark-get (car entity)) (if (elmo-cache-exists-p (car entity)) ;; XXX - (if (or (member "\\Seen" flags) seen) + (if (or seen + (and use-flag + (member "\\Seen" flags))) nil (nth 1 app-data)) - (if (or (member "\\Seen" flags) seen) + (if (or seen + (and use-flag + (member "\\Seen" flags))) (if elmo-imap4-use-cache (nth 2 app-data)) (nth 0 app-data))))) @@ -1078,7 +1104,9 @@ If optional argument UNMARK is non-nil, unmark." (with-current-buffer (elmo-network-session-buffer session) (setq elmo-imap4-current-msgdb nil elmo-imap4-fetch-callback 'elmo-imap4-fetch-callback-1 - elmo-imap4-fetch-callback-data args) + elmo-imap4-fetch-callback-data (cons args + (elmo-imap4-use-flag-p + spec))) (while set-list (elmo-imap4-send-command-wait session @@ -1103,7 +1131,20 @@ If optional argument UNMARK is non-nil, unmark." (elmo-read (concat "(" (downcase (elmo-match-string 1 string)) ")")))) -;; Current buffer is process buffer. +(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)) @@ -1121,59 +1162,6 @@ If optional argument UNMARK is non-nil, unmark." (or (elmo-imap4-read-ok session tag) (signal 'elmo-authenticate-error '(elmo-imap4-auth-login))) (setq elmo-imap4-status 'auth))) - -(defun elmo-imap4-auth-cram-md5 (session) - (let ((tag (elmo-imap4-send-command session "authenticate cram-md5")) - (elmo-imap4-debug-inhibit-logging t) - response) - (or (setq response (elmo-imap4-read-continue-req session)) - (signal 'elmo-authenticate-error - '(elmo-imap4-auth-cram-md5))) - (elmo-imap4-send-string - session - (elmo-base64-encode-string - (sasl-cram-md5 (elmo-network-session-user-internal session) - (elmo-get-passwd - (elmo-network-session-password-key session)) - (elmo-base64-decode-string response)))) - (or (elmo-imap4-read-ok session tag) - (signal 'elmo-authenticate-error '(elmo-imap4-auth-cram-md5))))) - -(defun elmo-imap4-auth-digest-md5 (session) - (let ((tag (elmo-imap4-send-command session "authenticate digest-md5")) - (elmo-imap4-debug-inhibit-logging t) - response) - (or (setq response (elmo-imap4-read-continue-req session)) - (signal 'elmo-authenticate-error '(elmo-imap4-auth-digest-md5))) - (elmo-imap4-send-string - session - (elmo-base64-encode-string - (sasl-digest-md5-digest-response - (elmo-base64-decode-string response) - (elmo-network-session-user-internal session) - (elmo-get-passwd (elmo-network-session-password-key session)) - "imap" - (elmo-network-session-password-key session)) - 'no-line-break)) - (or (setq response (elmo-imap4-read-continue-req session)) - (signal 'elmo-authenticate-error '(elmo-imap4-auth-digest-md5))) - (elmo-imap4-send-string session "") - (or (elmo-imap4-read-ok session tag) - (signal 'elmo-authenticate-error '(elmo-imap4-auth-digest-md5))))) - -(defun elmo-imap4-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 '(login))))) (luna-define-method elmo-network-initialize-session-buffer :after ((session @@ -1185,8 +1173,7 @@ If optional argument UNMARK is non-nil, unmark." (luna-define-method elmo-network-initialize-session ((session elmo-imap4-session)) - (let ((process (elmo-network-session-process-internal session)) - capability) + (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)) @@ -1212,42 +1199,116 @@ If optional argument UNMARK is non-nil, unmark." (when (eq (elmo-network-stream-type-symbol (elmo-network-session-stream-type-internal session)) 'starttls) - (or (memq 'starttls capability) + (or (memq 'starttls + (elmo-imap4-session-capability-internal session)) (signal 'elmo-open-error - '(elmo-network-initialize-session))) + '(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)) - (unless (eq elmo-imap4-status 'auth) - (unless (or (not (elmo-network-session-auth-internal session)) - (eq (elmo-network-session-auth-internal session) 'plain) - (and (memq (intern - (format "auth=%s" - (elmo-network-session-auth-internal - session))) - (elmo-imap4-session-capability-internal session)) - (assq - (elmo-network-session-auth-internal session) - elmo-imap4-authenticator-alist))) - (if (or elmo-imap4-force-login - (y-or-n-p - (format - "There's no %s capability in server. continue?" - (elmo-network-session-auth-internal session)))) - (elmo-network-session-set-auth-internal session nil) - (signal 'elmo-open-error - '(elmo-network-initialize-session)))) - (let ((authenticator - (if (elmo-network-session-auth-internal session) - (nth 1 (assq - (elmo-network-session-auth-internal session) - elmo-imap4-authenticator-alist)) - 'elmo-imap4-login))) - (funcall authenticator 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-host-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-continue-req-p response) + (unless (sasl-next-step client step) + ;; response is '+' but there's no next step. + (signal 'elmo-authenticate-error + (list (intern + (concat "elmo-imap4-auth-" + (downcase name)))))) + ;; response is OK. + (if (elmo-imap4-response-ok-p response) + (throw 'done nil) ; finished. + ;; 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)) @@ -1298,7 +1359,7 @@ If optional argument UNMARK is non-nil, unmark." (elmo-imap4-read-msg spec msg outbuf 'unseen)) (defun elmo-imap4-read-msg (spec msg outbuf - &optional leave-seen-flag-untouched) + &optional msgdb leave-seen-flag-untouched) (let ((session (elmo-imap4-get-session spec)) response) (elmo-imap4-session-select-mailbox session @@ -1310,15 +1371,14 @@ If optional argument UNMARK is non-nil, unmark." (elmo-imap4-send-command-wait session (format (if elmo-imap4-use-uid - "uid fetch %s rfc822%s" - "fetch %s rfc822%s") + "uid fetch %s body%s[]" + "fetch %s body%s[]") msg (if leave-seen-flag-untouched ".peek" "")))) - (and (setq response (elmo-imap4-response-value + (and (setq response (elmo-imap4-response-bodydetail-text (elmo-imap4-response-value-all - response 'fetch ) - 'rfc822)) + response 'fetch ))) (with-current-buffer outbuf (erase-buffer) (insert response) @@ -1522,6 +1582,7 @@ Return nil if no complete line has arrived." (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)) @@ -1549,7 +1610,7 @@ Return nil if no complete line has arrived." (t (message "Unknown state %s in arrival filter" elmo-imap4-status)))) - (delete-region (point-min) (point-max))))))) + (delete-region (point-min) (point-max)))))))) ;; IMAP parser.