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