Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-pop.el @ 30:ec9a17fef872 r19-15b98

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b98
author cvs
date Mon, 13 Aug 2007 08:52:29 +0200
parents 441bb1e64a06
children 05472e90ae02
comparison
equal deleted inserted replaced
29:7976500f47f9 30:ec9a17fef872
1 ;;; Simple POP (RFC 1460) client for VM 1 ;;; Simple POP (RFC 1939) client for VM
2 ;;; Copyright (C) 1993, 1994 Kyle E. Jones 2 ;;; Copyright (C) 1993, 1994, 1997 Kyle E. Jones
3 ;;; 3 ;;;
4 ;;; This program is free software; you can redistribute it and/or modify 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 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) 6 ;;; the Free Software Foundation; either version 1, or (at your option)
7 ;;; any later version. 7 ;;; any later version.
30 (condition-case () 30 (condition-case ()
31 (find-file-name-handler source 'vm-pop-move-mail) 31 (find-file-name-handler source 'vm-pop-move-mail)
32 (wrong-number-of-arguments 32 (wrong-number-of-arguments
33 (find-file-name-handler source))))) 33 (find-file-name-handler source)))))
34 (popdrop (vm-safe-popdrop-string source)) 34 (popdrop (vm-safe-popdrop-string source))
35 (statblob nil)
35 mailbox-count mailbox-size message-size response 36 mailbox-count mailbox-size message-size response
36 n retrieved retrieved-bytes process-buffer) 37 n retrieved retrieved-bytes process-buffer)
37 (unwind-protect 38 (unwind-protect
38 (catch 'done 39 (catch 'done
39 (if handler 40 (if handler
56 (< mailbox-count 1)) 57 (< mailbox-count 1))
57 (throw 'done nil)) 58 (throw 'done nil))
58 ;; loop through the maildrop retrieving and deleting 59 ;; loop through the maildrop retrieving and deleting
59 ;; messages as we go. 60 ;; messages as we go.
60 (setq n 1 retrieved 0 retrieved-bytes 0) 61 (setq n 1 retrieved 0 retrieved-bytes 0)
62 (setq statblob (vm-pop-start-status-timer))
63 (vm-set-pop-stat-x-box statblob popdrop)
64 (vm-set-pop-stat-x-maxmsg statblob mailbox-count)
61 (while (and (<= n mailbox-count) 65 (while (and (<= n mailbox-count)
62 (or (not (natnump m-per-session)) 66 (or (not (natnump m-per-session))
63 (< retrieved m-per-session)) 67 (< retrieved m-per-session))
64 (or (not (natnump b-per-session)) 68 (or (not (natnump b-per-session))
65 (< retrieved-bytes b-per-session))) 69 (< retrieved-bytes b-per-session)))
66 (if (or vm-pop-max-message-size 70 (vm-set-pop-stat-x-currmsg statblob n)
67 b-per-session) 71 (vm-pop-send-command process (format "LIST %d" n))
68 (progn 72 (setq message-size (vm-pop-read-list-response process))
69 (vm-pop-send-command process (format "LIST %d" n)) 73 (vm-set-pop-stat-x-need statblob message-size)
70 (setq message-size
71 (vm-pop-read-list-response process))))
72 (if (and (integerp vm-pop-max-message-size) 74 (if (and (integerp vm-pop-max-message-size)
73 (> message-size vm-pop-max-message-size) 75 (> message-size vm-pop-max-message-size)
74 (progn 76 (progn
75 (setq response 77 (setq response
76 (if vm-pop-ok-to-ask 78 (if vm-pop-ok-to-ask
92 (message "Retrieving message %d (of %d) from %s..." 94 (message "Retrieving message %d (of %d) from %s..."
93 n mailbox-count popdrop) 95 n mailbox-count popdrop)
94 (vm-pop-send-command process (format "RETR %d" n)) 96 (vm-pop-send-command process (format "RETR %d" n))
95 (and (null (vm-pop-read-response process)) 97 (and (null (vm-pop-read-response process))
96 (throw 'done (not (equal retrieved 0)))) 98 (throw 'done (not (equal retrieved 0))))
97 (and (null (vm-pop-retrieve-to-crashbox process destination)) 99 (and (null (vm-pop-retrieve-to-crashbox process destination
100 statblob))
98 (throw 'done (not (equal retrieved 0)))) 101 (throw 'done (not (equal retrieved 0))))
99 (vm-increment retrieved) 102 (vm-increment retrieved)
100 (and b-per-session 103 (and b-per-session
101 (setq retrieved-bytes (+ retrieved-bytes message-size))) 104 (setq retrieved-bytes (+ retrieved-bytes message-size)))
102 (vm-pop-send-command process (format "DELE %d" n)) 105 (vm-pop-send-command process (format "DELE %d" n))
105 ;; connection, so... 108 ;; connection, so...
106 (and (null (vm-pop-read-response process)) 109 (and (null (vm-pop-read-response process))
107 (throw 'done (not (equal retrieved 0))))) 110 (throw 'done (not (equal retrieved 0)))))
108 (vm-increment n)) 111 (vm-increment n))
109 (not (equal retrieved 0)) )) 112 (not (equal retrieved 0)) ))
113 (and statblob (vm-pop-stop-status-timer statblob))
110 (if process 114 (if process
111 (vm-pop-end-session process))))) 115 (vm-pop-end-session process)))))
112 116
113 (defun vm-pop-check-mail (source) 117 (defun vm-pop-check-mail (source)
114 (let ((process nil) 118 (let ((process nil)
238 (format "APOP %s %s" 242 (format "APOP %s %s"
239 user 243 user
240 (vm-pop-md5 (concat timestamp pass)))) 244 (vm-pop-md5 (concat timestamp pass))))
241 (and (null (vm-pop-read-response process)) 245 (and (null (vm-pop-read-response process))
242 (throw 'done nil))) 246 (throw 'done nil)))
243 (t (error "Don't know how to authenticate with %s" auth))) 247 (t (error "Don't know how to authenticate using %s" auth)))
244 (setq process-to-shutdown nil) 248 (setq process-to-shutdown nil)
245 process )) 249 process ))
246 (if process-to-shutdown 250 (if process-to-shutdown
247 (vm-pop-end-session process-to-shutdown))))) 251 (vm-pop-end-session process-to-shutdown)))))
248 252
252 (vm-pop-send-command process "QUIT") 256 (vm-pop-send-command process "QUIT")
253 (vm-pop-read-response process) 257 (vm-pop-read-response process)
254 (if (fboundp 'add-async-timeout) 258 (if (fboundp 'add-async-timeout)
255 (add-async-timeout 2 'delete-process process) 259 (add-async-timeout 2 'delete-process process)
256 (run-at-time 2 nil 'delete-process process)))) 260 (run-at-time 2 nil 'delete-process process))))
261
262 (defun vm-pop-stat-timer (o) (aref o 0))
263 (defun vm-pop-stat-x-box (o) (aref o 1))
264 (defun vm-pop-stat-x-currmsg (o) (aref o 2))
265 (defun vm-pop-stat-x-maxmsg (o) (aref o 3))
266 (defun vm-pop-stat-x-got (o) (aref o 4))
267 (defun vm-pop-stat-x-need (o) (aref o 5))
268 (defun vm-pop-stat-y-box (o) (aref o 6))
269 (defun vm-pop-stat-y-currmsg (o) (aref o 7))
270 (defun vm-pop-stat-y-maxmsg (o) (aref o 8))
271 (defun vm-pop-stat-y-got (o) (aref o 9))
272 (defun vm-pop-stat-y-need (o) (aref o 10))
273
274 (defun vm-set-pop-stat-timer (o val) (aset o 0 val))
275 (defun vm-set-pop-stat-x-box (o val) (aset o 1 val))
276 (defun vm-set-pop-stat-x-currmsg (o val) (aset o 2 val))
277 (defun vm-set-pop-stat-x-maxmsg (o val) (aset o 3 val))
278 (defun vm-set-pop-stat-x-got (o val) (aset o 4 val))
279 (defun vm-set-pop-stat-x-need (o val) (aset o 5 val))
280 (defun vm-set-pop-stat-y-box (o val) (aset o 6 val))
281 (defun vm-set-pop-stat-y-currmsg (o val) (aset o 7 val))
282 (defun vm-set-pop-stat-y-maxmsg (o val) (aset o 8 val))
283 (defun vm-set-pop-stat-y-got (o val) (aset o 9 val))
284 (defun vm-set-pop-stat-y-need (o val) (aset o 10 val))
285
286 (defun vm-pop-start-status-timer ()
287 (let ((blob (make-vector 11 nil))
288 timer)
289 (setq timer (add-timeout 5 'vm-pop-report-retrieval-status blob 5))
290 (vm-set-pop-stat-timer blob timer)
291 blob ))
292
293 (defun vm-pop-stop-status-timer (status-blob)
294 (if (fboundp 'disable-timeout)
295 (disable-timeout (vm-pop-stat-timer status-blob))
296 (cancel-timer (vm-pop-stat-timer status-blob))))
297
298 (defun vm-pop-report-retrieval-status (o)
299 (cond ((null (vm-pop-stat-x-got o)) t)
300 ;; should not be possible, but better safe...
301 ((not (eq (vm-pop-stat-x-box o) (vm-pop-stat-y-box o))) t)
302 ((not (eq (vm-pop-stat-x-currmsg o) (vm-pop-stat-y-currmsg o))) t)
303 (t (message "Retrieving message %d (of %d) from %s, %s..."
304 (vm-pop-stat-x-currmsg o)
305 (vm-pop-stat-x-maxmsg o)
306 (vm-pop-stat-x-box o)
307 (format "%d%s of %d%s"
308 (vm-pop-stat-x-got o)
309 (if (> (vm-pop-stat-x-got o)
310 (vm-pop-stat-x-need o))
311 "!"
312 "")
313 (vm-pop-stat-x-need o)
314 (if (eq (vm-pop-stat-x-got o)
315 (vm-pop-stat-y-got o))
316 " (stalled)"
317 "")))))
318 (vm-set-pop-stat-y-box o (vm-pop-stat-x-box o))
319 (vm-set-pop-stat-y-currmsg o (vm-pop-stat-x-currmsg o))
320 (vm-set-pop-stat-y-maxmsg o (vm-pop-stat-x-maxmsg o))
321 (vm-set-pop-stat-y-got o (vm-pop-stat-x-got o))
322 (vm-set-pop-stat-y-need o (vm-pop-stat-x-need o)))
257 323
258 (defun vm-pop-send-command (process command) 324 (defun vm-pop-send-command (process command)
259 (goto-char (point-max)) 325 (goto-char (point-max))
260 (if (= (aref command 0) ?P) 326 (if (= (aref command 0) ?P)
261 (insert-before-markers "PASS <omitted>\r\n") 327 (insert-before-markers "PASS <omitted>\r\n")
281 t )))) 347 t ))))
282 348
283 (defun vm-pop-read-past-dot-sentinel-line (process) 349 (defun vm-pop-read-past-dot-sentinel-line (process)
284 (let ((case-fold-search nil)) 350 (let ((case-fold-search nil))
285 (goto-char vm-pop-read-point) 351 (goto-char vm-pop-read-point)
286 (while (not (search-forward "^.\r\n" nil 0)) 352 (while (not (re-search-forward "^\\.\r\n" nil 0))
287 (beginning-of-line) 353 (beginning-of-line)
288 ;; save-excursion doesn't work right 354 ;; save-excursion doesn't work right
289 (let ((opoint (point))) 355 (let ((opoint (point)))
290 (accept-process-output process) 356 (accept-process-output process)
291 (goto-char opoint))) 357 (goto-char opoint)))
335 (if (y-or-n-p (format "Delete message %d from popdrop? " n size)) 401 (if (y-or-n-p (format "Delete message %d from popdrop? " n size))
336 'delete 402 'delete
337 'skip)))) 403 'skip))))
338 (and work-buffer (kill-buffer work-buffer))))) 404 (and work-buffer (kill-buffer work-buffer)))))
339 405
340 (defun vm-pop-retrieve-to-crashbox (process crash) 406 (defun vm-pop-retrieve-to-crashbox (process crash statblob)
341 (let ((start vm-pop-read-point) end) 407 (let ((start vm-pop-read-point) end)
342 (goto-char start) 408 (goto-char start)
409 (vm-set-pop-stat-x-got statblob 0)
343 (while (not (re-search-forward "^\\.\r\n" nil 0)) 410 (while (not (re-search-forward "^\\.\r\n" nil 0))
344 (beginning-of-line) 411 (beginning-of-line)
345 ;; save-excursion doesn't work right 412 ;; save-excursion doesn't work right
346 (let ((opoint (point))) 413 (let* ((opoint (point))
414 (func
415 (function
416 (lambda (beg end len)
417 (if vm-pop-read-point
418 (progn
419 (vm-set-pop-stat-x-got statblob (- end start))
420 (if (zerop (% (random) 10))
421 (vm-pop-report-retrieval-status statblob)))))))
422 (after-change-functions (cons func after-change-functions)))
347 (accept-process-output process) 423 (accept-process-output process)
348 (goto-char opoint))) 424 (goto-char opoint)))
425 (vm-set-pop-stat-x-got statblob nil)
349 (setq vm-pop-read-point (point-marker)) 426 (setq vm-pop-read-point (point-marker))
350 (goto-char (match-beginning 0)) 427 (goto-char (match-beginning 0))
351 (setq end (point-marker)) 428 (setq end (point-marker))
352 (vm-pop-cleanup-region start end) 429 (vm-pop-cleanup-region start end)
353 ;; Some POP servers strip leading and trailing message 430 ;; Some POP servers strip leading and trailing message
387 (write-region start end crash t 0)) 464 (write-region start end crash t 0))
388 (delete-region start end) 465 (delete-region start end)
389 t )) 466 t ))
390 467
391 (defun vm-pop-cleanup-region (start end) 468 (defun vm-pop-cleanup-region (start end)
469 (if (> (- end start) 30000)
470 (message "CRLF conversion and char unstuffing..."))
392 (setq end (vm-marker end)) 471 (setq end (vm-marker end))
393 (save-excursion 472 (save-excursion
394 (goto-char start) 473 (goto-char start)
395 ;; CRLF -> LF 474 ;; CRLF -> LF
396 (while (and (< (point) end) (search-forward "\r\n" end t)) 475 (while (and (< (point) end) (search-forward "\r\n" end t))
398 (goto-char start) 477 (goto-char start)
399 ;; chop leading dots 478 ;; chop leading dots
400 (while (and (< (point) end) (re-search-forward "^\\." end t)) 479 (while (and (< (point) end) (re-search-forward "^\\." end t))
401 (replace-match "" t t) 480 (replace-match "" t t)
402 (forward-char))) 481 (forward-char)))
482 (if (> (- end start) 30000)
483 (message "CRLF conversion and dot unstuffing... done"))
403 (set-marker end nil)) 484 (set-marker end nil))
404 485
405 (defun vm-pop-md5 (string) 486 (defun vm-pop-md5 (string)
406 (let ((buffer nil)) 487 (let ((buffer nil))
407 (unwind-protect 488 (unwind-protect