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