Synch to No Gnus 200409231508.

[elisp/gnus.git-] / lisp / pop3.el

diff --git a/lisp/pop3.el b/lisp/pop3.el
index 4885f61..ec3c27b 100644 (file)
--- a/lisp/pop3.el
+++ b/lisp/pop3.el
@@ -1,13 +1,15 @@
 ;;; pop3.el --- Post Office Protocol (RFC 1460) interface
 
 ;;; pop3.el --- Post Office Protocol (RFC 1460) interface
 

-;; Copyright (C) 1996-1999 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
+;;        Free Software Foundation, Inc.

 
 ;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>
 ;;      Daiki Ueno  <ueno@ueda.info.waseda.ac.jp>
 
 ;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>
 ;;      Daiki Ueno  <ueno@ueda.info.waseda.ac.jp>

-;; Keywords: mail, pop3
-;; Version: 1.3s
+;;      Katsumi Yamaoka <yamaoka@jpl.org>
+;; Maintainer: Volunteers
+;; Keywords: mail

 
 

-;; This file is part of GNU Emacs.
+;; This file is part of T-gnus.

 
 ;; GNU Emacs is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
 
 ;; GNU Emacs is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by

@@ -33,12 +35,49 @@
 
 ;; This program was inspired by Kyle E. Jones's vm-pop program.
 
 
 ;; This program was inspired by Kyle E. Jones's vm-pop program.
 

