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

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

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

revision 1.22 by miles, Mon Sep 1 15:45:25 2003 UTC revision 1.22.2.1 by schwab, Thu Jul 22 16:45:51 2004 UTC
# Line 1  Line 1 
1  ;;; pop3.el --- Post Office Protocol (RFC 1460) interface  ;;; pop3.el --- Post Office Protocol (RFC 1460) interface
2    
3  ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002  ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
4  ;;        Free Software Foundation, Inc.  ;;        Free Software Foundation, Inc.
5    
6  ;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>  ;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>
# Line 54  Line 54 
54  Defaults to 'pass, for the standard USER/PASS authentication.  Other valid  Defaults to 'pass, for the standard USER/PASS authentication.  Other valid
55  values are 'apop.")  values are 'apop.")
56    
 (defvar pop3-leave-mail-on-server nil  
   "*Non-nil if the mail is to be left on the POP server after fetching.")  
   
57  (defvar pop3-timestamp nil  (defvar pop3-timestamp nil
58    "Timestamp returned when initially connected to the POP server.    "Timestamp returned when initially connected to the POP server.
59  Used for APOP authentication.")  Used for APOP authentication.")
# Line 78  Used for APOP authentication.") Line 75  Used for APOP authentication.")
75      ;; query for password      ;; query for password
76      (if (and pop3-password-required (not pop3-password))      (if (and pop3-password-required (not pop3-password))
77          (setq pop3-password          (setq pop3-password
78                (pop3-read-passwd (format "Password for %s: " pop3-maildrop))))                (read-passwd (format "Password for %s: " pop3-maildrop))))
79      (cond ((equal 'apop pop3-authentication-scheme)      (cond ((equal 'apop pop3-authentication-scheme)
80             (pop3-apop process pop3-maildrop))             (pop3-apop process pop3-maildrop))
81            ((equal 'pass pop3-authentication-scheme)            ((equal 'pass pop3-authentication-scheme)
# Line 88  Used for APOP authentication.") Line 85  Used for APOP authentication.")
85      (setq message-count (car (pop3-stat process)))      (setq message-count (car (pop3-stat process)))
86      (unwind-protect      (unwind-protect
87          (while (<= n message-count)          (while (<= n message-count)
88            (message (format "Retrieving message %d of %d from %s..."            (message "Retrieving message %d of %d from %s..."
89                             n message-count pop3-mailhost))                     n message-count pop3-mailhost)
90            (pop3-retr process n crashbuf)            (pop3-retr process n crashbuf)
91            (save-excursion            (save-excursion
92              (set-buffer crashbuf)              (set-buffer crashbuf)
# Line 100  Used for APOP authentication.") Line 97  Used for APOP authentication.")
97                (goto-char (point-min))                (goto-char (point-min))
98                (forward-line 50)                (forward-line 50)
99                (delete-region (point-min) (point))))                (delete-region (point-min) (point))))
100            (unless pop3-leave-mail-on-server            (pop3-dele process n)
             (pop3-dele process n))  
101            (setq n (+ 1 n))            (setq n (+ 1 n))
102            (if pop3-debug (sit-for 1) (sit-for 0.1))            (if pop3-debug (sit-for 1) (sit-for 0.1))
103            )            )
# Line 121  Used for APOP authentication.") Line 117  Used for APOP authentication.")
117      ;; query for password      ;; query for password
118      (if (and pop3-password-required (not pop3-password))      (if (and pop3-password-required (not pop3-password))
119          (setq pop3-password          (setq pop3-password
120                (pop3-read-passwd (format "Password for %s: " pop3-maildrop))))                (read-passwd (format "Password for %s: " pop3-maildrop))))
121      (cond ((equal 'apop pop3-authentication-scheme)      (cond ((equal 'apop pop3-authentication-scheme)
122             (pop3-apop process pop3-maildrop))             (pop3-apop process pop3-maildrop))
123            ((equal 'pass pop3-authentication-scheme)            ((equal 'pass pop3-authentication-scheme)
# Line 177  Return the response string if optional s Line 173  Return the response string if optional s
173      (save-excursion      (save-excursion
174        (set-buffer (process-buffer process))        (set-buffer (process-buffer process))
175        (goto-char pop3-read-point)        (goto-char pop3-read-point)
176        (while (not (search-forward "\r\n" nil t))        (while (and (memq (process-status process) '(open run))
177          (accept-process-output process 3)                    (not (search-forward "\r\n" nil t)))
178            (nnheader-accept-process-output process)
179          (goto-char pop3-read-point))          (goto-char pop3-read-point))
180        (setq match-end (point))        (setq match-end (point))
181        (goto-char pop3-read-point)        (goto-char pop3-read-point)
# Line 192  Return the response string if optional s Line 189  Return the response string if optional s
189              t)              t)
190            )))))            )))))
191    
 (defvar pop3-read-passwd nil)  
 (defun pop3-read-passwd (prompt)  
   (if (not pop3-read-passwd)  
       (if (fboundp 'read-passwd)  
           (setq pop3-read-passwd 'read-passwd)  
         (if (load "passwd" t)  
             (setq pop3-read-passwd 'read-passwd)  
           (autoload 'ange-ftp-read-passwd "ange-ftp")  
           (setq pop3-read-passwd 'ange-ftp-read-passwd))))  
   (funcall pop3-read-passwd prompt))  
   
192  (defun pop3-clean-region (start end)  (defun pop3-clean-region (start end)
193    (setq end (set-marker (make-marker) end))    (setq end (set-marker (make-marker) end))
194    (save-excursion    (save-excursion
# Line 263  If NOW, use that time instead." Line 249  If NOW, use that time instead."
249              ;; Tue Jul 9 09:04:21 1996              ;; Tue Jul 9 09:04:21 1996
250              (setq date              (setq date
251                    (cond ((not date)                    (cond ((not date)
252                          "Tue Jan 1 00:00:0 1900")                           "Tue Jan 1 00:00:0 1900")
253                          ((string-match "[A-Z]" (nth 0 date))                          ((string-match "[A-Z]" (nth 0 date))
254                           (format "%s %s %s %s %s"                           (format "%s %s %s %s %s"
255                                   (nth 0 date) (nth 2 date) (nth 1 date)                                   (nth 0 date) (nth 2 date) (nth 1 date)
# Line 316  If NOW, use that time instead." Line 302  If NOW, use that time instead."
302    (let ((pass pop3-password))    (let ((pass pop3-password))
303      (if (and pop3-password-required (not pass))      (if (and pop3-password-required (not pass))
304          (setq pass          (setq pass
305                (pop3-read-passwd (format "Password for %s: " pop3-maildrop))))                (read-passwd (format "Password for %s: " pop3-maildrop))))
306      (if pass      (if pass
307          (let ((hash (pop3-md5 (concat pop3-timestamp pass))))          (let ((hash (pop3-md5 (concat pop3-timestamp pass))))
308            (pop3-send-command process (format "APOP %s %s" user hash))            (pop3-send-command process (format "APOP %s %s" user hash))
# Line 363  This function currently does nothing.") Line 349  This function currently does nothing.")
349      (save-excursion      (save-excursion
350        (set-buffer (process-buffer process))        (set-buffer (process-buffer process))
351        (while (not (re-search-forward "^\\.\r\n" nil t))        (while (not (re-search-forward "^\\.\r\n" nil t))
352          (accept-process-output process 3)          ;; Fixme: Shouldn't depend on nnheader.
353            (nnheader-accept-process-output process)
354          ;; bill@att.com ... to save wear and tear on the heap          ;; bill@att.com ... to save wear and tear on the heap
355          ;; uncommented because the condensed version below is a problem for          ;; uncommented because the condensed version below is a problem for
356          ;; some.          ;; some.

Legend:
Removed from v.1.22  
changed lines
  Added in v.1.22.2.1

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