Mercurial > emacs

comparison lisp/net/imap.el @ 110210:3d982e5c5f58

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
pop3.el (pop3-streaming-movemail): Return t for success; imap.el (imap-log): New convenience function used throughout instead of repeating the same code all over the place.
author Katsumi Yamaoka <yamaoka@jpl.org>
date Sun, 05 Sep 2010 23:34:30 +0000
parents 5b9f64b04a04
children e9bead2d481f
comparison
equal deleted inserted replaced
110209:bafb89eacad6 110210:3d982e5c5f58
512 (with-current-buffer (or buffer (current-buffer)) 512 (with-current-buffer (or buffer (current-buffer))
513 (nth 3 (car imap-failed-tags)))) 513 (nth 3 (car imap-failed-tags))))
514 514
515 515
516 ;; Server functions; stream stuff: 516 ;; Server functions; stream stuff:
517
518 (defun imap-log (string-or-buffer)
519 (when imap-log
520 (with-current-buffer (get-buffer-create imap-log-buffer)
521 (imap-disable-multibyte)
522 (buffer-disable-undo)
523 (goto-char (point-max))
524 (if (bufferp string-or-buffer)
525 (insert-buffer-substring string-or-buffer)
526 (insert string-or-buffer)))))
517 527
518 (defun imap-kerberos4-stream-p (buffer) 528 (defun imap-kerberos4-stream-p (buffer)
519 (imap-capability 'AUTH=KERBEROS_V4 buffer)) 529 (imap-capability 'AUTH=KERBEROS_V4 buffer))
520 530
521 (defun imap-kerberos4-open (name buffer server port) 531 (defun imap-kerberos4-open (name buffer server port)
567 (re-search-forward 577 (re-search-forward
568 "^\\(Authenticat.*\\)" nil t)) 578 "^\\(Authenticat.*\\)" nil t))
569 (setq response (match-string 1))))) 579 (setq response (match-string 1)))))
570 (accept-process-output process 1) 580 (accept-process-output process 1)
571 (sit-for 1)) 581 (sit-for 1))
572 (and imap-log
573 (with-current-buffer (get-buffer-create imap-log-buffer)
574 (imap-disable-multibyte)
575 (buffer-disable-undo)
576 (goto-char (point-max))
577 (insert-buffer-substring buffer)))
578 (erase-buffer) 582 (erase-buffer)
579 (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd 583 (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
580 (if response (concat "done, " response) "failed")) 584 (if response (concat "done, " response) "failed"))
581 (if (and response (let ((case-fold-search nil)) 585 (if (and response (let ((case-fold-search nil))
582 (not (string-match "failed" response)))) 586 (not (string-match "failed" response))))
643 "finished.*\\)\\)") 647 "finished.*\\)\\)")
644 nil t) 648 nil t)
645 (setq response (match-string 1))))) 649 (setq response (match-string 1)))))
646 (accept-process-output process 1) 650 (accept-process-output process 1)
647 (sit-for 1)) 651 (sit-for 1))
648 (and imap-log 652 (imap-log buffer)
649 (with-current-buffer (get-buffer-create imap-log-buffer)
650 (imap-disable-multibyte)
651 (buffer-disable-undo)
652 (goto-char (point-max))
653 (insert-buffer-substring buffer)))
654 (erase-buffer) 653 (erase-buffer)
655 (message "GSSAPI IMAP connection: %s" (or response "failed")) 654 (message "GSSAPI IMAP connection: %s" (or response "failed"))
656 (if (and response (let ((case-fold-search nil)) 655 (if (and response (let ((case-fold-search nil))
657 (not (string-match "failed" response)))) 656 (not (string-match "failed" response))))
658 (setq done process) 657 (setq done process)
699 (goto-char (point-max)) 698 (goto-char (point-max))
700 (forward-line -1) 699 (forward-line -1)
701 (not (imap-parse-greeting))) 700 (not (imap-parse-greeting)))
702 (accept-process-output process 1) 701 (accept-process-output process 1)
703 (sit-for 1)) 702 (sit-for 1))
704 (and imap-log 703 (imap-log buffer)
705 (with-current-buffer (get-buffer-create imap-log-buffer)
706 (imap-disable-multibyte)
707 (buffer-disable-undo)
708 (goto-char (point-max))
709 (insert-buffer-substring buffer)))
710 (erase-buffer) 704 (erase-buffer)
711 (when (memq (process-status process) '(open run)) 705 (when (memq (process-status process) '(open run))
712 (setq done process)))))) 706 (setq done process))))))
713 (if done 707 (if done
714 (progn 708 (progn
738 (goto-char (point-max)) 732 (goto-char (point-max))
739 (forward-line -1) 733 (forward-line -1)
740 (not (imap-parse-greeting))) 734 (not (imap-parse-greeting)))
741 (accept-process-output process 1) 735 (accept-process-output process 1)
742 (sit-for 1)) 736 (sit-for 1))
743 (and imap-log 737 (imap-log buffer)
744 (with-current-buffer (get-buffer-create imap-log-buffer)
745 (imap-disable-multibyte)
746 (buffer-disable-undo)
747 (goto-char (point-max))
748 (insert-buffer-substring buffer)))
749 (when (memq (process-status process) '(open run)) 738 (when (memq (process-status process) '(open run))
750 process)))) 739 process))))
751 740
752 (defun imap-network-p (buffer) 741 (defun imap-network-p (buffer)
753 t) 742 t)
762 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug 751 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
763 (goto-char (point-min)) 752 (goto-char (point-min))
764 (not (imap-parse-greeting))) 753 (not (imap-parse-greeting)))
765 (accept-process-output process 1) 754 (accept-process-output process 1)
766 (sit-for 1)) 755 (sit-for 1))
767 (and imap-log 756 (imap-log buffer)
768 (with-current-buffer (get-buffer-create imap-log-buffer)
769 (imap-disable-multibyte)
770 (buffer-disable-undo)
771 (goto-char (point-max))
772 (insert-buffer-substring buffer)))
773 (when (memq (process-status process) '(open run)) 757 (when (memq (process-status process) '(open run))
774 process)))) 758 process))))
775 759
776 (defun imap-shell-p (buffer) 760 (defun imap-shell-p (buffer)
777 nil) 761 nil)
801 (goto-char (point-max)) 785 (goto-char (point-max))
802 (forward-line -1) 786 (forward-line -1)
803 (not (imap-parse-greeting))) 787 (not (imap-parse-greeting)))
804 (accept-process-output process 1) 788 (accept-process-output process 1)
805 (sit-for 1)) 789 (sit-for 1))
806 (and imap-log 790 (imap-log buffer)
807 (with-current-buffer (get-buffer-create imap-log-buffer)
808 (imap-disable-multibyte)
809 (buffer-disable-undo)
810 (goto-char (point-max))
811 (insert-buffer-substring buffer)))
812 (erase-buffer) 791 (erase-buffer)
813 (when (memq (process-status process) '(open run)) 792 (when (memq (process-status process) '(open run))
814 (setq done process))))) 793 (setq done process)))))
815 (if done 794 (if done
816 (progn 795 (progn
843 (goto-char (point-max)) 822 (goto-char (point-max))
844 (forward-line -1) 823 (forward-line -1)
845 (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t))) 824 (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t)))
846 (accept-process-output process 1) 825 (accept-process-output process 1)
847 (sit-for 1)) 826 (sit-for 1))
848 (and imap-log 827 (imap-log buffer)
849 (with-current-buffer (get-buffer-create imap-log-buffer)
850 (buffer-disable-undo)
851 (goto-char (point-max))
852 (insert-buffer-substring buffer)))
853 (when (and (setq tls-info (starttls-negotiate process)) 828 (when (and (setq tls-info (starttls-negotiate process))
854 (memq (process-status process) '(open run))) 829 (memq (process-status process) '(open run)))
855 (setq done process))) 830 (setq done process)))
856 (if (stringp tls-info) 831 (if (stringp tls-info)
857 (message "imap: STARTTLS info: %s" tls-info)) 832 (message "imap: STARTTLS info: %s" tls-info))
1957 (defun imap-add-callback (tag func) 1932 (defun imap-add-callback (tag func)
1958 (setq imap-callbacks (append (list (cons tag func)) imap-callbacks))) 1933 (setq imap-callbacks (append (list (cons tag func)) imap-callbacks)))
1959 1934
1960 (defun imap-send-command-1 (cmdstr) 1935 (defun imap-send-command-1 (cmdstr)
1961 (setq cmdstr (concat cmdstr imap-client-eol)) 1936 (setq cmdstr (concat cmdstr imap-client-eol))
1962 (and imap-log 1937 (imap-log cmdstr)
1963 (with-current-buffer (get-buffer-create imap-log-buffer)
1964 (imap-disable-multibyte)
1965 (buffer-disable-undo)
1966 (goto-char (point-max))
1967 (insert cmdstr)))
1968 (process-send-string imap-process cmdstr)) 1938 (process-send-string imap-process cmdstr))
1969 1939
1970 (defun imap-send-command (command &optional buffer) 1940 (defun imap-send-command (command &optional buffer)
1971 (with-current-buffer (or buffer (current-buffer)) 1941 (with-current-buffer (or buffer (current-buffer))
1972 (if (not (listp command)) (setq command (list command))) 1942 (if (not (listp command)) (setq command (list command)))
2000 (setq command nil) ;; abort command if no cont-req 1970 (setq command nil) ;; abort command if no cont-req
2001 (let ((process imap-process) 1971 (let ((process imap-process)
2002 (stream imap-stream) 1972 (stream imap-stream)
2003 (eol imap-client-eol)) 1973 (eol imap-client-eol))
2004 (with-current-buffer cmd 1974 (with-current-buffer cmd
2005 (and imap-log 1975 (imap-log cmd)
2006 (with-current-buffer (get-buffer-create
2007 imap-log-buffer)
2008 (imap-disable-multibyte)
2009 (buffer-disable-undo)
2010 (goto-char (point-max))
2011 (insert-buffer-substring cmd)))
2012 (process-send-region process (point-min) 1976 (process-send-region process (point-min)
2013 (point-max))) 1977 (point-max)))
2014 (process-send-string process imap-client-eol)))) 1978 (process-send-string process imap-client-eol))))
2015 (setq imap-continuation nil))) 1979 (setq imap-continuation nil)))
2016 ((functionp cmd) 1980 ((functionp cmd)
2082 ;; Better abstain from doing stuff in that case. 2046 ;; Better abstain from doing stuff in that case.
2083 (when (buffer-name (process-buffer proc)) 2047 (when (buffer-name (process-buffer proc))
2084 (with-current-buffer (process-buffer proc) 2048 (with-current-buffer (process-buffer proc)
2085 (goto-char (point-max)) 2049 (goto-char (point-max))
2086 (insert string) 2050 (insert string)
2087 (and imap-log 2051 (imap-log string)
2088 (with-current-buffer (get-buffer-create imap-log-buffer)
2089 (imap-disable-multibyte)
2090 (buffer-disable-undo)
2091 (goto-char (point-max))
2092 (insert string)))
2093 (let (end) 2052 (let (end)
2094 (goto-char (point-min)) 2053 (goto-char (point-min))
2095 (while (setq end (imap-find-next-line)) 2054 (while (setq end (imap-find-next-line))
2096 (save-restriction 2055 (save-restriction
2097 (narrow-to-region (point-min) end) 2056 (narrow-to-region (point-min) end)