| 1 | ;;; pop3.el --- Post Office Protocol (RFC 1460) interface |
| 2 | |
| 3 | ;; Copyright (C) 1996-2012 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Richard L. Pieri <ratinox@peorth.gweep.net> |
| 6 | ;; Maintainer: FSF |
| 7 | ;; Keywords: mail |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 12 | ;; it under the terms of the GNU General Public License as published by |
| 13 | ;; the Free Software Foundation, either version 3 of the License, or |
| 14 | ;; (at your option) any later version. |
| 15 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 19 | ;; GNU General Public License for more details. |
| 20 | |
| 21 | ;; You should have received a copy of the GNU General Public License |
| 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 23 | |
| 24 | ;;; Commentary: |
| 25 | |
| 26 | ;; Most of the standard Post Office Protocol version 3 (RFC 1460) commands |
| 27 | ;; are implemented. The LIST command has not been implemented due to lack |
| 28 | ;; of actual usefulness. |
| 29 | ;; The optional POP3 command TOP has not been implemented. |
| 30 | |
| 31 | ;; This program was inspired by Kyle E. Jones's vm-pop program. |
| 32 | |
| 33 | ;;; Code: |
| 34 | |
| 35 | (eval-when-compile (require 'cl)) |
| 36 | |
| 37 | (eval-and-compile |
| 38 | ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for |
| 39 | ;; `make-network-stream'. |
| 40 | (unless (fboundp 'open-protocol-stream) |
| 41 | (require 'proto-stream))) |
| 42 | |
| 43 | (require 'mail-utils) |
| 44 | (defvar parse-time-months) |
| 45 | |
| 46 | (defgroup pop3 nil |
| 47 | "Post Office Protocol." |
| 48 | :group 'mail |
| 49 | :group 'mail-source) |
| 50 | |
| 51 | (defcustom pop3-maildrop (or (user-login-name) |
| 52 | (getenv "LOGNAME") |
| 53 | (getenv "USER")) |
| 54 | "*POP3 maildrop." |
| 55 | :version "22.1" ;; Oort Gnus |
| 56 | :type 'string |
| 57 | :group 'pop3) |
| 58 | |
| 59 | (defcustom pop3-mailhost (or (getenv "MAILHOST") ;; nil -> mismatch |
| 60 | "pop3") |
| 61 | "*POP3 mailhost." |
| 62 | :version "22.1" ;; Oort Gnus |
| 63 | :type 'string |
| 64 | :group 'pop3) |
| 65 | |
| 66 | (defcustom pop3-port 110 |
| 67 | "*POP3 port." |
| 68 | :version "22.1" ;; Oort Gnus |
| 69 | :type 'number |
| 70 | :group 'pop3) |
| 71 | |
| 72 | (defcustom pop3-password-required t |
| 73 | "*Non-nil if a password is required when connecting to POP server." |
| 74 | :version "22.1" ;; Oort Gnus |
| 75 | :type 'boolean |
| 76 | :group 'pop3) |
| 77 | |
| 78 | ;; Should this be customizable? |
| 79 | (defvar pop3-password nil |
| 80 | "*Password to use when connecting to POP server.") |
| 81 | |
| 82 | (defcustom pop3-authentication-scheme 'pass |
| 83 | "*POP3 authentication scheme. |
| 84 | Defaults to `pass', for the standard USER/PASS authentication. The other |
| 85 | valid value is 'apop'." |
| 86 | :type '(choice (const :tag "Normal user/password" pass) |
| 87 | (const :tag "APOP" apop)) |
| 88 | :version "22.1" ;; Oort Gnus |
| 89 | :group 'pop3) |
| 90 | |
| 91 | (defcustom pop3-stream-length 100 |
| 92 | "How many messages should be requested at one time. |
| 93 | The lower the number, the more latency-sensitive the fetching |
| 94 | will be. If your pop3 server doesn't support streaming at all, |
| 95 | set this to 1." |
| 96 | :type 'number |
| 97 | :version "24.1" |
| 98 | :group 'pop3) |
| 99 | |
| 100 | (defcustom pop3-leave-mail-on-server nil |
| 101 | "*Non-nil if the mail is to be left on the POP server after fetching. |
| 102 | |
| 103 | If `pop3-leave-mail-on-server' is non-nil the mail is to be left |
| 104 | on the POP server after fetching. Note that POP servers maintain |
| 105 | no state information between sessions, so what the client |
| 106 | believes is there and what is actually there may not match up. |
| 107 | If they do not, then you may get duplicate mails or the whole |
| 108 | thing can fall apart and leave you with a corrupt mailbox." |
| 109 | ;; We can't use the UILD support from XEmacs mail-lib or cvs.m17n.org: |
| 110 | ;; http://thread.gmane.org/v9lld8fml4.fsf@marauder.physik.uni-ulm.de |
| 111 | ;; http://thread.gmane.org/b9yy8hzy9ej.fsf@jpl.org |
| 112 | ;; Any volunteer to re-implement this? |
| 113 | :version "22.1" ;; Oort Gnus |
| 114 | :type 'boolean |
| 115 | :group 'pop3) |
| 116 | |
| 117 | (defvar pop3-timestamp nil |
| 118 | "Timestamp returned when initially connected to the POP server. |
| 119 | Used for APOP authentication.") |
| 120 | |
| 121 | (defvar pop3-read-point nil) |
| 122 | (defvar pop3-debug nil) |
| 123 | |
| 124 | ;; Borrowed from nnheader-accept-process-output in nnheader.el. See the |
| 125 | ;; comments there for explanations about the values. |
| 126 | |
| 127 | (eval-and-compile |
| 128 | (if (and (fboundp 'nnheader-accept-process-output) |
| 129 | (boundp 'nnheader-read-timeout)) |
| 130 | (defalias 'pop3-accept-process-output 'nnheader-accept-process-output) |
| 131 | ;; Borrowed from `nnheader.el': |
| 132 | (defvar pop3-read-timeout |
| 133 | (if (string-match "windows-nt\\|os/2\\|cygwin" |
| 134 | (symbol-name system-type)) |
| 135 | 1.0 |
| 136 | 0.01) |
| 137 | "How long pop3 should wait between checking for the end of output. |
| 138 | Shorter values mean quicker response, but are more CPU intensive.") |
| 139 | (defun pop3-accept-process-output (process) |
| 140 | (accept-process-output |
| 141 | process |
| 142 | (truncate pop3-read-timeout) |
| 143 | (truncate (* (- pop3-read-timeout |
| 144 | (truncate pop3-read-timeout)) |
| 145 | 1000)))))) |
| 146 | |
| 147 | ;;;###autoload |
| 148 | (defun pop3-movemail (file) |
| 149 | "Transfer contents of a maildrop to the specified FILE. |
| 150 | Use streaming commands." |
| 151 | (let* ((process (pop3-open-server pop3-mailhost pop3-port)) |
| 152 | message-count message-total-size) |
| 153 | (pop3-logon process) |
| 154 | (with-current-buffer (process-buffer process) |
| 155 | (let ((size (pop3-stat process))) |
| 156 | (setq message-count (car size) |
| 157 | message-total-size (cadr size))) |
| 158 | (when (> message-count 0) |
| 159 | (pop3-send-streaming-command |
| 160 | process "RETR" message-count message-total-size) |
| 161 | (pop3-write-to-file file) |
| 162 | (unless pop3-leave-mail-on-server |
| 163 | (pop3-send-streaming-command |
| 164 | process "DELE" message-count nil)))) |
| 165 | (pop3-quit process) |
| 166 | t)) |
| 167 | |
| 168 | (defun pop3-send-streaming-command (process command count total-size) |
| 169 | (erase-buffer) |
| 170 | (let ((i 1) |
| 171 | (start-point (point-min)) |
| 172 | (waited-for 0)) |
| 173 | (while (>= count i) |
| 174 | (process-send-string process (format "%s %d\r\n" command i)) |
| 175 | ;; Only do 100 messages at a time to avoid pipe stalls. |
| 176 | (when (zerop (% i pop3-stream-length)) |
| 177 | (setq start-point |
| 178 | (pop3-wait-for-messages process pop3-stream-length |
| 179 | total-size start-point)) |
| 180 | (incf waited-for pop3-stream-length)) |
| 181 | (incf i)) |
| 182 | (pop3-wait-for-messages process (- count waited-for) |
| 183 | total-size start-point))) |
| 184 | |
| 185 | (defun pop3-wait-for-messages (process count total-size start-point) |
| 186 | (while (> count 0) |
| 187 | (goto-char start-point) |
| 188 | (while (or (and (re-search-forward "^\\+OK" nil t) |
| 189 | (or (not total-size) |
| 190 | (re-search-forward "^\\.\r?\n" nil t))) |
| 191 | (re-search-forward "^-ERR " nil t)) |
| 192 | (decf count) |
| 193 | (setq start-point (point))) |
| 194 | (unless (memq (process-status process) '(open run)) |
| 195 | (error "pop3 process died")) |
| 196 | (when total-size |
| 197 | (message "pop3 retrieved %dKB (%d%%)" |
| 198 | (truncate (/ (buffer-size) 1000)) |
| 199 | (truncate (* (/ (* (buffer-size) 1.0) |
| 200 | total-size) 100)))) |
| 201 | (pop3-accept-process-output process)) |
| 202 | start-point) |
| 203 | |
| 204 | (defun pop3-write-to-file (file) |
| 205 | (let ((pop-buffer (current-buffer)) |
| 206 | (start (point-min)) |
| 207 | beg end |
| 208 | temp-buffer) |
| 209 | (with-temp-buffer |
| 210 | (setq temp-buffer (current-buffer)) |
| 211 | (with-current-buffer pop-buffer |
| 212 | (goto-char (point-min)) |
| 213 | (while (re-search-forward "^\\+OK" nil t) |
| 214 | (forward-line 1) |
| 215 | (setq beg (point)) |
| 216 | (when (re-search-forward "^\\.\r?\n" nil t) |
| 217 | (setq start (point)) |
| 218 | (forward-line -1) |
| 219 | (setq end (point))) |
| 220 | (with-current-buffer temp-buffer |
| 221 | (goto-char (point-max)) |
| 222 | (let ((hstart (point))) |
| 223 | (insert-buffer-substring pop-buffer beg end) |
| 224 | (pop3-clean-region hstart (point)) |
| 225 | (goto-char (point-max)) |
| 226 | (pop3-munge-message-separator hstart (point)) |
| 227 | (goto-char (point-max)))))) |
| 228 | (let ((coding-system-for-write 'binary)) |
| 229 | (goto-char (point-min)) |
| 230 | ;; Check whether something inserted a newline at the start and |
| 231 | ;; delete it. |
| 232 | (when (eolp) |
| 233 | (delete-char 1)) |
| 234 | (write-region (point-min) (point-max) file nil 'nomesg))))) |
| 235 | |
| 236 | (defun pop3-logon (process) |
| 237 | (let ((pop3-password pop3-password)) |
| 238 | ;; for debugging only |
| 239 | (if pop3-debug (switch-to-buffer (process-buffer process))) |
| 240 | ;; query for password |
| 241 | (if (and pop3-password-required (not pop3-password)) |
| 242 | (setq pop3-password |
| 243 | (read-passwd (format "Password for %s: " pop3-maildrop)))) |
| 244 | (cond ((equal 'apop pop3-authentication-scheme) |
| 245 | (pop3-apop process pop3-maildrop)) |
| 246 | ((equal 'pass pop3-authentication-scheme) |
| 247 | (pop3-user process pop3-maildrop) |
| 248 | (pop3-pass process)) |
| 249 | (t (error "Invalid POP3 authentication scheme"))))) |
| 250 | |
| 251 | (defun pop3-get-message-count () |
| 252 | "Return the number of messages in the maildrop." |
| 253 | (let* ((process (pop3-open-server pop3-mailhost pop3-port)) |
| 254 | message-count |
| 255 | (pop3-password pop3-password)) |
| 256 | ;; for debugging only |
| 257 | (if pop3-debug (switch-to-buffer (process-buffer process))) |
| 258 | ;; query for password |
| 259 | (if (and pop3-password-required (not pop3-password)) |
| 260 | (setq pop3-password |
| 261 | (read-passwd (format "Password for %s: " pop3-maildrop)))) |
| 262 | (cond ((equal 'apop pop3-authentication-scheme) |
| 263 | (pop3-apop process pop3-maildrop)) |
| 264 | ((equal 'pass pop3-authentication-scheme) |
| 265 | (pop3-user process pop3-maildrop) |
| 266 | (pop3-pass process)) |
| 267 | (t (error "Invalid POP3 authentication scheme"))) |
| 268 | (setq message-count (car (pop3-stat process))) |
| 269 | (pop3-quit process) |
| 270 | message-count)) |
| 271 | |
| 272 | (defcustom pop3-stream-type nil |
| 273 | "*Transport security type for POP3 connections. |
| 274 | This may be either nil (plain connection), `ssl' (use an |
| 275 | SSL/TSL-secured stream) or `starttls' (use the starttls mechanism |
| 276 | to turn on TLS security after opening the stream). However, if |
| 277 | this is nil, `ssl' is assumed for connections to port |
| 278 | 995 (pop3s)." |
| 279 | :version "23.1" ;; No Gnus |
| 280 | :group 'pop3 |
| 281 | :type '(choice (const :tag "Plain" nil) |
| 282 | (const :tag "SSL/TLS" ssl) |
| 283 | (const starttls))) |
| 284 | |
| 285 | (eval-and-compile |
| 286 | (if (fboundp 'set-process-query-on-exit-flag) |
| 287 | (defalias 'pop3-set-process-query-on-exit-flag |
| 288 | 'set-process-query-on-exit-flag) |
| 289 | (defalias 'pop3-set-process-query-on-exit-flag |
| 290 | 'process-kill-without-query))) |
| 291 | |
| 292 | (defun pop3-open-server (mailhost port) |
| 293 | "Open TCP connection to MAILHOST on PORT. |
| 294 | Returns the process associated with the connection." |
| 295 | (let ((coding-system-for-read 'binary) |
| 296 | (coding-system-for-write 'binary) |
| 297 | result) |
| 298 | (with-current-buffer |
| 299 | (get-buffer-create (concat " trace of POP session to " |
| 300 | mailhost)) |
| 301 | (erase-buffer) |
| 302 | (setq pop3-read-point (point-min)) |
| 303 | (setq result |
| 304 | (open-protocol-stream |
| 305 | "POP" (current-buffer) mailhost port |
| 306 | :type (cond |
| 307 | ((or (eq pop3-stream-type 'ssl) |
| 308 | (and (not pop3-stream-type) |
| 309 | (member port '(995 "pop3s")))) |
| 310 | 'tls) |
| 311 | (t |
| 312 | (or pop3-stream-type 'network))) |
| 313 | :capability-command "CAPA\r\n" |
| 314 | :end-of-command "^\\(-ERR\\|+OK\\).*\n" |
| 315 | :end-of-capability "^\\.\r?\n\\|^-ERR" |
| 316 | :success "^\\+OK.*\n" |
| 317 | :return-list t |
| 318 | :starttls-function |
| 319 | (lambda (capabilities) |
| 320 | (and (string-match "\\bSTLS\\b" capabilities) |
| 321 | "STLS\r\n")))) |
| 322 | (when result |
| 323 | (let ((response (plist-get (cdr result) :greeting))) |
| 324 | (setq pop3-timestamp |
| 325 | (substring response (or (string-match "<" response) 0) |
| 326 | (+ 1 (or (string-match ">" response) -1))))) |
| 327 | (pop3-set-process-query-on-exit-flag (car result) nil) |
| 328 | (erase-buffer) |
| 329 | (car result))))) |
| 330 | |
| 331 | ;; Support functions |
| 332 | |
| 333 | (defun pop3-send-command (process command) |
| 334 | (set-buffer (process-buffer process)) |
| 335 | (goto-char (point-max)) |
| 336 | ;; (if (= (aref command 0) ?P) |
| 337 | ;; (insert "PASS <omitted>\r\n") |
| 338 | ;; (insert command "\r\n")) |
| 339 | (setq pop3-read-point (point)) |
| 340 | (goto-char (point-max)) |
| 341 | (process-send-string process (concat command "\r\n"))) |
| 342 | |
| 343 | (defun pop3-read-response (process &optional return) |
| 344 | "Read the response from the server. |
| 345 | Return the response string if optional second argument is non-nil." |
| 346 | (let ((case-fold-search nil) |
| 347 | match-end) |
| 348 | (with-current-buffer (process-buffer process) |
| 349 | (goto-char pop3-read-point) |
| 350 | (while (and (memq (process-status process) '(open run)) |
| 351 | (not (search-forward "\r\n" nil t))) |
| 352 | (pop3-accept-process-output process) |
| 353 | (goto-char pop3-read-point)) |
| 354 | (setq match-end (point)) |
| 355 | (goto-char pop3-read-point) |
| 356 | (if (looking-at "-ERR") |
| 357 | (error "%s" (buffer-substring (point) (- match-end 2))) |
| 358 | (if (not (looking-at "+OK")) |
| 359 | (progn (setq pop3-read-point match-end) nil) |
| 360 | (setq pop3-read-point match-end) |
| 361 | (if return |
| 362 | (buffer-substring (point) match-end) |
| 363 | t) |
| 364 | ))))) |
| 365 | |
| 366 | (defun pop3-clean-region (start end) |
| 367 | (setq end (set-marker (make-marker) end)) |
| 368 | (save-excursion |
| 369 | (goto-char start) |
| 370 | (while (and (< (point) end) (search-forward "\r\n" end t)) |
| 371 | (replace-match "\n" t t)) |
| 372 | (goto-char start) |
| 373 | (while (and (< (point) end) (re-search-forward "^\\." end t)) |
| 374 | (replace-match "" t t) |
| 375 | (forward-char))) |
| 376 | (set-marker end nil)) |
| 377 | |
| 378 | ;; Copied from message-make-date. |
| 379 | (defun pop3-make-date (&optional now) |
| 380 | "Make a valid date header. |
| 381 | If NOW, use that time instead." |
| 382 | (require 'parse-time) |
| 383 | (let* ((now (or now (current-time))) |
| 384 | (zone (nth 8 (decode-time now))) |
| 385 | (sign "+")) |
| 386 | (when (< zone 0) |
| 387 | (setq sign "-") |
| 388 | (setq zone (- zone))) |
| 389 | (concat |
| 390 | (format-time-string "%d" now) |
| 391 | ;; The month name of the %b spec is locale-specific. Pfff. |
| 392 | (format " %s " |
| 393 | (capitalize (car (rassoc (nth 4 (decode-time now)) |
| 394 | parse-time-months)))) |
| 395 | (format-time-string "%Y %H:%M:%S " now) |
| 396 | ;; We do all of this because XEmacs doesn't have the %z spec. |
| 397 | (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60))))) |
| 398 | |
| 399 | (defun pop3-munge-message-separator (start end) |
| 400 | "Check to see if a message separator exists. If not, generate one." |
| 401 | (save-excursion |
| 402 | (save-restriction |
| 403 | (narrow-to-region start end) |
| 404 | (goto-char (point-min)) |
| 405 | (if (not (or (looking-at "From .?") ; Unix mail |
| 406 | (looking-at "\001\001\001\001\n") ; MMDF |
| 407 | (looking-at "BABYL OPTIONS:") ; Babyl |
| 408 | )) |
| 409 | (let* ((from (mail-strip-quoted-names (mail-fetch-field "From"))) |
| 410 | (tdate (mail-fetch-field "Date")) |
| 411 | (date (split-string (or (and tdate |
| 412 | (not (string= "" tdate)) |
| 413 | tdate) |
| 414 | (pop3-make-date)) |
| 415 | " ")) |
| 416 | (From_)) |
| 417 | ;; sample date formats I have seen |
| 418 | ;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT) |
| 419 | ;; Date: 08 Jul 1996 23:22:24 -0400 |
| 420 | ;; should be |
| 421 | ;; Tue Jul 9 09:04:21 1996 |
| 422 | |
| 423 | ;; Fixme: This should use timezone on the date field contents. |
| 424 | (setq date |
| 425 | (cond ((not date) |
| 426 | "Tue Jan 1 00:00:0 1900") |
| 427 | ((string-match "[A-Z]" (nth 0 date)) |
| 428 | (format "%s %s %s %s %s" |
| 429 | (nth 0 date) (nth 2 date) (nth 1 date) |
| 430 | (nth 4 date) (nth 3 date))) |
| 431 | (t |
| 432 | ;; this really needs to be better but I don't feel |
| 433 | ;; like writing a date to day converter. |
| 434 | (format "Sun %s %s %s %s" |
| 435 | (nth 1 date) (nth 0 date) |
| 436 | (nth 3 date) (nth 2 date))) |
| 437 | )) |
| 438 | (setq From_ (format "\nFrom %s %s\n" from date)) |
| 439 | (while (string-match "," From_) |
| 440 | (setq From_ (concat (substring From_ 0 (match-beginning 0)) |
| 441 | (substring From_ (match-end 0))))) |
| 442 | (goto-char (point-min)) |
| 443 | (insert From_) |
| 444 | (if (search-forward "\n\n" nil t) |
| 445 | nil |
| 446 | (goto-char (point-max)) |
| 447 | (insert "\n")) |
| 448 | (let ((size (- (point-max) (point)))) |
| 449 | (forward-line -1) |
| 450 | (insert (format "Content-Length: %s\n" size))) |
| 451 | ))))) |
| 452 | |
| 453 | ;; The Command Set |
| 454 | |
| 455 | ;; AUTHORIZATION STATE |
| 456 | |
| 457 | (defun pop3-user (process user) |
| 458 | "Send USER information to POP3 server." |
| 459 | (pop3-send-command process (format "USER %s" user)) |
| 460 | (let ((response (pop3-read-response process t))) |
| 461 | (if (not (and response (string-match "+OK" response))) |
| 462 | (error "USER %s not valid" user)))) |
| 463 | |
| 464 | (defun pop3-pass (process) |
| 465 | "Send authentication information to the server." |
| 466 | (pop3-send-command process (format "PASS %s" pop3-password)) |
| 467 | (let ((response (pop3-read-response process t))) |
| 468 | (if (not (and response (string-match "+OK" response))) |
| 469 | (pop3-quit process)))) |
| 470 | |
| 471 | (defun pop3-apop (process user) |
| 472 | "Send alternate authentication information to the server." |
| 473 | (let ((pass pop3-password)) |
| 474 | (if (and pop3-password-required (not pass)) |
| 475 | (setq pass |
| 476 | (read-passwd (format "Password for %s: " pop3-maildrop)))) |
| 477 | (if pass |
| 478 | (let ((hash (md5 (concat pop3-timestamp pass) nil nil 'binary))) |
| 479 | (pop3-send-command process (format "APOP %s %s" user hash)) |
| 480 | (let ((response (pop3-read-response process t))) |
| 481 | (if (not (and response (string-match "+OK" response))) |
| 482 | (pop3-quit process))))) |
| 483 | )) |
| 484 | |
| 485 | ;; TRANSACTION STATE |
| 486 | |
| 487 | (defun pop3-stat (process) |
| 488 | "Return the number of messages in the maildrop and the maildrop's size." |
| 489 | (pop3-send-command process "STAT") |
| 490 | (let ((response (pop3-read-response process t))) |
| 491 | (list (string-to-number (nth 1 (split-string response " "))) |
| 492 | (string-to-number (nth 2 (split-string response " ")))) |
| 493 | )) |
| 494 | |
| 495 | (defun pop3-list (process &optional msg) |
| 496 | "If MSG is nil, return an alist of (MESSAGE-ID . SIZE) pairs. |
| 497 | Otherwise, return the size of the message-id MSG" |
| 498 | (pop3-send-command process (if msg |
| 499 | (format "LIST %d" msg) |
| 500 | "LIST")) |
| 501 | (let ((response (pop3-read-response process t))) |
| 502 | (if msg |
| 503 | (string-to-number (nth 2 (split-string response " "))) |
| 504 | (let ((start pop3-read-point) end) |
| 505 | (with-current-buffer (process-buffer process) |
| 506 | (while (not (re-search-forward "^\\.\r\n" nil t)) |
| 507 | (pop3-accept-process-output process) |
| 508 | (goto-char start)) |
| 509 | (setq pop3-read-point (point-marker)) |
| 510 | (goto-char (match-beginning 0)) |
| 511 | (setq end (point-marker)) |
| 512 | (mapcar #'(lambda (s) (let ((split (split-string s " "))) |
| 513 | (cons (string-to-number (nth 0 split)) |
| 514 | (string-to-number (nth 1 split))))) |
| 515 | (split-string (buffer-substring start end) "\r\n" t))))))) |
| 516 | |
| 517 | (defun pop3-retr (process msg crashbuf) |
| 518 | "Retrieve message-id MSG to buffer CRASHBUF." |
| 519 | (pop3-send-command process (format "RETR %s" msg)) |
| 520 | (pop3-read-response process) |
| 521 | (let ((start pop3-read-point) end) |
| 522 | (with-current-buffer (process-buffer process) |
| 523 | (while (not (re-search-forward "^\\.\r\n" nil t)) |
| 524 | (unless (memq (process-status process) '(open run)) |
| 525 | (error "pop3 server closed the connection")) |
| 526 | (pop3-accept-process-output process) |
| 527 | (goto-char start)) |
| 528 | (setq pop3-read-point (point-marker)) |
| 529 | ;; this code does not seem to work for some POP servers... |
| 530 | ;; and I cannot figure out why not. |
| 531 | ;; (goto-char (match-beginning 0)) |
| 532 | ;; (backward-char 2) |
| 533 | ;; (if (not (looking-at "\r\n")) |
| 534 | ;; (insert "\r\n")) |
| 535 | ;; (re-search-forward "\\.\r\n") |
| 536 | (goto-char (match-beginning 0)) |
| 537 | (setq end (point-marker)) |
| 538 | (pop3-clean-region start end) |
| 539 | (pop3-munge-message-separator start end) |
| 540 | (with-current-buffer crashbuf |
| 541 | (erase-buffer)) |
| 542 | (copy-to-buffer crashbuf start end) |
| 543 | (delete-region start end) |
| 544 | ))) |
| 545 | |
| 546 | (defun pop3-dele (process msg) |
| 547 | "Mark message-id MSG as deleted." |
| 548 | (pop3-send-command process (format "DELE %s" msg)) |
| 549 | (pop3-read-response process)) |
| 550 | |
| 551 | (defun pop3-noop (process msg) |
| 552 | "No-operation." |
| 553 | (pop3-send-command process "NOOP") |
| 554 | (pop3-read-response process)) |
| 555 | |
| 556 | (defun pop3-last (process) |
| 557 | "Return highest accessed message-id number for the session." |
| 558 | (pop3-send-command process "LAST") |
| 559 | (let ((response (pop3-read-response process t))) |
| 560 | (string-to-number (nth 1 (split-string response " "))) |
| 561 | )) |
| 562 | |
| 563 | (defun pop3-rset (process) |
| 564 | "Remove all delete marks from current maildrop." |
| 565 | (pop3-send-command process "RSET") |
| 566 | (pop3-read-response process)) |
| 567 | |
| 568 | ;; UPDATE |
| 569 | |
| 570 | (defun pop3-quit (process) |
| 571 | "Close connection to POP3 server. |
| 572 | Tell server to remove all messages marked as deleted, unlock the maildrop, |
| 573 | and close the connection." |
| 574 | (pop3-send-command process "QUIT") |
| 575 | (pop3-read-response process t) |
| 576 | (if process |
| 577 | (with-current-buffer (process-buffer process) |
| 578 | (goto-char (point-max)) |
| 579 | (delete-process process)))) |
| 580 | \f |
| 581 | ;; Summary of POP3 (Post Office Protocol version 3) commands and responses |
| 582 | |
| 583 | ;;; AUTHORIZATION STATE |
| 584 | |
| 585 | ;; Initial TCP connection |
| 586 | ;; Arguments: none |
| 587 | ;; Restrictions: none |
| 588 | ;; Possible responses: |
| 589 | ;; +OK [POP3 server ready] |
| 590 | |
| 591 | ;; USER name |
| 592 | ;; Arguments: a server specific user-id (required) |
| 593 | ;; Restrictions: authorization state [after unsuccessful USER or PASS |
| 594 | ;; Possible responses: |
| 595 | ;; +OK [valid user-id] |
| 596 | ;; -ERR [invalid user-id] |
| 597 | |
| 598 | ;; PASS string |
| 599 | ;; Arguments: a server/user-id specific password (required) |
| 600 | ;; Restrictions: authorization state, after successful USER |
| 601 | ;; Possible responses: |
| 602 | ;; +OK [maildrop locked and ready] |
| 603 | ;; -ERR [invalid password] |
| 604 | ;; -ERR [unable to lock maildrop] |
| 605 | |
| 606 | ;; STLS (RFC 2595) |
| 607 | ;; Arguments: none |
| 608 | ;; Restrictions: Only permitted in AUTHORIZATION state. |
| 609 | ;; Possible responses: |
| 610 | ;; +OK |
| 611 | ;; -ERR |
| 612 | |
| 613 | ;;; TRANSACTION STATE |
| 614 | |
| 615 | ;; STAT |
| 616 | ;; Arguments: none |
| 617 | ;; Restrictions: transaction state |
| 618 | ;; Possible responses: |
| 619 | ;; +OK nn mm [# of messages, size of maildrop] |
| 620 | |
| 621 | ;; LIST [msg] |
| 622 | ;; Arguments: a message-id (optional) |
| 623 | ;; Restrictions: transaction state; msg must not be deleted |
| 624 | ;; Possible responses: |
| 625 | ;; +OK [scan listing follows] |
| 626 | ;; -ERR [no such message] |
| 627 | |
| 628 | ;; RETR msg |
| 629 | ;; Arguments: a message-id (required) |
| 630 | ;; Restrictions: transaction state; msg must not be deleted |
| 631 | ;; Possible responses: |
| 632 | ;; +OK [message contents follow] |
| 633 | ;; -ERR [no such message] |
| 634 | |
| 635 | ;; DELE msg |
| 636 | ;; Arguments: a message-id (required) |
| 637 | ;; Restrictions: transaction state; msg must not be deleted |
| 638 | ;; Possible responses: |
| 639 | ;; +OK [message deleted] |
| 640 | ;; -ERR [no such message] |
| 641 | |
| 642 | ;; NOOP |
| 643 | ;; Arguments: none |
| 644 | ;; Restrictions: transaction state |
| 645 | ;; Possible responses: |
| 646 | ;; +OK |
| 647 | |
| 648 | ;; LAST |
| 649 | ;; Arguments: none |
| 650 | ;; Restrictions: transaction state |
| 651 | ;; Possible responses: |
| 652 | ;; +OK nn [highest numbered message accessed] |
| 653 | |
| 654 | ;; RSET |
| 655 | ;; Arguments: none |
| 656 | ;; Restrictions: transaction state |
| 657 | ;; Possible responses: |
| 658 | ;; +OK [all delete marks removed] |
| 659 | |
| 660 | ;;; UPDATE STATE |
| 661 | |
| 662 | ;; QUIT |
| 663 | ;; Arguments: none |
| 664 | ;; Restrictions: none |
| 665 | ;; Possible responses: |
| 666 | ;; +OK [TCP connection closed] |
| 667 | |
| 668 | (provide 'pop3) |
| 669 | |
| 670 | ;;; pop3.el ends here |