[gnus] / lisp / pop3.el

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

;; Copyright (C) 1996,1997 Free Software Foundation, Inc.

;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>
;; Keywords: mail, pop3
;; Version: 1.3g

;; 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)
(provide 'pop3)

(defconst pop3-version "1.3g")

(defvar pop3-maildrop (or user-login-name (getenv "LOGNAME") (getenv "USER") nil)
  "*POP3 maildrop.")
(defvar pop3-mailhost (or (getenv "MAILHOST") nil)
  "*POP3 mailhost.")
(defvar pop3-port 110
  "*POP3 port.")

(defvar pop3-password-required t
  "*Non-nil if a password is required when connecting to POP server.")
(defvar pop3-password nil
  "*Password to use when connecting to POP server.")

(defvar pop3-authentication-scheme 'pass
  "*POP3 authentication scheme.
Defaults to 'pass, for the standard USER/PASS authentication.  Other valid
values are 'apop.")

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

(defvar pop3-movemail-file-coding-system nil
  "Crashbox made by pop3-movemail with this coding system.")

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

(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)
    ;; for debugging only
    (if pop3-debug (switch-to-buffer (process-buffer process)))
    (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)))
    (while (<= n message-count)
      (message (format "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 pop3-movemail-file-coding-system))
          (append-to-file (point-min) (point-max) crashbox))
        (set-buffer (process-buffer process))
        (while (> (buffer-size) 5000)
          (goto-char (point-min))
          (forward-line 50)
          (delete-region (point-min) (point))))
      (pop3-dele process n)
      (setq n (+ 1 n))
      (if pop3-debug (sit-for 1) (sit-for 0.1))
      )
    (pop3-quit process)
    (kill-buffer crashbuf)
    )
  )

(defun pop3-open-server (mailhost port)
  "Open TCP connection to MAILHOST.
Returns the process associated with the connection."
  (let ((process-buffer
         (get-buffer-create (format "trace of POP session to %s" mailhost)))
        (process))
    (save-excursion
      (set-buffer process-buffer)
      (erase-buffer))
    (setq process
          (open-network-stream "POP" process-buffer mailhost port))
    (setq pop3-read-point (point-min))
    (let ((response (pop3-read-response process t)))
      (setq pop3-timestamp
            (substring response (or (string-match "<" response) 0)
                       (+ 1 (or (string-match ">" response) -1)))))
    process
    ))

;; Support functions

(defun pop3-process-filter (process output)
  (save-excursion
    (set-buffer (process-buffer process))
    (goto-char (point-max))
    (insert output)))

(defun pop3-send-command (process command)
    (set-buffer (process-buffer process))
    (goto-char (point-max))
;;    (if (= (aref command 0) ?P)
;;      (insert "PASS <omitted>\r\n")
;;      (insert command "\r\n"))
    (setq pop3-read-point (point))
    (goto-char (point-max))
    (process-send-string process command)
    (process-send-string process "\r\n")
    )

(defun pop3-read-response (process &optional return)
  "Read the response from the server.
Return the response string if optional second argument is non-nil."
  (let ((case-fold-search nil)
        match-end)
    (save-excursion
      (set-buffer (process-buffer process))
      (goto-char pop3-read-point)
      (while (not (search-forward "\r\n" nil t))
        (accept-process-output process 3)
        (goto-char pop3-read-point))
      (setq match-end (point))
      (goto-char pop3-read-point)
      (if (looking-at "-ERR")
          (error (buffer-substring (point) (- match-end 2)))
        (if (not (looking-at "+OK"))
            (progn (setq pop3-read-point match-end) nil)
          (setq pop3-read-point match-end)
          (if return
              (buffer-substring (point) match-end)
            t)
          )))))

(defun pop3-string-to-list (string &optional regexp)
  "Chop up a string into a list."
  (let ((list)
        (regexp (or regexp " "))
        (string (if (string-match "\r" string)
                    (substring string 0 (match-beginning 0))
                  string)))
    (store-match-data nil)
    (while string