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.1"                       ; fixme?
 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) (= port 995))) ; pop3s
 338          (pop3-open-ssl-stream "POP" (current-buffer) mailhost port))
 339         ((or (memq pop3-connection-type '(tls starttls))
 340              (memq pop3-stream-type '(tls starttls)))
 341          (pop3-open-tls-stream "POP" (current-buffer) mailhost port))
 342         (t
 343          (let ((coding-system-for-read 'binary)
 344                (coding-system-for-write 'binary))
 345            (open-network-stream "POP" (current-buffer) mailhost port)))))
 346       (let ((response (pop3-read-response process t)))
 347         (setq pop3-timestamp
 348               (substring response (or (string-match "<" response) 0)
 349                          (+ 1 (or (string-match ">" response) -1)))))
 350       process)))
 351
 352 (eval-when-compile
 353   (autoload 'open-ssl-stream "ssl"))
 354
 355 (defun pop3-open-ssl-stream-1 (name buffer host service extra-arg)
 356   (require 'ssl)
 357   (let* ((ssl-program-name
 358           pop3-ssl-program-name)
 359          (ssl-program-arguments
 360           `(,@pop3-ssl-program-arguments
 361             ,extra-arg
 362             "-connect" ,(format "%s:%d" host service)))
 363          (process (open-ssl-stream name buffer host service)))
 364     (when process
 365       ;; There's a load of info printed that needs deleting.
 366       (with-current-buffer buffer
 367         (goto-char (point-min))
 368         (while (and (memq (process-status process) '(open run))
 369                     (goto-char (point-max))
 370                     (forward-line -1)
 371                     (not (looking-at "+OK")))
 372           (pop3-accept-process-output process)
 373           (sit-for 1))
 374         (delete-region (point-min) (point)))
 375       (and process (memq (process-status process) '(open run))
 376            process))))
 377
 378 (defun pop3-open-ssl-stream (name buffer host service)
 379   "Open a SSL connection for a service to a host.
 380 Returns a subprocess-object to represent the connection.
 381 Args are NAME BUFFER HOST SERVICE."
 382   (let (selective-display ;; Disable ^M to nl translation.
 383         (coding-system-for-read 'binary)
 384         (coding-system-for-write 'binary))
 385     (or (pop3-open-ssl-stream-1 name buffer host service "-ssl3")
 386         (pop3-open-ssl-stream-1 name buffer host service "-ssl2"))))
 387
 388 (defun pop3-open-tls-stream (name buffer host service)
 389   "Open a TLSv1 connection for a service to a host.
 390 Returns a subprocess-object to represent the connection.
 391 Args are NAME BUFFER HOST SERVICE."
 392   (let* (selective-display ;; Disable ^M to nl translation.
 393          (coding-system-for-read 'binary)
 394          (coding-system-for-write 'binary)
 395          (process (starttls-open-stream name buffer host service)))
 396     (pop3-stls process)
 397     (starttls-negotiate process)
 398     process))
 399
 400 ;; Support functions
 401
 402 (defun pop3-process-filter (process output)
 403   (save-excursion
 404     (set-buffer (process-buffer process))
 405     (goto-char (point-max))
 406     (insert output)))
 407
 408 (defun pop3-send-command (process command)
 409   (set-buffer (process-buffer process))
 410   (goto-char (point-max))
 411   ;; (if (= (aref command 0) ?P)
 412   ;;     (insert "PASS <omitted>\r\n")
 413   ;;   (insert command "\r\n"))
 414   (setq pop3-read-point (point))
 415   (goto-char (point-max))
 416   (process-send-string process (concat command "\r\n")))
 417
 418 (defun pop3-read-response (process &optional return)
 419   "Read the response from the server PROCESS.
 420 Return the response string if optional second argument RETURN is non-nil."
 421   (let ((case-fold-search nil)
 422         match-end)
 423     (save-excursion
 424       (set-buffer (process-buffer process))
 425       (goto-char pop3-read-point)
 426       (while (and (memq (process-status process) '(open run))
 427                   (not (search-forward "\r\n" nil t)))
 428         (pop3-accept-process-output process)
 429         (goto-char pop3-read-point))
 430       (setq match-end (point))
 431       (goto-char pop3-read-point)
 432       (if (looking-at "-ERR")
 433           (error (buffer-substring (point) (- match-end 2)))
 434         (if (not (looking-at "+OK"))
 435             (progn (setq pop3-read-point match-end) nil)
 436           (setq pop3-read-point match-end)
 437           (if return
 438               (buffer-substring (point) match-end)
 439             t))))))
 440
 441 (defun pop3-clean-region (start end)
 442   (setq end (set-marker (make-marker) end))
 443   (save-excursion
 444     (goto-char start)
 445     (while (and (< (point) end) (search-forward "\r\n" end t))
 446       (replace-match "\n" t t))
 447     (goto-char start)
 448     (while (re-search-forward "\n\n\\(From \\)" end t)
 449       (replace-match "\n\n>\\1" t nil))
 450     (goto-char start)
 451     (while (and (< (point) end) (re-search-forward "^\\." end t))
 452       (replace-match "" t t)
 453       (forward-char)))
 454   (set-marker end nil))
 455
 456 (eval-when-compile (defvar parse-time-months))
 457
 458 ;; Copied from message-make-date.
 459 (defun pop3-make-date (&optional now)
 460   "Make a valid date header.
 461 If NOW, use that time instead."
 462   (require 'parse-time)
 463   (let* ((now (or now (current-time)))
 464          (zone (nth 8 (decode-time now)))
 465          (sign "+"))
 466     (when (< zone 0)
 467       (setq sign "-")
 468       (setq zone (- zone)))
 469     (concat
 470      (format-time-string "%d" now)
 471      ;; The month name of the %b spec is locale-specific.  Pfff.
 472      (format " %s "
 473              (capitalize (car (rassoc (nth 4 (decode-time now))
 474                                       parse-time-months))))
 475      (format-time-string "%Y %H:%M:%S " now)
 476      ;; We do all of this because XEmacs doesn't have the %z spec.
 477      (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60)))))
 478
 479 (defun pop3-munge-message-separator (start end)
 480   "Check to see if a message separator exists.  If not, generate one."
 481   (save-excursion
 482     (save-restriction
 483       (narrow-to-region start end)
 484       (goto-char (point-min))
 485       (if (not (or (looking-at "From .?") ; Unix mail
 486                    (looking-at "\001\001\001\001\n") ; MMDF
 487                    (looking-at "BABYL OPTIONS:"))) ; Babyl
 488           (let* ((from (mail-strip-quoted-names (mail-fetch-field "From")))
 489                  (tdate (mail-fetch-field "Date"))
 490                  (date (split-string (or (and tdate
 491                                               (not (string= "" tdate))
 492                                               tdate)
 493                                          (pop3-make-date))
 494                                      " "))
 495                  (From_))
 496             ;; sample date formats I have seen
 497             ;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT)
 498             ;; Date: 08 Jul 1996 23:22:24 -0400
 499             ;; should be
 500             ;; Tue Jul 9 09:04:21 1996
 501
 502             ;; Fixme: This should use timezone on the date field contents.
 503             (setq date
 504                   (cond ((not date)
 505                          "Tue Jan 1 00:00:0 1900")
 506                         ((string-match "[A-Z]" (nth 0 date))
 507                          (format "%s %s %s %s %s"
 508                                  (nth 0 date) (nth 2 date) (nth 1 date)
 509                                  (nth 4 date) (nth 3 date)))
 510                         (t
 511                          ;; this really needs to be better but I don't feel
 512                          ;; like writing a date to day converter.
 513                          (format "Sun %s %s %s %s"
 514                                  (nth 1 date) (nth 0 date)
 515                                  (nth 3 date) (nth 2 date)))))
 516             (setq From_ (format "\nFrom %s  %s\n" from date))
 517             (while (string-match "," From_)
 518               (setq From_ (concat (substring From_ 0 (match-beginning 0))
 519                                   (substring From_ (match-end 0)))))
 520             (goto-char (point-min))
 521             (insert From_)
 522             (if (search-forward "\n\n" nil t)
 523                 nil
 524               (goto-char (point-max))
 525               (insert "\n"))
 526             (narrow-to-region (point) (point-max))
 527             (let ((size (- (point-max) (point-min))))
 528               (goto-char (point-min))
 529               (widen)
 530               (forward-line -1)
 531               (insert (format "Content-Length: %s\n" size))))))))
 532
 533 ;; UIDL support
 534
 535 (defun pop3-get-message-numbers (process)
 536   "Get the list of message numbers and lengths to retrieve via PROCESS."
 537   ;; we use the LIST comand first anyway to get the message lengths.
 538   ;; then if we're leaving mail on the server, see if the UIDL command
 539   ;; is implemented. if so, we use it to get the message number list.
 540   (let* ((messages (pop3-list process))
 541          (total (or (pop messages) 0))
 542          (uidl (if pop3-leave-mail-on-server
 543                    (pop3-get-uidl process)))
 544          out)
 545     (while messages
 546       ;; only retrieve messages matching our regexp or in the uidl list
 547       (when (and
 548              ;; remove elements not in the uidl, this assumes the uidl is short
 549              (or (not (and pop3-leave-mail-on-server
 550                            (cdr (assoc pop3-mailhost pop3-uidl-support))))
 551                  (memq (caar messages) uidl))
 552              (caar messages)
 553              ;; don't download messages that are too large
 554              (not (and pop3-maximum-message-size
 555                        (> (cdar messages) pop3-maximum-message-size)))
 556              (not (and pop3-except-header-regexp
 557                        (string-match pop3-except-header-regexp
 558                                      (pop3-top process (caar messages) 0)))))
 559         (push (car messages) out))
 560       (setq messages (cdr messages)))
 561     (cons total (nreverse out))))
 562
 563 (defun pop3-get-uidl (process)
 564   "Use PROCESS to get a list of unread message numbers."
 565   (let ((messages (pop3-uidl process))
 566         (support (assoc pop3-mailhost pop3-uidl-support))
 567         uidl)
 568     (if support
 569         (setcdr support (and messages t))
 570       (push (cons pop3-mailhost (and messages t))
 571             pop3-uidl-support))
 572     (when messages
 573       (save-excursion
 574         (with-temp-buffer
 575           (when (file-readable-p pop3-uidl-file-name)
 576             (insert-file-contents pop3-uidl-file-name))
 577           (goto-char (point-min))
 578           (while (looking-at "\\([^ \n\t]+\\)")
 579             (set (intern (match-string 1) pop3-uidl-obarray)
 580                  (cons nil t))
 581             (forward-line 1))))
 582       (dolist (message (cdr messages))
 583         (if (setq uidl (intern-soft (cdr message) pop3-uidl-obarray))
 584             (setcar (symbol-value uidl) (car message))
 585           (set (intern (cdr message) pop3-uidl-obarray)
 586                (cons (car message) nil))))
 587       (pop3-get-unread-message-numbers))))
 588
 589 (defun pop3-get-unread-message-numbers ()
 590   "Return a sorted list of unread msg numbers to retrieve."
 591   (let (nums)
 592     (mapatoms (lambda (atom)
 593                 (if (not (cdr (symbol-value atom)))
 594                     (push (car (symbol-value atom)) nums)))
 595               pop3-uidl-obarray)
 596     (sort nums '<)))
 597
 598 (defun pop3-save-uidls ()
 599   "Save the updated UIDLs to disk for use next time."
 600   (when (and pop3-leave-mail-on-server
 601              ;; UIDL hash table is non-empty
 602              (let ((len (length pop3-uidl-obarray)))
 603                (while (< 0 len)
 604                  (setq len (if (symbolp (aref pop3-uidl-obarray (1- len)))
 605                                -1 (1- len))))
 606                (minusp len)))
 607     (when (file-readable-p pop3-uidl-file-name)
 608       (copy-file pop3-uidl-file-name
 609                  (concat pop3-uidl-file-name ".old")
 610                  'overwrite 'keeptime))
 611     (save-excursion
 612       (with-temp-file pop3-uidl-file-name
 613         (mapatoms
 614          (lambda (atom)
 615            (when (car (symbol-value atom))
 616              (insert (format "%s\n" atom))))
 617          pop3-uidl-obarray)))
 618     (fillarray pop3-uidl-obarray 0)))
 619
 620
 621 ;; The Command Set
 622
 623 ;; AUTHORIZATION STATE
 624
 625 (defun pop3-user (process user)
 626   "Send USER information to POP3 server."
 627   (pop3-send-command process (format "USER %s" user))
 628   (let ((response (pop3-read-response process t)))
 629     (if (not (and response (string-match "+OK" response)))
 630         (error "USER %s not valid" user))))
 631
 632 (defun pop3-pass (process)
 633   "Send authentication information to the server."
 634   (pop3-send-command process (format "PASS %s" pop3-password))
 635   (let ((response (pop3-read-response process t)))
 636     (if (not (and response (string-match "+OK" response)))
 637         (pop3-quit process))))
 638
 639 (defun pop3-apop (process user)
 640   "Send alternate authentication information to the server."
 641   (let ((pass pop3-password))
 642     (if (and pop3-password-required (not pass))
 643         (setq pass
 644               (read-passwd (format "Password for %s: " pop3-maildrop))))
 645     (if pass
 646         ;; Note that `md5' should never encode a given string to use for
 647         ;; the apop authentication, so we should specify `binary'.
 648         (let ((hash (md5 (concat pop3-timestamp pass) nil nil 'binary)))
 649           (pop3-send-command process (format "APOP %s %s" user hash))
 650           (let ((response (pop3-read-response process t)))
 651             (if (not (and response (string-match "+OK" response)))
 652                 (pop3-quit process)))))))
 653
 654 (defun pop3-stls (process)
 655   "Query whether TLS extension is supported"
 656   (pop3-send-command process "STLS")
 657   (let ((response (pop3-read-response process t)))
 658     (if (not (and response (string-match "+OK" response)))
 659         (pop3-quit process))))
 660
 661 ;; TRANSACTION STATE
 662
 663 (defun pop3-stat (process)
 664   "Return the number of messages in the maildrop and the maildrop's size."
 665   (pop3-send-command process "STAT")
 666   (let ((response (pop3-read-response process t)))
 667     (list (string-to-number (nth 1 (split-string response " ")))
 668           (string-to-number (nth 2 (split-string response " "))))))
 669
 670 (defun pop3-retr (process msg crashbuf)
 671   "Retrieve message-id MSG to buffer CRASHBUF."
 672   (pop3-send-command process (format "RETR %s" msg))
 673   (pop3-read-response process)
 674   (save-excursion
 675     (let ((region (pop3-get-extended-response process)))
 676       (pop3-munge-message-separator (car region) (cadr region))
 677       (append-to-buffer crashbuf (car region) (cadr region))
 678       (delete-region (car region) (cadr region)))))
 679
 680 (defun pop3-dele (process msg)
 681   "Mark message-id MSG as deleted."
 682   (pop3-send-command process (format "DELE %s" msg))
 683   (pop3-read-response process))
 684
 685 (defun pop3-noop (process msg)
 686   "No-operation."
 687   (pop3-send-command process "NOOP")
 688   (pop3-read-response process))
 689
 690 (defun pop3-last (process)
 691   "Return highest accessed message-id number for the session."
 692   (pop3-send-command process "LAST")
 693   (let ((response (pop3-read-response process t)))
 694     (string-to-number (nth 1 (split-string response " ")))))
 695
 696 (defun pop3-rset (process)
 697   "Remove all delete marks from current maildrop."
 698   (pop3-send-command process "RSET")
 699   (pop3-read-response process))
 700
 701 ;; UPDATE
 702
 703 (defun pop3-quit (process)
 704   "Close connection to POP3 server.
 705 Tell server to remove all messages marked as deleted, unlock the maildrop,
 706 and close the connection."
 707   (pop3-send-command process "QUIT")
 708   (pop3-read-response process t)
 709   (when process
 710     (save-excursion
 711       (set-buffer (process-buffer process))
 712       (goto-char (point-max))
 713       (delete-process process))))
 714
 715 (defun pop3-uidl (process &optional msgno)
 716   "Return the results of a UIDL command in PROCESS for optional MSGNO.
 717 If UIDL is unsupported on this mail server or if msgno is invalid, return nil.
 718 Otherwise, return a list in the form
 719
 720    (N (1 UIDL-1) (2 UIDL-2) ... (N UIDL-N))
 721
 722 where
 723
 724    N is an integer for the number of UIDLs returned (could be 0)
 725    UIDL-n is a string."
 726
 727   (if msgno
 728       (pop3-send-command process (format "UIDL %d" msgno))
 729     (pop3-send-command process "UIDL"))
 730
 731   (if (null (pop3-read-response process t))
 732       nil ;; UIDL is not supported on this server
 733     (let (pairs uidl)
 734       (save-excursion
 735         (save-restriction
 736           (apply 'narrow-to-region (pop3-get-extended-response process))
 737           (goto-char (point-min))
 738           (while (looking-at "\\([^ \n\t]*\\) \\([^ \n\t]*\\)")
 739             (setq msgno (string-to-number (match-string 1))
 740                   uidl (match-string 2))
 741             (push (cons msgno uidl) pairs)
 742             (beginning-of-line 2))
 743           (cons (length pairs) (nreverse pairs)))))))
 744
 745 (defun pop3-list (process &optional msgno)
 746   "Return the results of a LIST command for PROCESS and optional MSGNO.
 747 If (optional) msgno is invalid, return nil.  Otherwise, return a list
 748 in the form
 749
 750    (N (1 LEN-1) (2 LEN-2) ... (N LEN-N))
 751
 752 where
 753
 754    N is an integer for the number of msg/len pairs (could be 0)
 755    LEN-n is an integer."
 756   (if msgno
 757       (pop3-send-command process (format "LIST %d" msgno))
 758     (pop3-send-command process "LIST"))
 759
 760   (if (null (pop3-read-response process t))
 761       nil ;; MSGNO is not valid number
 762     (let (pairs len)
 763       (save-excursion
 764         (save-restriction
 765           (apply 'narrow-to-region (pop3-get-extended-response process))
 766           (goto-char (point-min))
 767           (while (looking-at "\\([^ \n\t]*\\) \\([^ \n\t]*\\)")
 768             (setq msgno (string-to-number (match-string 1))
 769                   len (string-to-number (match-string 2)))
 770             (push (cons msgno len) pairs)
 771             (beginning-of-line 2))
 772           (cons (length pairs) (nreverse pairs)))))))
 773
 774 (defun pop3-top (process msgno &optional lines)
 775   "Return the top LINES of messages for PROCESS and MSGNO.
 776 If msgno is invalid, return nil.  Otherwise, return a string."
 777   (pop3-send-command process (format "TOP %d %d" msgno (or lines 1)))
 778   (if (pop3-read-response process t)
 779       nil ;; MSGNO is not valid number
 780     (save-excursion
 781       (apply 'buffer-substring (pop3-get-extended-response process)))))
 782
 783 ;;; Utility code
 784
 785 (defun pop3-get-extended-response (process)
 786   "Get the extended pop3 response in the PROCESS buffer."
 787   (let ((start pop3-read-point) end)
 788     (set-buffer (process-buffer process))
 789     (goto-char start)
 790     (while (not (re-search-forward "^\\.\r\n" nil t))
 791       (pop3-accept-process-output process)
 792       (goto-char start))
 793     (setq pop3-read-point (point-marker))
 794     (goto-char (match-beginning 0))
 795     (setq end (point-marker))
 796     (pop3-clean-region start end)
 797     (list start end)))
 798
 799 ;;; Advise the mail-source function in order to use this module in Gnus.
 800
 801 (eval-after-load "mail-source"
 802   '(if (member '(:connection)
 803                (assq 'pop (symbol-value 'mail-source-keyword-map)))
 804        nil ;; T-gnus is running.
 805      (defadvice mail-source-fetch-pop (around bind-t-gnus-keywords activate)
 806        "Bind `pop3-connection-type' and `pop3-leave-mail-on-server' according
 807 to `mail-sources' while fetching mails with Gnus."
 808        (let ((pop3-connection-type (or (plist-get (cdr (ad-get-arg 0))
 809                                                   :connection)
 810                                        pop3-connection-type))
 811              (pop3-leave-mail-on-server (or (plist-get (cdr (ad-get-arg 0))
 812                                                        :leave)
 813                                             pop3-leave-mail-on-server)))
 814          ad-do-it))))
 815
 816 \f
 817 ;; Summary of POP3 (Post Office Protocol version 3) commands and responses
 818
 819 ;;; AUTHORIZATION STATE
 820
 821 ;; Initial TCP connection
 822 ;; Arguments: none
 823 ;; Restrictions: none
 824 ;; Possible responses:
 825 ;;  +OK [POP3 server ready]
 826
 827 ;; USER name
 828 ;; Arguments: a server specific user-id (required)
 829 ;; Restrictions: authorization state [after unsuccessful USER or PASS
 830 ;; Possible responses:
 831 ;;  +OK [valid user-id]
 832 ;;  -ERR [invalid user-id]
 833
 834 ;; PASS string
 835 ;; Arguments: a server/user-id specific password (required)
 836 ;; Restrictions: authorization state, after successful USER
 837 ;; Possible responses:
 838 ;;  +OK [maildrop locked and ready]
 839 ;;  -ERR [invalid password]
 840 ;;  -ERR [unable to lock maildrop]
 841
 842 ;; STLS
 843 ;; Arguments: none
 844 ;; Restrictions: authorization state
 845 ;; Possible responses:
 846 ;;  +OK [negotiation is ready]
 847 ;;  -ERR [security layer is already active]
 848
 849 ;; STLS      (RFC 2595)
 850 ;; Arguments: none
 851 ;; Restrictions: Only permitted in AUTHORIZATION state.
 852 ;; Possible responses:
 853 ;;  +OK
 854 ;;  -ERR
 855
 856 ;;; TRANSACTION STATE
 857
 858 ;; STAT
 859 ;; Arguments: none
 860 ;; Restrictions: transaction state
 861 ;; Possible responses:
 862 ;;  +OK nn mm [# of messages, size of maildrop]
 863
 864 ;; LIST [msg]
 865 ;; Arguments: a message-id (optional)
 866 ;; Restrictions: transaction state; msg must not be deleted
 867 ;; Possible responses:
 868 ;;  +OK [scan listing follows]
 869 ;;  -ERR [no such message]
 870
 871 ;; TOP msg [lines]
 872 ;; Arguments: a message-id (required), number of lines (optional)
 873 ;; Restrictions: transaction state; msg must not be deleted
 874 ;; Possible responses:
 875 ;;  +OK [partial message listing follows]
 876 ;;  -ERR [no such message]
 877
 878 ;; UIDL [msg]
 879 ;; Arguments: a message-id (optional)
 880 ;; Restrictions: transaction state; msg must not be deleted
 881 ;; Possible responses:
 882 ;;  +OK [uidl listing follows]
 883 ;;  -ERR [no such message]
 884
 885 ;; RETR msg
 886 ;; Arguments: a message-id (required)
 887 ;; Restrictions: transaction state; msg must not be deleted
 888 ;; Possible responses:
 889 ;;  +OK [message contents follow]
 890 ;;  -ERR [no such message]
 891
 892 ;; DELE msg
 893 ;; Arguments: a message-id (required)
 894 ;; Restrictions: transaction state; msg must not be deleted
 895 ;; Possible responses:
 896 ;;  +OK [message deleted]
 897 ;;  -ERR [no such message]
 898
 899 ;; NOOP
 900 ;; Arguments: none
 901 ;; Restrictions: transaction state
 902 ;; Possible responses:
 903 ;;  +OK
 904
 905 ;; LAST
 906 ;; Arguments: none
 907 ;; Restrictions: transaction state
 908 ;; Possible responses:
 909 ;;  +OK nn [highest numbered message accessed]
 910
 911 ;; RSET
 912 ;; Arguments: none
 913 ;; Restrictions: transaction state
 914 ;; Possible responses:
 915 ;;  +OK [all delete marks removed]
 916
 917 ;;; UPDATE STATE
 918
 919 ;; QUIT
 920 ;; Arguments: none
 921 ;; Restrictions: none
 922 ;; Possible responses:
 923 ;;  +OK [TCP connection closed]
 924
 925 (provide 'pop3)
 926
 927 ;;; pop3.el ends here