cgit.sxemacs.org Git - gnus/blob - lisp/pop3.el

   1 ;;; pop3.el --- Post Office Protocol (RFC 1460) interface\r
   2 \r
   3 ;; Copyright (C) 1996, Free Software Foundation, Inc.\r
   4 \r
   5 ;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>\r
   6 ;; Keywords: mail, pop3\r
   7 ;; Version: 1.3c\r
   8 \r
   9 ;; This file is part of GNU Emacs.\r
  10 \r
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify\r
  12 ;; it under the terms of the GNU General Public License as published by\r
  13 ;; the Free Software Foundation; either version 2, or (at your option)\r
  14 ;; any later version.\r
  15 \r
  16 ;; GNU Emacs is distributed in the hope that it will be useful,\r
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of\r
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\r
  19 ;; GNU General Public License for more details.\r
  20 \r
  21 ;; You should have received a copy of the GNU General Public License\r
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the\r
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,\r
  24 ;; Boston, MA 02111-1307, USA.\r
  25 \r
  26 ;;; Commentary:\r
  27 \r
  28 ;; Most of the standard Post Office Protocol version 3 (RFC 1460) commands\r
  29 ;; are implemented.  The LIST command has not been implemented due to lack\r
  30 ;; of actual usefulness.\r
  31 ;; The optional POP3 command TOP has not been implemented.\r
  32 \r
  33 ;; This program was inspired by Kyle E. Jones's vm-pop program.\r
  34 \r
  35 ;;; Code:\r
  36 \r
  37 (require 'mail-utils)\r
  38 (provide 'pop3)\r
  39 \r
  40 (defvar pop3-maildrop (or user-login-name (getenv "LOGNAME") (getenv "USER") nil)\r
  41   "*POP3 maildrop.")\r
  42 (defvar pop3-mailhost (or (getenv "MAILHOST") nil)\r
  43   "*POP3 mailhost.")\r
  44 (defvar pop3-port 110\r
  45   "*POP3 port.")\r
  46 \r
  47 (defvar pop3-password-required t\r
  48   "*Non-nil if a password is required when connecting to POP server.")\r
  49 (defvar pop3-password nil\r
  50   "*Password to use when connecting to POP server.")\r
  51 \r
  52 (defvar pop3-authentication-scheme 'pass\r
  53   "*POP3 authentication scheme.\r
  54 Defaults to 'pass, for the standard USER/PASS authentication.  Other valid\r
  55 values are 'apop.")\r
  56 \r
  57 (defvar pop3-timestamp nil\r
  58   "Timestamp returned when initially connected to the POP server.\r
  59 Used for APOP authentication.")\r
  60 \r
  61 (defvar pop3-read-point nil)\r
  62 (defvar pop3-debug nil)\r
  63 \r
  64 (defun pop3-movemail (&optional crashbox)\r
  65   "Transfer contents of a maildrop to the specified CRASHBOX."\r
  66   (or crashbox (setq crashbox (expand-file-name "~/.crashbox")))\r
  67   (let* ((process (pop3-open-server pop3-mailhost pop3-port))\r
  68          (crashbuf (get-buffer-create " *pop3-retr*"))\r
  69          (n 1)\r
  70          message-count)\r
  71     ;; for debugging only\r
  72     (if pop3-debug (switch-to-buffer (process-buffer process)))\r
  73     (cond ((equal 'apop pop3-authentication-scheme)\r
  74            (pop3-apop process pop3-maildrop))\r
  75           ((equal 'pass pop3-authentication-scheme)\r
  76            (pop3-user process pop3-maildrop)\r
  77            (pop3-pass process))\r
  78           (t (error "Invalid POP3 authentication scheme.")))\r
  79     (setq message-count (car (pop3-stat process)))\r
  80     (while (<= n message-count)\r
  81       (message (format "Retrieving message %d of %d from %s..."\r
  82                        n message-count pop3-mailhost))\r
  83       (pop3-retr process n crashbuf)\r
  84       (save-excursion\r
  85         (set-buffer crashbuf)\r
  86         (append-to-file (point-min) (point-max) crashbox)\r
  87         (set-buffer (process-buffer process))\r
  88         (while (> (buffer-size) 5000)\r
  89           (goto-char (point-min))\r
  90           (forward-line 50)\r
  91           (delete-region (point-min) (point))))\r
  92       (pop3-dele process n)\r
  93       (setq n (+ 1 n))\r
  94       (if pop3-debug (sit-for 1) (sit-for 0.1))\r
  95       )\r
  96     (pop3-quit process)\r
  97     (kill-buffer crashbuf)\r
  98     )\r
  99   )\r
 100 \r
 101 (defun pop3-open-server (mailhost port)\r
 102   "Open TCP connection to MAILHOST.\r
 103 Returns the process associated with the connection."\r
 104   (let ((process-buffer\r
 105          (get-buffer-create (format "trace of POP session to %s" mailhost)))\r
 106         (process))\r
 107     (save-excursion\r
 108       (set-buffer process-buffer)\r
 109       (erase-buffer))\r
 110     (setq process\r
 111           (open-network-stream "POP" process-buffer mailhost port))\r
 112     (setq pop3-read-point (point-min))\r
 113     (let ((response (pop3-read-response process t)))\r
 114       (setq pop3-timestamp\r
 115             (substring response (or (string-match "<" response) 0)\r
 116                        (+ 1 (or (string-match ">" response) -1)))))\r
 117     process\r
 118     ))\r
 119 \r
 120 ;; Support functions\r
 121 \r
 122 (defun pop3-process-filter (process output)\r
 123   (save-excursion\r
 124     (set-buffer (process-buffer process))\r
 125     (goto-char (point-max))\r
 126     (insert output)))\r
 127 \r
 128 (defun pop3-send-command (process command)\r
 129     (set-buffer (process-buffer process))\r
 130     (goto-char (point-max))\r
 131 ;;    (if (= (aref command 0) ?P)\r
 132 ;;      (insert "PASS <omitted>\r\n")\r
 133 ;;      (insert command "\r\n"))\r
 134     (setq pop3-read-point (point))\r
 135     (goto-char (point-max))\r
 136     (process-send-string process command)\r
 137     (process-send-string process "\r\n")\r
 138     )\r
 139 \r
 140 (defun pop3-read-response (process &optional return)\r
 141   "Read the response from the server.\r
 142 Return the response string if optional second argument is non-nil."\r
 143   (let ((case-fold-search nil)\r
 144         match-end)\r
 145     (save-excursion\r
 146       (set-buffer (process-buffer process))\r
 147       (goto-char pop3-read-point)\r
 148       (while (not (search-forward "\r\n" nil t))\r
 149         (accept-process-output process)\r
 150         (goto-char pop3-read-point))\r
 151       (setq match-end (point))\r
 152       (goto-char pop3-read-point)\r
 153       (if (looking-at "-ERR")\r
 154           (error (buffer-substring (point) (- match-end 2)))\r
 155         (if (not (looking-at "+OK"))\r
 156             (progn (setq pop3-read-point match-end) nil)\r
 157           (setq pop3-read-point match-end)\r
 158           (if return\r
 159               (buffer-substring (point) match-end)\r
 160             t)\r
 161           )))))\r
 162 \r
 163 (defun pop3-string-to-list (string &optional regexp)\r
 164   "Chop up a string into a list."\r
 165   (let ((list)\r
 166         (regexp (or regexp " "))\r
 167         (string (if (string-match "\r" string)\r
 168                     (substring string 0 (match-beginning 0))\r
 169                   string)))\r
 170     (store-match-data nil)\r
 171     (while string\r
 172       (if (string-match regexp string)\r
 173           (setq list (cons (substring string 0 (- (match-end 0) 1)) list)\r
 174                 string (substring string (match-end 0)))\r
 175         (setq list (cons string list)\r
 176               string nil)))\r
 177     (nreverse list)))\r
 178 \r
 179 (defvar pop3-read-passwd nil)\r
 180 (defun pop3-read-passwd (prompt)\r
 181   (if (not pop3-read-passwd)\r
 182       (if (load "passwd" t)\r
 183           (setq pop3-read-passwd 'read-passwd)\r
 184         (autoload 'ange-ftp-read-passwd "ange-ftp")\r
 185         (setq pop3-read-passwd 'ange-ftp-read-passwd)))\r
 186   (funcall pop3-read-passwd prompt))\r
 187 \r
 188 (defun pop3-clean-region (start end)\r
 189   (setq end (set-marker (make-marker) end))\r
 190   (save-excursion\r
 191     (goto-char start)\r
 192     (while (and (< (point) end) (search-forward "\r\n" end t))\r
 193       (replace-match "\n" t t))\r
 194     (goto-char start)\r
 195     (while (and (< (point) end) (re-search-forward "^\\." end t))\r
 196       (replace-match "" t t)\r
 197       (forward-char)))\r
 198   (set-marker end nil))\r
 199 \r
 200 (defun pop3-munge-message-separator (start end)\r
 201   "Check to see if a message separator exists.  If not, generate one."\r
 202   (save-excursion\r
 203     (save-restriction\r
 204       (narrow-to-region start end)\r
 205       (goto-char (point-min))\r
 206       (if (not (or (looking-at "From .?") ; Unix mail\r
 207                    (looking-at "\001\001\001\001\n") ; MMDF\r
 208                    (looking-at "BABYL OPTIONS:") ; Babyl\r
 209                    ))\r
 210           (let ((from (mail-strip-quoted-names (mail-fetch-field "From")))\r
 211                 (date (pop3-string-to-list (mail-fetch-field "Date")))\r
 212                 (From_))\r
 213             ;; sample date formats I have seen\r
 214             ;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT)\r
 215             ;; Date: 08 Jul 1996 23:22:24 -0400\r
 216             ;; should be\r
 217             ;; Tue Jul 9 09:04:21 1996\r
 218             (setq date\r
 219                   (cond ((string-match "[A-Z]" (nth 0 date))\r
 220                          (format "%s %s %s %s %s"\r
 221                                  (nth 0 date) (nth 2 date) (nth 1 date)\r
 222                                  (nth 4 date) (nth 3 date)))\r
 223                         (t\r
 224                          ;; this really needs to be better but I don't feel\r
 225                          ;; like writing a date to day converter.\r
 226                          (format "Sun %s %s %s %s"\r
 227                                  (nth 1 date) (nth 0 date)\r
 228                                  (nth 3 date) (nth 2 date)))\r
 229                         ))\r
 230             (setq From_ (format "From %s  %s\n" from date))\r
 231             (while (string-match "," From_)\r
 232               (setq From_ (concat (substring From_ 0 (match-beginning 0))\r
 233                                   (substring From_ (match-end 0)))))\r
 234             (goto-char (point-min))\r
 235             (insert From_))))))\r
 236 \r
 237 ;; The Command Set\r
 238 \r
 239 ;; AUTHORIZATION STATE\r
 240 \r
 241 (defun pop3-user (process user)\r
 242   "Send USER information to POP3 server."\r
 243   (pop3-send-command process (format "USER %s" user))\r
 244   (let ((response (pop3-read-response process t)))\r
 245     (if (not (and response (string-match "+OK" response)))\r
 246         (error (format "USER %s not valid." user)))))\r
 247 \r
 248 (defun pop3-pass (process)\r
 249   "Send authentication information to the server."\r
 250   (let ((pass pop3-password))\r
 251     (if (and pop3-password-required (not pass))\r
 252         (setq pass\r
 253               (pop3-read-passwd (format "Password for %s: " pop3-maildrop))))\r
 254     (if pass\r
 255         (progn\r
 256           (pop3-send-command process (format "PASS %s" pass))\r
 257           (let ((response (pop3-read-response process t)))\r
 258             (if (not (and response (string-match "+OK" response)))\r
 259                 (pop3-quit process)))))\r
 260     ))\r
 261 \r
 262 (defun pop3-apop (process user)\r
 263   "Send alternate authentication information to the server."\r
 264   (if (not (fboundp 'md5)) (autoload 'md5 "md5"))\r
 265   (let ((pass pop3-password))\r
 266     (if (and pop3-password-required (not pass))\r
 267         (setq pass\r
 268               (pop3-read-passwd (format "Password for %s: " pop3-maildrop))))\r
 269     (if pass\r
 270         (let ((hash (md5 (concat pop3-timestamp pass))))\r
 271           (pop3-send-command process (format "APOP %s %s" user hash))\r
 272           (let ((response (pop3-read-response process t)))\r
 273             (if (not (and response (string-match "+OK" response)))\r
 274                 (pop3-quit process)))))\r
 275     ))\r
 276 \r
 277 ;; TRANSACTION STATE\r
 278 \r
 279 (defun pop3-stat (process)\r
 280   "Return the number of messages in the maildrop and the maildrop's size."\r
 281   (pop3-send-command process "STAT")\r
 282   (let ((response (pop3-read-response process t)))\r
 283     (list (string-to-int (nth 1 (pop3-string-to-list response)))\r
 284           (string-to-int (nth 2 (pop3-string-to-list response))))\r
 285     ))\r
 286 \r
 287 (defun pop3-list (process &optional msg)\r
 288   "Scan listing of available messages.\r
 289 This function currently does nothing.")\r
 290 \r
 291 (defun pop3-retr (process msg crashbuf)\r
 292   "Retrieve message-id MSG to buffer CRASHBUF."\r
 293   (pop3-send-command process (format "RETR %s" msg))\r
 294   (pop3-read-response process)\r
 295   (let ((start pop3-read-point) end)\r
 296     (save-excursion\r
 297       (set-buffer (process-buffer process))\r
 298       (while (not (re-search-forward "^\\.\r\n" nil t))\r
 299         (accept-process-output process)\r
 300         ;; bill@att.com ... to save wear and tear on the heap\r
 301         (if (> (buffer-size)  20000) (sleep-for 1))\r
 302         (if (> (buffer-size)  50000) (sleep-for 1))\r
 303         (if (> (buffer-size) 100000) (sleep-for 1))\r
 304         (if (> (buffer-size) 200000) (sleep-for 1))\r
 305         (if (> (buffer-size) 500000) (sleep-for 1))\r
 306         ;; bill@att.com\r
 307         (goto-char start))\r
 308       (setq pop3-read-point (point-marker))\r
 309       (goto-char (match-beginning 0))\r
 310       (insert "\r\n")\r
 311       (setq end (point-marker))\r
 312       (pop3-clean-region start end)\r
 313       (pop3-munge-message-separator start end)\r
 314       (save-excursion\r
 315         (set-buffer crashbuf)\r
 316         (erase-buffer))\r
 317       (copy-to-buffer crashbuf start end)\r
 318       (delete-region start end)\r
 319       )))\r
 320 \r
 321 (defun pop3-dele (process msg)\r
 322   "Mark message-id MSG as deleted."\r
 323   (pop3-send-command process (format "DELE %s" msg))\r
 324   (pop3-read-response process))\r
 325 \r
 326 (defun pop3-noop (process msg)\r
 327   "No-operation."\r
 328   (pop3-send-command process "NOOP")\r
 329   (pop3-read-response process))\r
 330 \r
 331 (defun pop3-last (process)\r
 332   "Return highest accessed message-id number for the session."\r
 333   (pop3-send-command process "LAST")\r
 334   (let ((response (pop3-read-response process t)))\r
 335     (string-to-int (nth 1 (pop3-string-to-list response)))\r
 336     ))\r
 337 \r
 338 (defun pop3-rset (process)\r
 339   "Remove all delete marks from current maildrop."\r
 340   (pop3-send-command process "RSET")\r
 341   (pop3-read-response process))\r
 342 \r
 343 ;; UPDATE\r
 344 \r
 345 (defun pop3-quit (process)\r
 346   "Close connection to POP3 server.\r
 347 Tell server to remove all messages marked as deleted, unlock the maildrop,\r
 348 and close the connection."\r
 349   (pop3-send-command process "QUIT")\r
 350   (pop3-read-response process t)\r
 351   (if process\r
 352       (save-excursion\r
 353         (set-buffer (process-buffer process))\r
 354         (goto-char (point-max))\r
 355         (delete-process process))))\r
 356 \f\r
 357 ;; Summary of POP3 (Post Office Protocol version 3) commands and responses\r
 358 \r
 359 ;;; AUTHORIZATION STATE\r
 360 \r
 361 ;; Initial TCP connection\r
 362 ;; Arguments: none\r
 363 ;; Restrictions: none\r
 364 ;; Possible responses:\r
 365 ;;  +OK [POP3 server ready]\r
 366 \r
 367 ;; USER name\r
 368 ;; Arguments: a server specific user-id (required)\r
 369 ;; Restrictions: authorization state [after unsuccessful USER or PASS\r
 370 ;; Possible responses:\r
 371 ;;  +OK [valid user-id]\r
 372 ;;  -ERR [invalid user-id]\r
 373 \r
 374 ;; PASS string\r
 375 ;; Arguments: a server/user-id specific password (required)\r
 376 ;; Restrictions: authorization state, after successful USER\r
 377 ;; Possible responses:\r
 378 ;;  +OK [maildrop locked and ready]\r
 379 ;;  -ERR [invalid password]\r
 380 ;;  -ERR [unable to lock maildrop]\r
 381 \r
 382 ;;; TRANSACTION STATE\r
 383 \r
 384 ;; STAT\r
 385 ;; Arguments: none\r
 386 ;; Restrictions: transaction state\r
 387 ;; Possible responses:\r
 388 ;;  +OK nn mm [# of messages, size of maildrop]\r
 389 \r
 390 ;; LIST [msg]\r
 391 ;; Arguments: a message-id (optional)\r
 392 ;; Restrictions: transaction state; msg must not be deleted\r
 393 ;; Possible responses:\r
 394 ;;  +OK [scan listing follows]\r
 395 ;;  -ERR [no such message]\r
 396 \r
 397 ;; RETR msg\r
 398 ;; Arguments: a message-id (required)\r
 399 ;; Restrictions: transaction state; msg must not be deleted\r
 400 ;; Possible responses:\r
 401 ;;  +OK [message contents follow]\r
 402 ;;  -ERR [no such message]\r
 403 \r
 404 ;; DELE msg\r
 405 ;; Arguments: a message-id (required)\r
 406 ;; Restrictions: transaction state; msg must not be deleted\r
 407 ;; Possible responses:\r
 408 ;;  +OK [message deleted]\r
 409 ;;  -ERR [no such message]\r
 410 \r
 411 ;; NOOP\r
 412 ;; Arguments: none\r
 413 ;; Restrictions: transaction state\r
 414 ;; Possible responses:\r
 415 ;;  +OK\r
 416 \r
 417 ;; LAST\r
 418 ;; Arguments: none\r
 419 ;; Restrictions: transaction state\r
 420 ;; Possible responses:\r
 421 ;;  +OK nn [highest numbered message accessed]\r
 422 \r
 423 ;; RSET\r
 424 ;; Arguments: none\r
 425 ;; Restrictions: transaction state\r
 426 ;; Possible responses:\r
 427 ;;  +OK [all delete marks removed]\r
 428 \r
 429 ;;; UPDATE STATE\r
 430 \r
 431 ;; QUIT\r
 432 ;; Arguments: none\r
 433 ;; Restrictions: none\r
 434 ;; Possible responses:\r
 435 ;;  +OK [TCP connection closed]\r