/[emacs]/emacs/lisp/gnus/imap.el
ViewVC logotype

Diff of /emacs/lisp/gnus/imap.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6.4.3 by miles, Thu Apr 1 04:29:05 2004 UTC revision 1.6.4.4 by miles, Thu Sep 16 00:12:16 2004 UTC
# Line 1  Line 1 
1  ;;; imap.el --- imap library  ;;; imap.el --- imap library
2  ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004  ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
3  ;;        Free Software Foundation, Inc.  ;;        Free Software Foundation, Inc.
4    
5  ;; Author: Simon Josefsson <jas@pdc.kth.se>  ;; Author: Simon Josefsson <jas@pdc.kth.se>
# Line 125  Line 125 
125  ;; o Don't use `read' at all (important places already fixed)  ;; o Don't use `read' at all (important places already fixed)
126  ;; o Accept list of articles instead of message set string in most  ;; o Accept list of articles instead of message set string in most
127  ;;   imap-message-* functions.  ;;   imap-message-* functions.
128    ;; o Send strings as literal if they contain, e.g., ".
129  ;;  ;;
130  ;; Revision history:  ;; Revision history:
131  ;;  ;;
# Line 152  Line 153 
153    (autoload 'utf7-decode "utf7")    (autoload 'utf7-decode "utf7")
154    (autoload 'format-spec "format-spec")    (autoload 'format-spec "format-spec")
155    (autoload 'format-spec-make "format-spec")    (autoload 'format-spec-make "format-spec")
156      (autoload 'open-tls-stream "tls")
157    ;; Avoid use gnus-point-at-eol so we're independent of Gnus.  These    ;; Avoid use gnus-point-at-eol so we're independent of Gnus.  These
158    ;; days we have point-at-eol anyhow.    ;; days we have point-at-eol anyhow.
159    (if (fboundp 'point-at-eol)    (if (fboundp 'point-at-eol)
# Line 178  the list is tried until a successful con Line 180  the list is tried until a successful con
180    :group 'imap    :group 'imap
181    :type '(repeat string))    :type '(repeat string))
182    
183  (defcustom imap-gssapi-program '("imtest -m gssapi -u %l -p %p %s")  (defcustom imap-gssapi-program (list
184                                    (concat "gsasl --client --connect %s:%p "
185                                            "--imap --application-data "
186                                            "--mechanism GSSAPI "
187                                            "--authentication-id %l")
188                                    "imtest -m gssapi -u %l -p %p %s")
189    "List of strings containing commands for GSSAPI (krb5) authentication.    "List of strings containing commands for GSSAPI (krb5) authentication.
190  %s is replaced with server hostname, %p with port to connect to, and  %s is replaced with server hostname, %p with port to connect to, and
191  %l with the value of `imap-default-user'.  The program should accept  %l with the value of `imap-default-user'.  The program should accept
# Line 213  until a successful connection is made." Line 220  until a successful connection is made."
220    :group 'imap    :group 'imap
221    :type '(repeat string))    :type '(repeat string))
222    
223  (defvar imap-shell-host "gateway"  (defcustom imap-process-connection-type nil
224    "Hostname of rlogin proxy.")    "*Value for `process-connection-type' to use for Kerberos4, GSSAPI and SSL.
225    The `process-connection-type' variable control type of device
226    used to communicate with subprocesses.  Values are nil to use a
227    pipe, or t or `pty' to use a pty.  The value has no effect if the
228    system has no ptys or if all ptys are busy: then a pipe is used
229    in any case.  The value takes effect when a IMAP server is
230    opened, changing it after that has no effect.."
231      :group 'imap
232      :type 'boolean)
233    
234  (defvar imap-default-user (user-login-name)  (defcustom imap-use-utf7 t
235    "Default username to use.")    "If non-nil, do utf7 encoding/decoding of mailbox names.
236    Since the UTF7 decoding currently only decodes into ISO-8859-1
237    characters, you may disable this decoding if you need to access UTF7
238    encoded mailboxes which doesn't translate into ISO-8859-1."
239      :group 'imap
240      :type 'boolean)
241    
242  (defvar imap-error nil  (defcustom imap-log nil
243    "Error codes from the last command.")    "If non-nil, a imap session trace is placed in *imap-log* buffer."
244      :group 'imap
245      :type 'boolean)
246    
247    (defcustom imap-debug nil
248      "If non-nil, random debug spews are placed in *imap-debug* buffer."
249      :group 'imap
250      :type 'boolean)
251    
252    (defcustom imap-shell-host "gateway"
253      "Hostname of rlogin proxy."
254      :group 'imap
255      :type 'string)
256    
257    (defcustom imap-default-user (user-login-name)
258      "Default username to use."
259      :group 'imap
260      :type 'string)
261    
262    (defcustom imap-read-timeout (if (string-match
263                                      "windows-nt\\|os/2\\|emx\\|cygwin"
264                                      (symbol-name system-type))
265                                     1.0
266                                   0.1)
267      "*How long to wait between checking for the end of output.
268    Shorter values mean quicker response, but is more CPU intensive."
269      :type 'number
270      :group 'imap)
271    
272  ;; Various variables.  ;; Various variables.
273    
274  (defvar imap-fetch-data-hook nil  (defvar imap-fetch-data-hook nil
275    "Hooks called after receiving each FETCH response.")    "Hooks called after receiving each FETCH response.")
276    
277  (defvar imap-streams '(gssapi kerberos4 starttls ssl network shell)  (defvar imap-streams '(gssapi kerberos4 starttls tls ssl network shell)
278    "Priority of streams to consider when opening connection to server.")    "Priority of streams to consider when opening connection to server.")
279    
280  (defvar imap-stream-alist  (defvar imap-stream-alist
281    '((gssapi    imap-gssapi-stream-p    imap-gssapi-open)    '((gssapi    imap-gssapi-stream-p    imap-gssapi-open)
282      (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)      (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
283        (tls       imap-tls-p              imap-tls-open)
284      (ssl       imap-ssl-p              imap-ssl-open)      (ssl       imap-ssl-p              imap-ssl-open)
285      (network   imap-network-p          imap-network-open)      (network   imap-network-p          imap-network-open)
286      (shell     imap-shell-p            imap-shell-open)      (shell     imap-shell-p            imap-shell-open)
# Line 242  until a successful connection is made." Line 290  until a successful connection is made."
290  \(NAME CHECK OPEN)  \(NAME CHECK OPEN)
291    
292  NAME names the stream, CHECK is a function returning non-nil if the  NAME names the stream, CHECK is a function returning non-nil if the
293  server supports the stream and OPEN is a function for opening the  server support the stream and OPEN is a function for opening the
294  stream.")  stream.")
295    
296  (defvar imap-authenticators '(gssapi  (defvar imap-authenticators '(gssapi
# Line 268  NAME names the authenticator.  CHECK is Line 316  NAME names the authenticator.  CHECK is
316  the server support the authenticator and AUTHENTICATE is a function  the server support the authenticator and AUTHENTICATE is a function
317  for doing the actual authentication.")  for doing the actual authentication.")
318    
319  (defvar imap-use-utf7 t  (defvar imap-error nil
320    "If non-nil, do utf7 encoding/decoding of mailbox names.    "Error codes from the last command.")
 Since the UTF7 decoding currently only decodes into ISO-8859-1  
 characters, you may disable this decoding if you need to access UTF7  
 encoded mailboxes which doesn't translate into ISO-8859-1.")  
321    
322  ;; Internal constants.  Change theese and die.  ;; Internal constants.  Change theese and die.
323    
324  (defconst imap-default-port 143)  (defconst imap-default-port 143)
325  (defconst imap-default-ssl-port 993)  (defconst imap-default-ssl-port 993)
326    (defconst imap-default-tls-port 993)
327  (defconst imap-default-stream 'network)  (defconst imap-default-stream 'network)
328  (defconst imap-coding-system-for-read 'binary)  (defconst imap-coding-system-for-read 'binary)
329  (defconst imap-coding-system-for-write 'binary)  (defconst imap-coding-system-for-write 'binary)
# Line 301  encoded mailboxes which doesn't translat Line 347  encoded mailboxes which doesn't translat
347                                   imap-process                                   imap-process
348                                   imap-calculate-literal-size-first                                   imap-calculate-literal-size-first
349                                   imap-mailbox-data))                                   imap-mailbox-data))
350    (defconst imap-log-buffer "*imap-log*")
351    (defconst imap-debug-buffer "*imap-debug*")
352    
353  ;; Internal variables.  ;; Internal variables.
354    
# Line 368  human readable response text (a string). Line 416  human readable response text (a string).
416    "Non-nil indicates that the server emitted a continuation request.    "Non-nil indicates that the server emitted a continuation request.
417  The actual value is really the text on the continuation line.")  The actual value is really the text on the continuation line.")
418    
419  (defvar imap-log nil  (defvar imap-callbacks nil
420    "Name of buffer for imap session trace.    "List of response tags and callbacks, on the form `(number . function)'.
421  For example: (setq imap-log \"*imap-log*\")")  The function should take two arguments, the first the IMAP tag and the
422    second the status (OK, NO, BAD etc) of the command.")
 (defvar imap-debug nil                  ;"*imap-debug*"  
   "Name of buffer for random debug spew.  
 For example: (setq imap-debug \"*imap-debug*\")")  
423    
424    
425  ;; Utility functions:  ;; Utility functions:
426    
427    (defun imap-remassoc (key alist)
428      "Delete by side effect any elements of LIST whose car is `equal' to KEY.
429    The modified LIST is returned.  If the first member
430    of LIST has a car that is `equal' to KEY, there is no way to remove it
431    by side effect; therefore, write `(setq foo (remassoc key foo))' to be
432    sure of changing the value of `foo'."
433      (when alist
434        (if (equal key (caar alist))
435            (cdr alist)
436          (setcdr alist (imap-remassoc key (cdr alist)))
437          alist)))
438    
439  (defsubst imap-disable-multibyte ()  (defsubst imap-disable-multibyte ()
440    "Enable multibyte in the current buffer."    "Enable multibyte in the current buffer."
441    (when (fboundp 'set-buffer-multibyte)    (when (fboundp 'set-buffer-multibyte)
442      (set-buffer-multibyte nil)))      (set-buffer-multibyte nil)))
443    
 (defun imap-read-passwd (prompt &rest args)  
   "Read a password using PROMPT.  
 If ARGS, PROMPT is used as an argument to `format'."  
   (let ((prompt (if args  
                     (apply 'format prompt args)  
                   prompt)))  
     (funcall (if (or (fboundp 'read-passwd)  
                      (and (load "subr" t)  
                           (fboundp 'read-passwd))  
                      (and (load "passwd" t)  
                           (fboundp 'read-passwd)))  
                  'read-passwd  
                (autoload 'ange-ftp-read-passwd "ange-ftp")  
                'ange-ftp-read-passwd)  
              prompt)))  
   
444  (defsubst imap-utf7-encode (string)  (defsubst imap-utf7-encode (string)
445    (if imap-use-utf7    (if imap-use-utf7
446        (and string        (and string
# Line 447  If ARGS, PROMPT is used as an argument t Line 488  If ARGS, PROMPT is used as an argument t
488        (let* ((port (or port imap-default-port))        (let* ((port (or port imap-default-port))
489               (coding-system-for-read imap-coding-system-for-read)               (coding-system-for-read imap-coding-system-for-read)
490               (coding-system-for-write imap-coding-system-for-write)               (coding-system-for-write imap-coding-system-for-write)
491                 (process-connection-type imap-process-connection-type)
492               (process (start-process               (process (start-process
493                         name buffer shell-file-name shell-command-switch                         name buffer shell-file-name shell-command-switch
494                         (format-spec                         (format-spec
# Line 461  If ARGS, PROMPT is used as an argument t Line 503  If ARGS, PROMPT is used as an argument t
503              (setq imap-client-eol "\n"              (setq imap-client-eol "\n"
504                    imap-calculate-literal-size-first t)                    imap-calculate-literal-size-first t)
505              (while (and (memq (process-status process) '(open run))              (while (and (memq (process-status process) '(open run))
506                            (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
507                          (goto-char (point-min))                          (goto-char (point-min))
508                          ;; cyrus 1.6.x (13? < x <= 22) queries capabilities                          ;; Athena IMTEST can output SSL verify errors
509                          (or (while (looking-at "^C:")                          (or (while (looking-at "^verify error:num=")
510                                  (forward-line))
511                                t)
512                            (or (while (looking-at "^TLS connection established")
513                                  (forward-line))
514                                t)
515                            ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
516                            (or (while (looking-at "^C:")
517                                (forward-line))                                (forward-line))
518                              t)                              t)
519                          ;; cyrus 1.6 imtest print "S: " before server greeting                          ;; cyrus 1.6 imtest print "S: " before server greeting
# Line 481  If ARGS, PROMPT is used as an argument t Line 531  If ARGS, PROMPT is used as an argument t
531                (accept-process-output process 1)                (accept-process-output process 1)
532                (sit-for 1))                (sit-for 1))
533              (and imap-log              (and imap-log
534                   (with-current-buffer (get-buffer-create imap-log)                   (with-current-buffer (get-buffer-create imap-log-buffer)
535                     (imap-disable-multibyte)                     (imap-disable-multibyte)
536                     (buffer-disable-undo)                     (buffer-disable-undo)
537                     (goto-char (point-max))                     (goto-char (point-max))
# Line 493  If ARGS, PROMPT is used as an argument t Line 543  If ARGS, PROMPT is used as an argument t
543                                  (not (string-match "failed" response))))                                  (not (string-match "failed" response))))
544                  (setq done process)                  (setq done process)
545                (if (memq (process-status process) '(open run))                (if (memq (process-status process) '(open run))
546                    (imap-send-command-wait "LOGOUT"))                    (imap-send-command "LOGOUT"))
547                (delete-process process)                (delete-process process)
548                nil)))))                nil)))))
549      done))      done))
# Line 506  If ARGS, PROMPT is used as an argument t Line 556  If ARGS, PROMPT is used as an argument t
556          cmd done)          cmd done)
557      (while (and (not done) (setq cmd (pop cmds)))      (while (and (not done) (setq cmd (pop cmds)))
558        (message "Opening GSSAPI IMAP connection with `%s'..." cmd)        (message "Opening GSSAPI IMAP connection with `%s'..." cmd)
559          (erase-buffer)
560        (let* ((port (or port imap-default-port))        (let* ((port (or port imap-default-port))
561               (coding-system-for-read imap-coding-system-for-read)               (coding-system-for-read imap-coding-system-for-read)
562               (coding-system-for-write imap-coding-system-for-write)               (coding-system-for-write imap-coding-system-for-write)
563                 (process-connection-type imap-process-connection-type)
564               (process (start-process               (process (start-process
565                         name buffer shell-file-name shell-command-switch                         name buffer shell-file-name shell-command-switch
566                         (format-spec                         (format-spec
# Line 520  If ARGS, PROMPT is used as an argument t Line 572  If ARGS, PROMPT is used as an argument t
572               response)               response)
573          (when process          (when process
574            (with-current-buffer buffer            (with-current-buffer buffer
575              (setq imap-client-eol "\n")              (setq imap-client-eol "\n"
576                      imap-calculate-literal-size-first t)
577              (while (and (memq (process-status process) '(open run))              (while (and (memq (process-status process) '(open run))
578                            (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
579                          (goto-char (point-min))                          (goto-char (point-min))
580                          ;; cyrus 1.6.x (13? < x <= 22) queries capabilities                          ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
581                          (or (while (looking-at "^C:")                          (or (while (looking-at "^C:")
582                                (forward-line))                                (forward-line))
583                              t)                              t)
584                          ;; cyrus 1.6 imtest print "S: " before server greeting                          ;; cyrus 1.6 imtest print "S: " before server greeting
# Line 534  If ARGS, PROMPT is used as an argument t Line 588  If ARGS, PROMPT is used as an argument t
588                          (not (and (imap-parse-greeting)                          (not (and (imap-parse-greeting)
589                                    ;; success in imtest 1.6:                                    ;; success in imtest 1.6:
590                                    (re-search-forward                                    (re-search-forward
591                                     "^\\(Authenticat.*\\)" nil t)                                     (concat "^\\(\\(Authenticat.*\\)\\|\\("
592                                               "Client authentication "
593                                               "finished.*\\)\\)")
594                                       nil t)
595                                    (setq response (match-string 1)))))                                    (setq response (match-string 1)))))
596                (accept-process-output process 1)                (accept-process-output process 1)
597                (sit-for 1))                (sit-for 1))
598              (and imap-log              (and imap-log
599                   (with-current-buffer (get-buffer-create imap-log)                   (with-current-buffer (get-buffer-create imap-log-buffer)
600                     (imap-disable-multibyte)                     (imap-disable-multibyte)
601                     (buffer-disable-undo)                     (buffer-disable-undo)
602                     (goto-char (point-max))                     (goto-char (point-max))
# Line 550  If ARGS, PROMPT is used as an argument t Line 607  If ARGS, PROMPT is used as an argument t
607                                  (not (string-match "failed" response))))                                  (not (string-match "failed" response))))
608                  (setq done process)                  (setq done process)
609                (if (memq (process-status process) '(open run))                (if (memq (process-status process) '(open run))
610                    (imap-send-command-wait "LOGOUT"))                    (imap-send-command "LOGOUT"))
611                (delete-process process)                (delete-process process)
612                nil)))))                nil)))))
613      done))      done))
# Line 565  If ARGS, PROMPT is used as an argument t Line 622  If ARGS, PROMPT is used as an argument t
622          cmd done)          cmd done)
623      (while (and (not done) (setq cmd (pop cmds)))      (while (and (not done) (setq cmd (pop cmds)))
624        (message "imap: Opening SSL connection with `%s'..." cmd)        (message "imap: Opening SSL connection with `%s'..." cmd)
625          (erase-buffer)
626        (let* ((port (or port imap-default-ssl-port))        (let* ((port (or port imap-default-ssl-port))
627               (coding-system-for-read imap-coding-system-for-read)               (coding-system-for-read imap-coding-system-for-read)
628               (coding-system-for-write imap-coding-system-for-write)               (coding-system-for-write imap-coding-system-for-write)
629               (process-connection-type nil)               (process-connection-type nil)
630               process)               process)
631          (when (progn          (when (progn
632                  (setq process (start-process                  (setq process (start-process
633                                 name buffer shell-file-name                                 name buffer shell-file-name
634                                 shell-command-switch                                 shell-command-switch
635                                 (format-spec cmd                                 (format-spec cmd
636                                              (format-spec-make                                              (format-spec-make
637                                               ?s server                                               ?s server
638                                               ?p (number-to-string port)))))                                               ?p (number-to-string port)))))
# Line 590  If ARGS, PROMPT is used as an argument t Line 648  If ARGS, PROMPT is used as an argument t
648                (accept-process-output process 1)                (accept-process-output process 1)
649                (sit-for 1))                (sit-for 1))
650              (and imap-log              (and imap-log
651                   (with-current-buffer (get-buffer-create imap-log)                   (with-current-buffer (get-buffer-create imap-log-buffer)
652                     (imap-disable-multibyte)                     (imap-disable-multibyte)
653                     (buffer-disable-undo)                     (buffer-disable-undo)
654                     (goto-char (point-max))                     (goto-char (point-max))
# Line 602  If ARGS, PROMPT is used as an argument t Line 660  If ARGS, PROMPT is used as an argument t
660          (progn          (progn
661            (message "imap: Opening SSL connection with `%s'...done" cmd)            (message "imap: Opening SSL connection with `%s'...done" cmd)
662            done)            done)
663            (message "imap: Opening SSL connection with `%s'...failed" cmd)        (message "imap: Opening SSL connection with `%s'...failed" cmd)
664        nil)))        nil)))
665    
666    (defun imap-tls-p (buffer)
667      nil)
668    
669    (defun imap-tls-open (name buffer server port)
670      (let* ((port (or port imap-default-tls-port))
671             (coding-system-for-read imap-coding-system-for-read)
672             (coding-system-for-write imap-coding-system-for-write)
673             (process (open-tls-stream name buffer server port)))
674        (when process
675          (while (and (memq (process-status process) '(open run))
676                      (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
677                      (goto-char (point-max))
678                      (forward-line -1)
679                      (not (imap-parse-greeting)))
680            (accept-process-output process 1)
681            (sit-for 1))
682          (and imap-log
683               (with-current-buffer (get-buffer-create imap-log-buffer)
684                 (imap-disable-multibyte)
685                 (buffer-disable-undo)
686                 (goto-char (point-max))
687                 (insert-buffer-substring buffer)))
688          (when (memq (process-status process) '(open run))
689            process))))
690    
691  (defun imap-network-p (buffer)  (defun imap-network-p (buffer)
692    t)    t)
693    
# Line 615  If ARGS, PROMPT is used as an argument t Line 698  If ARGS, PROMPT is used as an argument t
698           (process (open-network-stream name buffer server port)))           (process (open-network-stream name buffer server port)))
699      (when process      (when process
700        (while (and (memq (process-status process) '(open run))        (while (and (memq (process-status process) '(open run))
701                      (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
702                    (goto-char (point-min))                    (goto-char (point-min))
703                    (not (imap-parse-greeting)))                    (not (imap-parse-greeting)))
704          (accept-process-output process 1)          (accept-process-output process 1)
705          (sit-for 1))          (sit-for 1))
706        (and imap-log        (and imap-log
707             (with-current-buffer (get-buffer-create imap-log)             (with-current-buffer (get-buffer-create imap-log-buffer)
708               (imap-disable-multibyte)               (imap-disable-multibyte)
709               (buffer-disable-undo)               (buffer-disable-undo)
710               (goto-char (point-max))               (goto-char (point-max))
# Line 632  If ARGS, PROMPT is used as an argument t Line 716  If ARGS, PROMPT is used as an argument t
716    nil)    nil)
717    
718  (defun imap-shell-open (name buffer server port)  (defun imap-shell-open (name buffer server port)
719    (let ((cmds imap-shell-program)    (let ((cmds (if (listp imap-shell-program) imap-shell-program
720                    (list imap-shell-program)))
721          cmd done)          cmd done)
722      (while (and (not done) (setq cmd (pop cmds)))      (while (and (not done) (setq cmd (pop cmds)))
723        (message "imap: Opening IMAP connection with `%s'..." cmd)        (message "imap: Opening IMAP connection with `%s'..." cmd)
# Line 651  If ARGS, PROMPT is used as an argument t Line 736  If ARGS, PROMPT is used as an argument t
736                           ?l imap-default-user)))))                           ?l imap-default-user)))))
737          (when process          (when process
738            (while (and (memq (process-status process) '(open run))            (while (and (memq (process-status process) '(open run))
739                        (goto-char (point-min))                        (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
740                          (goto-char (point-max))
741                          (forward-line -1)
742                        (not (imap-parse-greeting)))                        (not (imap-parse-greeting)))
743              (accept-process-output process 1)              (accept-process-output process 1)
744              (sit-for 1))              (sit-for 1))
           (erase-buffer)  
745            (and imap-log            (and imap-log
746                 (with-current-buffer (get-buffer-create imap-log)                 (with-current-buffer (get-buffer-create imap-log-buffer)
747                   (imap-disable-multibyte)                   (imap-disable-multibyte)
748                   (buffer-disable-undo)                   (buffer-disable-undo)
749                   (goto-char (point-max))                   (goto-char (point-max))
750                   (insert-buffer-substring buffer)))                   (insert-buffer-substring buffer)))
751              (erase-buffer)
752            (when (memq (process-status process) '(open run))            (when (memq (process-status process) '(open run))
753              (setq done process)))))              (setq done process)))))
754      (if done      (if done
755          (progn          (progn
756            (message "imap: Opening IMAP connection with `%s'...done" cmd)            (message "imap: Opening IMAP connection with `%s'...done" cmd)
757            done)            done)
758            (message "imap: Opening IMAP connection with `%s'...failed" cmd)        (message "imap: Opening IMAP connection with `%s'...failed" cmd)
759        nil)))        nil)))
760    
761  (defun imap-starttls-p (buffer)  (defun imap-starttls-p (buffer)
762    (and (imap-capability 'STARTTLS buffer)    (imap-capability 'STARTTLS buffer))
        (condition-case ()  
            (progn  
              (require 'starttls)  
              (call-process "starttls"))  
          (error nil))))  
763    
764  (defun imap-starttls-open (name buffer server port)  (defun imap-starttls-open (name buffer server port)
765    (let* ((port (or port imap-default-port))    (let* ((port (or port imap-default-port))
766           (coding-system-for-read imap-coding-system-for-read)           (coding-system-for-read imap-coding-system-for-read)
767           (coding-system-for-write imap-coding-system-for-write)           (coding-system-for-write imap-coding-system-for-write)
768           (process (starttls-open-stream name buffer server port))           (process (starttls-open-stream name buffer server port))
769           done)           done tls-info)
770      (message "imap: Connecting with STARTTLS...")      (message "imap: Connecting with STARTTLS...")
771      (when process      (when process
772        (while (and (memq (process-status process) '(open run))        (while (and (memq (process-status process) '(open run))
773                    (goto-char (point-min))                    (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
774                      (goto-char (point-max))
775                      (forward-line -1)
776                    (not (imap-parse-greeting)))                    (not (imap-parse-greeting)))
777          (accept-process-output process 1)          (accept-process-output process 1)
778          (sit-for 1))          (sit-for 1))
779          (imap-send-command "STARTTLS")
780          (while (and (memq (process-status process) '(open run))
781                      (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
782                      (goto-char (point-max))
783                      (forward-line -1)
784                      (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t)))
785            (accept-process-output process 1)
786            (sit-for 1))
787        (and imap-log        (and imap-log
788             (with-current-buffer (get-buffer-create imap-log)             (with-current-buffer (get-buffer-create imap-log-buffer)
789               (buffer-disable-undo)               (buffer-disable-undo)
790               (goto-char (point-max))               (goto-char (point-max))
791               (insert-buffer-substring buffer)))               (insert-buffer-substring buffer)))
792        (let ((imap-process process))        (when (and (setq tls-info (starttls-negotiate process))
793          (unwind-protect                   (memq (process-status process) '(open run)))
             (progn  
               (set-process-filter imap-process 'imap-arrival-filter)  
               (when (and (eq imap-stream 'starttls)  
                          (imap-ok-p (imap-send-command-wait "STARTTLS")))  
                 (starttls-negotiate imap-process)))  
           (set-process-filter imap-process nil)))  
       (when (memq (process-status process) '(open run))  
794          (setq done process)))          (setq done process)))
795      (if done      (if (stringp tls-info)
796          (progn          (message "imap: STARTTLS info: %s" tls-info))
797            (message "imap: Connecting with STARTTLS...done")      (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed"))
798            done)      done))
       (message "imap: Connecting with STARTTLS...failed")  
       nil)))  
799    
800  ;; Server functions; authenticator stuff:  ;; Server functions; authenticator stuff:
801    
# Line 729  Returns t if login was successful, nil o Line 812  Returns t if login was successful, nil o
812        (while (or (not user) (not passwd))        (while (or (not user) (not passwd))
813          (setq user (or imap-username          (setq user (or imap-username
814                         (read-from-minibuffer                         (read-from-minibuffer
815                          (concat "IMAP username for " imap-server ": ")                          (concat "IMAP username for " imap-server
816                                    " (using stream `" (symbol-name imap-stream)
817                                    "'): ")
818                          (or user imap-default-user))))                          (or user imap-default-user))))
819          (setq passwd (or imap-password          (setq passwd (or imap-password
820                           (imap-read-passwd                           (read-passwd
821                            (concat "IMAP password for " user "@"                            (concat "IMAP password for " user "@"
822                                    imap-server ": "))))                                    imap-server " (using authenticator `"
823                                      (symbol-name imap-auth) "'): "))))
824          (when (and user passwd)          (when (and user passwd)
825            (if (funcall loginfunc user passwd)            (if (funcall loginfunc user passwd)
826                (progn                (progn
# Line 745  Returns t if login was successful, nil o Line 831  Returns t if login was successful, nil o
831                      (setq imap-password passwd)))                      (setq imap-password passwd)))
832              (message "Login failed...")              (message "Login failed...")
833              (setq passwd nil)              (setq passwd nil)
834                (setq imap-password nil)
835              (sit-for 1))))              (sit-for 1))))
836        ;;        (quit (with-current-buffer buffer        ;;        (quit (with-current-buffer buffer
837        ;;                (setq user nil        ;;                (setq user nil
# Line 755  Returns t if login was successful, nil o Line 842  Returns t if login was successful, nil o
842        ret)))        ret)))
843    
844  (defun imap-gssapi-auth-p (buffer)  (defun imap-gssapi-auth-p (buffer)
845    (imap-capability 'AUTH=GSSAPI buffer))    (eq imap-stream 'gssapi))
846    
847  (defun imap-gssapi-auth (buffer)  (defun imap-gssapi-auth (buffer)
848    (message "imap: Authenticating using GSSAPI...%s"    (message "imap: Authenticating using GSSAPI...%s"
# Line 763  Returns t if login was successful, nil o Line 850  Returns t if login was successful, nil o
850    (eq imap-stream 'gssapi))    (eq imap-stream 'gssapi))
851    
852  (defun imap-kerberos4-auth-p (buffer)  (defun imap-kerberos4-auth-p (buffer)
853    (imap-capability 'AUTH=KERBEROS_V4 buffer))    (and (imap-capability 'AUTH=KERBEROS_V4 buffer)
854           (eq imap-stream 'kerberos4)))
855    
856  (defun imap-kerberos4-auth (buffer)  (defun imap-kerberos4-auth (buffer)
857    (message "imap: Authenticating using Kerberos 4...%s"    (message "imap: Authenticating using Kerberos 4...%s"
# Line 793  Returns t if login was successful, nil o Line 881  Returns t if login was successful, nil o
881          (message "imap: Authenticating using CRAM-MD5...done")          (message "imap: Authenticating using CRAM-MD5...done")
882        (message "imap: Authenticating using CRAM-MD5...failed"))))        (message "imap: Authenticating using CRAM-MD5...failed"))))
883    
   
   
884  (defun imap-login-p (buffer)  (defun imap-login-p (buffer)
885    (and (not (imap-capability 'LOGINDISABLED buffer))    (and (not (imap-capability 'LOGINDISABLED buffer))
886         (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))))         (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))))
# Line 898  necessary.  If nil, the buffer name is g Line 984  necessary.  If nil, the buffer name is g
984      (setq imap-auth (or auth imap-auth))      (setq imap-auth (or auth imap-auth))
985      (setq imap-stream (or stream imap-stream))      (setq imap-stream (or stream imap-stream))
986      (message "imap: Connecting to %s..." imap-server)      (message "imap: Connecting to %s..." imap-server)
987      (if (let ((imap-stream (or imap-stream imap-default-stream)))      (if (null (let ((imap-stream (or imap-stream imap-default-stream)))
988            (imap-open-1 buffer))                  (imap-open-1 buffer)))
989          ;; Choose stream.          (progn
990          (let (stream-changed)            (message "imap: Connecting to %s...failed" imap-server)
991            (message "imap: Connecting to %s...done" imap-server)            nil)
992            (when (null imap-stream)        (when (null imap-stream)
993              (let ((streams imap-streams))          ;; Need to choose stream.
994                (while (setq stream (pop streams))          (let ((streams imap-streams))
995                  (if (funcall (nth 1 (assq stream imap-stream-alist)) buffer)            (while (setq stream (pop streams))
996                      (setq stream-changed (not (eq (or imap-stream              ;; OK to use this stream?
997                                                        imap-default-stream)              (when (funcall (nth 1 (assq stream imap-stream-alist)) buffer)
998                                                    stream))                ;; Stream changed?
999                            imap-stream stream                (if (not (eq imap-default-stream stream))
1000                            streams nil)))                    (with-current-buffer (get-buffer-create
1001                (unless imap-stream                                          (generate-new-buffer-name " *temp*"))
1002                  (error "Couldn't figure out a stream for server"))))                      (mapcar 'make-local-variable imap-local-variables)
1003            (when stream-changed                      (imap-disable-multibyte)
1004              (message "imap: Reconnecting with stream `%s'..." imap-stream)                      (buffer-disable-undo)
1005              (imap-close buffer)                      (setq imap-server (or server imap-server))
1006              (if (imap-open-1 buffer)                      (setq imap-port (or port imap-port))
1007                  (message "imap: Reconnecting with stream `%s'...done"                      (setq imap-auth (or auth imap-auth))
1008                           imap-stream)                      (message "imap: Reconnecting with stream `%s'..." stream)
1009                (message "imap: Reconnecting with stream `%s'...failed"                      (if (null (let ((imap-stream stream))
1010                         imap-stream))                                  (imap-open-1 (current-buffer))))
1011              (setq imap-capability nil))                          (progn
1012            (if (imap-opened buffer)                            (kill-buffer (current-buffer))
1013                ;; Choose authenticator                            (message
1014                (when (and (null imap-auth) (not (eq imap-state 'auth)))                             "imap: Reconnecting with stream `%s'...failed"
1015                  (let ((auths imap-authenticators))                             stream))
1016                    (while (setq auth (pop auths))                        ;; We're done, kill the first connection
1017                      (if (funcall (nth 1 (assq auth imap-authenticator-alist))                        (imap-close buffer)
1018                                   buffer)                        (kill-buffer buffer)
1019                          (setq imap-auth auth                        (rename-buffer buffer)
1020                                auths nil)))                        (message "imap: Reconnecting with stream `%s'...done"
1021                    (unless imap-auth                                 stream)
1022                      (error "Couldn't figure out authenticator for server"))))))                        (setq imap-stream stream)
1023        (message "imap: Connecting to %s...failed" imap-server))                        (setq imap-capability nil)
1024      (when (imap-opened buffer)                        (setq streams nil)))
1025        (setq imap-mailbox-data (make-vector imap-mailbox-prime 0))                  ;; We're done
1026        buffer)))                  (message "imap: Connecting to %s...done" imap-server)
1027                    (setq imap-stream stream)
1028                    (setq imap-capability nil)
1029                    (setq streams nil))))))
1030          (when (imap-opened buffer)
1031            (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)))
1032          (when imap-stream
1033            buffer))))
1034    
1035  (defun imap-opened (&optional buffer)  (defun imap-opened (&optional buffer)
1036    "Return non-nil if connection to imap server in BUFFER is open.    "Return non-nil if connection to imap server in BUFFER is open.
# Line 964  password is remembered in the buffer." Line 1057  password is remembered in the buffer."
1057        (make-local-variable 'imap-password)        (make-local-variable 'imap-password)
1058        (if user (setq imap-username user))        (if user (setq imap-username user))
1059        (if passwd (setq imap-password passwd))        (if passwd (setq imap-password passwd))
1060        (if (funcall (nth 2 (assq imap-auth imap-authenticator-alist)) buffer)        (if imap-auth
1061            (setq imap-state 'auth)))))            (and (funcall (nth 2 (assq imap-auth
1062                                         imap-authenticator-alist)) buffer)
1063                   (setq imap-state 'auth))
1064            ;; Choose authenticator.
1065            (let ((auths imap-authenticators)
1066                  auth)
1067              (while (setq auth (pop auths))
1068                ;; OK to use authenticator?
1069                (when (funcall (nth 1 (assq auth imap-authenticator-alist)) buffer)
1070                  (message "imap: Authenticating to `%s' using `%s'..."
1071                           imap-server auth)
1072                  (setq imap-auth auth)
1073                  (if (funcall (nth 2 (assq auth imap-authenticator-alist)) buffer)
1074                      (progn
1075                        (message "imap: Authenticating to `%s' using `%s'...done"
1076                                 imap-server auth)
1077                        (setq auths nil))
1078                    (message "imap: Authenticating to `%s' using `%s'...failed"
1079                             imap-server auth)))))
1080            imap-state))))
1081    
1082  (defun imap-close (&optional buffer)  (defun imap-close (&optional buffer)
1083    "Close connection to server in BUFFER.    "Close connection to server in BUFFER.
1084  If BUFFER is nil, the current buffer is used."  If BUFFER is nil, the current buffer is used."
1085    (with-current-buffer (or buffer (current-buffer))    (with-current-buffer (or buffer (current-buffer))
1086      (and (imap-opened)      (when (imap-opened)
1087           (not (imap-ok-p (imap-send-command-wait "LOGOUT")))        (condition-case nil
1088           (message "Server %s didn't let me log out" imap-server))            (imap-send-command-wait "LOGOUT")
1089            (quit nil)))
1090      (when (and imap-process      (when (and imap-process
1091                 (memq (process-status imap-process) '(open run)))                 (memq (process-status imap-process) '(open run)))
1092        (delete-process imap-process))        (delete-process imap-process))
# Line 1105  If EXAMINE is non-nil, do a read-only se Line 1218  If EXAMINE is non-nil, do a read-only se
1218              imap-state 'auth)              imap-state 'auth)
1219        t)))        t)))
1220    
1221  (defun imap-mailbox-expunge (&optional buffer)  (defun imap-mailbox-expunge (&optional asynch buffer)
1222    "Expunge articles in current folder in BUFFER.    "Expunge articles in current folder in BUFFER.
1223    If ASYNCH, do not wait for succesful completion of the command.
1224  If BUFFER is nil the current buffer is assumed."  If BUFFER is nil the current buffer is assumed."
1225    (with-current-buffer (or buffer (current-buffer))    (with-current-buffer (or buffer (current-buffer))
1226      (when (and imap-current-mailbox (not (eq imap-state 'examine)))      (when (and imap-current-mailbox (not (eq imap-state 'examine)))
1227        (imap-ok-p (imap-send-command-wait "EXPUNGE")))))        (if asynch
1228              (imap-send-command "EXPUNGE")
1229          (imap-ok-p (imap-send-command-wait "EXPUNGE"))))))
1230    
1231  (defun imap-mailbox-close (&optional buffer)  (defun imap-mailbox-close (&optional asynch buffer)
1232    "Expunge articles and close current folder in BUFFER.    "Expunge articles and close current folder in BUFFER.
1233    If ASYNCH, do not wait for succesful completion of the command.
1234  If BUFFER is nil the current buffer is assumed."  If BUFFER is nil the current buffer is assumed."
1235    (with-current-buffer (or buffer (current-buffer))    (with-current-buffer (or buffer (current-buffer))
1236      (when (and imap-current-mailbox      (when imap-current-mailbox
1237                 (imap-ok-p (imap-send-command-wait "CLOSE")))        (if asynch
1238        (setq imap-current-mailbox nil            (imap-add-callback (imap-send-command "CLOSE")
1239              imap-message-data nil                               `(lambda (tag status)
1240              imap-state 'auth)                                  (message "IMAP mailbox `%s' closed... %s"
1241                                             imap-current-mailbox status)
1242                                    (when (eq ,imap-current-mailbox
1243                                              imap-current-mailbox)
1244                                      ;; Don't wipe out data if another mailbox
1245                                      ;; was selected...
1246                                      (setq imap-current-mailbox nil
1247                                            imap-message-data nil
1248                                            imap-state 'auth))))
1249            (when (imap-ok-p (imap-send-command-wait "CLOSE"))
1250              (setq imap-current-mailbox nil
1251                    imap-message-data nil
1252                    imap-state 'auth)))
1253        t)))        t)))
1254    
1255  (defun imap-mailbox-create-1 (mailbox)  (defun imap-mailbox-create-1 (mailbox)
# Line 1225  returned, if ITEMS is a symbol only its Line 1354  returned, if ITEMS is a symbol only its
1354             (imap-send-command-wait (list "STATUS \""             (imap-send-command-wait (list "STATUS \""
1355                                           (imap-utf7-encode mailbox)                                           (imap-utf7-encode mailbox)
1356                                           "\" "                                           "\" "
1357                                           (format "%s"                                           (upcase
1358                                                   (if (listp items)                                            (format "%s"
1359                                                       items                                                    (if (listp items)
1360                                                     (list items))))))                                                        items
1361                                                        (list items)))))))
1362        (if (listp items)        (if (listp items)
1363            (mapcar (lambda (item)            (mapcar (lambda (item)
1364                      (imap-mailbox-get item mailbox))                      (imap-mailbox-get item mailbox))
1365                    items)                    items)
1366          (imap-mailbox-get items mailbox)))))          (imap-mailbox-get items mailbox)))))
1367    
1368    (defun imap-mailbox-status-asynch (mailbox items &optional buffer)
1369      "Send status item request ITEM on MAILBOX to server in BUFFER.
1370    ITEMS can be a symbol or a list of symbols, valid symbols are one of
1371    the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
1372    or 'unseen.  The IMAP command tag is returned."
1373      (with-current-buffer (or buffer (current-buffer))
1374        (imap-send-command (list "STATUS \""
1375                                 (imap-utf7-encode mailbox)
1376                                 "\" "
1377                                 (format "%s"
1378                                         (if (listp items)
1379                                             items
1380                                           (list items)))))))
1381    
1382  (defun imap-mailbox-acl-get (&optional mailbox buffer)  (defun imap-mailbox-acl-get (&optional mailbox buffer)
1383    "Get ACL on mailbox from server in BUFFER."    "Get ACL on mailbox from server in BUFFER."
1384    (let ((mailbox (imap-utf7-encode mailbox)))    (let ((mailbox (imap-utf7-encode mailbox)))
# Line 1286  returned, if ITEMS is a symbol only its Line 1430  returned, if ITEMS is a symbol only its
1430    (mapconcat    (mapconcat
1431     (lambda (item)     (lambda (item)
1432       (if (consp item)       (if (consp item)
1433           (format "%d:%d"           (format "%d:%d"
1434                   (car item) (cdr item))                   (car item) (cdr item))
1435         (format "%d" item)))         (format "%d" item)))
1436     (if (and (listp range) (not (listp (cdr range))))     (if (and (listp range) (not (listp (cdr range))))
1437         (list range) ;; make (1 . 2) into ((1 . 2))         (list range) ;; make (1 . 2) into ((1 . 2))
# Line 1398  is non-nil return theese properties." Line 1542  is non-nil return theese properties."
1542      (imap-mailbox-put 'search 'dummy)      (imap-mailbox-put 'search 'dummy)
1543      (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate)))      (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate)))
1544        (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy)        (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy)
1545            (error "Missing SEARCH response to a SEARCH command")            (progn
1546                (message "Missing SEARCH response to a SEARCH command (server not RFC compliant)...")
1547                nil)
1548          (imap-mailbox-get-1 'search imap-current-mailbox)))))          (imap-mailbox-get-1 'search imap-current-mailbox)))))
1549    
1550  (defun imap-message-flag-permanent-p (flag &optional mailbox buffer)  (defun imap-message-flag-permanent-p (flag &optional mailbox buffer)
# Line 1464  first element, rest of list contain the Line 1610  first element, rest of list contain the
1610                (if (imap-ok-p (imap-send-command-wait cmd))                (if (imap-ok-p (imap-send-command-wait cmd))
1611                    t                    t
1612                  (when (and (not dont-create)                  (when (and (not dont-create)
1613                             (imap-mailbox-get-1 'trycreate mailbox))                             ;; removed because of buggy Oracle server
1614                    (imap-mailbox-create-1 mailbox)                             ;; that doesn't send TRYCREATE tags (which
1615                               ;; is a MUST according to specifications):
1616                               ;;(imap-mailbox-get-1 'trycreate mailbox)
1617                               (imap-mailbox-create-1 mailbox))
1618                    (imap-ok-p (imap-send-command-wait cmd)))))                    (imap-ok-p (imap-send-command-wait cmd)))))
1619              (or no-copyuid              (or no-copyuid
1620                  (imap-message-copyuid-1 mailbox)))))))                  (imap-message-copyuid-1 mailbox)))))))
# Line 1530  on failure." Line 1679  on failure."
1679    
1680  ;; Internal functions.  ;; Internal functions.
1681    
1682    (defun imap-add-callback (tag func)
1683      (setq imap-callbacks (append (list (cons tag func)) imap-callbacks)))
1684    
1685  (defun imap-send-command-1 (cmdstr)  (defun imap-send-command-1 (cmdstr)
1686    (setq cmdstr (concat cmdstr imap-client-eol))    (setq cmdstr (concat cmdstr imap-client-eol))
1687    (and imap-log    (and imap-log
1688         (with-current-buffer (get-buffer-create imap-log)         (with-current-buffer (get-buffer-create imap-log-buffer)
1689           (imap-disable-multibyte)           (imap-disable-multibyte)
1690           (buffer-disable-undo)           (buffer-disable-undo)
1691           (goto-char (point-max))           (goto-char (point-max))
# Line 1570  on failure." Line 1722  on failure."
1722                       (imap-send-command-1 cmdstr)                       (imap-send-command-1 cmdstr)
1723                       (setq cmdstr nil)                       (setq cmdstr nil)
1724                       (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))                       (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1725                           (setq command nil);; abort command if no cont-req                           (setq command nil) ;; abort command if no cont-req
1726                         (let ((process imap-process)                         (let ((process imap-process)
1727                               (stream imap-stream)                               (stream imap-stream)
1728                               (eol imap-client-eol))                               (eol imap-client-eol))
1729                           (with-current-buffer cmd                           (with-current-buffer cmd
1730                             (and imap-log                             (and imap-log
1731                                  (with-current-buffer (get-buffer-create                                  (with-current-buffer (get-buffer-create
1732                                                        imap-log)                                                        imap-log-buffer)
1733                                    (imap-disable-multibyte)                                    (imap-disable-multibyte)
1734                                    (buffer-disable-undo)                                    (buffer-disable-undo)
1735                                    (goto-char (point-max))                                    (goto-char (point-max))
# Line 1591  on failure." Line 1743  on failure."
1743                 (setq cmdstr nil)                 (setq cmdstr nil)
1744                 (unwind-protect                 (unwind-protect
1745                     (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))                     (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1746                         (setq command nil);; abort command if no cont-req                         (setq command nil) ;; abort command if no cont-req
1747                       (setq command (cons (funcall cmd imap-continuation)                       (setq command (cons (funcall cmd imap-continuation)
1748                                           command)))                                           command)))
1749                   (setq imap-continuation nil)))                   (setq imap-continuation nil)))
# Line 1603  on failure." Line 1755  on failure."
1755    
1756  (defun imap-wait-for-tag (tag &optional buffer)  (defun imap-wait-for-tag (tag &optional buffer)
1757    (with-current-buffer (or buffer (current-buffer))    (with-current-buffer (or buffer (current-buffer))
1758      (while (and (null imap-continuation)      (let (imap-have-messaged)
1759                  (< imap-reached-tag tag))        (while (and (null imap-continuation)
1760        (or (and (not (memq (process-status imap-process) '(open run)))                    (memq (process-status imap-process) '(open run))
1761                 (sit-for 1))                    (< imap-reached-tag tag))
1762            (accept-process-output imap-process 1)))          (let ((len (/ (point-max) 1024))
1763      (or (assq tag imap-failed-tags)                message-log-max)
1764          (if imap-continuation            (unless (< len 10)
1765              'INCOMPLETE              (setq imap-have-messaged t)
1766            'OK))))              (message "imap read: %dk" len))
1767              (accept-process-output imap-process
1768                                     (truncate imap-read-timeout)
1769                                     (truncate (* (- imap-read-timeout
1770                                                     (truncate imap-read-timeout))
1771                                                  1000)))))
1772          ;; A process can die _before_ we have processed everything it
1773          ;; has to say.  Moreover, this can happen in between the call to
1774          ;; accept-process-output and the call to process-status in an
1775          ;; iteration of the loop above.
1776          (when (and (null imap-continuation)
1777                     (< imap-reached-tag tag))
1778            (accept-process-output imap-process 0 0))
1779          (when imap-have-messaged
1780            (message ""))
1781          (and (memq (process-status imap-process) '(open run))
1782               (or (assq tag imap-failed-tags)
1783                   (if imap-continuation
1784                       'INCOMPLETE
1785                     'OK))))))
1786    
1787  (defun imap-sentinel (process string)  (defun imap-sentinel (process string)
1788    (delete-process process))    (delete-process process))
# Line 1631  Return nil if no complete line has arriv Line 1802  Return nil if no complete line has arriv
1802    
1803  (defun imap-arrival-filter (proc string)  (defun imap-arrival-filter (proc string)
1804    "IMAP process filter."    "IMAP process filter."
1805    (with-current-buffer (process-buffer proc)    ;; Sometimes, we are called even though the process has died.
1806      (goto-char (point-max))    ;; Better abstain from doing stuff in that case.
1807      (insert string)    (when (buffer-name (process-buffer proc))
1808      (and imap-log      (with-current-buffer (process-buffer proc)
1809           (with-current-buffer (get-buffer-create imap-log)        (goto-char (point-max))
1810             (imap-disable-multibyte)        (insert string)
1811             (buffer-disable-undo)        (and imap-log
1812             (goto-char (point-max))             (with-current-buffer (get-buffer-create imap-log-buffer)
1813             (insert string)))               (imap-disable-multibyte)
1814      (let (end)               (buffer-disable-undo)
1815        (goto-char (point-min))               (goto-char (point-max))
1816        (while (setq end (imap-find-next-line))               (insert string)))
1817          (save-restriction        (let (end)
1818            (narrow-to-region (point-min) end)          (goto-char (point-min))
1819            (delete-backward-char (length imap-server-eol))          (while (setq end (imap-find-next-line))
1820            (goto-char (point-min))            (save-restriction
1821            (unwind-protect              (narrow-to-region (point-min) end)
1822                (cond ((eq imap-state 'initial)              (delete-backward-char (length imap-server-eol))
1823                       (imap-parse-greeting))              (goto-char (point-min))
1824                      ((or (eq imap-state 'auth)              (unwind-protect
1825                           (eq imap-state 'nonauth)                  (cond ((eq imap-state 'initial)
1826                           (eq imap-state 'selected)                         (imap-parse-greeting))
1827                           (eq imap-state 'examine))                        ((or (eq imap-state 'auth)
1828                       (imap-parse-response))                             (eq imap-state 'nonauth)
1829                      (t                             (eq imap-state 'selected)
1830                       (message "Unknown state %s in arrival filter"                             (eq imap-state 'examine))
1831                                imap-state)))                         (imap-parse-response))
1832              (delete-region (point-min) (point-max))))))))                        (t
1833                           (message "Unknown state %s in arrival filter"
1834                                    imap-state)))
1835                  (delete-region (point-min) (point-max)))))))))
1836    
1837    
1838  ;; Imap parser.  ;; Imap parser.
# Line 1803  Return nil if no complete line has arriv Line 1977  Return nil if no complete line has arriv
1977          (when (eq (char-after) ?\))          (when (eq (char-after) ?\))
1978            (imap-forward)            (imap-forward)
1979            (nreverse addresses)))            (nreverse addresses)))
1980      ;; (assert (imap-parse-nil)) ; With assert, the code might not be eval'd.      ;; With assert, the code might not be eval'd.
1981        ;; (assert (imap-parse-nil) t "In imap-parse-address-list")
1982      (imap-parse-nil)))      (imap-parse-nil)))
1983    
1984  ;;   mailbox         = "INBOX" / astring  ;;   mailbox         = "INBOX" / astring
# Line 1857  Return nil if no complete line has arriv Line 2032  Return nil if no complete line has arriv
2032  ;;   resp-cond-bye   = "BYE" SP resp-text  ;;   resp-cond-bye   = "BYE" SP resp-text
2033  ;;  ;;
2034  ;;   mailbox-data    =  "FLAGS" SP flag-list /  ;;   mailbox-data    =  "FLAGS" SP flag-list /
2035  ;;                      "LIST" SP mailbox-list /  ;;                      "LIST" SP mailbox-list /
2036  ;;                      "LSUB" SP mailbox-list /  ;;                      "LSUB" SP mailbox-list /
2037  ;;                      "SEARCH" *(SP nz-number) /  ;;                      "SEARCH" *(SP nz-number) /
2038  ;;                      "STATUS" SP mailbox SP "("  ;;                      "STATUS" SP mailbox SP "("
# Line 1895  Return nil if no complete line has arriv Line 2070  Return nil if no complete line has arriv
2070                          (read (concat "(" (buffer-substring (point) (point-max)) ")"))))                          (read (concat "(" (buffer-substring (point) (point-max)) ")"))))
2071             (STATUS     (imap-parse-status))             (STATUS     (imap-parse-status))
2072             (CAPABILITY (setq imap-capability             (CAPABILITY (setq imap-capability
2073                               (read (concat "(" (upcase (buffer-substring                                 (read (concat "(" (upcase (buffer-substring
2074                                                          (point) (point-max)))                                                            (point) (point-max)))
2075                                             ")"))))                                               ")"))))
2076             (ACL        (imap-parse-acl))             (ACL        (imap-parse-acl))
2077             (t       (case (prog1 (read (current-buffer))             (t       (case (prog1 (read (current-buffer))
2078                              (imap-forward))                              (imap-forward))
# Line 1939  Return nil if no complete line has arriv Line 2114  Return nil if no complete line has arriv
2114                          (push (list token status code text) imap-failed-tags)                          (push (list token status code text) imap-failed-tags)
2115                          (error "Internal error, tag %s status %s code %s text %s"                          (error "Internal error, tag %s status %s code %s text %s"
2116                                 token status code text))))                                 token status code text))))
2117                 (t   (message "Garbage: %s" (buffer-string))))))))))                 (t   (message "Garbage: %s" (buffer-string))))
2118                 (when (assq token imap-callbacks)
2119                   (funcall (cdr (assq token imap-callbacks)) token status)
2120                   (setq imap-callbacks
2121                         (imap-remassoc token imap-callbacks)))))))))
2122    
2123  ;;   resp-text       = ["[" resp-text-code "]" SP] text  ;;   resp-text       = ["[" resp-text-code "]" SP] text
2124  ;;  ;;
# Line 1958  Return nil if no complete line has arriv Line 2137  Return nil if no complete line has arriv
2137  ;;                               [flag-perm *(SP flag-perm)] ")" /  ;;                               [flag-perm *(SP flag-perm)] ")" /
2138  ;;                     "READ-ONLY" /  ;;                     "READ-ONLY" /
2139  ;;                     "READ-WRITE" /  ;;                     "READ-WRITE" /
2140  ;;                     "TRYCREATE" /  ;;                     "TRYCREATE" /
2141  ;;                     "UIDNEXT" SP nz-number /  ;;                     "UIDNEXT" SP nz-number /
2142  ;;                     "UIDVALIDITY" SP nz-number /  ;;                     "UIDVALIDITY" SP nz-number /
2143  ;;                     "UNSEEN" SP nz-number /  ;;                     "UNSEEN" SP nz-number /
# Line 2005  Return nil if no complete line has arriv Line 2184  Return nil if no complete line has arriv
2184  ;;   resp-text-atom  = 1*<any ATOM-CHAR except "]">  ;;   resp-text-atom  = 1*<any ATOM-CHAR except "]">
2185    
2186  (defun imap-parse-resp-text-code ()  (defun imap-parse-resp-text-code ()
2187      ;; xxx next line for stalker communigate pro 3.3.1 bug
2188      (when (looking-at " \\[")
2189        (imap-forward))
2190    (when (eq (char-after) ?\[)    (when (eq (char-after) ?\[)
2191      (imap-forward)      (imap-forward)
2192      (cond ((search-forward "PERMANENTFLAGS " nil t)      (cond ((search-forward "PERMANENTFLAGS " nil t)
2193             (imap-mailbox-put 'permanentflags (imap-parse-flag-list)))             (imap-mailbox-put 'permanentflags (imap-parse-flag-list)))
2194            ((search-forward "UIDNEXT " nil t)            ((search-forward "UIDNEXT \\([0-9]+\\)" nil t)
2195             (imap-mailbox-put 'uidnext (read (current-buffer))))             (imap-mailbox-put 'uidnext (match-string 1)))
2196            ((search-forward "UNSEEN " nil t)            ((search-forward "UNSEEN " nil t)
2197             (imap-mailbox-put 'unseen (read (current-buffer))))             (imap-mailbox-put 'first-unseen (read (current-buffer))))
2198            ((looking-at "UIDVALIDITY \\([0-9]+\\)")            ((looking-at "UIDVALIDITY \\([0-9]+\\)")
2199             (imap-mailbox-put 'uidvalidity (match-string 1)))             (imap-mailbox-put 'uidvalidity (match-string 1)))
2200            ((search-forward "READ-ONLY" nil t)            ((search-forward "READ-ONLY" nil t)
# Line 2111  Return nil if no complete line has arriv Line 2293  Return nil if no complete line has arriv
2293  (defun imap-parse-fetch (response)  (defun imap-parse-fetch (response)
2294    (when (eq (char-after) ?\()    (when (eq (char-after) ?\()
2295      (let (uid flags envelope internaldate rfc822 rfc822header rfc822text      (let (uid flags envelope internaldate rfc822 rfc822header rfc822text
2296                rfc822size body bodydetail bodystructure)                rfc822size body bodydetail bodystructure flags-empty)
2297        (while (not (eq (char-after) ?\)))        (while (not (eq (char-after) ?\)))
2298          (imap-forward)          (imap-forward)
2299          (let ((token (read (current-buffer))))          (let ((token (read (current-buffer))))
2300            (imap-forward)            (imap-forward)
2301            (cond ((eq token 'UID)            (cond ((eq token 'UID)
2302                   (setq uid (ignore-errors (read (current-buffer)))))                   (setq uid (condition-case ()
2303                                   (read (current-buffer))
2304                                 (error))))
2305                  ((eq token 'FLAGS)                  ((eq token 'FLAGS)
2306                   (setq flags (imap-parse-flag-list)))                   (setq flags (imap-parse-flag-list))
2307                     (if (not flags)
2308                         (setq flags-empty 't)))
2309                  ((eq token 'ENVELOPE)                  ((eq token 'ENVELOPE)
2310                   (setq envelope (imap-parse-envelope)))                   (setq envelope (imap-parse-envelope)))
2311                  ((eq token 'INTERNALDATE)                  ((eq token 'INTERNALDATE)
# Line 2148  Return nil if no complete line has arriv Line 2334  Return nil if no complete line has arriv
2334        (when uid        (when uid
2335          (setq imap-current-message uid)          (setq imap-current-message uid)
2336          (imap-message-put uid 'UID uid)          (imap-message-put uid 'UID uid)
2337          (and flags (imap-message-put uid 'FLAGS flags))          (and (or flags flags-empty) (imap-message-put uid 'FLAGS flags))
2338          (and envelope (imap-message-put uid 'ENVELOPE envelope))          (and envelope (imap-message-put uid 'ENVELOPE envelope))
2339          (and internaldate (imap-message-put uid 'INTERNALDATE internaldate))          (and internaldate (imap-message-put uid 'INTERNALDATE internaldate))
2340          (and rfc822 (imap-message-put uid 'RFC822 rfc822))          (and rfc822 (imap-message-put uid 'RFC822 rfc822))
# Line 2171  Return nil if no complete line has arriv Line 2357  Return nil if no complete line has arriv
2357    
2358  (defun imap-parse-status ()  (defun imap-parse-status ()
2359    (let ((mailbox (imap-parse-mailbox)))    (let ((mailbox (imap-parse-mailbox)))
2360      (when (and mailbox (search-forward "(" nil t))      (if (eq (char-after) ? )
2361        (while (not (eq (char-after) ?\)))          (forward-char))
2362          (let ((token (read (current-buffer))))      (when (and mailbox (eq (char-after) ?\())
2363            (cond ((eq token 'MESSAGES)        (while (and (not (eq (char-after) ?\)))
2364                      (or (forward-char) t)
2365                      (looking-at "\\([A-Za-z]+\\) "))
2366            (let ((token (match-string 1)))
2367              (goto-char (match-end 0))
2368              (cond ((string= token "MESSAGES")
2369                   (imap-mailbox-put 'messages (read (current-buffer)) mailbox))                   (imap-mailbox-put 'messages (read (current-buffer)) mailbox))
2370                  ((eq token 'RECENT)                  ((string= token "RECENT")
2371                   (imap-mailbox-put 'recent (read (current-buffer)) mailbox))                   (imap-mailbox-put 'recent (read (current-buffer)) mailbox))
2372                  ((eq token 'UIDNEXT)                  ((string= token "UIDNEXT")
2373                   (imap-mailbox-put 'uidnext (read (current-buffer)) mailbox))                   (and (looking-at "[0-9]+")
2374                  ((eq token 'UIDVALIDITY)                        (imap-mailbox-put 'uidnext (match-string 0) mailbox)
2375                   (and (looking-at " \\([0-9]+\\)")                        (goto-char (match-end 0))))
2376                        (imap-mailbox-put 'uidvalidity (match-string 1) mailbox)                  ((string= token "UIDVALIDITY")
2377                        (goto-char (match-end 1))))                   (and (looking-at "[0-9]+")
2378                  ((eq token 'UNSEEN)                        (imap-mailbox-put 'uidvalidity (match-string 0) mailbox)
2379                          (goto-char (match-end 0))))
2380                    ((string= token "UNSEEN")
2381                   (imap-mailbox-put 'unseen (read (current-buffer)) mailbox))                   (imap-mailbox-put 'unseen (read (current-buffer)) mailbox))
2382                  (t                  (t
2383                   (message "Unknown status data %s in mailbox %s ignored"                   (message "Unknown status data %s in mailbox %s ignored"
2384                            token mailbox))))))))                            token mailbox)
2385                     (read (current-buffer)))))))))
2386    
2387  ;;   acl_data        ::= "ACL" SPACE mailbox *(SPACE identifier SPACE  ;;   acl_data        ::= "ACL" SPACE mailbox *(SPACE identifier SPACE
2388  ;;                        rights)  ;;                        rights)
# Line 2226  Return nil if no complete line has arriv Line 2420  Return nil if no complete line has arriv
2420    
2421  (defun imap-parse-flag-list ()  (defun imap-parse-flag-list ()
2422    (let (flag-list start)    (let (flag-list start)
2423      (assert (eq (char-after) ?\())      (assert (eq (char-after) ?\() t "In imap-parse-flag-list")
2424      (while (and (not (eq (char-after) ?\)))      (while (and (not (eq (char-after) ?\)))
2425                  (setq start (progn (imap-forward) (point)))                  (setq start (progn
2426                                  (imap-forward)
2427                                  ;; next line for Courier IMAP bug.
2428                                  (skip-chars-forward " ")
2429                                  (point)))
2430                  (> (skip-chars-forward "^ )" (imap-point-at-eol)) 0))                  (> (skip-chars-forward "^ )" (imap-point-at-eol)) 0))
2431        (push (buffer-substring start (point)) flag-list))        (push (buffer-substring start (point)) flag-list))
2432      (assert (eq (char-after) ?\)))      (assert (eq (char-after) ?\)) t "In imap-parse-flag-list")
2433      (imap-forward)      (imap-forward)
2434      (nreverse flag-list)))      (nreverse flag-list)))
2435    
# Line 2262  Return nil if no complete line has arriv Line 2460  Return nil if no complete line has arriv
2460  (defun imap-parse-envelope ()  (defun imap-parse-envelope ()
2461    (when (eq (char-after) ?\()    (when (eq (char-after) ?\()
2462      (imap-forward)      (imap-forward)
2463      (vector (prog1 (imap-parse-nstring);; date      (vector (prog1 (imap-parse-nstring) ;; date
2464                (imap-forward))                (imap-forward))
2465              (prog1 (imap-parse-nstring);; subject              (prog1 (imap-parse-nstring) ;; subject
2466                (imap-forward))                (imap-forward))
2467              (prog1 (imap-parse-address-list);; from              (prog1 (imap-parse-address-list) ;; from
2468                (imap-forward))                (imap-forward))
2469              (prog1 (imap-parse-address-list);; sender              (prog1 (imap-parse-address-list) ;; sender
2470                (imap-forward))                (imap-forward))
2471              (prog1 (imap-parse-address-list);; reply-to              (prog1 (imap-parse-address-list) ;; reply-to
2472                (imap-forward))                (imap-forward))
2473              (prog1 (imap-parse-address-list);; to              (prog1 (imap-parse-address-list) ;; to
2474                (imap-forward))                (imap-forward))
2475              (prog1 (imap-parse-address-list);; cc              (prog1 (imap-parse-address-list) ;; cc
2476                (imap-forward))                (imap-forward))
2477              (prog1 (imap-parse-address-list);; bcc              (prog1 (imap-parse-address-list) ;; bcc
2478                (imap-forward))                (imap-forward))
2479              (prog1 (imap-parse-nstring);; in-reply-to              (prog1 (imap-parse-nstring) ;; in-reply-to
2480                (imap-forward))                (imap-forward))
2481              (prog1 (imap-parse-nstring);; message-id              (prog1 (imap-parse-nstring) ;; message-id
2482                (imap-forward)))))                (imap-forward)))))
2483    
2484  ;;   body-fld-param  = "(" string SP string *(SP string SP string) ")" / nil  ;;   body-fld-param  = "(" string SP string *(SP string SP string) ")" / nil
2485    
2486  (defsubst imap-parse-string-list ()  (defsubst imap-parse-string-list ()
2487    (cond ((eq (char-after) ?\();; body-fld-param    (cond ((eq (char-after) ?\() ;; body-fld-param
2488           (let (strlist str)           (let (strlist str)
2489             (imap-forward)             (imap-forward)
2490             (while (setq str (imap-parse-string))             (while (setq str (imap-parse-string))
# Line 2316  Return nil if no complete line has arriv Line 2514  Return nil if no complete line has arriv
2514          (while (eq (char-after) ?\ )          (while (eq (char-after) ?\ )
2515            (imap-forward)            (imap-forward)
2516            (push (imap-parse-body-extension) b-e))            (push (imap-parse-body-extension) b-e))
2517          (assert (eq (char-after) ?\)))          (assert (eq (char-after) ?\)) t "In imap-parse-body-extension")
2518          (imap-forward)          (imap-forward)
2519          (nreverse b-e))          (nreverse b-e))
2520      (or (imap-parse-number)      (or (imap-parse-number)
# Line 2334  Return nil if no complete line has arriv Line 2532  Return nil if no complete line has arriv
2532    
2533  (defsubst imap-parse-body-ext ()  (defsubst imap-parse-body-ext ()
2534    (let (ext)    (let (ext)
2535      (when (eq (char-after) ?\ );; body-fld-dsp      (when (eq (char-after) ?\ ) ;; body-fld-dsp
2536        (imap-forward)        (imap-forward)
2537        (let (dsp)        (let (dsp)
2538          (if (eq (char-after) ?\()          (if (eq (char-after) ?\()
# Line 2344  Return nil if no complete line has arriv Line 2542  Return nil if no complete line has arriv
2542                (imap-forward)                (imap-forward)
2543                (push (imap-parse-string-list) dsp)                (push (imap-parse-string-list) dsp)
2544                (imap-forward))                (imap-forward))
2545            ;; (assert (imap-parse-nil)) ; Code in assert might not be eval'd.            ;; With assert, the code might not be eval'd.
2546              ;; (assert (imap-parse-nil) t "In imap-parse-body-ext")
2547            (imap-parse-nil))            (imap-parse-nil))
2548          (push (nreverse dsp) ext))          (push (nreverse dsp) ext))
2549        (when (eq (char-after) ?\ );; body-fld-lang        (when (eq (char-after) ?\ ) ;; body-fld-lang
2550          (imap-forward)          (imap-forward)
2551          (if (eq (char-after) ?\()          (if (eq (char-after) ?\()
2552              (push (imap-parse-string-list) ext)              (push (imap-parse-string-list) ext)
2553            (push (imap-parse-nstring) ext))            (push (imap-parse-nstring) ext))
2554          (while (eq (char-after) ?\ );; body-extension          (while (eq (char-after) ?\ ) ;; body-extension
2555            (imap-forward)            (imap-forward)
2556            (setq ext (append (imap-parse-body-extension) ext)))))            (setq ext (append (imap-parse-body-extension) ext)))))
2557      ext))      ext))
# Line 2426  Return nil if no complete line has arriv Line 2625  Return nil if no complete line has arriv
2625            (let (subbody)            (let (subbody)
2626              (while (and (eq (char-after) ?\()              (while (and (eq (char-after) ?\()
2627                          (setq subbody (imap-parse-body)))                          (setq subbody (imap-parse-body)))
2628                ;; buggy stalker communigate pro 3.0 insert a SPC between               ;; buggy stalker communigate pro 3.0 insert a SPC between
2629                ;; parts in multiparts                ;; parts in multiparts
2630                (when (and (eq (char-after) ?\ )                (when (and (eq (char-after) ?\ )
2631                           (eq (char-after (1+ (point))) ?\())                           (eq (char-after (1+ (point))) ?\())
2632                  (imap-forward))                  (imap-forward))
2633                (push subbody body))                (push subbody body))
2634              (imap-forward)              (imap-forward)
2635              (push (imap-parse-string) body);; media-subtype              (push (imap-parse-string) body) ;; media-subtype
2636              (when (eq (char-after) ?\ );; body-ext-mpart:              (when (eq (char-after) ?\ ) ;; body-ext-mpart:
2637                (imap-forward)                (imap-forward)
2638                (if (eq (char-after) ?\();; body-fld-param                (if (eq (char-after) ?\() ;; body-fld-param
2639                    (push (imap-parse-string-list) body)                    (push (imap-parse-string-list) body)
2640                  (push (and (imap-parse-nil) nil) body))                  (push (and (imap-parse-nil) nil) body))
2641                (setq body                (setq body
2642                      (append (imap-parse-body-ext) body)));; body-ext-...                      (append (imap-parse-body-ext) body))) ;; body-ext-...
2643              (assert (eq (char-after) ?\)))              (assert (eq (char-after) ?\)) t "In imap-parse-body")
2644              (imap-forward)              (imap-forward)
2645              (nreverse body))              (nreverse body))
2646    
2647          (push (imap-parse-string) body);; media-type          (push (imap-parse-string) body) ;; media-type
2648          (imap-forward)          (imap-forward)
2649          (push (imap-parse-string) body);; media-subtype          (push (imap-parse-string) body) ;; media-subtype
2650          (imap-forward)          (imap-forward)
2651          ;; next line for Sun SIMS bug          ;; next line for Sun SIMS bug
2652          (and (eq (char-after) ? ) (imap-forward))          (and (eq (char-after) ? ) (imap-forward))
2653          (if (eq (char-after) ?\();; body-fld-param          (if (eq (char-after) ?\() ;; body-fld-param
2654              (push (imap-parse-string-list) body)              (push (imap-parse-string-list) body)
2655            (push (and (imap-parse-nil) nil) body))            (push (and (imap-parse-nil) nil) body))
2656          (imap-forward)          (imap-forward)
2657          (push (imap-parse-nstring) body);; body-fld-id          (push (imap-parse-nstring) body) ;; body-fld-id
2658          (imap-forward)          (imap-forward)
2659          (push (imap-parse-nstring) body);; body-fld-desc          (push (imap-parse-nstring) body) ;; body-fld-desc
2660          (imap-forward)          (imap-forward)
2661          ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a          ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a
2662          ;; nstring and return nil instead of defaulting back to 7BIT          ;; nstring and return nil instead of defaulting back to 7BIT
2663          ;; as the standard says.          ;; as the standard says.
2664          (push (or (imap-parse-nstring) "7BIT") body);; body-fld-enc          (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc
2665          (imap-forward)          (imap-forward)
2666          (push (imap-parse-number) body);; body-fld-octets          (push (imap-parse-number) body) ;; body-fld-octets
2667    
2668          ;; ok, we're done parsing the required parts, what comes now is one     ;; ok, we're done parsing the required parts, what comes now is one
2669          ;; of three things:          ;; of three things:
2670          ;;          ;;
2671          ;; envelope       (then we're parsing body-type-msg)          ;; envelope       (then we're parsing body-type-msg)
2672          ;; body-fld-lines (then we're parsing body-type-text)          ;; body-fld-lines (then we're parsing body-type-text)
2673          ;; body-ext-1part (then we're parsing body-type-basic)          ;; body-ext-1part (then we're parsing body-type-basic)
2674          ;;          ;;
2675          ;; the problem is that the two first are in turn optionally followed    ;; the problem is that the two first are in turn optionally followed
2676          ;; by the third.  So we parse the first two here (if there are any)...  ;; by the third.  So we parse the first two here (if there are any)...
2677    
2678          (when (eq (char-after) ?\ )          (when (eq (char-after) ?\ )
2679            (imap-forward)            (imap-forward)
2680            (let (lines)            (let (lines)
2681              (cond ((eq (char-after) ?\();; body-type-msg:              (cond ((eq (char-after) ?\() ;; body-type-msg:
2682                     (push (imap-parse-envelope) body);; envelope                     (push (imap-parse-envelope) body) ;; envelope
2683                     (imap-forward)                     (imap-forward)
2684                     (push (imap-parse-body) body);; body                     (push (imap-parse-body) body) ;; body
2685                     ;; buggy stalker communigate pro 3.0 doesn't print                     ;; buggy stalker communigate pro 3.0 doesn't print
2686                     ;; number of lines in message/rfc822 attachment                     ;; number of lines in message/rfc822 attachment
2687                     (if (eq (char-after) ?\))                     (if (eq (char-after) ?\))
2688                         (push 0 body)                         (push 0 body)
2689                       (imap-forward)                       (imap-forward)
2690                       (push (imap-parse-number) body))) ;; body-fld-lines                       (push (imap-parse-number) body))) ;; body-fld-lines
2691                    ((setq lines (imap-parse-number))    ;; body-type-text:                    ((setq lines (imap-parse-number)) ;; body-type-text:
2692                     (push lines body))                  ;; body-fld-lines                     (push lines body)) ;; body-fld-lines
2693                    (t                    (t
2694                     (backward-char)))))                 ;; no match...                     (backward-char))))) ;; no match...
2695    
2696          ;; ...and then parse the third one here...          ;; ...and then parse the third one here...
2697    
2698          (when (eq (char-after) ?\ );; body-ext-1part:          (when (eq (char-after) ?\ ) ;; body-ext-1part:
2699            (imap-forward)            (imap-forward)
2700            (push (imap-parse-nstring) body);; body-fld-md5            (push (imap-parse-nstring) body) ;; body-fld-md5
2701            (setq body (append (imap-parse-body-ext) body)));; body-ext-1part..            (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part..
2702    
2703          (assert (eq (char-after) ?\)))          (assert (eq (char-after) ?\)) t "In imap-parse-body 2")
2704          (imap-forward)          (imap-forward)
2705          (nreverse body)))))          (nreverse body)))))
2706    
2707  (when imap-debug                        ; (untrace-all)  (when imap-debug                        ; (untrace-all)
2708    (require 'trace)    (require 'trace)
2709    (buffer-disable-undo (get-buffer-create imap-debug))    (buffer-disable-undo (get-buffer-create imap-debug-buffer))
2710    (mapcar (lambda (f) (trace-function-background f imap-debug))    (mapcar (lambda (f) (trace-function-background f imap-debug-buffer))
2711            '(            '(
             imap-read-passwd  
2712              imap-utf7-encode              imap-utf7-encode
2713              imap-utf7-decode              imap-utf7-decode
2714              imap-error-text              imap-error-text

Legend:
Removed from v.1.6.4.3  
changed lines
  Added in v.1.6.4.4

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26