Mercurial > hg > xemacs-beta
comparison lisp/vm/vm-pop.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | 859a2309aef8 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;;; Simple POP (RFC 1460) client for VM | |
| 2 ;;; Copyright (C) 1993, 1994 Kyle E. Jones | |
| 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)) | |
| 33 greeting timestamp n message-count | |
| 34 host port auth user pass source-list process-buffer) | |
| 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 (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)))) | |
| 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)) | |
| 87 (set-process-filter process 'vm-pop-process-filter) | |
| 88 (save-excursion | |
| 89 (set-buffer process-buffer) | |
| 90 (make-local-variable 'vm-pop-read-point) | |
| 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)) | |
| 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)) | |
| 121 (insert "<<< ooops, no timestamp found in greeting! >>>\n") | |
| 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))) | |
| 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)))))) | |
| 164 | |
| 165 (defun vm-pop-process-filter (process output) | |
| 166 (save-excursion | |
| 167 (set-buffer (process-buffer process)) | |
| 168 (goto-char (point-max)) | |
| 169 (insert output))) | |
| 170 | |
| 171 (defun vm-pop-send-command (process command) | |
| 172 (goto-char (point-max)) | |
| 173 (if (= (aref command 0) ?P) | |
| 174 (insert "PASS <omitted>\r\n") | |
| 175 (insert command "\r\n")) | |
| 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))) | |
| 198 (string-to-int (nth 1 (vm-parse response "\\([^ ]+\\) *"))))) | |
| 199 | |
| 200 (defun vm-pop-retrieve-to-crashbox (process crash) | |
| 201 (let ((start vm-pop-read-point) end) | |
| 202 (goto-char start) | |
| 203 (while (not (re-search-forward "^\\.\r\n" nil t)) | |
| 204 (accept-process-output process) | |
| 205 (goto-char start)) | |
| 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)))) | |
| 238 (write-region start end crash t 0) | |
| 239 (delete-region start end) | |
| 240 t )) | |
| 241 | |
| 242 (defun vm-pop-cleanup-region (start end) | |
| 243 (setq end (vm-marker end)) | |
| 244 (save-excursion | |
| 245 (goto-char start) | |
| 246 ;; CRLF -> LF | |
| 247 (while (and (< (point) end) (search-forward "\r\n" end t)) | |
| 248 (replace-match "\n" t t)) | |
| 249 (goto-char start) | |
| 250 ;; chop leading dots | |
| 251 (while (and (< (point) end) (re-search-forward "^\\." end t)) | |
| 252 (replace-match "" t t) | |
| 253 (forward-char))) | |
| 254 (set-marker end nil)) | |
| 255 | |
| 256 (defun vm-pop-md5 (string) | |
| 257 (let ((buffer nil)) | |
| 258 (unwind-protect | |
| 259 (save-excursion | |
| 260 (setq buffer (generate-new-buffer "*vm-work*")) | |
| 261 (set-buffer buffer) | |
| 262 (insert string) | |
| 263 (call-process-region (point-min) (point-max) | |
| 264 "/bin/sh" t buffer nil | |
| 265 "-c" vm-pop-md5-program) | |
| 266 ;; MD5 digest is 32 chars long | |
| 267 ;; mddriver adds a newline to make neaten output for tty | |
| 268 ;; viewing, make sure we leave it behind. | |
| 269 (vm-buffer-substring-no-properties (point-min) (+ (point-min) 32))) | |
| 270 (and buffer (kill-buffer buffer))))) |