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

   1 ;;; pop3.el --- Post Office Protocol (RFC 1460) interface
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
   4 ;;        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., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, 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 (defvar pop3-maildrop (or (user-login-name) (getenv "LOGNAME") (getenv "USER") nil)
  41   "*POP3 maildrop.")
  42 (defvar pop3-mailhost (or (getenv "MAILHOST") nil)
  43   "*POP3 mailhost.")
  44 (defvar pop3-port 110
  45   "*POP3 port.")
  46
  47 (defvar pop3-password-required t
  48   "*Non-nil if a password is required when connecting to POP server.")
  49 (defvar pop3-password nil
  50   "*Password to use when connecting to POP server.")
  51
  52 (defvar pop3-authentication-scheme 'pass
  53   "*POP3 authentication scheme.
  54 Defaults to 'pass, for the standard USER/PASS authentication.  Other valid
  55 values are 'apop.")
  56
  57 (defvar pop3-timestamp nil
  58   "Timestamp returned when initially connected to the POP server.
  59 Used for APOP authentication.")
  60
  61 (defvar pop3-read-point nil)
  62 (defvar pop3-debug nil)
  63
  64 (defun pop3-movemail (&optional crashbox)
  65   "Transfer contents of a maildrop to the specified CRASHBOX."
  66   (or crashbox (setq crashbox (expand-file-name "~/.crashbox")))
  67   (let* ((process (pop3-open-server pop3-mailhost pop3-port))
  68          (crashbuf (get-buffer-create " *pop3-retr*"))
  69          (n 1)
  70          message-count
  71          (pop3-password pop3-password)
  72          )
  73     ;; for debugging only
  74     (if pop3-debug (switch-to-buffer (process-buffer process)))
  75     ;; query for password
  76     (if (and pop3-password-required (not pop3-password))
  77         (setq pop3-password
  78               (read-passwd (format "Password for %s: " pop3-maildrop))))
  79     (cond ((equal 'apop pop3-authentication-scheme)
  80            (pop3-apop process pop3-maildrop))
  81           ((equal 'pass pop3-authentication-scheme)
  82            (pop3-user process pop3-maildrop)
  83            (pop3-pass process))
  84           (t (error "Invalid POP3 authentication scheme")))
  85     (setq message-count (car (pop3-stat process)))
  86     (unwind-protect
  87         (while (<= n message-count)
  88           (message "Retrieving message %d of %d from %s..."
  89                    n message-count pop3-mailhost)
  90           (pop3-retr process n crashbuf)
  91           (save-excursion
  92             (set-buffer crashbuf)
  93             (let ((coding-system-for-write 'binary))
  94               (write-region (point-min) (point-max) crashbox t 'nomesg))
  95             (set-buffer (process-buffer process))
  96             (while (> (buffer-size) 5000)
  97               (goto-char (point-min))
  98               (forward-line 50)
  99               (delete-region (point-min) (point))))
 100           (pop3-dele process n)
 101           (setq n (+ 1 n))
 102           (if pop3-debug (sit-for 1) (sit-for 0.1))
 103           )
 104       (pop3-quit process))
 105     (kill-buffer crashbuf)
 106     )
 107   t)
 108
 109 (defun pop3-get-message-count ()
 110   "Return the number of messages in the maildrop."
 111   (let* ((process (pop3-open-server pop3-mailhost pop3-port))
 112          message-count
 113          (pop3-password pop3-password)
 114          )
 115     ;; for debugging only
 116     (if pop3-debug (switch-to-buffer (process-buffer process)))
 117     ;; query for password
 118     (if (and pop3-password-required (not pop3-password))
 119         (setq pop3-password
 120               (read-passwd (format "Password for %s: " pop3-maildrop))))
 121     (cond ((equal 'apop pop3-authentication-scheme)
 122            (pop3-apop process pop3-maildrop))
 123           ((equal 'pass pop3-authentication-scheme)
 124            (pop3-user process pop3-maildrop)
 125            (pop3-pass process))
 126           (t (error "Invalid POP3 authentication scheme")))
 127     (setq message-count (car (pop3-stat process)))
 128     (pop3-quit process)
 129     message-count))
 130
 131 (defun pop3-open-server (mailhost port)
 132   "Open TCP connection to MAILHOST on PORT.
 133 Returns the process associated with the connection."
 134   (let ((coding-system-for-read 'binary)
 135         (coding-system-for-write 'binary)
 136         process)
 137     (save-excursion
 138       (set-buffer (get-buffer-create (concat " trace of POP session to "
 139                                              mailhost)))
 140       (erase-buffer)
 141       (setq pop3-read-point (point-min))
 142       (setq process (open-network-stream "POP" (current-buffer) mailhost port))
 143       (let ((response (pop3-read-response process t)))
 144         (setq pop3-timestamp
 145               (substring response (or (string-match "<" response) 0)
 146                          (+ 1 (or (string-match ">" response) -1)))))
 147       process)))
 148
 149 ;; Support functions
 150
 151 (defun pop3-process-filter (process output)
 152   (save-excursion
 153     (set-buffer (process-buffer process))
 154     (goto-char (point-max))
 155     (insert output)))
 156
 157 (defun pop3-send-command (process command)
 158     (set-buffer (process-buffer process))
 159     (goto-char (point-max))
 160 ;;    (if (= (aref command 0) ?P)
 161 ;;      (insert "PASS <omitted>\r\n")
 162 ;;      (insert command "\r\n"))
 163     (setq pop3-read-point (point))
 164     (goto-char (point-max))
 165     (process-send-string process (concat command "\r\n"))
 166     )
 167
 168 (defun pop3-read-response (process &optional return)
 169   "Read the response from the server.
 170 Return the response string if optional second argument is non-nil."
 171   (let ((case-fold-search nil)
 172         match-end)
 173     (save-excursion
 174       (set-buffer (process-buffer process))
 175       (goto-char pop3-read-point)
 176       (while (and (memq (process-status process) '(open run))
 177                   (not (search-forward "\r\n" nil t)))
 178         (nnheader-accept-process-output process)
 179         (goto-char pop3-read-point))
 180       (setq match-end (point))
 181       (goto-char pop3-read-point)
 182       (if (looking-at "-ERR")
 183           (error (buffer-substring (point) (- match-end 2)))
 184         (if (not (looking-at "+OK"))
 185             (progn (setq pop3-read-point match-end) nil)
 186           (setq pop3-read-point match-end)
 187           (if return
 188               (buffer-substring (point) match-end)
 189             t)
 190           )))))
 191
 192 (defun pop3-clean-region (start end)
 193   (setq end (set-marker (make-marker) end))
 194   (save-excursion
 195     (goto-char start)
 196     (while (and (< (point) end) (search-forward "\r\n" end t))
 197       (replace-match "\n" t t))
 198     (goto-char start)
 199     (while (and (< (point) end) (re-search-forward "^\\." end t))
 200       (replace-match "" t t)
 201       (forward-char)))
 202   (set-marker end nil))
 203
 204 (eval-when-compile (defvar parse-time-months))
 205
 206 ;; Copied from message-make-date.
 207 (defun pop3-make-date (&optional now)
 208   "Make a valid date header.
 209 If NOW, use that time instead."
 210   (require 'parse-time)
 211   (let* ((now (or now (current-time)))