Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-pop.el @ 100:4be1180a9e89 r20-1b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b2
author cvs
date Mon, 13 Aug 2007 09:15:11 +0200
parents 0d2f883870bc
children a145efe76779
comparison
equal deleted inserted replaced
99:2d83cbd90d8d 100:4be1180a9e89
22 ;; just as if we were using movemail on a spool file. 22 ;; just as if we were using movemail on a spool file.
23 (defun vm-pop-move-mail (source destination) 23 (defun vm-pop-move-mail (source destination)
24 (let ((process nil) 24 (let ((process nil)
25 (folder-type vm-folder-type) 25 (folder-type vm-folder-type)
26 (saved-password t) 26 (saved-password t)
27 (m-per-session vm-pop-messages-per-session)
28 (b-per-session vm-pop-bytes-per-session)
27 (handler (and (fboundp 'find-file-name-handler) 29 (handler (and (fboundp 'find-file-name-handler)
28 (condition-case () 30 (condition-case ()
29 (find-file-name-handler source 'vm-pop-move-mail) 31 (find-file-name-handler source 'vm-pop-move-mail)
30 (wrong-number-of-arguments 32 (wrong-number-of-arguments
31 (find-file-name-handler source))))) 33 (find-file-name-handler source)))))
32 (popdrop (vm-safe-popdrop-string source)) 34 (popdrop (vm-safe-popdrop-string source))
33 greeting timestamp n message-count 35 mailbox-count mailbox-size message-size response
34 host port auth user pass source-list process-buffer) 36 n retrieved retrieved-bytes process-buffer)
35 (unwind-protect 37 (unwind-protect
36 (catch 'done 38 (catch 'done
37 (if handler 39 (if handler
38 (throw 'done 40 (throw 'done
39 (funcall handler 'vm-pop-move-mail source destination))) 41 (funcall handler 'vm-pop-move-mail source destination)))
42 (setq process (vm-pop-make-session source))
43 (or process (throw 'done nil))
44 (setq process-buffer (process-buffer process))
45 (save-excursion
46 (set-buffer process-buffer)
47 (setq vm-folder-type (or folder-type vm-default-folder-type))
48 ;; find out how many messages are in the box.
49 (vm-pop-send-command process "STAT")
50 (setq response (vm-pop-read-stat-response process)
51 mailbox-count (nth 0 response)
52 mailbox-size (nth 1 response))
53 ;; forget it if the command fails
54 ;; or if there are no messages present.
55 (if (or (null mailbox-count)
56 (< mailbox-count 1))
57 (throw 'done nil))
58 ;; loop through the maildrop retrieving and deleting
59 ;; messages as we go.
60 (setq n 1 retrieved 0 retrieved-bytes 0)
61 (while (and (<= n mailbox-count)
62 (or (not (natnump m-per-session))
63 (< retrieved m-per-session))
64 (or (not (natnump b-per-session))
65 (< retrieved-bytes b-per-session)))
66 (if (or vm-pop-max-message-size
67 b-per-session)
68 (progn
69 (vm-pop-send-command process (format "LIST %d" n))
70 (setq message-size
71 (vm-pop-read-list-response process))))
72 (if (and (integerp vm-pop-max-message-size)
73 (> message-size vm-pop-max-message-size)
74 (progn
75 (setq response
76 (if vm-pop-ok-to-ask
77 (vm-pop-ask-about-large-message process
78 message-size
79 n)
80 'skip))
81 (not (eq response 'retrieve))))
82 (if (eq response 'delete)
83 (progn
84 (message "Deleting message %d..." n)
85 (vm-pop-send-command process (format "DELE %d" n))
86 (and (null (vm-pop-read-response process))
87 (throw 'done (not (equal retrieved 0)))))
88 (if vm-pop-ok-to-ask
89 (message "Skipping message %d..." n)
90 (message "Skipping message %d in %s, too large (%d > %d)..."
91 n popdrop message-size vm-pop-max-message-size)))
92 (message "Retrieving message %d (of %d) from %s..."
93 n mailbox-count popdrop)
94 (vm-pop-send-command process (format "RETR %d" n))
95 (and (null (vm-pop-read-response process))
96 (throw 'done (not (equal retrieved 0))))
97 (and (null (vm-pop-retrieve-to-crashbox process destination))
98 (throw 'done (not (equal retrieved 0))))
99 (vm-increment retrieved)
100 (and b-per-session
101 (setq retrieved-bytes (+ retrieved-bytes message-size)))
102 (vm-pop-send-command process (format "DELE %d" n))
103 ;; DELE can't fail but Emacs or this code might
104 ;; blow a gasket and spew filth down the
105 ;; connection, so...
106 (and (null (vm-pop-read-response process))
107 (throw 'done (not (equal retrieved 0)))))
108 (vm-increment n))
109 (not (equal retrieved 0)) ))
110 (if process
111 (vm-pop-end-session process)))))
112
113 (defun vm-pop-check-mail (source)
114 (let ((process nil)
115 (handler (and (fboundp 'find-file-name-handler)
116 (condition-case ()
117 (find-file-name-handler source 'vm-pop-check-mail)
118 (wrong-number-of-arguments
119 (find-file-name-handler source)))))
120 response)
121 (unwind-protect
122 (save-excursion
123 (catch 'done
124 (if handler
125 (throw 'done
126 (funcall handler 'vm-pop-check-mail source)))
127 (setq process (vm-pop-make-session source))
128 (or process (throw 'done nil))
129 (set-buffer (process-buffer process))
130 (vm-pop-send-command process "STAT")
131 (setq response (vm-pop-read-stat-response process))
132 (if (null response)
133 nil
134 (not (equal 0 (car response))))))
135 (and process (vm-pop-end-session process)))))
136
137 (defun vm-pop-make-session (source)
138 (let ((process-to-shutdown nil)
139 process
140 (saved-password t)
141 (popdrop (vm-safe-popdrop-string source))
142 greeting timestamp
143 host port auth user pass source-list process-buffer)
144 (unwind-protect
145 (catch 'done
40 ;; parse the maildrop 146 ;; parse the maildrop
41 (setq source-list (vm-parse source "\\([^:]+\\):?") 147 (setq source-list (vm-parse source "\\([^:]+\\):?")
42 host (nth 0 source-list) 148 host (nth 0 source-list)
43 port (nth 1 source-list) 149 port (nth 1 source-list)
44 auth (nth 2 source-list) 150 auth (nth 2 source-list)
65 source)) 171 source))
66 (if (equal pass "*") 172 (if (equal pass "*")
67 (progn 173 (progn
68 (setq pass (car (cdr (assoc source vm-pop-passwords)))) 174 (setq pass (car (cdr (assoc source vm-pop-passwords))))
69 (if (null pass) 175 (if (null pass)
70 (setq pass 176 (if (null vm-pop-ok-to-ask)
71 (vm-read-password 177 (progn (message "Need password for %s" popdrop)
72 (format "POP password for %s: " 178 (throw 'done nil))
73 popdrop)) 179 (setq pass
74 vm-pop-passwords (cons (list source pass) 180 (vm-read-password
75 vm-pop-passwords) 181 (format "POP password for %s: "
76 saved-password t)))) 182 popdrop))
183 vm-pop-passwords (cons (list source pass)
184 vm-pop-passwords)
185 saved-password t)))))
77 ;; get the trace buffer 186 ;; get the trace buffer
78 (setq process-buffer 187 (setq process-buffer
79 (get-buffer-create (format "trace of POP session to %s" host))) 188 (get-buffer-create (format "trace of POP session to %s" host)))
189 ;; Tell XEmacs/MULE not to mess with the text.
190 (and (fboundp 'set-file-coding-system)
191 (set-file-coding-system 'binary t))
80 ;; clear the trace buffer of old output 192 ;; clear the trace buffer of old output
81 (save-excursion 193 (save-excursion
82 (set-buffer process-buffer) 194 (set-buffer process-buffer)
83 (erase-buffer)) 195 (erase-buffer))
84 ;; open the connection to the server 196 ;; open the connection to the server
85 (setq process (open-network-stream "POP" process-buffer host port)) 197 (setq process (open-network-stream "POP" process-buffer host port))
86 (and (null process) (throw 'done nil)) 198 (and (null process) (throw 'done nil))
87 (set-process-filter process 'vm-pop-process-filter) 199 (process-kill-without-query process)
88 (save-excursion 200 (save-excursion
89 (set-buffer process-buffer) 201 (set-buffer process-buffer)
90 (make-local-variable 'vm-pop-read-point) 202 (make-local-variable 'vm-pop-read-point)
91 (setq vm-pop-read-point (point-min) 203 (setq vm-pop-read-point (point-min))
92 vm-folder-type (or folder-type vm-default-folder-type)) 204 (if (null (setq greeting (vm-pop-read-response process t)))
93 (and (null (setq greeting (vm-pop-read-response process t))) 205 (progn (delete-process process)
94 (throw 'done nil)) 206 (throw 'done nil)))
207 (setq process-to-shutdown process)
95 ;; authentication 208 ;; authentication
96 (cond ((equal auth "pass") 209 (cond ((equal auth "pass")
97 (vm-pop-send-command process (format "USER %s" user)) 210 (vm-pop-send-command process (format "USER %s" user))
98 (and (null (vm-pop-read-response process)) 211 (and (null (vm-pop-read-response process))
99 (throw 'done nil)) 212 (throw 'done nil))
116 (setq timestamp (vm-parse greeting "[^<]+\\(<[^>]+>\\)") 229 (setq timestamp (vm-parse greeting "[^<]+\\(<[^>]+>\\)")
117 timestamp (car timestamp)) 230 timestamp (car timestamp))
118 (if (null timestamp) 231 (if (null timestamp)
119 (progn 232 (progn
120 (goto-char (point-max)) 233 (goto-char (point-max))
121 (insert "<<< ooops, no timestamp found in greeting! >>>\n") 234 (insert-before-markers "<<< ooops, no timestamp found in greeting! >>>\n")
122 (throw 'done nil))) 235 (throw 'done nil)))
123 (vm-pop-send-command 236 (vm-pop-send-command
124 process 237 process
125 (format "APOP %s %s" 238 (format "APOP %s %s"
126 user 239 user
127 (vm-pop-md5 (concat timestamp pass)))) 240 (vm-pop-md5 (concat timestamp pass))))
128 (and (null (vm-pop-read-response process)) 241 (and (null (vm-pop-read-response process))
129 (throw 'done nil))) 242 (throw 'done nil)))
130 (t (error "Don't know how to authenticate with %s" auth))) 243 (t (error "Don't know how to authenticate with %s" auth)))
131 ;; find out how many messages are in the box. 244 (setq process-to-shutdown nil)
132 (vm-pop-send-command process "STAT") 245 process ))
133 (setq message-count (vm-pop-read-stat-response process)) 246 (if process-to-shutdown
134 ;; forget it if the command fails 247 (vm-pop-end-session process-to-shutdown)))))
135 ;; or if there are no messages present. 248
136 (if (or (null message-count) 249 (defun vm-pop-end-session (process)
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))))))
164
165 (defun vm-pop-process-filter (process output)
166 (save-excursion 250 (save-excursion
167 (set-buffer (process-buffer process)) 251 (set-buffer (process-buffer process))
168 (goto-char (point-max)) 252 (vm-pop-send-command process "QUIT")
169 (insert output))) 253 (vm-pop-read-response process)
254 (if (fboundp 'add-async-timeout)
255 (add-async-timeout 2 'delete-process process)
256 (run-at-time 2 nil 'delete-process process))))
170 257
171 (defun vm-pop-send-command (process command) 258 (defun vm-pop-send-command (process command)
172 (goto-char (point-max)) 259 (goto-char (point-max))
173 (if (= (aref command 0) ?P) 260 (if (= (aref command 0) ?P)
174 (insert "PASS <omitted>\r\n") 261 (insert-before-markers "PASS <omitted>\r\n")
175 (insert command "\r\n")) 262 (insert-before-markers command "\r\n"))
176 (setq vm-pop-read-point (point)) 263 (setq vm-pop-read-point (point))
177 (process-send-string process command) 264 (process-send-string process command)
178 (process-send-string process "\r\n")) 265 (process-send-string process "\r\n"))
179 266
180 (defun vm-pop-read-response (process &optional return-response-string) 267 (defun vm-pop-read-response (process &optional return-response-string)
191 (setq vm-pop-read-point match-end) 278 (setq vm-pop-read-point match-end)
192 (if return-response-string 279 (if return-response-string
193 (buffer-substring (point) match-end) 280 (buffer-substring (point) match-end)
194 t )))) 281 t ))))
195 282
283 (defun vm-pop-read-past-dot-sentinel-line (process)
284 (let ((case-fold-search nil))
285 (goto-char vm-pop-read-point)
286 (while (not (search-forward "^.\r\n" nil 0))
287 (beginning-of-line)
288 ;; save-excursion doesn't work right
289 (let ((opoint (point)))
290 (accept-process-output process)
291 (goto-char opoint)))
292 (setq vm-pop-read-point (point))))
293
196 (defun vm-pop-read-stat-response (process) 294 (defun vm-pop-read-stat-response (process)
295 (let ((response (vm-pop-read-response process t))
296 list)
297 (setq list (vm-parse response "\\([^ ]+\\) *"))
298 (list (string-to-int (nth 1 list)) (string-to-int (nth 2 list)))))
299
300 (defun vm-pop-read-list-response (process)
197 (let ((response (vm-pop-read-response process t))) 301 (let ((response (vm-pop-read-response process t)))
198 (string-to-int (nth 1 (vm-parse response "\\([^ ]+\\) *"))))) 302 (string-to-int (nth 2 (vm-parse response "\\([^ ]+\\) *")))))
303
304 (defun vm-pop-ask-about-large-message (process size n)
305 (let ((work-buffer nil)
306 (pop-buffer (current-buffer))
307 start end)
308 (unwind-protect
309 (save-excursion
310 (save-window-excursion
311 (vm-pop-send-command process (format "TOP %d %d" n 0))
312 (if (vm-pop-read-response process)
313 (progn
314 (setq start vm-pop-read-point)
315 (vm-pop-read-past-dot-sentinel-line process)
316 (setq end vm-pop-read-point)
317 (setq work-buffer (generate-new-buffer "*pop-glop*"))
318 (set-buffer work-buffer)
319 (insert-buffer-substring pop-buffer start end)
320 (forward-line -1)
321 (delete-region (point) (point-max))
322 (vm-pop-cleanup-region (point-min) (point-max))
323 (vm-display-buffer work-buffer)
324 (setq minibuffer-scroll-window (selected-window))
325 (goto-char (point-min))
326 (if (re-search-forward "^Received:" nil t)
327 (progn
328 (goto-char (match-beginning 0))
329 (vm-reorder-message-headers
330 nil vm-visible-headers
331 vm-invisible-header-regexp)))
332 (set-window-point (selected-window) (point))))
333 (if (y-or-n-p (format "Message %d, size = %d, retrieve? " n size))
334 'retrieve
335 (if (y-or-n-p (format "Delete message %d from popdrop? " n size))
336 'delete
337 'skip))))
338 (and work-buffer (kill-buffer work-buffer)))))
199 339
200 (defun vm-pop-retrieve-to-crashbox (process crash) 340 (defun vm-pop-retrieve-to-crashbox (process crash)
201 (let ((start vm-pop-read-point) end) 341 (let ((start vm-pop-read-point) end)
202 (goto-char start) 342 (goto-char start)
203 (while (not (re-search-forward "^\\.\r\n" nil t)) 343 (while (not (re-search-forward "^\\.\r\n" nil 0))
204 (accept-process-output process) 344 (beginning-of-line)
205 (goto-char start)) 345 ;; save-excursion doesn't work right
346 (let ((opoint (point)))
347 (accept-process-output process)
348 (goto-char opoint)))
206 (setq vm-pop-read-point (point-marker)) 349 (setq vm-pop-read-point (point-marker))
207 (goto-char (match-beginning 0)) 350 (goto-char (match-beginning 0))
208 (setq end (point-marker)) 351 (setq end (point-marker))
209 (vm-pop-cleanup-region start end) 352 (vm-pop-cleanup-region start end)
210 ;; Some POP servers strip leading and trailing message 353 ;; Some POP servers strip leading and trailing message