+;;; Gnus:
+
+;; You can use this program for Gnus, without needing any modification.
+;; There are two ways to do that; one is to replace Gnus' pop3.el with
+;; it when installing Gnus; the other is to replace Gnus' pop3.el which
+;; has been installed with this module and byte-compile it.
+
+;; Note: you should not modify the value for the `pop' section of the
+;; `mail-source-keyword-map' variable.
+
+;; This program provides the following features in addition to Gnus:
+
+;; 1. You can use SSL or STARTTLS stream to connect to mail servers.
+;;    For example, specify the `:connection' keyword and the value pair
+;;    in a mail-source as follows:
+;;
+;;(setq mail-sources '((pop :server "pop3.mail.server" :port 995
+;;                       :connection ssl :authentication apop)))
+;;
+;;    For STARTTLS stream, use `tls' isntead of `ssl'.  The default
+;;    connection type is defined by `pop3-connection-type' which
+;;    defaults to nil.
+
+;; 2. You can fetch mails without deleting them in mail servers.  To do
+;;    that, specify the `:leave' keyword with the value t as follows:
+;;
+;;(setq mail-sources '((pop :server "pop3.mail.server" :leave t)))
+;;
+;;    Already read mails are registered into the ~/.uidls-SERVER file
+;;    (which is the default, see `pop3-uidl-file-name'), and you will
+;;    never need to fetch them twice.  The default value for the
+;;    `:leave' keyword is specified by the `pop3-leave-mail-on-server'
+;;    variable.  You have no need to modify that value normally.
+
+;; 3. See the source code for some other miscellaneous extended features.
+

 ;;; Code:
 
 ;;; Code:
 

-(eval-when-compile (require 'cl))
-(require 'mail-utils)
+(eval-when-compile
+  (require 'cl))

 
 

-(defconst pop3-version "1.3s")
+(require 'mail-utils)
+(require 'nnheader)

 
 (defvar pop3-maildrop (or (user-login-name) (getenv "LOGNAME") (getenv "USER") nil)
   "*POP3 maildrop.")
 
 (defvar pop3-maildrop (or (user-login-name) (getenv "LOGNAME") (getenv "USER") nil)
   "*POP3 maildrop.")

@@ -75,9 +114,9 @@ Used for APOP authentication.")
 (defvar pop3-uidl-file-name "~/.uidls"
   "File in which to store the UIDL of processed messages.")
 
 (defvar pop3-uidl-file-name "~/.uidls"
   "File in which to store the UIDL of processed messages.")
 

-(defvar pop3-uidl-support 'dont-know
-  "Whether the server supports UIDL.
-Nil means no, t means yes, not-nil-or-t means yet to be determined.")
+(defvar pop3-uidl-support nil
+  "Alist of servers and flags of whether they support UIDLs.
+Users don't have to set this value.")

 
 (defvar pop3-uidl-obarray (make-vector 31 0)
   "Uidl hash table.")
 
 (defvar pop3-uidl-obarray (make-vector 31 0)
   "Uidl hash table.")

@@ -86,12 +125,17 @@ Nil means no, t means yes, not-nil-or-t means yet to be determined.")
 (defvar pop3-debug nil)
 
 (eval-and-compile
 (defvar pop3-debug nil)
 
 (eval-and-compile

-  (autoload 'open-ssl-stream "ssl")

   (autoload 'starttls-open-stream "starttls")
   (autoload 'starttls-negotiate "starttls"))
 
   (autoload 'starttls-open-stream "starttls")
   (autoload 'starttls-negotiate "starttls"))
 

+(defvar pop3-ssl-program-name
+  (if (executable-find "openssl")
+      "openssl"
+    "ssleay")
+  "The program to run in a subprocess to open an SSL connection.")
+

 (defvar pop3-ssl-program-arguments
 (defvar pop3-ssl-program-arguments

-  '("-quiet")
+  '("s_client" "-quiet")

   "Arguments to be passed to the program `pop3-ssl-program-name'.")
 
 (defun pop3-progress-message (format percent &rest args)
   "Arguments to be passed to the program `pop3-ssl-program-name'.")
 
 (defun pop3-progress-message (format percent &rest args)

@@ -103,18 +147,18 @@ Nil means no, t means yes, not-nil-or-t means yet to be determined.")
   (let* ((process (pop3-open-server pop3-mailhost pop3-port))
         (crashbuf (get-buffer-create " *pop3-retr*"))
         (n 1)
   (let* ((process (pop3-open-server pop3-mailhost pop3-port))
         (crashbuf (get-buffer-create " *pop3-retr*"))
         (n 1)

+        message-count

         (pop3-password pop3-password)
         (pop3-password pop3-password)

-        (pop3-uidl-file-name
-         (convert-standard-filename
-          (concat pop3-uidl-file-name "-" pop3-mailhost)))
-        (retrieved-messages nil)
-        messages message-count)
+        (pop3-uidl-file-name (convert-standard-filename
+                              (concat pop3-uidl-file-name "-"
+                                      pop3-mailhost)))
+        retrieved-messages messages)

     ;; for debugging only
     (if pop3-debug (switch-to-buffer (process-buffer process)))
     ;; query for password
     (if (and pop3-password-required (not pop3-password))
        (setq pop3-password
     ;; for debugging only
     (if pop3-debug (switch-to-buffer (process-buffer process)))
     ;; query for password
     (if (and pop3-password-required (not pop3-password))
        (setq pop3-password

-             (pop3-read-passwd (format "Password for %s: " pop3-maildrop))))
+             (read-passwd (format "Password for %s: " pop3-maildrop))))

     (cond ((equal 'apop pop3-authentication-scheme)
           (pop3-apop process pop3-maildrop))
          ((equal 'pass pop3-authentication-scheme)
     (cond ((equal 'apop pop3-authentication-scheme)
           (pop3-apop process pop3-maildrop))
          ((equal 'pass pop3-authentication-scheme)

@@ -125,8 +169,8 @@ Nil means no, t means yes, not-nil-or-t means yet to be determined.")
     (message "Retrieving message list...")
     (setq messages (pop3-get-message-numbers process)
          message-count (length (cdr messages)))
     (message "Retrieving message list...")
     (setq messages (pop3-get-message-numbers process)
          message-count (length (cdr messages)))

-    (message (format "Retrieving message list...%d of %d unread"
-                    message-count (pop messages)))
+    (message "Retrieving message list...%d of %d unread"
+            message-count (pop messages))

     (unwind-protect
        (unless (not (stringp crashbox))
          (while messages
     (unwind-protect
        (unless (not (stringp crashbox))
          (while messages

@@ -139,62 +183,94 @@ Nil means no, t means yes, not-nil-or-t means yet to be determined.")
            (setq messages (cdr messages)
                  n (1+ n)))
          (with-current-buffer crashbuf
            (setq messages (cdr messages)
                  n (1+ n)))
          (with-current-buffer crashbuf

-           (write-region-as-binary (point-min) (point-max)
-                                   crashbox 'append 'nomesg))
+           (let ((coding-system-for-write 'binary)
+                 jka-compr-compression-info-list jam-zcat-filename-list)
+             (write-region (point-min) (point-max)
+                           crashbox 'append 'nomesg)))

          ;; mark messages as read
          (when pop3-leave-mail-on-server
            (pop3-save-uidls))
          ;; now delete the messages we have retrieved
          (unless pop3-leave-mail-on-server
            (dolist (n retrieved-messages)
          ;; mark messages as read
          (when pop3-leave-mail-on-server
            (pop3-save-uidls))
          ;; now delete the messages we have retrieved
          (unless pop3-leave-mail-on-server
            (dolist (n retrieved-messages)

-             (message (format "Deleting message %d of %d from %s..."
-                              n message-count pop3-mailhost))
+             (message "Deleting message %d of %d from %s..."
+                      n message-count pop3-mailhost)

              (pop3-dele process n)))
          )
       (pop3-quit process))
     (kill-buffer crashbuf)
     message-count))
 
              (pop3-dele process n)))
          )
       (pop3-quit process))
     (kill-buffer crashbuf)
     message-count))
 

+(defun pop3-get-message-count ()
+  "Return the number of messages in the maildrop."
+  (let* ((process (pop3-open-server pop3-mailhost pop3-port))
+        message-count
+        (pop3-password pop3-password)
+        )
+    ;; for debugging only
+    (if pop3-debug (switch-to-buffer (process-buffer process)))
+    ;; query for password
+    (if (and pop3-password-required (not pop3-password))
+       (setq pop3-password
+             (read-passwd (format "Password for %s: " pop3-maildrop))))
+    (cond ((equal 'apop pop3-authentication-scheme)
+          (pop3-apop process pop3-maildrop))
+         ((equal 'pass pop3-authentication-scheme)
+          (pop3-user process pop3-maildrop)
+          (pop3-pass process))
+         (t (error "Invalid POP3 authentication scheme")))
+    (setq message-count (car (pop3-stat process)))
+    (pop3-quit process)
+    message-count))
+

 (defun pop3-open-server (mailhost port)
 (defun pop3-open-server (mailhost port)

-  "Open TCP connection to MAILHOST.
+  "Open TCP connection to MAILHOST on PORT.

 Returns the process associated with the connection.
 Argument PORT specifies connecting port."
 Returns the process associated with the connection.
 Argument PORT specifies connecting port."

-  (let ((process-buffer
-        (get-buffer-create (format "trace of POP session to %s" mailhost)))
-       (process))
+  (let (process)

     (save-excursion
     (save-excursion

-      (set-buffer process-buffer)
-      (erase-buffer))
-    (setq
-     process
-     (cond
-      ((eq pop3-connection-type 'ssl)
-       (pop3-open-ssl-stream "POP" process-buffer mailhost port))
-      ((eq pop3-connection-type 'tls)
-       (pop3-open-tls-stream "POP" process-buffer mailhost port))
-      (t
-       (open-network-stream-as-binary "POP" process-buffer mailhost port))))
-    (setq pop3-read-point (point-min))
-    (let ((response (pop3-read-response process t)))
-      (setq pop3-timestamp
-           (substring response (or (string-match "<" response) 0)
-                      (+ 1 (or (string-match ">" response) -1)))))
-    process))
+      (set-buffer (get-buffer-create (concat " trace of POP session to "
+                                            mailhost)))
+      (erase-buffer)
+      (setq pop3-read-point (point-min))
+      (setq
+       process
+       (cond
+       ((eq pop3-connection-type 'ssl)
+        (pop3-open-ssl-stream "POP" (current-buffer) mailhost port))
+       ((eq pop3-connection-type 'tls)
+        (pop3-open-tls-stream "POP" (current-buffer) mailhost port))
+       (t
+        (let ((coding-system-for-read 'binary)
+              (coding-system-for-write 'binary))
+          (open-network-stream "POP" (current-buffer) mailhost port)))))
+      (let ((response (pop3-read-response process t)))
+       (setq pop3-timestamp
+             (substring response (or (string-match "<" response) 0)
+                        (+ 1 (or (string-match ">" response) -1)))))
+      process)))
+
+(eval-when-compile
+  (autoload 'open-ssl-stream "ssl"))

 
 (defun pop3-open-ssl-stream-1 (name buffer host service extra-arg)
 
 (defun pop3-open-ssl-stream-1 (name buffer host service extra-arg)

-  (let* ((ssl-program-arguments
-         `(,@pop3-ssl-program-arguments ,extra-arg
+  (require 'ssl)
+  (let* ((ssl-program-name
+         pop3-ssl-program-name)
+        (ssl-program-arguments
+         `(,@pop3-ssl-program-arguments
+           ,extra-arg

            "-connect" ,(format "%s:%d" host service)))
            "-connect" ,(format "%s:%d" host service)))

-         (process (open-ssl-stream name buffer host service)))
+        (process (open-ssl-stream name buffer host service)))

     (when process
       (with-current-buffer buffer
        (goto-char (point-min))
        (while (and (memq (process-status process) '(open run))
     (when process
       (with-current-buffer buffer
        (goto-char (point-min))
        (while (and (memq (process-status process) '(open run))

-                    (goto-char (point-max))
-                    (forward-line -1)
-                    (not (looking-at "+OK")))
-          (accept-process-output process 1)
-          (sit-for 1))
+                   (goto-char (point-max))
+                   (forward-line -1)
+                   (not (looking-at "+OK")))
+         (nnheader-accept-process-output process)
+         (sit-for 1))

        (delete-region (point-min) (point)))
       (and process (memq (process-status process) '(open run))
           process))))
        (delete-region (point-min) (point)))
       (and process (memq (process-status process) '(open run))
           process))))

@@ -203,17 +279,20 @@ Argument PORT specifies connecting port."
   "Open a SSL connection for a service to a host.
 Returns a subprocess-object to represent the connection.
 Args are NAME BUFFER HOST SERVICE."
   "Open a SSL connection for a service to a host.
 Returns a subprocess-object to represent the connection.
 Args are NAME BUFFER HOST SERVICE."

-  (as-binary-process
-   (or (pop3-open-ssl-stream-1 name buffer host service "-ssl3")
-       (pop3-open-ssl-stream-1 name buffer host service "-ssl2"))))
+  (let (selective-display ;; Disable ^M to nl translation.
+       (coding-system-for-read 'binary)
+       (coding-system-for-write 'binary))
+    (or (pop3-open-ssl-stream-1 name buffer host service "-ssl3")
+       (pop3-open-ssl-stream-1 name buffer host service "-ssl2"))))

 
 (defun pop3-open-tls-stream (name buffer host service)
   "Open a TLSv1 connection for a service to a host.
 Returns a subprocess-object to represent the connection.
 Args are NAME BUFFER HOST SERVICE."
 
 (defun pop3-open-tls-stream (name buffer host service)
   "Open a TLSv1 connection for a service to a host.
 Returns a subprocess-object to represent the connection.
 Args are NAME BUFFER HOST SERVICE."

-  (let ((process
-        (as-binary-process (starttls-open-stream
-                            name buffer host service))))
+  (let* (selective-display ;; Disable ^M to nl translation.
+        (coding-system-for-read 'binary)
+        (coding-system-for-write 'binary)
+        (process (starttls-open-stream name buffer host service)))

     (pop3-stls process)
     (starttls-negotiate process)
     process))
     (pop3-stls process)
     (starttls-negotiate process)
     process))

@@ -227,15 +306,15 @@ Args are NAME BUFFER HOST SERVICE."
     (insert output)))
 
 (defun pop3-send-command (process command)
     (insert output)))
 
 (defun pop3-send-command (process command)

-    (set-buffer (process-buffer process))
-    (goto-char (point-max))
-;;    (if (= (aref command 0) ?P)
-;;     (insert "PASS <omitted>\r\n")
-;;      (insert command "\r\n"))
-    (setq pop3-read-point (point))
-    (goto-char (point-max))
-    (process-send-string process (concat command "\r\n"))
-    )
+  (set-buffer (process-buffer process))
+  (goto-char (point-max))
+;;  (if (= (aref command 0) ?P)
+;;      (insert "PASS <omitted>\r\n")
+;;    (insert command "\r\n"))
+  (setq pop3-read-point (point))
+  (goto-char (point-max))
+  (process-send-string process (concat command "\r\n"))
+  )

 
 (defun pop3-read-response (process &optional return)
   "Read the response from the server PROCESS.
 
 (defun pop3-read-response (process &optional return)
   "Read the response from the server PROCESS.

@@ -245,13 +324,14 @@ Return the response string if optional second argument RETURN is non-nil."
     (save-excursion
       (set-buffer (process-buffer process))
       (goto-char pop3-read-point)
     (save-excursion
       (set-buffer (process-buffer process))
       (goto-char pop3-read-point)

-      (while (not (search-forward "\r\n" nil t))
-       (accept-process-output process 3)
+      (while (and (memq (process-status process) '(open run))
+                 (not (search-forward "\r\n" nil t)))
+       (nnheader-accept-process-output process)

        (goto-char pop3-read-point))
       (setq match-end (point))
       (goto-char pop3-read-point)
       (if (looking-at "-ERR")
        (goto-char pop3-read-point))
       (setq match-end (point))
       (goto-char pop3-read-point)
       (if (looking-at "-ERR")

-         (signal 'error (list (buffer-substring (point) (- match-end 2))))
+         (error (buffer-substring (point) (- match-end 2)))

        (if (not (looking-at "+OK"))
            (progn (setq pop3-read-point match-end) nil)
          (setq pop3-read-point match-end)
        (if (not (looking-at "+OK"))
            (progn (setq pop3-read-point match-end) nil)
          (setq pop3-read-point match-end)

@@ -260,17 +340,6 @@ Return the response string if optional second argument RETURN is non-nil."
            t)
          )))))
 
            t)
          )))))
 

-(defvar pop3-read-passwd nil)
-(defun pop3-read-passwd (prompt)
-  (if (not pop3-read-passwd)
-      (if (functionp '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))
-

 (defun pop3-clean-region (start end)
   (setq end (set-marker (make-marker) end))
   (save-excursion
 (defun pop3-clean-region (start end)
   (setq end (set-marker (make-marker) end))
   (save-excursion

@@ -286,10 +355,31 @@ Return the response string if optional second argument RETURN is non-nil."
       (forward-char)))
   (set-marker end nil))
 
       (forward-char)))
   (set-marker end nil))
 

+(eval-when-compile (defvar parse-time-months))
+
+;; Copied from message-make-date.
+(defun pop3-make-date (&optional now)
+  "Make a valid date header.
+If NOW, use that time instead."
+  (require 'parse-time)
+  (let* ((now (or now (current-time)))
+        (zone (nth 8 (decode-time now)))
+        (sign "+"))
+    (when (< zone 0)
+      (setq sign "-")
+      (setq zone (- zone)))
+    (concat
+     (format-time-string "%d" now)
+     ;; The month name of the %b spec is locale-specific.  Pfff.
+     (format " %s "
+            (capitalize (car (rassoc (nth 4 (decode-time now))
+                                     parse-time-months))))
+     (format-time-string "%Y %H:%M:%S " now)
+     ;; We do all of this because XEmacs doesn't have the %z spec.
+     (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60)))))
+

 (defun pop3-munge-message-separator (start end)
   "Check to see if a message separator exists.  If not, generate one."
 (defun pop3-munge-message-separator (start end)
   "Check to see if a message separator exists.  If not, generate one."

-  (if (not (fboundp 'parse-time-string))
-      (autoload 'parse-time-string "parse-time"))

   (save-excursion
     (save-restriction
       (narrow-to-region start end)
   (save-excursion
     (save-restriction
       (narrow-to-region start end)

@@ -298,27 +388,50 @@ Return the response string if optional second argument RETURN is non-nil."
                   (looking-at "\001\001\001\001\n") ; MMDF
                   (looking-at "BABYL OPTIONS:") ; Babyl
                   ))
                   (looking-at "\001\001\001\001\n") ; MMDF
                   (looking-at "BABYL OPTIONS:") ; Babyl
                   ))

-         (let ((from (mail-strip-quoted-names (mail-fetch-field "From")))
-               (date (mail-fetch-field "Date"))
-               (From_))
+         (let* ((from (mail-strip-quoted-names (mail-fetch-field "From")))
+                (tdate (mail-fetch-field "Date"))
+                (date (split-string (or (and tdate
+                                             (not (string= "" tdate))
+                                             tdate)
+                                        (pop3-make-date))
+                                    " "))
+                (From_))

            ;; sample date formats I have seen
            ;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT)
            ;; Date: 08 Jul 1996 23:22:24 -0400
            ;; should be
            ;; Tue Jul 9 09:04:21 1996
            ;; sample date formats I have seen
            ;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT)
            ;; Date: 08 Jul 1996 23:22:24 -0400
            ;; should be
            ;; Tue Jul 9 09:04:21 1996

-           (setq date (format-time-string
-                       "%a %b %e %T %Y"
-                       (if date
-                           (condition-case nil
-                               (apply 'encode-time (parse-time-string date))
-                             (error (current-time)))
-                         (current-time))))
+           (setq date
+                 (cond ((not date)
+                        "Tue Jan 1 00:00:0 1900")
+                       ((string-match "[A-Z]" (nth 0 date))
+                        (format "%s %s %s %s %s"
+                                (nth 0 date) (nth 2 date) (nth 1 date)
+                                (nth 4 date) (nth 3 date)))
+                       (t
+                        ;; this really needs to be better but I don't feel
+                        ;; like writing a date to day converter.
+                        (format "Sun %s %s %s %s"
+                                (nth 1 date) (nth 0 date)
+                                (nth 3 date) (nth 2 date)))
+                       ))

            (setq From_ (format "\nFrom %s  %s\n" from date))
            (while (string-match "," From_)
              (setq From_ (concat (substring From_ 0 (match-beginning 0))
                                  (substring From_ (match-end 0)))))
            (goto-char (point-min))
            (setq From_ (format "\nFrom %s  %s\n" from date))
            (while (string-match "," From_)
              (setq From_ (concat (substring From_ 0 (match-beginning 0))
                                  (substring From_ (match-end 0)))))
            (goto-char (point-min))

-           (insert From_))))))
+           (insert From_)
+           (if (search-forward "\n\n" nil t)
+               nil
+             (goto-char (point-max))
+             (insert "\n"))
+           (narrow-to-region (point) (point-max))
+           (let ((size (- (point-max) (point-min))))
+             (goto-char (point-min))
+             (widen)
+             (forward-line -1)
+             (insert (format "Content-Length: %s\n" size)))
+           )))))

 
 ;; UIDL support
 
 
 ;; UIDL support
 

@@ -336,7 +449,8 @@ Return the response string if optional second argument RETURN is non-nil."
       ;; only retrieve messages matching our regexp or in the uidl list
       (when (and
             ;; remove elements not in the uidl, this assumes the uidl is short
       ;; only retrieve messages matching our regexp or in the uidl list
       (when (and
             ;; remove elements not in the uidl, this assumes the uidl is short

-            (or (not (eq pop3-uidl-support t))
+            (or (not (and pop3-leave-mail-on-server
+                          (cdr (assoc pop3-mailhost pop3-uidl-support))))

                 (memq (caar messages) uidl))
             (caar messages)
             ;; don't download messages that are too large
                 (memq (caar messages) uidl))
             (caar messages)
             ;; don't download messages that are too large

@@ -347,14 +461,18 @@ Return the response string if optional second argument RETURN is non-nil."
                                     (pop3-top process (caar messages) 0)))))
        (push (car messages) out))
       (setq messages (cdr messages)))
                                     (pop3-top process (caar messages) 0)))))
        (push (car messages) out))
       (setq messages (cdr messages)))

-    (cons total (reverse out))))
+    (cons total (nreverse out))))

 
 (defun pop3-get-uidl (process)
   "Use PROCESS to get a list of unread message numbers."
 
 (defun pop3-get-uidl (process)
   "Use PROCESS to get a list of unread message numbers."

-  (let ((messages (pop3-uidl process)) uidl)
-    (if (or (null messages) (null pop3-uidl-support))
-       (setq pop3-uidl-support nil)
-      (setq pop3-uidl-support t)
+  (let ((messages (pop3-uidl process))
+       (support (assoc pop3-mailhost pop3-uidl-support))
+       uidl)
+    (if support
+       (setcdr support (and messages t))
+      (push (cons pop3-mailhost (and messages t))
+           pop3-uidl-support))
+    (when messages

       (save-excursion
        (with-temp-buffer
          (when (file-readable-p pop3-uidl-file-name)
       (save-excursion
        (with-temp-buffer
          (when (file-readable-p pop3-uidl-file-name)

@@ -363,15 +481,13 @@ Return the response string if optional second argument RETURN is non-nil."
          (while (looking-at "\\([^ \n\t]+\\)")
            (set (intern (match-string 1) pop3-uidl-obarray)
                 (cons nil t))
          (while (looking-at "\\([^ \n\t]+\\)")
            (set (intern (match-string 1) pop3-uidl-obarray)
                 (cons nil t))

-           (forward-line 1))
-         ))
+           (forward-line 1))))

       (dolist (message (cdr messages))
        (if (setq uidl (intern-soft (cdr message) pop3-uidl-obarray))
            (setcar (symbol-value uidl) (car message))
          (set (intern (cdr message) pop3-uidl-obarray)
               (cons (car message) nil))))
       (dolist (message (cdr messages))
        (if (setq uidl (intern-soft (cdr message) pop3-uidl-obarray))
            (setcar (symbol-value uidl) (car message))
          (set (intern (cdr message) pop3-uidl-obarray)
               (cons (car message) nil))))

-      (pop3-get-unread-message-numbers))
-    ))
+      (pop3-get-unread-message-numbers))))

 
 (defun pop3-get-unread-message-numbers ()
   "Return a sorted list of unread msg numbers to retrieve."
 
 (defun pop3-get-unread-message-numbers ()
   "Return a sorted list of unread msg numbers to retrieve."

@@ -401,8 +517,9 @@ Return the response string if optional second argument RETURN is non-nil."
         (lambda (atom)
           (when (car (symbol-value atom))
             (insert (format "%s\n" atom))))
         (lambda (atom)
           (when (car (symbol-value atom))
             (insert (format "%s\n" atom))))

-        pop3-uidl-obarray)))))
-    
+        pop3-uidl-obarray)))
+    (fillarray pop3-uidl-obarray 0)))
+

 
 ;; The Command Set
 
 
 ;; The Command Set
 

@@ -413,7 +530,7 @@ Return the response string if optional second argument RETURN is non-nil."
   (pop3-send-command process (format "USER %s" user))
   (let ((response (pop3-read-response process t)))
     (if (not (and response (string-match "+OK" response)))
   (pop3-send-command process (format "USER %s" user))
   (let ((response (pop3-read-response process t)))
     (if (not (and response (string-match "+OK" response)))

-       (error (format "USER %s not valid." user)))))
+       (error (format "USER %s not valid" user)))))

 
 (defun pop3-pass (process)
   "Send authentication information to the server."
 
 (defun pop3-pass (process)
   "Send authentication information to the server."

@@ -422,15 +539,21 @@ Return the response string if optional second argument RETURN is non-nil."
     (if (not (and response (string-match "+OK" response)))
        (pop3-quit process))))
 
     (if (not (and response (string-match "+OK" response)))
        (pop3-quit process))))
 

-(autoload 'md5 "md5")
-

 (defun pop3-apop (process user)
   "Send alternate authentication information to the server."
 (defun pop3-apop (process user)
   "Send alternate authentication information to the server."

-  (let ((hash (md5 (concat pop3-timestamp pop3-password))))
-    (pop3-send-command process (format "APOP %s %s" user hash))
-    (let ((response (pop3-read-response process t)))
-      (if (not (and response (string-match "+OK" response)))
-         (pop3-quit process)))))
+  (let ((pass pop3-password))
+    (if (and pop3-password-required (not pass))
+       (setq pass
+             (read-passwd (format "Password for %s: " pop3-maildrop))))
+    (if pass
+       ;; Note that `md5' should never encode a given string to use for
+       ;; the apop authentication, so we should specify `binary'.
+       (let ((hash (md5 (concat pop3-timestamp pass) nil nil 'binary)))
+         (pop3-send-command process (format "APOP %s %s" user hash))
+         (let ((response (pop3-read-response process t)))
+           (if (not (and response (string-match "+OK" response)))
+               (pop3-quit process)))))
+    ))

 
 (defun pop3-stls (process)
   "Query whether TLS extension is supported"
 
 (defun pop3-stls (process)
   "Query whether TLS extension is supported"

@@ -445,8 +568,8 @@ Return the response string if optional second argument RETURN is non-nil."
   "Return the number of messages in the maildrop and the maildrop's size."
   (pop3-send-command process "STAT")
   (let ((response (pop3-read-response process t)))
   "Return the number of messages in the maildrop and the maildrop's size."
   (pop3-send-command process "STAT")
   (let ((response (pop3-read-response process t)))

-    (list (string-to-int (nth 1 (split-string response)))
-         (string-to-int (nth 2 (split-string response))))
+    (list (string-to-int (nth 1 (split-string response " ")))
+         (string-to-int (nth 2 (split-string response " "))))

     ))
 
 (defun pop3-retr (process msg crashbuf)
     ))
 
 (defun pop3-retr (process msg crashbuf)

@@ -474,7 +597,7 @@ Return the response string if optional second argument RETURN is non-nil."
   "Return highest accessed message-id number for the session."
   (pop3-send-command process "LAST")
   (let ((response (pop3-read-response process t)))
   "Return highest accessed message-id number for the session."
   (pop3-send-command process "LAST")
   (let ((response (pop3-read-response process t)))

-    (string-to-int (nth 1 (split-string response)))
+    (string-to-int (nth 1 (split-string response " ")))

     ))
 
 (defun pop3-rset (process)
     ))
 
 (defun pop3-rset (process)

@@ -494,14 +617,7 @@ and close the connection."
     (save-excursion
       (set-buffer (process-buffer process))
       (goto-char (point-max))
     (save-excursion
       (set-buffer (process-buffer process))
       (goto-char (point-max))

-      (delete-process process)
-      ))
-  (when pop3-leave-mail-on-server
-    (mapatoms
-     (lambda (atom)
-       (when (car (symbol-value atom))
-        (unintern atom pop3-uidl-obarray)))
-     pop3-uidl-obarray)))
+      (delete-process process))))

 
 (defun pop3-uidl (process &optional msgno)
   "Return the results of a UIDL command in PROCESS for optional MSGNO.
 
 (defun pop3-uidl (process &optional msgno)
   "Return the results of a UIDL command in PROCESS for optional MSGNO.

@@ -518,7 +634,7 @@ where
   (if msgno
       (pop3-send-command process (format "UIDL %d" msgno))
     (pop3-send-command process "UIDL"))
   (if msgno
       (pop3-send-command process (format "UIDL %d" msgno))
     (pop3-send-command process "UIDL"))

-  
+

   (if (null (pop3-read-response process t))
       nil ;; UIDL is not supported on this server
     (let (pairs uidl)
   (if (null (pop3-read-response process t))
       nil ;; UIDL is not supported on this server
     (let (pairs uidl)

@@ -582,7 +698,8 @@ If msgno is invalid, return nil.  Otherwise, return a string."
     (set-buffer (process-buffer process))
     (goto-char start)
     (while (not (re-search-forward "^\\.\r\n" nil t))
     (set-buffer (process-buffer process))
     (goto-char start)
     (while (not (re-search-forward "^\\.\r\n" nil t))

-      (accept-process-output process 3)
+      ;; Fixme: Shouldn't depend on nnheader.
+      (nnheader-accept-process-output process)

       (goto-char start))
     (setq pop3-read-point (point-marker))
     (goto-char (match-beginning 0))
       (goto-char start))
     (setq pop3-read-point (point-marker))
     (goto-char (match-beginning 0))

@@ -590,6 +707,23 @@ If msgno is invalid, return nil.  Otherwise, return a string."
     (pop3-clean-region start end)
     (list start end)))
 
     (pop3-clean-region start end)
     (list start end)))
 

+;;; Advise the mail-source function in order to use this module in Gnus.
+
+(eval-after-load "mail-source"
+  '(if (member '(:connection)
+              (assq 'pop (symbol-value 'mail-source-keyword-map)))
+       nil ;; T-gnus is running.
+     (defadvice mail-source-fetch-pop (around bind-t-gnus-keywords activate)
+       "Bind `pop3-connection-type' and `pop3-leave-mail-on-server' according
+to `mail-sources' while fetching mails with Gnus."
+       (let ((pop3-connection-type (or (plist-get (cdr (ad-get-arg 0))
+                                                 :connection)
+                                      pop3-connection-type))
+            (pop3-leave-mail-on-server (or (plist-get (cdr (ad-get-arg 0))
+                                                      :leave)
+                                           pop3-leave-mail-on-server)))
+        ad-do-it))))
+

 \f
 ;; Summary of POP3 (Post Office Protocol version 3) commands and responses
 
 \f
 ;; Summary of POP3 (Post Office Protocol version 3) commands and responses