[gnus] / lisp / pop3.el

;;; pop3.el --- Post Office Protocol (RFC 1460) interface

;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
;;        Free Software Foundation, Inc.

;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>
;; Maintainer: FSF
;; Keywords: mail

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; Most of the standard Post Office Protocol version 3 (RFC 1460) commands
;; are implemented.  The LIST command has not been implemented due to lack
;; of actual usefulness.
;; The optional POP3 command TOP has not been implemented.

;; This program was inspired by Kyle E. Jones's vm-pop program.

;;; Code:

(require 'mail-utils)

(defgroup pop3 nil
  "Post Office Protocol"
  :group 'mail
  :group 'mail-source)

(defcustom pop3-maildrop (or (user-login-name)
                             (getenv "LOGNAME")
                             (getenv "USER"))
  "*POP3 maildrop."
  :version "21.4" ;; Oort Gnus
  :type 'string
  :group 'pop3)

(defcustom pop3-mailhost (or (getenv "MAILHOST") ;; nil -> mismatch
                             "pop3")
  "*POP3 mailhost."
  :version "21.4" ;; Oort Gnus
  :type 'string
  :group 'pop3)

(defcustom pop3-port 110
  "*POP3 port."
  :version "21.4" ;; Oort Gnus
  :type 'number
  :group 'pop3)

(defcustom pop3-password-required t
  "*Non-nil if a password is required when connecting to POP server."
  :version "21.4" ;; Oort Gnus
  :type 'boolean
  :group 'pop3)

;; Should this be customizable?
(defvar pop3-password nil
  "*Password to use when connecting to POP server.")

(defcustom pop3-authentication-scheme 'pass
  "*POP3 authentication scheme.
Defaults to 'pass, for the standard USER/PASS authentication.  Other valid
values are 'apop."
  :version "21.4" ;; Oort Gnus
  :type '(choice (const :tag "USER/PASS" pass)
                 (const :tag "APOP" apop))
  :group 'pop3)

(defcustom pop3-leave-mail-on-server nil
  "*Non-nil if the mail is to be left on the POP server after fetching.

If `pop3-leave-mail-on-server' is non-nil the mail is to be left
on the POP server after fetching.  Note that POP servers maintain
no state information between sessions, so what the client
believes is there and what is actually there may not match up.
If they do not, then the whole thing can fall apart and leave you
with a corrupt mailbox."
  :version "21.4" ;; Oort Gnus
  :type 'boolean
  :group 'pop3)

(defvar pop3-timestamp nil
  "Timestamp returned when initially connected to the POP server.
Used for APOP authentication.")

(defvar pop3-read-point nil)
(defvar pop3-debug nil)

;; Borrowed from nnheader-accept-process-output in nnheader.el.
(defvar pop3-read-timeout
  (if (string-match "windows-nt\\|os/2\\|emx\\|cygwin"
                    (symbol-name system-type))
      ;; http://thread.gmane.org/v9655t3pjo.fsf@marauder.physik.uni-ulm.de
      ;;
      ;; IIRC, values lower than 1.0 didn't/don't work on Windows/DOS.
      ;;
      ;; There should probably be a runtime test to determine the timing
      ;; resolution, or a primitive to report it.  I don't know off-hand
      ;; what's possible.  Perhaps better, maybe the Windows/DOS primitive
      ;; could round up non-zero timeouts to a minimum of 1.0?
      1.0
    0.1)
  "How long pop3 should wait between checking for the end of output.
Shorter values mean quicker response, but are more CPU intensive.")

;; Borrowed from nnheader-accept-process-output in nnheader.el.
(defun pop3-accept-process-output (process)
  (accept-process-output
   process
   (truncate pop3-read-timeout)
   (truncate (* (- pop3-read-timeout
                   (truncate pop3-read-timeout))
                1000))))

(defun pop3-movemail (&optional crashbox)
  "Transfer contents of a maildrop to the specified CRASHBOX."
  (or crashbox (setq crashbox (expand-file-name "~/.crashbox")))
  (let* ((process (pop3-open-server pop3-mailhost pop3-port))
         (crashbuf (get-buffer-create " *pop3-retr*"))
         (n 1)
         message-count
         (pop3-password pop3-password))
    ;; for debugging only
    (if pop3-debug (switch-to-buffer (process-buffer process)))
    ;; query for password
    (if (and pop3-password-required (not pop3-password))
        (setq pop3-password
              (read-passwd (format "Password for %s: " pop3-maildrop))))
    (cond ((equal 'apop pop3-authentication-scheme)
           (pop3-apop process pop3-maildrop))
          ((equal 'pass pop3-authentication-scheme)
           (pop3-user process pop3-maildrop)
           (pop3-pass process))
          (t (error "Invalid POP3 authentication scheme")))
    (setq message-count (car (pop3-stat process)))
    (unwind-protect
        (while (<= n message-count)
          (message "Retrieving message %d of %d from %s..."
                   n message-count pop3-mailhost)
          (pop3-retr process n crashbuf)
          (save-excursion
            (set-buffer crashbuf)
            (let ((coding-system-for-write 'binary))
              (write-region (point-min) (point-max) crashbox t 'nomesg))
            (set-buffer (process-buffer process))
            (while (> (buffer-size) 5000)
              (goto-char (point-min))
              (forward-line 50)
              (delete-region (point-min) (point))))
          (unless pop3-leave-mail-on-server
            (pop3-dele process n))
          (setq n (+ 1 n))
          (if pop3-debug (sit-for 1) (sit-for 0.1))
          )
      (pop3-quit process))
    (kill-buffer crashbuf)
    )