git.chise.org Git - elisp/gnus.git-/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, 2004
   4 ;;        Free Software Foundation, Inc.
   5
   6 ;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>
   7 ;;      Daiki Ueno  <ueno@ueda.info.waseda.ac.jp>
   8 ;;      Katsumi Yamaoka <yamaoka@jpl.org>
   9 ;; Maintainer: Volunteers
  10 ;; Keywords: mail
  11
  12 ;; This file is part of T-gnus.
  13
  14 ;; GNU Emacs is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  27 ;; Boston, MA 02111-1307, USA.
  28
  29 ;;; Commentary:
  30
  31 ;; Most of the standard Post Office Protocol version 3 (RFC 1460) commands
  32 ;; are implemented.  The LIST command has not been implemented due to lack
  33 ;; of actual usefulness.
  34 ;; The optional POP3 command TOP has not been implemented.
  35
  36 ;; This program was inspired by Kyle E. Jones's vm-pop program.
  37
  38 ;;; Gnus:
  39
  40 ;; You can use this program for Gnus, without needing any modification.
  41 ;; There are two ways to do that; one is to replace Gnus' pop3.el with
  42 ;; it when installing Gnus; the other is to replace Gnus' pop3.el which
  43 ;; has been installed with this module and byte-compile it.
  44
  45 ;; Note: you should not modify the value for the `pop' section of the
  46 ;; `mail-source-keyword-map' variable.
  47
  48 ;; This program provides the following features in addition to Gnus:
  49
  50 ;; 1. You can use SSL or STARTTLS stream to connect to mail servers.
  51 ;;    For example, specify the `:connection' keyword and the value pair
  52 ;;    in a mail-source as follows:
  53 ;;
  54 ;;(setq mail-sources '((pop :server "pop3.mail.server" :port 995
  55 ;;                        :connection ssl :authentication apop)))
  56 ;;
  57 ;;    For STARTTLS stream, use `tls' isntead of `ssl'.  The default
  58 ;;    connection type is defined by `pop3-connection-type' which
  59 ;;    defaults to nil.
  60
  61 ;; 2. You can fetch mails without deleting them in mail servers.  To do
  62 ;;    that, specify the `:leave' keyword with the value t as follows:
  63 ;;
  64 ;;(setq mail-sources '((pop :server "pop3.mail.server" :leave t)))
  65 ;;
  66 ;;    Already read mails are registered into the ~/.uidls-SERVER file
  67 ;;    (which is the default, see `pop3-uidl-file-name'), and you will
  68 ;;    never need to fetch them twice.  The default value for the
  69 ;;    `:leave' keyword is specified by the `pop3-leave-mail-on-server'
  70 ;;    variable.  You have no need to modify that value normally.
  71
  72 ;; 3. See the source code for some other miscellaneous extended features.
  73
  74 ;;; Code:
  75
  76 (eval-when-compile
  77   (require 'cl))
  78
  79 (require 'mail-utils)
  80
  81 (defgroup pop3 nil
  82   "Post Office Protocol"
  83   :group 'mail
  84   :group 'mail-source)
  85
  86 (defcustom pop3-maildrop (or (user-login-name)
  87                              (getenv "LOGNAME")
  88                              (getenv "USER"))
  89   "*POP3 maildrop."
  90   :version "22.1" ;; Oort Gnus
  91   :type 'string
  92   :group 'pop3)
  93
  94 (defcustom pop3-mailhost (or (getenv "MAILHOST") ;; nil -> mismatch
  95                              "pop3")
  96   "*POP3 mailhost."
  97   :version "22.1" ;; Oort Gnus
  98   :type 'string
  99   :group 'pop3)
 100
 101 (defcustom pop3-port 110
 102   "*POP3 port."
 103   :version "22.1" ;; Oort Gnus
 104   :type 'number
 105   :group 'pop3)
 106
 107 (defcustom pop3-connection-type nil
 108   "*POP3 connection type."
 109   :type '(choice (const :tag "Not specified" nil)
 110                  (const tls)
 111                  (const ssl))
 112   :group 'pop3)
 113
 114 (defcustom pop3-password-required t
 115   "*Non-nil if a password is required when connecting to POP server."
 116   :version "22.1" ;; Oort Gnus
 117   :type 'boolean
 118   :group 'pop3)
 119
 120 ;; Should this be customizable?
 121 (defvar pop3-password nil
 122   "*Password to use when connecting to POP server.")
 123
 124 (defcustom pop3-authentication-scheme 'pass
 125   "*POP3 authentication scheme.
 126 Defaults to 'pass, for the standard USER/PASS authentication.  Other valid
 127 values are 'apop."
 128   :version "22.1" ;; Oort Gnus
 129   :type '(choice (const :tag "USER/PASS" pass)
 130                  (const :tag "APOP" apop))
 131   :group 'pop3)
 132
 133 (defcustom pop3-leave-mail-on-server nil
 134   "*Non-nil if the mail is to be left on the POP server after fetching.
 135
 136 If `pop3-leave-mail-on-server' is non-nil the mail is to be left
 137 on the POP server after fetching.  Note that POP servers maintain
 138 no state information between sessions, so what the client
 139 believes is there and what is actually there may not match up.
 140 If they do not, then the whole thing can fall apart and leave you
 141 with a corrupt mailbox."
 142   :version "22.1" ;; Oort Gnus
 143   :type 'boolean
 144   :group 'pop3)
 145
 146 (defvar pop3-timestamp nil
 147   "Timestamp returned when initially connected to the POP server.
 148 Used for APOP authentication.")
 149
 150 (defcustom pop3-maximum-message-size nil
 151   "If non-nil only download messages smaller than this."
 152   :type '(choice (const :tag "Unlimited" nil)
 153                  (integer :tag "Maximum size"))
 154   :group 'pop3)
 155
 156 (defcustom pop3-except-header-regexp nil
 157   "If non-nil we do not retrieve messages whose headers are matching this regexp."
 158   :type '(choice (const :tag "Retrieve any messages" nil)
 159                  (regexp :format "\n%t: %v"))
 160   :group 'pop3)
 161
 162 (defcustom pop3-uidl-file-name "~/.uidls"
 163   "File in which to store the UIDL of processed messages."
 164   :type 'file
 165   :group 'pop3)
 166
 167 (defvar pop3-uidl-support nil
 168   "Alist of servers and flags of whether they support UIDLs.
 169 Users don't have to set this value.")
 170
 171 (defvar pop3-uidl-obarray (make-vector 31 0)
 172   "Uidl hash table.")
 173
 174 (defvar pop3-read-point nil)
 175 (defvar pop3-debug nil)
 176
 177 (eval-and-compile
 178   (autoload 'starttls-open-stream "starttls")
 179   (autoload 'starttls-negotiate "starttls"))
 180
 181 (defcustom pop3-ssl-program-name
 182   (if (executable-find "openssl")
 183       "openssl"
 184     "ssleay")
 185   "The program to run in a subprocess to open an SSL connection."
 186   :type 'string
 187   :group 'pop3)
 188
 189 (defcustom pop3-ssl-program-arguments
 190   '("s_client" "-quiet")
 191   "Arguments to be passed to the program `pop3-ssl-program-name'."
 192   :type '(repeat (string :format "%v"))
 193   :group 'pop3)
 194
 195 (defun pop3-progress-message (format percent &rest args)
 196   (apply (function message) format args))
 197
 198 ;; Borrowed from nnheader-accept-process-output in nnheader.el.
 199 (defvar pop3-read-timeout
 200   (if (string-match "windows-nt\\|os/2\\|emx\\|cygwin"
 201                     (symbol-name system-type))
 202       ;; http://thread.gmane.org/v9655t3pjo.fsf@marauder.physik.uni-ulm.de
 203       ;;
 204       ;; IIRC, values lower than 1.0 didn't/don't work on Windows/DOS.
 205       ;;
 206       ;; There should probably be a runtime test to determine the timing
 207       ;; resolution, or a primitive to report it.  I don't know off-hand
 208       ;; what's possible.  Perhaps better, maybe the Windows/DOS primitive
 209       ;; could round up non-zero timeouts to a minimum of 1.0?
 210       1.0
 211     0.1)
 212   "How long pop3 should wait between checking for the end of output.
 213 Shorter values mean quicker response, but are more CPU intensive.")
 214
 215 ;; Borrowed from nnheader-accept-process-output in nnheader.el.
 216 (defun pop3-accept-process-output (process)
 217   (accept-process-output
 218    process
 219    (truncate pop3-read-timeout)
 220    (truncate (* (- pop3-read-timeout
 221                    (truncate pop3-read-timeout))
 222                 1000))))
 223
 224 (defun pop3-movemail (&optional crashbox)
 225   "Transfer contents of a maildrop to the specified CRASHBOX."
 226   (or crashbox (setq crashbox (expand-file-name "~/.crashbox")))
 227   (let* ((process (pop3-open-server pop3-mailhost pop3-port))
 228          (crashbuf (get-buffer-create " *pop3-retr*"))
 229          (n 1)
 230          message-count
 231          (pop3-password pop3-password)
 232          (pop3-uidl-file-name (convert-standard-filename
 233                                (concat pop3-uidl-file-name "-"
 234                                        pop3-mailhost)))
 235          retrieved-messages messages)
 236     ;; for debugging only
 237     (if pop3-debug (switch-to-buffer (process-buffer process)))
 238     ;; query for password
 239     (if (and pop3-password-required (not pop3-password))
 240         (setq pop3-password
 241               (read-passwd (format "Password for %s: " pop3-maildrop))))
 242     (cond ((equal 'apop pop3-authentication-scheme)
 243            (pop3-apop process pop3-maildrop))
 244           ((equal 'pass pop3-authentication-scheme)
 245            (pop3-user process pop3-maildrop)
 246            (pop3-pass process))
 247           (t (error "Invalid POP3 authentication scheme")))
 248     ;; get messages that are suitable for download
 249     (message "Retrieving message list...")
 250     (setq messages (pop3-get-message-numbers process)
 251           message-count (length (cdr messages)))
 252     (message "Retrieving message list...%d of %d unread"
 253              message-count (pop messages))
 254     (unwind-protect
 255         (unless (not (stringp crashbox))
 256           (while messages
 257             (pop3-progress-message
 258              "Retrieving message %d of %d (%d octets) from %s..."
 259              (floor (* (/ (float n) message-count) 100))
 260              n message-count (cdar messages) pop3-mailhost)
 261             (pop3-retr process (caar messages) crashbuf)
 262             (push (caar messages) retrieved-messages)
 263             (setq messages (cdr messages)
 264                   n (1+ n)))
 265           (with-current-buffer crashbuf
 266             (let ((coding-system-for-write 'binary)
 267                   jka-compr-compression-info-list jam-zcat-filename-list)
 268               (write-region (point-min) (point-max)
 269                             crashbox 'append 'nomesg)))
 270           ;; mark messages as read
 271           (when pop3-leave-mail-on-server
 272             (pop3-save-uidls))
 273           ;; now delete the messages we have retrieved
 274           (unless pop3-leave-mail-on-server
 275             (dolist (n retrieved-messages)
 276               (message "Deleting message %d of %d from %s..."
 277                        n message-count pop3-mailhost)
 278               (pop3-dele process n))))
 279       (pop3-quit process))
 280     (kill-buffer crashbuf)
 281     message-count))
 282
 283 (defun pop3-get-message-count ()
 284   "Return the number of messages in the maildrop."
 285   (let* ((process (pop3-open-server pop3-mailhost pop3-port))
 286          message-count
 287          (pop3-password pop3-password))
 288     ;; for debugging only
 289     (if pop3-debug (switch-to-buffer (process-buffer process)))
 290     ;; query for password
 291     (if (and pop3-password-required (not pop3-password))
 292         (setq pop3-password
 293               (read-passwd (format "Password for %s: " pop3-maildrop))))
 294     (cond ((equal 'apop pop3-authentication-scheme)
 295            (pop3-apop process pop3-maildrop))
 296           ((equal 'pass pop3-authentication-scheme)
 297            (pop3-user process pop3-maildrop)
 298            (pop3-pass process))
 299           (t (error "Invalid POP3 authentication scheme")))
 300     (setq message-count (car (pop3-stat process)))
 301     (pop3-quit process)
 302     message-count))
 303
 304 (defun pop3-open-server (mailhost port)
 305   "Open TCP connection to MAILHOST on PORT.
 306 Returns the process associated with the connection.
 307 Argument PORT specifies connecting port."
 308   (let (process)
 309     (save-excursion
 310       (set-buffer (get-buffer-create (concat " trace of POP session to "
 311                                              mailhost)))
 312       (erase-buffer)
 313       (setq pop3-read-point (point-min))
 314       (setq
 315        process
 316        (cond
 317         ((eq pop3-connection-type 'ssl)
 318          (pop3-open-ssl-stream "POP" (current-buffer) mailhost port))
 319         ((eq pop3-connection-type 'tls)
 320          (pop3-open-tls-stream "POP" (current-buffer) mailhost port))
 321         (t
 322          (let ((coding-system-for-read 'binary)
 323                (coding-system-for-write 'binary))
 324            (open-network-stream "POP" (current-buffer) mailhost port)))))
 325       (let ((response (pop3-read-response process t)))
 326         (setq pop3-timestamp
 327               (substring response (or (string-match "<" response) 0)
 328                          (+ 1 (or (string-match ">" response) -1)))))
 329       process)))
 330
 331 (eval-when-compile
 332   (autoload 'open-ssl-stream "ssl"))
 333
 334 (defun pop3-open-ssl-stream-1 (name buffer host service extra-arg)
 335   (require 'ssl)
 336   (let* ((ssl-program-name
 337           pop3-ssl-program-name)
 338          (ssl-program-arguments
 339           `(,@pop3-ssl-program-arguments
 340             ,extra-arg
 341             "-connect" ,(format "%s:%d" host service)))
 342          (process (open-ssl-stream name buffer host service)))
 343     (when process
 344       (with-current-buffer buffer
 345         (goto-char (point-min))
 346         (while (and (memq (process-status process) '(open run))
 347                     (goto-char (point-max))
 348                     (forward-line -1)
 349                     (not (looking-at "+OK")))
 350           (pop3-accept-process-output process)
 351           (sit-for 1))
 352         (delete-region (point-min) (point)))
 353       (and process (memq (process-status process) '(open run))
 354            process))))
 355
 356 (defun pop3-open-ssl-stream (name buffer host service)
 357   "Open a SSL connection for a service to a host.
 358 Returns a subprocess-object to represent the connection.
 359 Args are NAME BUFFER HOST SERVICE."
 360   (let (selective-display ;; Disable ^M to nl translation.
 361         (coding-system-for-read 'binary)
 362         (coding-system-for-write 'binary))
 363     (or (pop3-open-ssl-stream-1 name buffer host service "-ssl3")
 364         (pop3-open-ssl-stream-1 name buffer host service "-ssl2"))))
 365
 366 (defun pop3-open-tls-stream (name buffer host service)
 367   "Open a TLSv1 connection for a service to a host.
 368 Returns a subprocess-object to represent the connection.
 369 Args are NAME BUFFER HOST SERVICE."
 370   (let* (selective-display ;; Disable ^M to nl translation.
 371          (coding-system-for-read 'binary)
 372          (coding-system-for-write 'binary)
 373          (process (starttls-open-stream name buffer host service)))
 374     (pop3-stls process)
 375     (starttls-negotiate process)
 376     process))
 377
 378 ;; Support functions
 379
 380 (defun pop3-process-filter (process output)
 381   (save-excursion
 382     (set-buffer (process-buffer process))
 383     (goto-char (point-max))
 384     (insert output)))
 385
 386 (defun pop3-send-command (process command)
 387   (set-buffer (process-buffer process))
 388   (goto-char (point-max))
 389   ;; (if (= (aref command 0) ?P)
 390   ;;     (insert "PASS <omitted>\r\n")
 391   ;;   (insert command "\r\n"))
 392   (setq pop3-read-point (point))
 393   (goto-char (point-max))
 394   (process-send-string process (concat command "\r\n")))
 395
 396 (defun pop3-read-response (process &optional return)
 397   "Read the response from the server PROCESS.
 398 Return the response string if optional second argument RETURN is non-nil."
 399   (let ((case-fold-search nil)
 400         match-end)
 401     (save-excursion
 402       (set-buffer (process-buffer process))
 403       (goto-char pop3-read-point)
 404       (while (and (memq (process-status process) '(open run))
 405                   (not (search-forward "\r\n" nil t)))
 406         (pop3-accept-process-output process)
 407         (goto-char pop3-read-point))
 408       (setq match-end (point))
 409       (goto-char pop3-read-point)
 410       (if (looking-at "-ERR")
 411           (error (buffer-substring (point) (- match-end 2)))
 412         (if (not (looking-at "+OK"))
 413             (progn (setq pop3-read-point match-end) nil)
 414           (setq pop3-read-point match-end)
 415           (if return
 416               (buffer-substring (point) match-end)
 417             t))))))
 418
 419 (defun pop3-clean-region (start end)
 420   (setq end (set-marker (make-marker) end))
 421   (save-excursion
 422     (goto-char start)
 423     (while (and (< (point) end) (search-forward "\r\n" end t))
 424       (replace-match "\n" t t))
 425     (goto-char start)
 426     (while (re-search-forward "\n\n\\(From \\)" end t)
 427       (replace-match "\n\n>\\1" t nil))
 428     (goto-char start)
 429     (while (and (< (point) end) (re-search-forward "^\\." end t))
 430       (replace-match "" t t)
 431       (forward-char)))
 432   (set-marker end nil))
 433
 434 (eval-when-compile (defvar parse-time-months))
 435
 436 ;; Copied from message-make-date.
 437 (defun pop3-make-date (&optional now)
 438   "Make a valid date header.
 439 If NOW, use that time instead."
 440   (require 'parse-time)
 441   (let* ((now (or now (current-time)))
 442          (zone (nth 8 (decode-time now)))
 443          (sign "+"))
 444     (when (< zone 0)
 445       (setq sign "-")
 446       (setq zone (- zone)))
 447     (concat
 448      (format-time-string "%d" now)
 449      ;; The month name of the %b spec is locale-specific.  Pfff.
 450      (format " %s "
 451              (capitalize (car (rassoc (nth 4 (decode-time now))
 452                                       parse-time-months))))
 453      (format-time-string "%Y %H:%M:%S " now)
 454      ;; We do all of this because XEmacs doesn't have the %z spec.
 455      (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60)))))
 456
 457 (defun pop3-munge-message-separator (start end)
 458   "Check to see if a message separator exists.  If not, generate one."
 459   (save-excursion
 460     (save-restriction
 461       (narrow-to-region start end)
 462       (goto-char (point-min))
 463       (if (not (or (looking-at "From .?") ; Unix mail
 464                    (looking-at "\001\001\001\001\n") ; MMDF
 465                    (looking-at "BABYL OPTIONS:"))) ; Babyl
 466           (let* ((from (mail-strip-quoted-names (mail-fetch-field "From")))
 467                  (tdate (mail-fetch-field "Date"))
 468                  (date (split-string (or (and tdate
 469                                               (not (string= "" tdate))
 470                                               tdate)
 471                                          (pop3-make-date))
 472                                      " "))
 473                  (From_))
 474             ;; sample date formats I have seen
 475             ;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT)
 476             ;; Date: 08 Jul 1996 23:22:24 -0400
 477             ;; should be
 478             ;; Tue Jul 9 09:04:21 1996
 479             (setq date
 480                   (cond ((not date)
 481                          "Tue Jan 1 00:00:0 1900")
 482                         ((string-match "[A-Z]" (nth 0 date))
 483                          (format "%s %s %s %s %s"
 484                                  (nth 0 date) (nth 2 date) (nth 1 date)
 485                                  (nth 4 date) (nth 3 date)))
 486                         (t
 487                          ;; this really needs to be better but I don't feel
 488                          ;; like writing a date to day converter.
 489                          (format "Sun %s %s %s %s"
 490                                  (nth 1 date) (nth 0 date)
 491                                  (nth 3 date) (nth 2 date)))))
 492             (setq From_ (format "\nFrom %s  %s\n" from date))
 493             (while (string-match "," From_)
 494               (setq From_ (concat (substring From_ 0 (match-beginning 0))
 495                                   (substring From_ (match-end 0)))))
 496             (goto-char (point-min))
 497             (insert From_)
 498             (if (search-forward "\n\n" nil t)
 499                 nil
 500               (goto-char (point-max))
 501               (insert "\n"))
 502             (narrow-to-region (point) (point-max))
 503             (let ((size (- (point-max) (point-min))))
 504               (goto-char (point-min))
 505               (widen)
 506               (forward-line -1)
 507               (insert (format "Content-Length: %s\n" size))))))))
 508
 509 ;; UIDL support
 510
 511 (defun pop3-get-message-numbers (process)
 512   "Get the list of message numbers and lengths to retrieve via PROCESS."
 513   ;; we use the LIST comand first anyway to get the message lengths.
 514   ;; then if we're leaving mail on the server, see if the UIDL command
 515   ;; is implemented. if so, we use it to get the message number list.
 516   (let* ((messages (pop3-list process))
 517          (total (or (pop messages) 0))
 518          (uidl (if pop3-leave-mail-on-server
 519                    (pop3-get-uidl process)))
 520          out)
 521     (while messages
 522       ;; only retrieve messages matching our regexp or in the uidl list
 523       (when (and
 524              ;; remove elements not in the uidl, this assumes the uidl is short
 525              (or (not (and pop3-leave-mail-on-server
 526                            (cdr (assoc pop3-mailhost pop3-uidl-support))))
 527                  (memq (caar messages) uidl))
 528              (caar messages)
 529              ;; don't download messages that are too large
 530              (not (and pop3-maximum-message-size
 531                        (> (cdar messages) pop3-maximum-message-size)))
 532              (not (and pop3-except-header-regexp
 533                        (string-match pop3-except-header-regexp
 534                                      (pop3-top process (caar messages) 0)))))
 535         (push (car messages) out))
 536       (setq messages (cdr messages)))
 537     (cons total (nreverse out))))
 538
 539 (defun pop3-get-uidl (process)
 540   "Use PROCESS to get a list of unread message numbers."
 541   (let ((messages (pop3-uidl process))
 542         (support (assoc pop3-mailhost pop3-uidl-support))
 543         uidl)
 544     (if support
 545         (setcdr support (and messages t))
 546       (push (cons pop3-mailhost (and messages t))
 547             pop3-uidl-support))
 548     (when messages
 549       (save-excursion
 550         (with-temp-buffer
 551           (when (file-readable-p pop3-uidl-file-name)
 552             (insert-file-contents pop3-uidl-file-name))
 553           (goto-char (point-min))
 554           (while (looking-at "\\([^ \n\t]+\\)")
 555             (set (intern (match-string 1) pop3-uidl-obarray)
 556                  (cons nil t))
 557             (forward-line 1))))
 558       (dolist (message (cdr messages))
 559         (if (setq uidl (intern-soft (cdr message) pop3-uidl-obarray))
 560             (setcar (symbol-value uidl) (car message))
 561           (set (intern (cdr message) pop3-uidl-obarray)
 562                (cons (car message) nil))))
 563       (pop3-get-unread-message-numbers))))
 564
 565 (defun pop3-get-unread-message-numbers ()
 566   "Return a sorted list of unread msg numbers to retrieve."
 567   (let (nums)
 568     (mapatoms (lambda (atom)
 569                 (if (not (cdr (symbol-value atom)))
 570                     (push (car (symbol-value atom)) nums)))
 571               pop3-uidl-obarray)
 572     (sort nums '<)))
 573
 574 (defun pop3-save-uidls ()
 575   "Save the updated UIDLs to disk for use next time."
 576   (when (and pop3-leave-mail-on-server
 577              ;; UIDL hash table is non-empty
 578              (let ((len (length pop3-uidl-obarray)))
 579                (while (< 0 len)
 580                  (setq len (if (symbolp (aref pop3-uidl-obarray (1- len)))
 581                                -1 (1- len))))
 582                (minusp len)))
 583     (when (file-readable-p pop3-uidl-file-name)
 584       (copy-file pop3-uidl-file-name
 585                  (concat pop3-uidl-file-name ".old")
 586                  'overwrite 'keeptime))
 587     (save-excursion
 588       (with-temp-file pop3-uidl-file-name
 589         (mapatoms
 590          (lambda (atom)
 591            (when (car (symbol-value atom))
 592              (insert (format "%s\n" atom))))
 593          pop3-uidl-obarray)))
 594     (fillarray pop3-uidl-obarray 0)))
 595
 596
 597 ;; The Command Set
 598
 599 ;; AUTHORIZATION STATE
 600
 601 (defun pop3-user (process user)
 602   "Send USER information to POP3 server."
 603   (pop3-send-command process (format "USER %s" user))
 604   (let ((response (pop3-read-response process t)))
 605     (if (not (and response (string-match "+OK" response)))
 606         (error (format "USER %s not valid" user)))))
 607
 608 (defun pop3-pass (process)
 609   "Send authentication information to the server."
 610   (pop3-send-command process (format "PASS %s" pop3-password))
 611   (let ((response (pop3-read-response process t)))
 612     (if (not (and response (string-match "+OK" response)))
 613         (pop3-quit process))))
 614
 615 (defun pop3-apop (process user)
 616   "Send alternate authentication information to the server."
 617   (let ((pass pop3-password))
 618     (if (and pop3-password-required (not pass))
 619         (setq pass
 620               (read-passwd (format "Password for %s: " pop3-maildrop))))
 621     (if pass
 622         ;; Note that `md5' should never encode a given string to use for
 623         ;; the apop authentication, so we should specify `binary'.
 624         (let ((hash (md5 (concat pop3-timestamp pass) nil nil 'binary)))
 625           (pop3-send-command process (format "APOP %s %s" user hash))
 626           (let ((response (pop3-read-response process t)))
 627             (if (not (and response (string-match "+OK" response)))
 628                 (pop3-quit process)))))))
 629
 630 (defun pop3-stls (process)
 631   "Query whether TLS extension is supported"
 632   (pop3-send-command process "STLS")
 633   (let ((response (pop3-read-response process t)))
 634     (if (not (and response (string-match "+OK" response)))
 635         (pop3-quit process))))
 636
 637 ;; TRANSACTION STATE
 638
 639 (defun pop3-stat (process)
 640   "Return the number of messages in the maildrop and the maildrop's size."
 641   (pop3-send-command process "STAT")
 642   (let ((response (pop3-read-response process t)))
 643     (list (string-to-number (nth 1 (split-string response " ")))
 644           (string-to-number (nth 2 (split-string response " "))))))
 645
 646 (defun pop3-retr (process msg crashbuf)
 647   "Retrieve message-id MSG to buffer CRASHBUF."
 648   (pop3-send-command process (format "RETR %s" msg))
 649   (pop3-read-response process)
 650   (save-excursion
 651     (let ((region (pop3-get-extended-response process)))
 652       (pop3-munge-message-separator (car region) (cadr region))
 653       (append-to-buffer crashbuf (car region) (cadr region))
 654       (delete-region (car region) (cadr region)))))
 655
 656 (defun pop3-dele (process msg)
 657   "Mark message-id MSG as deleted."
 658   (pop3-send-command process (format "DELE %s" msg))
 659   (pop3-read-response process))
 660
 661 (defun pop3-noop (process msg)
 662   "No-operation."
 663   (pop3-send-command process "NOOP")
 664   (pop3-read-response process))
 665
 666 (defun pop3-last (process)
 667   "Return highest accessed message-id number for the session."
 668   (pop3-send-command process "LAST")
 669   (let ((response (pop3-read-response process t)))
 670     (string-to-number (nth 1 (split-string response " ")))))
 671
 672 (defun pop3-rset (process)
 673   "Remove all delete marks from current maildrop."
 674   (pop3-send-command process "RSET")
 675   (pop3-read-response process))
 676
 677 ;; UPDATE
 678
 679 (defun pop3-quit (process)
 680   "Close connection to POP3 server.
 681 Tell server to remove all messages marked as deleted, unlock the maildrop,
 682 and close the connection."
 683   (pop3-send-command process "QUIT")
 684   (pop3-read-response process t)
 685   (when process
 686     (save-excursion
 687       (set-buffer (process-buffer process))
 688       (goto-char (point-max))
 689       (delete-process process))))
 690
 691 (defun pop3-uidl (process &optional msgno)
 692   "Return the results of a UIDL command in PROCESS for optional MSGNO.
 693 If UIDL is unsupported on this mail server or if msgno is invalid, return nil.
 694 Otherwise, return a list in the form
 695
 696    (N (1 UIDL-1) (2 UIDL-2) ... (N UIDL-N))
 697
 698 where
 699
 700    N is an integer for the number of UIDLs returned (could be 0)
 701    UIDL-n is a string."
 702
 703   (if msgno
 704       (pop3-send-command process (format "UIDL %d" msgno))
 705     (pop3-send-command process "UIDL"))
 706
 707   (if (null (pop3-read-response process t))
 708       nil ;; UIDL is not supported on this server
 709     (let (pairs uidl)
 710       (save-excursion
 711         (save-restriction
 712           (apply 'narrow-to-region (pop3-get-extended-response process))
 713           (goto-char (point-min))
 714           (while (looking-at "\\([^ \n\t]*\\) \\([^ \n\t]*\\)")
 715             (setq msgno (string-to-number (match-string 1))
 716                   uidl (match-string 2))
 717             (push (cons msgno uidl) pairs)
 718             (beginning-of-line 2))
 719           (cons (length pairs) (nreverse pairs)))))))
 720
 721 (defun pop3-list (process &optional msgno)
 722   "Return the results of a LIST command for PROCESS and optional MSGNO.
 723 If (optional) msgno is invalid, return nil.  Otherwise, return a list
 724 in the form
 725
 726    (N (1 LEN-1) (2 LEN-2) ... (N LEN-N))
 727
 728 where
 729
 730    N is an integer for the number of msg/len pairs (could be 0)
 731    LEN-n is an integer."
 732   (if msgno
 733       (pop3-send-command process (format "LIST %d" msgno))
 734     (pop3-send-command process "LIST"))
 735
 736   (if (null (pop3-read-response process t))
 737       nil ;; MSGNO is not valid number
 738     (let (pairs len)
 739       (save-excursion
 740         (save-restriction
 741           (apply 'narrow-to-region (pop3-get-extended-response process))
 742           (goto-char (point-min))
 743           (while (looking-at "\\([^ \n\t]*\\) \\([^ \n\t]*\\)")
 744             (setq msgno (string-to-number (match-string 1))
 745                   len (string-to-number (match-string 2)))
 746             (push (cons msgno len) pairs)
 747             (beginning-of-line 2))
 748           (cons (length pairs) (nreverse pairs)))))))
 749
 750 (defun pop3-top (process msgno &optional lines)
 751   "Return the top LINES of messages for PROCESS and MSGNO.
 752 If msgno is invalid, return nil.  Otherwise, return a string."
 753   (pop3-send-command process (format "TOP %d %d" msgno (or lines 1)))
 754   (if (pop3-read-response process t)
 755       nil ;; MSGNO is not valid number
 756     (save-excursion
 757       (apply 'buffer-substring (pop3-get-extended-response process)))))
 758
 759 ;;; Utility code
 760
 761 (defun pop3-get-extended-response (process)
 762   "Get the extended pop3 response in the PROCESS buffer."
 763   (let ((start pop3-read-point) end)
 764     (set-buffer (process-buffer process))
 765     (goto-char start)
 766     (while (not (re-search-forward "^\\.\r\n" nil t))
 767       (pop3-accept-process-output process)
 768       (goto-char start))
 769     (setq pop3-read-point (point-marker))
 770     (goto-char (match-beginning 0))
 771     (setq end (point-marker))
 772     (pop3-clean-region start end)
 773     (list start end)))
 774
 775 ;;; Advise the mail-source function in order to use this module in Gnus.
 776
 777 (eval-after-load "mail-source"
 778   '(if (member '(:connection)
 779                (assq 'pop (symbol-value 'mail-source-keyword-map)))
 780        nil ;; T-gnus is running.
 781      (defadvice mail-source-fetch-pop (around bind-t-gnus-keywords activate)
 782        "Bind `pop3-connection-type' and `pop3-leave-mail-on-server' according
 783 to `mail-sources' while fetching mails with Gnus."
 784        (let ((pop3-connection-type (or (plist-get (cdr (ad-get-arg 0))
 785                                                   :connection)
 786                                        pop3-connection-type))
 787              (pop3-leave-mail-on-server (or (plist-get (cdr (ad-get-arg 0))
 788                                                        :leave)
 789                                             pop3-leave-mail-on-server)))
 790          ad-do-it))))
 791
 792 \f
 793 ;; Summary of POP3 (Post Office Protocol version 3) commands and responses
 794
 795 ;;; AUTHORIZATION STATE
 796
 797 ;; Initial TCP connection
 798 ;; Arguments: none
 799 ;; Restrictions: none
 800 ;; Possible responses:
 801 ;;  +OK [POP3 server ready]
 802
 803 ;; USER name
 804 ;; Arguments: a server specific user-id (required)
 805 ;; Restrictions: authorization state [after unsuccessful USER or PASS
 806 ;; Possible responses:
 807 ;;  +OK [valid user-id]
 808 ;;  -ERR [invalid user-id]
 809
 810 ;; PASS string
 811 ;; Arguments: a server/user-id specific password (required)
 812 ;; Restrictions: authorization state, after successful USER
 813 ;; Possible responses:
 814 ;;  +OK [maildrop locked and ready]
 815 ;;  -ERR [invalid password]
 816 ;;  -ERR [unable to lock maildrop]
 817
 818 ;; STLS
 819 ;; Arguments: none
 820 ;; Restrictions: authorization state
 821 ;; Possible responses:
 822 ;;  +OK [negotiation is ready]
 823 ;;  -ERR [security layer is already active]
 824
 825 ;;; TRANSACTION STATE
 826
 827 ;; STAT
 828 ;; Arguments: none
 829 ;; Restrictions: transaction state
 830 ;; Possible responses:
 831 ;;  +OK nn mm [# of messages, size of maildrop]
 832
 833 ;; LIST [msg]
 834 ;; Arguments: a message-id (optional)
 835 ;; Restrictions: transaction state; msg must not be deleted
 836 ;; Possible responses:
 837 ;;  +OK [scan listing follows]
 838 ;;  -ERR [no such message]
 839
 840 ;; TOP msg [lines]
 841 ;; Arguments: a message-id (required), number of lines (optional)
 842 ;; Restrictions: transaction state; msg must not be deleted
 843 ;; Possible responses:
 844 ;;  +OK [partial message listing follows]
 845 ;;  -ERR [no such message]
 846
 847 ;; UIDL [msg]
 848 ;; Arguments: a message-id (optional)
 849 ;; Restrictions: transaction state; msg must not be deleted
 850 ;; Possible responses:
 851 ;;  +OK [uidl listing follows]
 852 ;;  -ERR [no such message]
 853
 854 ;; RETR msg
 855 ;; Arguments: a message-id (required)
 856 ;; Restrictions: transaction state; msg must not be deleted
 857 ;; Possible responses:
 858 ;;  +OK [message contents follow]
 859 ;;  -ERR [no such message]
 860
 861 ;; DELE msg
 862 ;; Arguments: a message-id (required)
 863 ;; Restrictions: transaction state; msg must not be deleted
 864 ;; Possible responses:
 865 ;;  +OK [message deleted]
 866 ;;  -ERR [no such message]
 867
 868 ;; NOOP
 869 ;; Arguments: none
 870 ;; Restrictions: transaction state
 871 ;; Possible responses:
 872 ;;  +OK
 873
 874 ;; LAST
 875 ;; Arguments: none
 876 ;; Restrictions: transaction state
 877 ;; Possible responses:
 878 ;;  +OK nn [highest numbered message accessed]
 879
 880 ;; RSET
 881 ;; Arguments: none
 882 ;; Restrictions: transaction state
 883 ;; Possible responses:
 884 ;;  +OK [all delete marks removed]
 885
 886 ;;; UPDATE STATE
 887
 888 ;; QUIT
 889 ;; Arguments: none
 890 ;; Restrictions: none
 891 ;; Possible responses:
 892 ;;  +OK [TCP connection closed]
 893
 894 (provide 'pop3)
 895
 896 ;;; pop3.el ends here