--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/vm/vm-pop.el	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,270 @@
+;;; Simple POP (RFC 1460) client for VM
+;;; Copyright (C) 1993, 1994 Kyle E. Jones
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 1, or (at your option)
+;;; any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+(provide 'vm-pop)
+
+;; Nothing fancy here.
+;; Our goal is to drag the mail from the POP maildrop to the crash box.
+;; just as if we were using movemail on a spool file.
+(defun vm-pop-move-mail (source destination)
+  (let ((process nil)
+	(folder-type vm-folder-type)
+	(saved-password t)
+	(handler (and (fboundp 'find-file-name-handler)
+		      (condition-case ()
+			  (find-file-name-handler source 'vm-pop-move-mail)
+			(wrong-number-of-arguments
+			  (find-file-name-handler source)))))
+	(popdrop (vm-safe-popdrop-string source))
+	greeting timestamp n message-count
+	host port auth user pass source-list process-buffer)
+    (unwind-protect
+	(catch 'done
+	  (if handler
+	      (throw 'done
+		     (funcall handler 'vm-pop-move-mail source destination)))
+	  ;; parse the maildrop
+	  (setq source-list (vm-parse source "\\([^:]+\\):?")
+		host (nth 0 source-list)
+		port (nth 1 source-list)
+		auth (nth 2 source-list)
+		user (nth 3 source-list)
+		pass (nth 4 source-list))
+	  ;; carp if parts are missing
+	  (if (null host)
+	      (error "No host in POP maildrop specification, \"%s\""
+		     source))
+	  (if (null port)
+	      (error "No port in POP maildrop specification, \"%s\""
+		     source))
+	  (if (string-match "^[0-9]+$" port)
+	      (setq port (string-to-int port)))
+	  (if (null auth)
+	      (error
+	       "No authentication method in POP maildrop specification, \"%s\""
+	       source))
+	  (if (null user)
+	      (error "No user in POP maildrop specification, \"%s\""
+		     source))
+	  (if (null pass)
+	      (error "No password in POP maildrop specification, \"%s\""
+		     source))
+	  (if (equal pass "*")
+	      (progn
+		(setq pass (car (cdr (assoc source vm-pop-passwords))))
+		(if (null pass)
+		    (setq pass
+			  (vm-read-password
+			   (format "POP password for %s: "
+				   popdrop))
+			  vm-pop-passwords (cons (list source pass)
+						 vm-pop-passwords)
+			  saved-password t))))
+	  ;; get the trace buffer
+	  (setq process-buffer
+		(get-buffer-create (format "trace of POP session to %s" host)))
+	  ;; clear the trace buffer of old output
+	  (save-excursion
+	    (set-buffer process-buffer)
+	    (erase-buffer))
+	  ;; open the connection to the server
+	  (setq process (open-network-stream "POP" process-buffer host port))
+	  (and (null process) (throw 'done nil))
+	  (set-process-filter process 'vm-pop-process-filter)
+	  (save-excursion
+	    (set-buffer process-buffer)
+	    (make-local-variable 'vm-pop-read-point)
+	    (setq vm-pop-read-point (point-min)
+		  vm-folder-type (or folder-type vm-default-folder-type))
+	    (and (null (setq greeting (vm-pop-read-response process t)))
+		 (throw 'done nil))
+	    ;; authentication
+	    (cond ((equal auth "pass")
+		   (vm-pop-send-command process (format "USER %s" user))
+		   (and (null (vm-pop-read-response process))
+			(throw 'done nil))
+		   (vm-pop-send-command process (format "PASS %s" pass))
+		   (if (null (vm-pop-read-response process))
+		       (progn
+			 (if saved-password
+			     (setq vm-pop-passwords
+				   (delete (list source pass)
+					   vm-pop-passwords)))
+			 (throw 'done nil))))
+		  ((equal auth "rpop")
+		   (vm-pop-send-command process (format "USER %s" user))
+		   (and (null (vm-pop-read-response process))
+			(throw 'done nil))
+		   (vm-pop-send-command process (format "RPOP %s" pass))
+		   (and (null (vm-pop-read-response process))
+			(throw 'done nil)))
+		  ((equal auth "apop")
+		   (setq timestamp (vm-parse greeting "[^<]+\\(<[^>]+>\\)")
+			 timestamp (car timestamp))
+		   (if (null timestamp)
+		       (progn
+			 (goto-char (point-max))
+		 (insert "<<< ooops, no timestamp found in greeting! >>>\n")
+			 (throw 'done nil)))
+		   (vm-pop-send-command
+		    process
+		    (format "APOP %s %s"
+			    user
+			    (vm-pop-md5 (concat timestamp pass))))
+		   (and (null (vm-pop-read-response process))
+			(throw 'done nil)))
+		  (t (error "Don't know how to authenticate with %s" auth)))
+	    ;; find out how many messages are in the box.
+	    (vm-pop-send-command process "STAT")
+	    (setq message-count (vm-pop-read-stat-response process))
+	    ;; forget it if the command fails
+	    ;; or if there are no messages present.
+	    (if (or (null message-count)
+		    (< message-count 1))
+		(throw 'done nil))
+	    ;; loop through the maildrop retrieving and deleting
+	    ;; messages as we go.
+	    (setq n 1)
+	    (while (<= n message-count)
+	      (vm-unsaved-message "Retrieving message %d (of %d) from %s..."
+				  n message-count popdrop)
+	      (vm-pop-send-command process (format "RETR %d" n))
+	      (and (null (vm-pop-read-response process))
+		   (throw 'done (not (equal n 1))))
+	      (and (null (vm-pop-retrieve-to-crashbox process destination))
+		   (throw 'done (not (equal n 1))))
+	      (vm-pop-send-command process (format "DELE %d" n))
+	      ;; DELE can't fail but Emacs or this code might
+	      ;; blow a gasket and spew filth down the
+	      ;; connection, so...
+	      (and (null (vm-pop-read-response process))
+		   (throw 'done (not (equal n 1))))
+	      (vm-increment n))
+	     t ))
+      (if process
+	  (save-excursion
+	    (set-buffer (process-buffer process))
+	    (vm-pop-send-command process "QUIT")
+	    (vm-pop-read-response process)
+	    (delete-process process))))))
+
+(defun vm-pop-process-filter (process output)
+  (save-excursion
+    (set-buffer (process-buffer process))
+    (goto-char (point-max))
+    (insert output)))
+
+(defun vm-pop-send-command (process command)
+  (goto-char (point-max))
+  (if (= (aref command 0) ?P)
+      (insert "PASS <omitted>\r\n")
+    (insert command "\r\n"))
+  (setq vm-pop-read-point (point))
+  (process-send-string process command)
+  (process-send-string process "\r\n"))
+
+(defun vm-pop-read-response (process &optional return-response-string)
+  (let ((case-fold-search nil)
+	 match-end)
+    (goto-char vm-pop-read-point)
+    (while (not (search-forward "\r\n" nil t))
+      (accept-process-output process)
+      (goto-char vm-pop-read-point))
+    (setq match-end (point))
+    (goto-char vm-pop-read-point)
+    (if (not (looking-at "+OK"))
+	(progn (setq vm-pop-read-point match-end) nil)
+      (setq vm-pop-read-point match-end)
+      (if return-response-string
+	  (buffer-substring (point) match-end)
+	t ))))
+
+(defun vm-pop-read-stat-response (process)
+  (let ((response (vm-pop-read-response process t)))
+    (string-to-int (nth 1 (vm-parse response "\\([^ ]+\\) *")))))
+
+(defun vm-pop-retrieve-to-crashbox (process crash)
+  (let ((start vm-pop-read-point) end)
+    (goto-char start)
+    (while (not (re-search-forward "^\\.\r\n" nil t))
+      (accept-process-output process)
+      (goto-char start))
+    (setq vm-pop-read-point (point-marker))
+    (goto-char (match-beginning 0))
+    (setq end (point-marker))
+    (vm-pop-cleanup-region start end)
+    ;; Some POP servers strip leading and trailing message
+    ;; separators, some don't.  Figure out what kind we're
+    ;; talking to and do the right thing.
+    (if (eq (vm-get-folder-type nil start end) 'unknown)
+	(progn
+	  (vm-munge-message-separators vm-folder-type start end)
+	  (goto-char start)
+	  ;; avoid the consing and stat() call for all but babyl
+	  ;; files, since this will probably slow things down.
+	  ;; only babyl files have the folder header, and we
+	  ;; should only insert it if the crash box is empty.
+	  (if (and (eq vm-folder-type 'babyl)
+		   (let ((attrs (file-attributes crash)))
+		     (or (null attrs) (equal 0 (nth 7 attrs)))))
+	      (let ((opoint (point)))
+		(vm-convert-folder-header nil vm-folder-type)
+		;; if start is a marker, then it was moved
+		;; forward by the insertion.  restore it.
+		(setq start opoint)
+		(goto-char start)
+		(vm-skip-past-folder-header)))
+	  (insert (vm-leading-message-separator))
+	  ;; this will not find the trailing message separator but
+	  ;; for the Content-Length stuff counting from eob is
+	  ;; the same thing in this case.
+	  (vm-convert-folder-type-headers nil vm-folder-type)
+	  (goto-char end)
+	  (insert-before-markers (vm-trailing-message-separator))))
+    (write-region start end crash t 0)
+    (delete-region start end)
+    t ))
+
+(defun vm-pop-cleanup-region (start end)
+  (setq end (vm-marker end))
+  (save-excursion
+    (goto-char start)
+    ;; CRLF -> LF
+    (while (and (< (point) end) (search-forward "\r\n"  end t))
+      (replace-match "\n" t t))
+    (goto-char start)
+    ;; chop leading dots
+    (while (and (< (point) end) (re-search-forward "^\\."  end t))
+      (replace-match "" t t)
+      (forward-char)))
+  (set-marker end nil))
+
+(defun vm-pop-md5 (string)
+  (let ((buffer nil))
+    (unwind-protect
+	(save-excursion
+	  (setq buffer (generate-new-buffer "*vm-work*"))
+	  (set-buffer buffer)
+	  (insert string)
+	  (call-process-region (point-min) (point-max)
+			       "/bin/sh" t buffer nil
+			       "-c" vm-pop-md5-program)
+	  ;; MD5 digest is 32 chars long
+	  ;; mddriver adds a newline to make neaten output for tty
+	  ;; viewing, make sure we leave it behind.
+	  (vm-buffer-substring-no-properties (point-min) (+ (point-min) 32)))
+      (and buffer (kill-buffer buffer)))))