mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2025-01-11 16:08:13 +00:00
2000-10-27 Simon Josefsson <simon@josefsson.org>
* nnimap.el (nnimap-group-overview-filename): Create directory for newfile (when use long filenames is nil). Copy+delete file if rename didn't work. (nnimap-group-overview-filename): `rename-file' and `copy-file' doesn't return anything useful, use ignore-errors instead. (nnimap-verify-uidvalidity): Delete overview file when uid validity changes. (nnimap-group-overview-filename): Store uidvalidity in filenames. Rename old files into new format. (nnimap-request-accept-article): Remove \n's from From_ lines. (nnimap-request-accept-article): Remove From[^:] lines. (imap-starttls-p): Check for starttls binary. (imap-starttls-open): More verbose. (imap-gssapi-auth): Ditto. (imap-kerberos4-auth): Ditto. (imap-cram-md5-auth): Ditto. (imap-login-auth): Ditto. (imap-anonymous-auth): Ditto. (imap-digest-md5-auth): Ditto. (imap-open): Ditto. (imap-digest-md5-p): Check capability first. (imap-parse-flag-list): Correctly parse empty lists. (imap-login-p): Support LOGINDISABLED. (imap-parse-body): Work around bug in Sun SIMS.
This commit is contained in:
Dave Love
parent
e0bad764b1
commit
a261748441
@ -75,11 +75,11 @@
|
||||
;;
|
||||
;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP
|
||||
;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
|
||||
;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS)
|
||||
;; (with use of external library starttls.el and program starttls) and
|
||||
;; the GSSAPI / kerberos V4 sections of RFC1731 (with use of external
|
||||
;; program `imtest'). It also take advantage the UNSELECT extension
|
||||
;; in Cyrus IMAPD.
|
||||
;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS,
|
||||
;; LOGINDISABLED) (with use of external library starttls.el and
|
||||
;; program starttls) and the GSSAPI / kerberos V4 sections of RFC1731
|
||||
;; (with use of external program `imtest'). It also take advantage
|
||||
;; the UNSELECT extension in Cyrus IMAPD.
|
||||
;;
|
||||
;; Without the work of John McClary Prevost and Jim Radford this library
|
||||
;; would not have seen the light of day. Many thanks.
|
||||
@ -480,7 +480,8 @@ If ARGS, PROMPT is used as an argument to `format'."
|
||||
(goto-char (point-max))
|
||||
(insert-buffer-substring buffer)))
|
||||
(erase-buffer)
|
||||
(message "Kerberos 4 IMAP connection: %s" (or response "failed"))
|
||||
(message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
|
||||
(if response (concat "done, " response) "failed"))
|
||||
(if (and response (let ((case-fold-search nil))
|
||||
(not (string-match "failed" response))))
|
||||
(setq done process)
|
||||
@ -590,7 +591,7 @@ If ARGS, PROMPT is used as an argument to `format'."
|
||||
(progn
|
||||
(message "imap: Opening SSL connection with `%s'...done" cmd)
|
||||
done)
|
||||
(message "imap: Failed opening SSL connection")
|
||||
(message "imap: Opening SSL connection with `%s'...failed" cmd)
|
||||
nil)))
|
||||
|
||||
(defun imap-network-p (buffer)
|
||||
@ -656,20 +657,24 @@ If ARGS, PROMPT is used as an argument to `format'."
|
||||
(progn
|
||||
(message "imap: Opening IMAP connection with `%s'...done" cmd)
|
||||
done)
|
||||
(message "imap: Failed opening IMAP connection")
|
||||
(message "imap: Opening IMAP connection with `%s'...failed" cmd)
|
||||
nil)))
|
||||
|
||||
(defun imap-starttls-p (buffer)
|
||||
(and (condition-case ()
|
||||
(require 'starttls)
|
||||
(error nil))
|
||||
(imap-capability 'STARTTLS buffer)))
|
||||
(and (imap-capability 'STARTTLS buffer)
|
||||
(condition-case ()
|
||||
(progn
|
||||
(require 'starttls)
|
||||
(call-process "starttls"))
|
||||
(error nil))))
|
||||
|
||||
(defun imap-starttls-open (name buffer server port)
|
||||
(let* ((port (or port imap-default-port))
|
||||
(coding-system-for-read imap-coding-system-for-read)
|
||||
(coding-system-for-write imap-coding-system-for-write)
|
||||
(process (starttls-open-stream name buffer server port)))
|
||||
(process (starttls-open-stream name buffer server port))
|
||||
done)
|
||||
(message "imap: Connecting with STARTTLS...")
|
||||
(when process
|
||||
(while (and (memq (process-status process) '(open run))
|
||||
(goto-char (point-min))
|
||||
@ -690,7 +695,13 @@ If ARGS, PROMPT is used as an argument to `format'."
|
||||
(starttls-negotiate imap-process)))
|
||||
(set-process-filter imap-process nil)))
|
||||
(when (memq (process-status process) '(open run))
|
||||
process))))
|
||||
(setq done process)))
|
||||
(if done
|
||||
(progn
|
||||
(message "imap: Connecting with STARTTLS...done")
|
||||
done)
|
||||
(message "imap: Connecting with STARTTLS...failed")
|
||||
nil)))
|
||||
|
||||
;; Server functions; authenticator stuff:
|
||||
|
||||
@ -736,12 +747,16 @@ Returns t if login was successful, nil otherwise."
|
||||
(imap-capability 'AUTH=GSSAPI buffer))
|
||||
|
||||
(defun imap-gssapi-auth (buffer)
|
||||
(message "imap: Authenticating using GSSAPI...%s"
|
||||
(if (eq imap-stream 'gssapi) "done" "failed"))
|
||||
(eq imap-stream 'gssapi))
|
||||
|
||||
(defun imap-kerberos4-auth-p (buffer)
|
||||
(imap-capability 'AUTH=KERBEROS_V4 buffer))
|
||||
|
||||
(defun imap-kerberos4-auth (buffer)
|
||||
(message "imap: Authenticating using Kerberos 4...%s"
|
||||
(if (eq imap-stream 'kerberos4) "done" "failed"))
|
||||
(eq imap-stream 'kerberos4))
|
||||
|
||||
(defun imap-cram-md5-p (buffer)
|
||||
@ -749,25 +764,33 @@ Returns t if login was successful, nil otherwise."
|
||||
|
||||
(defun imap-cram-md5-auth (buffer)
|
||||
"Login to server using the AUTH CRAM-MD5 method."
|
||||
(imap-interactive-login
|
||||
buffer
|
||||
(lambda (user passwd)
|
||||
(imap-ok-p
|
||||
(imap-send-command-wait
|
||||
(list
|
||||
"AUTHENTICATE CRAM-MD5"
|
||||
(lambda (challenge)
|
||||
(let* ((decoded (base64-decode-string challenge))
|
||||
(hash (rfc2104-hash 'md5 64 16 passwd decoded))
|
||||
(response (concat user " " hash))
|
||||
(encoded (base64-encode-string response)))
|
||||
encoded))))))))
|
||||
(message "imap: Authenticating using CRAM-MD5...")
|
||||
(let ((done (imap-interactive-login
|
||||
buffer
|
||||
(lambda (user passwd)
|
||||
(imap-ok-p
|
||||
(imap-send-command-wait
|
||||
(list
|
||||
"AUTHENTICATE CRAM-MD5"
|
||||
(lambda (challenge)
|
||||
(let* ((decoded (base64-decode-string challenge))
|
||||
(hash (rfc2104-hash 'md5 64 16 passwd decoded))
|
||||
(response (concat user " " hash))
|
||||
(encoded (base64-encode-string response)))
|
||||
encoded)))))))))
|
||||
(if done
|
||||
(message "imap: Authenticating using CRAM-MD5...done")
|
||||
(message "imap: Authenticating using CRAM-MD5...failed"))))
|
||||
|
||||
|
||||
|
||||
(defun imap-login-p (buffer)
|
||||
(not (imap-capability 'X-LOGIN-CMD-DISABLED buffer)))
|
||||
(and (not (imap-capability 'LOGINDISABLED buffer))
|
||||
(not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))))
|
||||
|
||||
(defun imap-login-auth (buffer)
|
||||
"Login to server using the LOGIN command."
|
||||
(message "imap: Plaintext authentication...")
|
||||
(imap-interactive-login buffer
|
||||
(lambda (user passwd)
|
||||
(imap-ok-p (imap-send-command-wait
|
||||
@ -778,19 +801,21 @@ Returns t if login was successful, nil otherwise."
|
||||
t)
|
||||
|
||||
(defun imap-anonymous-auth (buffer)
|
||||
(message "imap: Loging in anonymously...")
|
||||
(with-current-buffer buffer
|
||||
(imap-ok-p (imap-send-command-wait
|
||||
(concat "LOGIN anonymous \"" (concat (user-login-name) "@"
|
||||
(system-name)) "\"")))))
|
||||
|
||||
(defun imap-digest-md5-p (buffer)
|
||||
(and (condition-case ()
|
||||
(and (imap-capability 'AUTH=DIGEST-MD5 buffer)
|
||||
(condition-case ()
|
||||
(require 'digest-md5)
|
||||
(error nil))
|
||||
(imap-capability 'AUTH=DIGEST-MD5 buffer)))
|
||||
(error nil))))
|
||||
|
||||
(defun imap-digest-md5-auth (buffer)
|
||||
"Login to server using the AUTH DIGEST-MD5 method."
|
||||
(message "imap: Authenticating using DIGEST-MD5...")
|
||||
(imap-interactive-login
|
||||
buffer
|
||||
(lambda (user passwd)
|
||||
@ -861,37 +886,44 @@ necessery. If nil, the buffer name is generated."
|
||||
(setq imap-port (or port imap-port))
|
||||
(setq imap-auth (or auth imap-auth))
|
||||
(setq imap-stream (or stream imap-stream))
|
||||
(when (let ((imap-stream (or imap-stream imap-default-stream)))
|
||||
(imap-open-1 buffer))
|
||||
;; Choose stream.
|
||||
(let (stream-changed)
|
||||
(when (null imap-stream)
|
||||
(let ((streams imap-streams))
|
||||
(while (setq stream (pop streams))
|
||||
(if (funcall (nth 1 (assq stream imap-stream-alist)) buffer)
|
||||
(setq stream-changed (not (eq (or imap-stream
|
||||
imap-default-stream)
|
||||
stream))
|
||||
imap-stream stream
|
||||
streams nil)))
|
||||
(unless imap-stream
|
||||
(error "Couldn't figure out a stream for server"))))
|
||||
(when stream-changed
|
||||
(message "Reconnecting with %s..." imap-stream)
|
||||
(imap-close buffer)
|
||||
(imap-open-1 buffer)
|
||||
(setq imap-capability nil)))
|
||||
(if (imap-opened buffer)
|
||||
;; Choose authenticator
|
||||
(when (and (null imap-auth) (not (eq imap-state 'auth)))
|
||||
(let ((auths imap-authenticators))
|
||||
(while (setq auth (pop auths))
|
||||
(if (funcall (nth 1 (assq auth imap-authenticator-alist))
|
||||
buffer)
|
||||
(setq imap-auth auth
|
||||
auths nil)))
|
||||
(unless imap-auth
|
||||
(error "Couldn't figure out authenticator for server"))))))
|
||||
(message "imap: Connecting to %s..." imap-server)
|
||||
(if (let ((imap-stream (or imap-stream imap-default-stream)))
|
||||
(imap-open-1 buffer))
|
||||
;; Choose stream.
|
||||
(let (stream-changed)
|
||||
(message "imap: Connecting to %s...done" imap-server)
|
||||
(when (null imap-stream)
|
||||
(let ((streams imap-streams))
|
||||
(while (setq stream (pop streams))
|
||||
(if (funcall (nth 1 (assq stream imap-stream-alist)) buffer)
|
||||
(setq stream-changed (not (eq (or imap-stream
|
||||
imap-default-stream)
|
||||
stream))
|
||||
imap-stream stream
|
||||
streams nil)))
|
||||
(unless imap-stream
|
||||
(error "Couldn't figure out a stream for server"))))
|
||||
(when stream-changed
|
||||
(message "imap: Reconnecting with stream `%s'..." imap-stream)
|
||||
(imap-close buffer)
|
||||
(if (imap-open-1 buffer)
|
||||
(message "imap: Reconnecting with stream `%s'...done"
|
||||
imap-stream)
|
||||
(message "imap: Reconnecting with stream `%s'...failed"
|
||||
imap-stream))
|
||||
(setq imap-capability nil))
|
||||
(if (imap-opened buffer)
|
||||
;; Choose authenticator
|
||||
(when (and (null imap-auth) (not (eq imap-state 'auth)))
|
||||
(let ((auths imap-authenticators))
|
||||
(while (setq auth (pop auths))
|
||||
(if (funcall (nth 1 (assq auth imap-authenticator-alist))
|
||||
buffer)
|
||||
(setq imap-auth auth
|
||||
auths nil)))
|
||||
(unless imap-auth
|
||||
(error "Couldn't figure out authenticator for server"))))))
|
||||
(message "imap: Connecting to %s...failed" imap-server))
|
||||
(when (imap-opened buffer)
|
||||
(setq imap-mailbox-data (make-vector imap-mailbox-prime 0))
|
||||
buffer)))
|
||||
@ -2182,14 +2214,14 @@ Return nil if no complete line has arrived."
|
||||
|
||||
(defun imap-parse-flag-list ()
|
||||
(let (flag-list start)
|
||||
(when (eq (char-after) ?\()
|
||||
(imap-forward)
|
||||
(while (and (not (eq (char-before) ?\)))
|
||||
(setq start (point))
|
||||
(> (skip-chars-forward "^ )" (gnus-point-at-eol)) 0))
|
||||
(push (buffer-substring start (point)) flag-list)
|
||||
(imap-forward))
|
||||
(nreverse flag-list))))
|
||||
(assert (eq (char-after) ?\())
|
||||
(while (and (not (eq (char-after) ?\)))
|
||||
(setq start (progn (imap-forward) (point)))
|
||||
(> (skip-chars-forward "^ )" (gnus-point-at-eol)) 0))
|
||||
(push (buffer-substring start (point)) flag-list))
|
||||
(assert (eq (char-after) ?\)))
|
||||
(imap-forward)
|
||||
(nreverse flag-list)))
|
||||
|
||||
;; envelope = "(" env-date SP env-subject SP env-from SP env-sender SP
|
||||
;; env-reply-to SP env-to SP env-cc SP env-bcc SP
|
||||
@ -2414,7 +2446,10 @@ Return nil if no complete line has arrived."
|
||||
(imap-forward)
|
||||
(push (imap-parse-nstring) body);; body-fld-desc
|
||||
(imap-forward)
|
||||
(push (imap-parse-string) body);; body-fld-enc
|
||||
;; next `or' for Sun SIMS bug, it regard body-fld-enc as a
|
||||
;; nstring and return NIL instead of defaulting back to 7BIT
|
||||
;; as the standard says.
|
||||
(push (or (imap-parse-nstring) "7BIT") body);; body-fld-enc
|
||||
(imap-forward)
|
||||
(push (imap-parse-number) body);; body-fld-octets
|
||||
|
||||
|
||||
@ -323,10 +323,26 @@ If SERVER is nil, uses the current server."
|
||||
group (gnus-server-to-method
|
||||
(format "nnimap:%s" server))))
|
||||
(new-uidvalidity (imap-mailbox-get 'uidvalidity))
|
||||
(old-uidvalidity (gnus-group-get-parameter gnusgroup 'uidvalidity)))
|
||||
(old-uidvalidity (gnus-group-get-parameter gnusgroup 'uidvalidity))
|
||||
(dir (file-name-as-directory (expand-file-name nnimap-directory)))
|
||||
(nameuid (nnheader-translate-file-chars
|
||||
(concat nnimap-nov-file-name
|
||||
(if (equal server "")
|
||||
"unnamed"
|
||||
server) "." group "." old-uidvalidity
|
||||
nnimap-nov-file-name-suffix) t))
|
||||
(file (if (or nnmail-use-long-file-names
|
||||
(file-exists-p (expand-file-name nameuid dir)))
|
||||
(expand-file-name nameuid dir)
|
||||
(expand-file-name
|
||||
(mm-encode-coding-string
|
||||
(nnheader-replace-chars-in-string nameuid ?. ?/)
|
||||
nnmail-pathname-coding-system)
|
||||
dir))))
|
||||
(if old-uidvalidity
|
||||
(if (not (equal old-uidvalidity new-uidvalidity))
|
||||
nil ;; uidvalidity clash
|
||||
;; uidvalidity clash
|
||||
(gnus-delete-file file)
|
||||
(gnus-group-set-parameter gnusgroup 'uidvalidity new-uidvalidity)
|
||||
t)
|
||||
(gnus-group-add-parameter gnusgroup (cons 'uidvalidity new-uidvalidity))
|
||||
@ -442,18 +458,48 @@ If EXAMINE is non-nil the group is selected read-only."
|
||||
|
||||
(defun nnimap-group-overview-filename (group server)
|
||||
"Make pathname for GROUP on SERVER."
|
||||
(let ((dir (file-name-as-directory (expand-file-name nnimap-directory)))
|
||||
(file (nnheader-translate-file-chars
|
||||
(concat nnimap-nov-file-name
|
||||
(if (equal server "")
|
||||
"unnamed"
|
||||
server) "." group nnimap-nov-file-name-suffix) t)))
|
||||
(if (or nnmail-use-long-file-names
|
||||
(file-exists-p (concat dir file)))
|
||||
(concat dir file)
|
||||
(concat dir (mm-encode-coding-string
|
||||
(nnheader-replace-chars-in-string file ?. ?/)
|
||||
nnmail-pathname-coding-system)))))
|
||||
(let* ((dir (file-name-as-directory (expand-file-name nnimap-directory)))
|
||||
(uidvalidity (gnus-group-get-parameter
|
||||
(gnus-group-prefixed-name
|
||||
group (gnus-server-to-method
|
||||
(format "nnimap:%s" server)))
|
||||
'uidvalidity))
|
||||
(name (nnheader-translate-file-chars
|
||||
(concat nnimap-nov-file-name
|
||||
(if (equal server "")
|
||||
"unnamed"
|
||||
server) "." group nnimap-nov-file-name-suffix) t))
|
||||
(nameuid (nnheader-translate-file-chars
|
||||
(concat nnimap-nov-file-name
|
||||
(if (equal server "")
|
||||
"unnamed"
|
||||
server) "." group "." uidvalidity
|
||||
nnimap-nov-file-name-suffix) t))
|
||||
(oldfile (if (or nnmail-use-long-file-names
|
||||
(file-exists-p (expand-file-name name dir)))
|
||||
(expand-file-name name dir)
|
||||
(expand-file-name
|
||||
(mm-encode-coding-string
|
||||
(nnheader-replace-chars-in-string name ?. ?/)
|
||||
nnmail-pathname-coding-system)
|
||||
dir)))
|
||||
(newfile (if (or nnmail-use-long-file-names
|
||||
(file-exists-p (expand-file-name nameuid dir)))
|
||||
(expand-file-name nameuid dir)
|
||||
(expand-file-name
|
||||
(mm-encode-coding-string
|
||||
(nnheader-replace-chars-in-string nameuid ?. ?/)
|
||||
nnmail-pathname-coding-system)
|
||||
dir))))
|
||||
(when (and (file-exists-p oldfile) (not (file-exists-p newfile)))
|
||||
(message "nnimap: Upgrading novcache filename...")
|
||||
(sit-for 1)
|
||||
(gnus-make-directory (file-name-directory newfile))
|
||||
(unless (ignore-errors (rename-file oldfile newfile) t)
|
||||
(if (ignore-errors (copy-file oldfile newfile) t)
|
||||
(delete-file oldfile)
|
||||
(error "Can't rename `%s' to `%s'" oldfile newfile))))
|
||||
newfile))
|
||||
|
||||
(defun nnimap-retrieve-headers-from-file (group server)
|
||||
(with-current-buffer nntp-server-buffer
|
||||
@ -1119,9 +1165,13 @@ function is generally only called when Gnus is shutting down."
|
||||
nnimap-current-move-article)
|
||||
group 'dontcreate nil
|
||||
nnimap-server-buffer))
|
||||
;; turn into rfc822 format (\r\n eol's)
|
||||
(with-current-buffer (current-buffer)
|
||||
(goto-char (point-min))
|
||||
;; remove any 'From blabla' lines, some IMAP servers
|
||||
;; reject the entire message otherwise.
|
||||
(when (looking-at "^From[^:]")
|
||||
(kill-region (point) (progn (forward-line) (point))))
|
||||
;; turn into rfc822 format (\r\n eol's)
|
||||
(while (search-forward "\n" nil t)
|
||||
(replace-match "\r\n")))
|
||||
;; this 'or' is for Cyrus server bug
|
||||
@ -1151,7 +1201,8 @@ function is generally only called when Gnus is shutting down."
|
||||
|
||||
(defun nnimap-acl-get (mailbox server)
|
||||
(when (nnimap-possibly-change-server server)
|
||||
(imap-mailbox-acl-get mailbox nnimap-server-buffer)))
|
||||
(and (imap-capability 'ACL nnimap-server-buffer)
|
||||
(imap-mailbox-acl-get mailbox nnimap-server-buffer))))
|
||||
|
||||
(defun nnimap-acl-edit (mailbox method old-acls new-acls)
|
||||
(when (nnimap-possibly-change-server (cadr method))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user