X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fpop3.el;h=b5441599b282e8e5adab63e548903b5bb988f7b8;hb=601afe74037d0b32ce36aa852a157c34cf071496;hp=44f033a82c63a293b40713b7d24a6a29d8f92051;hpb=ed5859e1e7c85dee6841ff01b44bdd132a265de9;p=elisp%2Fgnus.git-

diff --git a/lisp/pop3.el b/lisp/pop3.el
index 44f033a..b544159 100644
--- a/lisp/pop3.el
+++ b/lisp/pop3.el
@@ -3,6 +3,7 @@
 ;; Copyright (C) 1996-1999 Free Software Foundation, Inc.
 
 ;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>
+;;      Daiki Ueno  <ueno@ueda.info.waseda.ac.jp>
 ;; Keywords: mail, pop3
 ;; Version: 1.3s
 
@@ -34,8 +35,8 @@
 
 ;;; Code:
 
+(eval-when-compile (require 'cl))
 (require 'mail-utils)
-(provide 'pop3)
 
 (defconst pop3-version "1.3s")
 
@@ -62,25 +63,52 @@ values are 'apop.")
   "Timestamp returned when initially connected to the POP server.
 Used for APOP authentication.")
 
+(defvar pop3-leave-mail-on-server nil
+  "Non-nil if mail is to be left on the server and UIDL used for message retrieval.")
+
+(defvar pop3-maximum-message-size nil
+  "If non-nil only download messages smaller than this.")
+
+(defvar pop3-except-header-regexp nil
+  "If non-nil we do not retrieve messages whose headers are matching this regexp.")
+
+(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-obarray (make-vector 31 0)
+  "Uidl hash table.")
+
 (defvar pop3-read-point nil)
 (defvar pop3-debug nil)
 
 (eval-and-compile
-  (autoload 'open-ssl-stream "ssl"))
+  (autoload 'open-ssl-stream "ssl")
+  (autoload 'starttls-open-stream "starttls")
+  (autoload 'starttls-negotiate "starttls"))
 
 (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)
+  (apply (function message) format args))
+
 (defun pop3-movemail (&optional crashbox)
   "Transfer contents of a maildrop to the specified CRASHBOX."
   (or crashbox (setq crashbox (expand-file-name "~/.crashbox")))
   (let* ((process (pop3-open-server pop3-mailhost pop3-port))
 	 (crashbuf (get-buffer-create " *pop3-retr*"))
 	 (n 1)
-	 message-count
 	 (pop3-password pop3-password)
-	 )
+	 (pop3-uidl-file-name
+	  (convert-standard-filename
+	   (concat pop3-uidl-file-name "-" pop3-mailhost)))
+	 (retrieved-messages nil)
+	 messages message-count)
     ;; for debugging only
     (if pop3-debug (switch-to-buffer (process-buffer process)))
     ;; query for password
@@ -92,49 +120,61 @@ Used for APOP authentication.")
 	  ((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)))
+	  (t (error "Invalid POP3 authentication scheme")))
+    ;; get messages that are suitable for download
+    (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)))
     (unwind-protect
-	(while (<= n message-count)
-	  (message (format "Retrieving message %d of %d from %s..."
-			   n message-count pop3-mailhost))
-	  (pop3-retr process n crashbuf)
-	  (save-excursion
-	    (set-buffer crashbuf)
+	(unless (not (stringp crashbox))
+	  (while messages
+	    (pop3-progress-message
+	     "Retrieving message %d of %d (%d octets) from %s..."
+	     (floor (* (/ (float n) message-count) 100))
+	     n message-count (cdar messages) pop3-mailhost)
+	    (pop3-retr process (caar messages) crashbuf)
+	    (push (caar messages) retrieved-messages)
+	    (setq messages (cdr messages)
+		  n (1+ n)))
+	  (with-current-buffer crashbuf
 	    (write-region-as-binary (point-min) (point-max)
-				    crashbox 'append 'nomesg)
-	    (set-buffer (process-buffer process))
-	    (while (> (buffer-size) 5000)
-	      (goto-char (point-min))
-	      (forward-line 50)
-	      (delete-region (point-min) (point))))
-	  (pop3-dele process n)
-	  (setq n (+ 1 n))
-	  (if pop3-debug (sit-for 1) (sit-for 0.1))
+				    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)
+	      (message (format "Deleting message %d of %d from %s..."
+			       n message-count pop3-mailhost))
+	      (pop3-dele process n)))
 	  )
       (pop3-quit process))
     (kill-buffer crashbuf)
-    )
-  t)
+    message-count))
 
 (defun pop3-open-server (mailhost port)
   "Open TCP connection to MAILHOST.
-Returns the process associated with the connection."
+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))
     (save-excursion
       (set-buffer process-buffer)
-      (erase-buffer)
-      (setq pop3-read-point (point-min))
-      )
+      (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))))
+       (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)
@@ -142,9 +182,15 @@ Returns the process associated with the connection."
     process))
 
 (defun pop3-open-ssl-stream-1 (name buffer host service extra-arg)
-  (let* ((ssl-program-arguments 
-	  (` ((,@ pop3-ssl-program-arguments) (, extra-arg) 
-	      "-connect" (, (format "%s:%d" host service)))))
+  (require 'path-util)
+  (let* ((ssl-program-name
+	  (cond ((exec-installed-p "openssl")
+		 "openssl")
+		(t
+		 "ssleay")))
+	 (ssl-program-arguments
+	  `(,@pop3-ssl-program-arguments ,extra-arg
+	    "-connect" ,(format "%s:%d" host service)))
          (process (open-ssl-stream name buffer host service)))
     (when process
       (with-current-buffer buffer
@@ -160,10 +206,30 @@ Returns the process associated with the connection."
 	   process))))
 
 (defun pop3-open-ssl-stream (name buffer host service)
-  "Open a SSL connection for a service to a host."
-  (as-binary-process
-   (or (pop3-open-ssl-stream-1 name buffer host service "-ssl3")
-       (pop3-open-ssl-stream-1 name buffer host service "-ssl2"))))
+  "Open a SSL connection for a service to a host.
+Returns a subprocess-object to represent the connection.
+Args are NAME BUFFER HOST SERVICE."
+  (cond ((eq system-type 'windows-nt)
+	 (let (selective-display
+	       (coding-system-for-write 'binary)
+	       (coding-system-for-read 'raw-text-dos))
+	   (or (pop3-open-ssl-stream-1 name buffer host service "-ssl3")
+	       (pop3-open-ssl-stream-1 name buffer host service "-ssl2"))))
+	(t
+	 (as-binary-process
+	   (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."
+  (let ((process
+	 (as-binary-process (starttls-open-stream
+			     name buffer host service))))
+    (pop3-stls process)
+    (starttls-negotiate process)
+    process))
 
 ;; Support functions
 
@@ -185,8 +251,8 @@ Returns the process associated with the connection."
     )
 
 (defun pop3-read-response (process &optional return)
-  "Read the response from the server.
-Return the response string if optional second argument is non-nil."
+  "Read the response from the server PROCESS.
+Return the response string if optional second argument RETURN is non-nil."
   (let ((case-fold-search nil)
 	match-end)
     (save-excursion
@@ -207,22 +273,6 @@ Return the response string if optional second argument is non-nil."
 	    t)
 	  )))))
 
-(defun pop3-string-to-list (string &optional regexp)
-  "Chop up a string into a list."
-  (let ((list)
-	(regexp (or regexp " "))
-	(string (if (string-match "\r" string)
-		    (substring string 0 (match-beginning 0))
-		  string)))
-    (store-match-data nil)
-    (while string
-      (if (string-match regexp string)
-	  (setq list (cons (substring string 0 (- (match-end 0) 1)) list)
-		string (substring string (match-end 0)))
-	(setq list (cons string list)
-	      string nil)))
-    (nreverse list)))
-
 (defvar pop3-read-passwd nil)
 (defun pop3-read-passwd (prompt)
   (if (not pop3-read-passwd)
@@ -241,6 +291,9 @@ Return the response string if optional second argument is non-nil."
     (while (and (< (point) end) (search-forward "\r\n" end t))
       (replace-match "\n" t t))
     (goto-char start)
+    (while (re-search-forward "\n\n\\(From \\)" end t)
+      (replace-match "\n\n>\\1" t nil))
+    (goto-char start)
     (while (and (< (point) end) (re-search-forward "^\\." end t))
       (replace-match "" t t)
       (forward-char)))
@@ -278,15 +331,91 @@ Return the response string if optional second argument is non-nil."
 	      (setq From_ (concat (substring From_ 0 (match-beginning 0))
 				  (substring From_ (match-end 0)))))
 	    (goto-char (point-min))
-	    (insert From_)
-	    (re-search-forward "\n\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)))
-	    )))))
+	    (insert From_))))))
+
+;; UIDL support
+
+(defun pop3-get-message-numbers (process)
+  "Get the list of message numbers and lengths to retrieve via PROCESS."
+  ;; we use the LIST comand first anyway to get the message lengths.
+  ;; then if we're leaving mail on the server, see if the UIDL command
+  ;; is implemented. if so, we use it to get the message number list.
+  (let* ((messages (pop3-list process))
+	 (total (or (pop messages) 0))
+	 (uidl (if pop3-leave-mail-on-server
+		   (pop3-get-uidl process)))
+	 out)
+    (while messages
+      ;; 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))
+		 (memq (caar messages) uidl))
+	     (caar messages)
+	     ;; don't download messages that are too large
+	     (not (and pop3-maximum-message-size
+		       (> (cdar messages) pop3-maximum-message-size)))
+	     (not (and pop3-except-header-regexp
+		       (string-match pop3-except-header-regexp
+				     (pop3-top process (caar messages) 0)))))
+	(push (car messages) out))
+      (setq messages (cdr messages)))
+    (cons total (reverse out))))
+
+(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)
+      (save-excursion
+	(with-temp-buffer
+	  (when (file-readable-p pop3-uidl-file-name)
+	    (insert-file-contents pop3-uidl-file-name))
+	  (goto-char (point-min))
+	  (while (looking-at "\\([^ \n\t]+\\)")
+	    (set (intern (match-string 1) pop3-uidl-obarray)
+		 (cons nil t))
+	    (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))))
+      (pop3-get-unread-message-numbers))
+    ))
+
+(defun pop3-get-unread-message-numbers ()
+  "Return a sorted list of unread msg numbers to retrieve."
+  (let (nums)
+    (mapatoms (lambda (atom)
+		(if (not (cdr (symbol-value atom)))
+		    (push (car (symbol-value atom)) nums)))
+	      pop3-uidl-obarray)
+    (sort nums '<)))
+
+(defun pop3-save-uidls ()
+  "Save the updated UIDLs to disk for use next time."
+  (when (and pop3-leave-mail-on-server
+	     ;; UIDL hash table is non-empty
+	     (let ((len (length pop3-uidl-obarray)))
+	       (while (< 0 len)
+		 (setq len (if (symbolp (aref pop3-uidl-obarray (1- len)))
+			       -1 (1- len))))
+	       (minusp len)))
+    (when (file-readable-p pop3-uidl-file-name)
+      (copy-file pop3-uidl-file-name
+		 (concat pop3-uidl-file-name ".old")
+		 'overwrite 'keeptime))
+    (save-excursion
+      (with-temp-file pop3-uidl-file-name
+	(mapatoms
+	 (lambda (atom)
+	   (when (car (symbol-value atom))
+	     (insert (format "%s\n" atom))))
+	 pop3-uidl-obarray)))))
+    
 
 ;; The Command Set
 
@@ -306,15 +435,23 @@ Return the response string if optional second argument is non-nil."
     (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."
-  (if (not (fboundp 'md5)) (autoload 'md5 "md5"))
   (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)))))
 
+(defun pop3-stls (process)
+  "Query whether TLS extension is supported"
+  (pop3-send-command process "STLS")
+  (let ((response (pop3-read-response process t)))
+    (if (not (and response (string-match "+OK" response)))
+	(pop3-quit process))))
+
 ;; TRANSACTION STATE
 
 (defun pop3-stat (process)
@@ -325,49 +462,15 @@ Return the response string if optional second argument is non-nil."
 	  (string-to-int (nth 2 (split-string response))))
     ))
 
