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