;;; Code:
(eval-when-compile (require 'cl))
+(eval-when-compile (require 'static))
+
+(require 'base64)
+
(eval-and-compile
(autoload 'open-ssl-stream "ssl")
- (autoload 'base64-decode-string "base64")
- (autoload 'base64-encode-string "base64")
(autoload 'starttls-open-stream "starttls")
(autoload 'starttls-negotiate "starttls")
- (autoload 'digest-md5-parse-digest-challenge "digest-md5")
- (autoload 'digest-md5-digest-response "digest-md5")
- (autoload 'digest-md5-digest-uri "digest-md5")
- (autoload 'digest-md5-challenge "digest-md5")
(autoload 'rfc2104-hash "rfc2104")
(autoload 'md5 "md5")
(autoload 'utf7-encode "utf7")
(defun imap-point-at-eol ()
(save-excursion
(end-of-line)
- (point)))))
+ (point))))
+ (autoload 'sasl-digest-md5-digest-response "sasl"))
;; User variables.
(defgroup imap nil
"Low-level IMAP issues."
+ :version "21.1"
:group 'mail)
(defcustom imap-kerberos4-program '("imtest -m kerberos_v4 -u %l -p %p %s"
(starttls imap-starttls-p imap-starttls-open))
"Definition of network streams.
-(NAME CHECK OPEN)
+\(NAME CHECK OPEN)
NAME names the stream, CHECK is a function returning non-nil if the
server support the stream and OPEN is a function for opening the
(digest-md5 imap-digest-md5-p imap-digest-md5-auth))
"Definition of authenticators.
-(NAME CHECK AUTHENTICATE)
+\(NAME CHECK AUTHENTICATE)
NAME names the authenticator. CHECK is a function returning non-nil if
the server support the authenticator and AUTHENTICATE is a function
(defconst imap-default-port 143)
(defconst imap-default-ssl-port 993)
(defconst imap-default-stream 'network)
-(defconst imap-coding-system-for-read 'binary)
-(defconst imap-coding-system-for-write 'binary)
(defconst imap-local-variables '(imap-server
imap-port
imap-client-eol
\f
;; Utility functions:
-(defsubst imap-disable-multibyte ()
- "Enable multibyte in the current buffer."
- (when (fboundp 'set-buffer-multibyte)
- (set-buffer-multibyte nil)))
-
(defun imap-read-passwd (prompt &rest args)
"Read a password using PROMPT.
If ARGS, PROMPT is used as an argument to `format'."
(message "Opening Kerberos 4 IMAP connection with `%s'..." cmd)
(erase-buffer)
(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 (start-process
- name buffer shell-file-name shell-command-switch
- (format-spec
- cmd
- (format-spec-make
- ?s server
- ?p (number-to-string port)
- ?l imap-default-user))))
+ (process (as-binary-process
+ (start-process
+ name buffer shell-file-name shell-command-switch
+ (format-spec
+ cmd
+ (format-spec-make
+ ?s server
+ ?p (number-to-string port)
+ ?l imap-default-user)))))
response)
(when process
(with-current-buffer buffer
(setq imap-client-eol "\n"
imap-calculate-literal-size-first t)
(while (and (memq (process-status process) '(open run))
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
(goto-char (point-min))
;; cyrus 1.6.x (13? < x <= 22) queries capabilities
(or (while (looking-at "^C:")
(sit-for 1))
(and imap-log
(with-current-buffer (get-buffer-create imap-log)
- (imap-disable-multibyte)
(buffer-disable-undo)
(goto-char (point-max))
(insert-buffer-substring buffer)))
(while (and (not done) (setq cmd (pop cmds)))
(message "Opening GSSAPI IMAP connection with `%s'..." cmd)
(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 (start-process
- name buffer shell-file-name shell-command-switch
- (format-spec
- cmd
- (format-spec-make
- ?s server
- ?p (number-to-string port)
- ?l imap-default-user))))
+ (process (as-binary-process
+ (start-process
+ name buffer shell-file-name shell-command-switch
+ (format-spec
+ cmd
+ (format-spec-make
+ ?s server
+ ?p (number-to-string port)
+ ?l imap-default-user)))))
response)
(when process
(with-current-buffer buffer
- (setq imap-client-eol "\n")
+ (setq imap-client-eol "\n"
+ imap-calculate-literal-size-first t)
(while (and (memq (process-status process) '(open run))
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
(goto-char (point-min))
;; cyrus 1.6.x (13? < x <= 22) queries capabilities
(or (while (looking-at "^C:")
(sit-for 1))
(and imap-log
(with-current-buffer (get-buffer-create imap-log)
- (imap-disable-multibyte)
(buffer-disable-undo)
(goto-char (point-max))
(insert-buffer-substring buffer)))
(let ((cmds (if (listp imap-ssl-program) imap-ssl-program
(list imap-ssl-program)))
cmd done)
+ (ignore-errors (require 'ssl))
(while (and (not done) (setq cmd (pop cmds)))
(message "imap: Opening SSL connection with `%s'..." cmd)
(let* ((port (or port imap-default-ssl-port))
- (coding-system-for-read imap-coding-system-for-read)
- (coding-system-for-write imap-coding-system-for-write)
(ssl-program-name shell-file-name)
(ssl-program-arguments
(list shell-command-switch
?s server
?p (number-to-string port)))))
process)
- (when (setq process (ignore-errors (open-ssl-stream
- name buffer server port)))
+ (when (setq process
+ (ignore-errors
+ (cond ((eq system-type 'windows-nt)
+ (let (selective-display
+ (coding-system-for-write 'binary)
+ (coding-system-for-read 'raw-text-dos)
+ (output-coding-system 'binary)
+ (input-coding-system 'raw-text-dos))
+ (open-ssl-stream name buffer server port)))
+ (t
+ (as-binary-process
+ (open-ssl-stream name buffer server port))))))
(with-current-buffer buffer
(goto-char (point-min))
(while (and (memq (process-status process) '(open run))
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
(goto-char (point-max))
(forward-line -1)
(not (imap-parse-greeting)))
(sit-for 1))
(and imap-log
(with-current-buffer (get-buffer-create imap-log)
- (imap-disable-multibyte)
(buffer-disable-undo)
(goto-char (point-max))
(insert-buffer-substring buffer)))
(defun imap-network-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 (open-network-stream name buffer server port)))
+ (process (open-network-stream-as-binary name buffer server port)))
(when process
(while (and (memq (process-status process) '(open run))
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
(goto-char (point-min))
(not (imap-parse-greeting)))
(accept-process-output process 1)
(sit-for 1))
(and imap-log
(with-current-buffer (get-buffer-create imap-log)
- (imap-disable-multibyte)
(buffer-disable-undo)
(goto-char (point-max))
(insert-buffer-substring buffer)))
(message "imap: Opening IMAP connection with `%s'..." cmd)
(setq imap-client-eol "\n")
(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 (start-process
- name buffer shell-file-name shell-command-switch
- (format-spec
- cmd
- (format-spec-make
- ?s server
- ?g imap-shell-host
- ?p (number-to-string port)
- ?l imap-default-user)))))
+ (process (as-binary-process
+ (start-process
+ name buffer shell-file-name shell-command-switch
+ (format-spec
+ cmd
+ (format-spec-make
+ ?s server
+ ?g imap-shell-host
+ ?p (number-to-string port)
+ ?l imap-default-user))))))
(when process
(while (and (memq (process-status process) '(open run))
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
(goto-char (point-min))
(not (imap-parse-greeting)))
(accept-process-output process 1)
(sit-for 1))
- (erase-buffer)
(and imap-log
(with-current-buffer (get-buffer-create imap-log)
- (imap-disable-multibyte)
(buffer-disable-undo)
(goto-char (point-max))
(insert-buffer-substring buffer)))
+ (erase-buffer)
(when (memq (process-status process) '(open run))
(setq done process)))))
(if done
(progn
(message "imap: Opening IMAP connection with `%s'...done" cmd)
done)
- (message "imap: Opening IMAP connection with `%s'...failed" cmd)
+ (message "imap: Opening IMAP connection with `%s'...failed" cmd)
nil)))
(defun imap-starttls-p (buffer)
(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 (as-binary-process
+ (starttls-open-stream name buffer server port)))
done)
(message "imap: Connecting with STARTTLS...")
(when process
(while (and (memq (process-status process) '(open run))
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
(goto-char (point-min))
(not (imap-parse-greeting)))
(accept-process-output process 1)
"AUTHENTICATE CRAM-MD5"
(lambda (challenge)
(let* ((decoded (base64-decode-string challenge))
- (hash (rfc2104-hash 'md5 64 16 passwd decoded))
+ (hash-function
+ (if (and (featurep 'xemacs)
+ (>= (function-max-args 'md5) 4))
+ (lambda (object &optional start end)
+ (md5 object start end 'binary))
+ 'md5))
+ (hash (rfc2104-hash hash-function 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)
(and (not (imap-capability 'LOGINDISABLED buffer))
(list
"AUTHENTICATE DIGEST-MD5"
(lambda (challenge)
- (digest-md5-parse-digest-challenge
- (base64-decode-string challenge))
- (let* ((digest-uri
- (digest-md5-digest-uri
- "imap" (digest-md5-challenge 'realm)))
- (response
- (digest-md5-digest-response
- user passwd digest-uri)))
- (base64-encode-string response 'no-line-break))))
- )))
+ (base64-encode-string
+ (sasl-digest-md5-digest-response
+ (base64-decode-string challenge)
+ user passwd "imap" imap-server)
+ 'no-line-break))))))
(if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
nil
(setq imap-continuation nil)
(if (imap-opened buffer)
(imap-close buffer))
(mapcar 'make-variable-buffer-local imap-local-variables)
- (imap-disable-multibyte)
+ (set-buffer-multibyte nil)
(buffer-disable-undo)
(setq imap-server (or server imap-server))
(setq imap-port (or port imap-port))
(if (imap-ok-p (imap-send-command-wait cmd))
t
(when (and (not dont-create)
- (imap-mailbox-get-1 'trycreate mailbox))
- (imap-mailbox-create-1 mailbox)
+ ;; removed because of buggy Oracle server
+ ;; that doesn't send TRYCREATE tags (which
+ ;; is a MUST according to specifications):
+ ;;(imap-mailbox-get-1 'trycreate mailbox)
+ (imap-mailbox-create-1 mailbox))
(imap-ok-p (imap-send-command-wait cmd)))))
(or no-copyuid
(imap-message-copyuid-1 mailbox)))))))
(setq cmdstr (concat cmdstr imap-client-eol))
(and imap-log
(with-current-buffer (get-buffer-create imap-log)
- (imap-disable-multibyte)
(buffer-disable-undo)
(goto-char (point-max))
(insert cmdstr)))
(and imap-log
(with-current-buffer (get-buffer-create
imap-log)
- (imap-disable-multibyte)
(buffer-disable-undo)
(goto-char (point-max))
(insert-buffer-substring cmd)))
(insert string)
(and imap-log
(with-current-buffer (get-buffer-create imap-log)
- (imap-disable-multibyte)
(buffer-disable-undo)
(goto-char (point-max))
(insert string)))
projects / elisp / gnus.git- / blobdiff