|
70
|
1 ;;; Simple POP (RFC 1460) client for VM
|
|
|
2 ;;; Copyright (C) 1993, 1994 Kyle E. Jones
|
|
0
|
3 ;;;
|
|
|
4 ;;; This program is free software; you can redistribute it and/or modify
|
|
|
5 ;;; it under the terms of the GNU General Public License as published by
|
|
|
6 ;;; the Free Software Foundation; either version 1, or (at your option)
|
|
|
7 ;;; any later version.
|
|
|
8 ;;;
|
|
|
9 ;;; This program is distributed in the hope that it will be useful,
|
|
|
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
12 ;;; GNU General Public License for more details.
|
|
|
13 ;;;
|
|
|
14 ;;; You should have received a copy of the GNU General Public License
|
|
|
15 ;;; along with this program; if not, write to the Free Software
|
|
|
16 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
17
|
|
|
18 (provide 'vm-pop)
|
|
|
19
|
|
|
20 ;; Nothing fancy here.
|
|
|
21 ;; Our goal is to drag the mail from the POP maildrop to the crash box.
|
|
|
22 ;; just as if we were using movemail on a spool file.
|
|
|
23 (defun vm-pop-move-mail (source destination)
|
|
|
24 (let ((process nil)
|
|
|
25 (folder-type vm-folder-type)
|
|
|
26 (saved-password t)
|
|
|
27 (handler (and (fboundp 'find-file-name-handler)
|
|
|
28 (condition-case ()
|
|
|
29 (find-file-name-handler source 'vm-pop-move-mail)
|
|
|
30 (wrong-number-of-arguments
|
|
|
31 (find-file-name-handler source)))))
|
|
|
32 (popdrop (vm-safe-popdrop-string source))
|
|
70
|
33 greeting timestamp n message-count
|
|
|
34 host port auth user pass source-list process-buffer)
|
|
0
|
35 (unwind-protect
|
|
|
36 (catch 'done
|
|
|
37 (if handler
|
|
|
38 (throw 'done
|
|
|
39 (funcall handler 'vm-pop-move-mail source destination)))
|
|
|
40 ;; parse the maildrop
|
|
|
41 (setq source-list (vm-parse source "\\([^:]+\\):?")
|
|
|
42 host (nth 0 source-list)
|
|
|
43 port (nth 1 source-list)
|
|
|
44 auth (nth 2 source-list)
|
|
|
45 user (nth 3 source-list)
|
|
|
46 pass (nth 4 source-list))
|
|
|
47 ;; carp if parts are missing
|
|
|
48 (if (null host)
|
|
|
49 (error "No host in POP maildrop specification, \"%s\""
|
|
|
50 source))
|
|
|
51 (if (null port)
|
|
|
52 (error "No port in POP maildrop specification, \"%s\""
|
|
|
53 source))
|
|
|
54 (if (string-match "^[0-9]+$" port)
|
|
|
55 (setq port (string-to-int port)))
|
|
|
56 (if (null auth)
|
|
|
57 (error
|
|
|
58 "No authentication method in POP maildrop specification, \"%s\""
|
|
|
59 source))
|
|
|
60 (if (null user)
|
|
|
61 (error "No user in POP maildrop specification, \"%s\""
|
|
|
62 source))
|
|
|
63 (if (null pass)
|
|
|
64 (error "No password in POP maildrop specification, \"%s\""
|
|
|
65 source))
|
|
|
66 (if (equal pass "*")
|
|
|
67 (progn
|
|
|
68 (setq pass (car (cdr (assoc source vm-pop-passwords))))
|
|
|
69 (if (null pass)
|
|
70
|
70 (setq pass
|
|
|
71 (vm-read-password
|
|
|
72 (format "POP password for %s: "
|
|
|
73 popdrop))
|
|
|
74 vm-pop-passwords (cons (list source pass)
|
|
|
75 vm-pop-passwords)
|
|
|
76 saved-password t))))
|
|
0
|
77 ;; get the trace buffer
|
|
|
78 (setq process-buffer
|
|
|
79 (get-buffer-create (format "trace of POP session to %s" host)))
|
|
|
80 ;; clear the trace buffer of old output
|
|
|
81 (save-excursion
|
|
|
82 (set-buffer process-buffer)
|
|
|
83 (erase-buffer))
|
|
|
84 ;; open the connection to the server
|
|
|
85 (setq process (open-network-stream "POP" process-buffer host port))
|
|
|
86 (and (null process) (throw 'done nil))
|
|
70
|
87 (set-process-filter process 'vm-pop-process-filter)
|
|
0
|
88 (save-excursion
|
|
|
89 (set-buffer process-buffer)
|
|
|
90 (make-local-variable 'vm-pop-read-point)
|
|
70
|
91 (setq vm-pop-read-point (point-min)
|
|
|
92 vm-folder-type (or folder-type vm-default-folder-type))
|
|
|
93 (and (null (setq greeting (vm-pop-read-response process t)))
|
|
|
94 (throw 'done nil))
|
|
0
|
95 ;; authentication
|
|
|
96 (cond ((equal auth "pass")
|
|
|
97 (vm-pop-send-command process (format "USER %s" user))
|
|
|
98 (and (null (vm-pop-read-response process))
|
|
|
99 (throw 'done nil))
|
|
|
100 (vm-pop-send-command process (format "PASS %s" pass))
|
|
|
101 (if (null (vm-pop-read-response process))
|
|
|
102 (progn
|
|
|
103 (if saved-password
|
|
|
104 (setq vm-pop-passwords
|
|
|
105 (delete (list source pass)
|
|
|
106 vm-pop-passwords)))
|
|
|
107 (throw 'done nil))))
|
|
|
108 ((equal auth "rpop")
|
|
|
109 (vm-pop-send-command process (format "USER %s" user))
|
|
|
110 (and (null (vm-pop-read-response process))
|
|
|
111 (throw 'done nil))
|
|
|
112 (vm-pop-send-command process (format "RPOP %s" pass))
|
|
|
113 (and (null (vm-pop-read-response process))
|
|
|
114 (throw 'done nil)))
|
|
|
115 ((equal auth "apop")
|
|
|
116 (setq timestamp (vm-parse greeting "[^<]+\\(<[^>]+>\\)")
|
|
|
117 timestamp (car timestamp))
|
|
|
118 (if (null timestamp)
|
|
|
119 (progn
|
|
|
120 (goto-char (point-max))
|
|
70
|
121 (insert "<<< ooops, no timestamp found in greeting! >>>\n")
|
|
0
|
122 (throw 'done nil)))
|
|
|
123 (vm-pop-send-command
|
|
|
124 process
|
|
|
125 (format "APOP %s %s"
|
|
|
126 user
|
|
|
127 (vm-pop-md5 (concat timestamp pass))))
|
|
|
128 (and (null (vm-pop-read-response process))
|
|
|
129 (throw 'done nil)))
|
|
70
|
130 (t (error "Don't know how to authenticate with %s" auth)))
|
|
|
131 ;; find out how many messages are in the box.
|
|
|
132 (vm-pop-send-command process "STAT")
|
|
|
133 (setq message-count (vm-pop-read-stat-response process))
|
|
|
134 ;; forget it if the command fails
|
|
|
135 ;; or if there are no messages present.
|
|
|
136 (if (or (null message-count)
|
|
|
137 (< message-count 1))
|
|
|
138 (throw 'done nil))
|
|
|
139 ;; loop through the maildrop retrieving and deleting
|
|
|
140 ;; messages as we go.
|
|
|
141 (setq n 1)
|
|
|
142 (while (<= n message-count)
|
|
|
143 (vm-unsaved-message "Retrieving message %d (of %d) from %s..."
|
|
|
144 n message-count popdrop)
|
|
|
145 (vm-pop-send-command process (format "RETR %d" n))
|
|
|
146 (and (null (vm-pop-read-response process))
|
|
|
147 (throw 'done (not (equal n 1))))
|
|
|
148 (and (null (vm-pop-retrieve-to-crashbox process destination))
|
|
|
149 (throw 'done (not (equal n 1))))
|
|
|
150 (vm-pop-send-command process (format "DELE %d" n))
|
|
|
151 ;; DELE can't fail but Emacs or this code might
|
|
|
152 ;; blow a gasket and spew filth down the
|
|
|
153 ;; connection, so...
|
|
|
154 (and (null (vm-pop-read-response process))
|
|
|
155 (throw 'done (not (equal n 1))))
|
|
|
156 (vm-increment n))
|
|
|
157 t ))
|
|
|
158 (if process
|
|
|
159 (save-excursion
|
|
|
160 (set-buffer (process-buffer process))
|
|
|
161 (vm-pop-send-command process "QUIT")
|
|
|
162 (vm-pop-read-response process)
|
|
|
163 (delete-process process))))))
|
|
0
|
164
|
|
70
|
165 (defun vm-pop-process-filter (process output)
|
|
0
|
166 (save-excursion
|
|
|
167 (set-buffer (process-buffer process))
|
|
70
|
168 (goto-char (point-max))
|
|
|
169 (insert output)))
|
|
30
|
170
|
|
0
|
171 (defun vm-pop-send-command (process command)
|
|
|
172 (goto-char (point-max))
|
|
|
173 (if (= (aref command 0) ?P)
|
|
70
|
174 (insert "PASS <omitted>\r\n")
|
|
|
175 (insert command "\r\n"))
|
|
0
|
176 (setq vm-pop-read-point (point))
|
|
|
177 (process-send-string process command)
|
|
|
178 (process-send-string process "\r\n"))
|
|
|
179
|
|
|
180 (defun vm-pop-read-response (process &optional return-response-string)
|
|
|
181 (let ((case-fold-search nil)
|
|
|
182 match-end)
|
|
|
183 (goto-char vm-pop-read-point)
|
|
|
184 (while (not (search-forward "\r\n" nil t))
|
|
|
185 (accept-process-output process)
|
|
|
186 (goto-char vm-pop-read-point))
|
|
|
187 (setq match-end (point))
|
|
|
188 (goto-char vm-pop-read-point)
|
|
|
189 (if (not (looking-at "+OK"))
|
|
|
190 (progn (setq vm-pop-read-point match-end) nil)
|
|
|
191 (setq vm-pop-read-point match-end)
|
|
|
192 (if return-response-string
|
|
|
193 (buffer-substring (point) match-end)
|
|
|
194 t ))))
|
|
|
195
|
|
|
196 (defun vm-pop-read-stat-response (process)
|
|
|
197 (let ((response (vm-pop-read-response process t)))
|
|
70
|
198 (string-to-int (nth 1 (vm-parse response "\\([^ ]+\\) *")))))
|
|
24
|
199
|
|
70
|
200 (defun vm-pop-retrieve-to-crashbox (process crash)
|
|
0
|
201 (let ((start vm-pop-read-point) end)
|
|
|
202 (goto-char start)
|
|
70
|
203 (while (not (re-search-forward "^\\.\r\n" nil t))
|
|
|
204 (accept-process-output process)
|
|
|
205 (goto-char start))
|
|
0
|
206 (setq vm-pop-read-point (point-marker))
|
|
|
207 (goto-char (match-beginning 0))
|
|
|
208 (setq end (point-marker))
|
|
|
209 (vm-pop-cleanup-region start end)
|
|
|
210 ;; Some POP servers strip leading and trailing message
|
|
|
211 ;; separators, some don't. Figure out what kind we're
|
|
|
212 ;; talking to and do the right thing.
|
|
|
213 (if (eq (vm-get-folder-type nil start end) 'unknown)
|
|
|
214 (progn
|
|
|
215 (vm-munge-message-separators vm-folder-type start end)
|
|
|
216 (goto-char start)
|
|
|
217 ;; avoid the consing and stat() call for all but babyl
|
|
|
218 ;; files, since this will probably slow things down.
|
|
|
219 ;; only babyl files have the folder header, and we
|
|
|
220 ;; should only insert it if the crash box is empty.
|
|
|
221 (if (and (eq vm-folder-type 'babyl)
|
|
|
222 (let ((attrs (file-attributes crash)))
|
|
|
223 (or (null attrs) (equal 0 (nth 7 attrs)))))
|
|
|
224 (let ((opoint (point)))
|
|
|
225 (vm-convert-folder-header nil vm-folder-type)
|
|
|
226 ;; if start is a marker, then it was moved
|
|
|
227 ;; forward by the insertion. restore it.
|
|
|
228 (setq start opoint)
|
|
|
229 (goto-char start)
|
|
|
230 (vm-skip-past-folder-header)))
|
|
|
231 (insert (vm-leading-message-separator))
|
|
|
232 ;; this will not find the trailing message separator but
|
|
|
233 ;; for the Content-Length stuff counting from eob is
|
|
|
234 ;; the same thing in this case.
|
|
|
235 (vm-convert-folder-type-headers nil vm-folder-type)
|
|
|
236 (goto-char end)
|
|
|
237 (insert-before-markers (vm-trailing-message-separator))))
|
|
98
|
238 ;; Set file type to binary for DOS/Windows. I don't know if
|
|
|
239 ;; this is correct to do or not; it depends on whether the
|
|
|
240 ;; the CRLF or the LF newline convention is used on the inbox
|
|
|
241 ;; associated with this crashbox. This setting assumes the LF
|
|
|
242 ;; newline convention is used.
|
|
|
243 (let ((buffer-file-type t))
|
|
|
244 (write-region start end crash t 0))
|
|
0
|
245 (delete-region start end)
|
|
|
246 t ))
|
|
|
247
|
|
|
248 (defun vm-pop-cleanup-region (start end)
|
|
|
249 (setq end (vm-marker end))
|
|
|
250 (save-excursion
|
|
|
251 (goto-char start)
|
|
|
252 ;; CRLF -> LF
|
|
|
253 (while (and (< (point) end) (search-forward "\r\n" end t))
|
|
|
254 (replace-match "\n" t t))
|
|
|
255 (goto-char start)
|
|
|
256 ;; chop leading dots
|
|
|
257 (while (and (< (point) end) (re-search-forward "^\\." end t))
|
|
|
258 (replace-match "" t t)
|
|
|
259 (forward-char)))
|
|
|
260 (set-marker end nil))
|
|
|
261
|
|
|
262 (defun vm-pop-md5 (string)
|
|
|
263 (let ((buffer nil))
|
|
|
264 (unwind-protect
|
|
|
265 (save-excursion
|
|
|
266 (setq buffer (generate-new-buffer "*vm-work*"))
|
|
|
267 (set-buffer buffer)
|
|
|
268 (insert string)
|
|
|
269 (call-process-region (point-min) (point-max)
|
|
|
270 "/bin/sh" t buffer nil
|
|
98
|
271 shell-command-switch vm-pop-md5-program)
|
|
0
|
272 ;; MD5 digest is 32 chars long
|
|
|
273 ;; mddriver adds a newline to make neaten output for tty
|
|
|
274 ;; viewing, make sure we leave it behind.
|
|
|
275 (vm-buffer-substring-no-properties (point-min) (+ (point-min) 32)))
|
|
|
276 (and buffer (kill-buffer buffer)))))
|