-(defun pop3-list (process &optional msg)
-  "Scan listing of available messages.
-This function currently does nothing.")
-
 (defun pop3-retr (process msg crashbuf)
   "Retrieve message-id MSG to buffer CRASHBUF."
   (pop3-send-command process (format "RETR %s" msg))
   (pop3-read-response process)
-  (let ((start pop3-read-point) end)
-    (save-excursion
-      (set-buffer (process-buffer process))
-      (while (not (re-search-forward "^\\.\r\n" nil t))
-	(accept-process-output process 3)
-	;; bill@att.com ... to save wear and tear on the heap
-	;; uncommented because the condensed version below is a problem for
-	;; some.
-	(if (> (buffer-size)  20000) (sleep-for 1))
-	(if (> (buffer-size)  50000) (sleep-for 1))
-	(if (> (buffer-size) 100000) (sleep-for 1))
-	(if (> (buffer-size) 200000) (sleep-for 1))
-	(if (> (buffer-size) 500000) (sleep-for 1))
-	;; bill@att.com
-	;; condensed into:
-	;; (sometimes causes problems for really large messages.)
-;	(if (> (buffer-size) 20000) (sleep-for (/ (buffer-size) 20000)))
-	(goto-char start))
-      (setq pop3-read-point (point-marker))
-;; this code does not seem to work for some POP servers...
-;; and I cannot figure out why not.
-;      (goto-char (match-beginning 0))
-;      (backward-char 2)
-;      (if (not (looking-at "\r\n"))
-;	  (insert "\r\n"))
-;      (re-search-forward "\\.\r\n")
-      (goto-char (match-beginning 0))
-      (setq end (point-marker))
-      (pop3-clean-region start end)
-      (pop3-munge-message-separator start end)
-      (save-excursion
-	(set-buffer crashbuf)
-	(erase-buffer))
-      (copy-to-buffer crashbuf start end)
-      (delete-region start end)
+  (save-excursion
+    (let ((region (pop3-get-extended-response process)))
+      (pop3-munge-message-separator (car region) (cadr region))
+      (append-to-buffer crashbuf (car region) (cadr region))
+      (delete-region (car region) (cadr region))
       )))
 
 (defun pop3-dele (process msg)
@@ -400,11 +503,106 @@ Tell server to remove all messages marked as deleted, unlock the maildrop,
 and close the connection."
   (pop3-send-command process "QUIT")
   (pop3-read-response process t)
-  (if process
+  (when process
+    (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)))
+
+(defun pop3-uidl (process &optional msgno)
+  "Return the results of a UIDL command in PROCESS for optional MSGNO.
+If UIDL is unsupported on this mail server or if msgno is invalid, return nil.
+Otherwise, return a list in the form
+
+   (N (1 UIDL-1) (2 UIDL-2) ... (N UIDL-N))
+
+where
+
+   N is an integer for the number of UIDLs returned (could be 0)
+   UIDL-n is a string."
+
+  (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)
+      (save-excursion
+	(save-restriction
+	  (apply 'narrow-to-region (pop3-get-extended-response process))
+	  (goto-char (point-min))
+	  (while (looking-at "\\([^ \n\t]*\\) \\([^ \n\t]*\\)")
+	    (setq msgno (string-to-int (match-string 1))
+		  uidl (match-string 2))
+	    (push (cons msgno uidl) pairs)
+	    (beginning-of-line 2))
+	  (cons (length pairs) (nreverse pairs))
+	  )))))
+
+(defun pop3-list (process &optional msgno)
+  "Return the results of a LIST command for PROCESS and optional MSGNO.
+If (optional) msgno is invalid, return nil.  Otherwise, return a list
+in the form
+
+   (N (1 LEN-1) (2 LEN-2) ... (N LEN-N))
+
+where
+
+   N is an integer for the number of msg/len pairs (could be 0)
+   LEN-n is an integer."
+  (if msgno
+      (pop3-send-command process (format "LIST %d" msgno))
+    (pop3-send-command process "LIST"))
+
+  (if (null (pop3-read-response process t))
+      nil ;; MSGNO is not valid number
+    (let (pairs len)
       (save-excursion
-	(set-buffer (process-buffer process))
-	(goto-char (point-max))
-	(delete-process process))))
+	(save-restriction
+	  (apply 'narrow-to-region (pop3-get-extended-response process))
+	  (goto-char (point-min))
+	  (while (looking-at "\\([^ \n\t]*\\) \\([^ \n\t]*\\)")
+	    (setq msgno (string-to-int (match-string 1))
+		  len (string-to-int (match-string 2)))
+	    (push (cons msgno len) pairs)
+	    (beginning-of-line 2))
+	  (cons (length pairs) (nreverse pairs))
+	  )))))
+
+(defun pop3-top (process msgno &optional lines)
+  "Return the top LINES of messages for PROCESS and MSGNO.
+If msgno is invalid, return nil.  Otherwise, return a string."
+  (pop3-send-command process (format "TOP %d %d" msgno (or lines 1)))
+  (if (pop3-read-response process t)
+      nil ;; MSGNO is not valid number
+    (save-excursion
+      (apply 'buffer-substring (pop3-get-extended-response process)))
+    ))
+
+;;; Utility code
+
+(defun pop3-get-extended-response (process)
+  "Get the extended pop3 response in the PROCESS buffer."
+  (let ((start pop3-read-point) end)
+    (set-buffer (process-buffer process))
+    (goto-char start)
+    (while (not (re-search-forward "^\\.\r\n" nil t))
+      (accept-process-output process 3)
+      (goto-char start))
+    (setq pop3-read-point (point-marker))
+    (goto-char (match-beginning 0))
+    (setq end (point-marker))
+    (pop3-clean-region start end)
+    (list start end)))
+
 
 ;; Summary of POP3 (Post Office Protocol version 3) commands and responses
 
@@ -431,6 +629,13 @@ and close the connection."
 ;;  -ERR [invalid password]
 ;;  -ERR [unable to lock maildrop]
 
+;; STLS
+;; Arguments: none
+;; Restrictions: authorization state
+;; Possible responses:
+;;  +OK [negotiation is ready]
+;;  -ERR [security layer is already active]
+
 ;;; TRANSACTION STATE
 
 ;; STAT
@@ -446,6 +651,20 @@ and close the connection."
 ;;  +OK [scan listing follows]
 ;;  -ERR [no such message]
 
+;; TOP msg [lines]
+;; Arguments: a message-id (required), number of lines (optional)
+;; Restrictions: transaction state; msg must not be deleted
+;; Possible responses:
+;;  +OK [partial message listing follows]
+;;  -ERR [no such message]
+
+;; UIDL [msg]
+;; Arguments: a message-id (optional)
+;; Restrictions: transaction state; msg must not be deleted
+;; Possible responses:
+;;  +OK [uidl listing follows]
+;;  -ERR [no such message]
+
 ;; RETR msg
 ;; Arguments: a message-id (required)
 ;; Restrictions: transaction state; msg must not be deleted
@@ -485,3 +704,7 @@ and close the connection."
 ;; Restrictions: none
 ;; Possible responses:
 ;;  +OK [TCP connection closed]
+
+(provide 'pop3)
+
+;;; pop3.el ends here