cgit.sxemacs.org Git - packages/blob - xemacs-packages/mail-lib/pop3.el

   1 ;;; pop3.el --- Post Office Protocol (RFC 1460) interface
   2
   3 ;; Copyright (C) 1996, 1997, 1998 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1997 Franklin Lee
   5
   6 ;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>
   7 ;; Author: Franklin Lee <flee@lehman.com>
   8 ;; Author: Andy Piper <andy@xemacs.org>
   9
  10 ;; Maintainer:      Andy Piper <andy@xemacs.org>
  11
  12 ;; Keywords: mail, pop3
  13 ;; Version: 2.06
  14
  15 ;; Sync'ed up with: official pop3.el version 1.3s.
  16 ;; This version is a fork of the original pop3.el and the changes have
  17 ;; not been merged back in to that version due to political difficulties.
  18
  19 ;; This file is part of XEmacs.
  20
  21 ;; XEmacs is free software; you can redistribute it and/or modify
  22 ;; it under the terms of the GNU General Public License as published by
  23 ;; the Free Software Foundation; either version 2, or (at your option)
  24 ;; any later version.
  25
  26 ;; XEmacs is distributed in the hope that it will be useful,
  27 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  28 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  29 ;; GNU General Public License for more details.
  30
  31 ;; You should have received a copy of the GNU General Public License
  32 ;; along with XEmacs; see the file COPYING.  If not, write to the
  33 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  34 ;; Boston, MA 02111-1307, USA.
  35
  36 ;;; Commentary:
  37
  38 ;; Most of the standard and optional Post Office Protocol version 3
  39 ;; (RFC 1460) commands are implemented.
  40
  41 ;; This program was inspired by Kyle E. Jones's vm-pop program.
  42
  43 ;; This version has been enhanced for speed, UIDL and regexp matching
  44 ;; of headers by Andy Piper <andy@xemacs.org>.  UIDL support has been
  45 ;; mostly stolen from epop3mail. Please address problems with this
  46 ;; version (2.xx) to me.
  47
  48 ;; Speed has been enhanced by trying to slurp a maildrop in one
  49 ;; go. Also performance is vastly affected by how many POP3 commands
  50 ;; are issued, thus I have tried to cut down on this. Note that now
  51 ;; the single biggest time hog by a long way is
  52 ;; accept-process-output. I don't know of a good way to fix this as
  53 ;; this program is now close to the theoretical maximum as measured
  54 ;; against movemail. Under cygwin (and probably windows also) I think
  55 ;; socket I/O is just plain slow. YMMV.
  56
  57 ;;; Setup:
  58
  59 ;; To use this with gnus add:
  60 ;;      (setq nnmail-movemail-program 'pop3-nnmail-movemail)
  61 ;; to your .emacs
  62
  63 ;; You may also want to add the following
  64 ;;      (setq pop3-leave-mail-on-server t)
  65
  66 ;; If you (like me) use gnus to only pick up some of your mail you can
  67 ;; add something like:
  68 ;;      (setq pop3-retr-regexp "..:.*someaddress")
  69 ;; You probably want to leave mail on server in this instance as this
  70 ;; will prevent matching every message in your maildrop every time you
  71 ;; read mail. If you do this you may want to:
  72 ;;      (setq pop3-delete-retrieved-mail t)
  73 ;; so that mail you have actually downloaded gets deleted from your
  74 ;; maildrop.
  75
  76 ;;; Code:
  77
  78 (require 'mail-utils)
  79
  80 (defconst pop3-version "2.06-xemacs")
  81
  82 (defvar pop3-maildrop (or (user-login-name) (getenv "LOGNAME") (getenv "USER") nil)
  83   "*POP3 maildrop.")
  84 (defvar pop3-mailhost (or (getenv "MAILHOST") nil)
  85   "*POP3 mailhost.")
  86 (defvar pop3-port 110
  87   "*POP3 port.")
  88
  89 (defvar pop3-password-required t
  90   "*Non-nil if a password is required when connecting to POP server.")
  91
  92 (defvar pop3-password nil
  93   "*Password to use when connecting to POP server.")
  94
  95 (defvar pop3-authentication-scheme 'pass
  96   "*POP3 authentication scheme.
  97 Defaults to 'pass, for the standard USER/PASS authentication.  Other valid
  98 values are 'apop.")
  99
 100 (defvar pop3-timestamp nil
 101   "Timestamp returned when initially connected to the POP server.
 102 Used for APOP authentication.")
 103
 104 (defvar pop3-extended-response-beginning nil
 105   "Start of the region containing the last pop3 extended response.
 106 This does NOT include the initial response from `pop3-read-response'.")
 107
 108 (defvar pop3-extended-response-end nil
 109   "End of the region containing the last pop3 extended response.")
 110
 111 (defvar pop3-leave-mail-on-server nil
 112   "Non-nil if mail is to be left on the server and UIDL used for message retrieval.")
 113
 114 (defvar pop3-delete-retrieved-mail nil
 115   "Non-nil if mail that has been retrieved is to be deleted from the server.
 116 This is not the opposite to `pop3-leave-mail-on-server' since it is
 117 possible to not download all mail, hence leaving mail on the server
 118 and hence requiring the use of UIDL support, but still wanting to
 119 delete the mail that has been downloaded. If
 120 `pop3-leave-mail-on-server' is nil then this variable has no effect.")
 121
 122 (defvar pop3-retr-regexp nil
 123   "If non-nil only retrieve messages matching this regexp.")
 124
 125 (defvar pop3-maximum-message-size nil
 126   "If non-nil only download messages smaller than this.")
 127
 128 (defvar pop3-uidl-file-name "~/.uidls"
 129   "File in which to store the UIDL of processed messages.")
 130
 131 (defvar pop3-cache-password nil
 132   "Whether to cache the pop password or not.
 133 If NIL ask for password each time mail is retrieved. Otherwise cache
 134 the password.")
 135
 136 (defvar pop3-read-point nil)
 137 (defvar pop3-debug nil)
 138 (defvar pop3-uidl-support 'dont-know
 139   "Whether the server supports UIDL.
 140 Nil means no, t means yes, not-nil-or-t means yet to be determined.")
 141
 142 (defvar pop3-utab nil
 143   "Uidl hash table.")
 144
 145 ;;;###autoload
 146 (defun pop3-nnmail-movemail (inbox crashbox)
 147   "Function to move mail from INBOX on a pop3 server to file CRASHBOX."
 148   (let ((pop3-maildrop
 149          (substring inbox (match-end (string-match "^po:" inbox)))))
 150     (pop3-movemail crashbox)))
 151
 152 ;;;###autoload
 153 (defun pop3-movemail (&optional crashbox)
 154   "Transfer contents of a maildrop to the specified CRASHBOX."
 155   (or crashbox (setq crashbox (expand-file-name "~/.crashbox")))
 156   (let* ((process (pop3-open-server pop3-mailhost pop3-port))
 157          (crashbuf (get-buffer-create " *pop3-retr*"))
 158          (n 1)
 159          (msgid 1)
 160          (msglen 0)
 161          message-count
 162          (password pop3-password)
 163          (retrieved-messages '())
 164          message-list)
 165     ;; for debugging only
 166     (if pop3-debug (switch-to-buffer (process-buffer process)))
 167     ;; query for password
 168     (if (and pop3-password-required (not pop3-password))
 169         (setq password
 170               (pop3-read-passwd (format "Password for %s: " pop3-maildrop))))
 171     (cond ((equal 'apop pop3-authentication-scheme)
 172            (pop3-apop process password pop3-maildrop))
 173           ((equal 'pass pop3-authentication-scheme)
 174            (pop3-user process pop3-maildrop)
 175            (pop3-pass process password))
 176           (t (error "Invalid POP3 authentication scheme.")))
 177     ;; cache the password if required
 178     (when pop3-cache-password
 179       (setq pop3-password password))
 180     ;; reset uidl support
 181     (unless pop3-uidl-support
 182       (setq pop3-uidl-support 'dont-know))
 183     ;; get messages that are suitable for download
 184     (message "Retrieving message list...")
 185     (setq message-list (pop3-get-message-numbers process))
 186     (setq message-count (length message-list))
 187     (message (format "Retrieving message list...%d unread" message-count))
 188     ;; now get messages
 189     (unwind-protect
 190         (while (<= n message-count)
 191           (setq msgid (car (car message-list)))
 192           (setq msglen (cdr (car message-list)))
 193           (setq message-list (cdr message-list))
 194           ;; only retrieve messages matching our regexp or in the uidl list
 195           (if (or (not msgid)
 196                   ;; don't download messages that are too large
 197                   (and pop3-maximum-message-size
 198                        (> msglen pop3-maximum-message-size))
 199                   (and (or (null pop3-leave-mail-on-server)
 200                            ;; we top messages that are longer than 10k
 201                            ;; since retrieving a large message only to
 202                            ;; ignore it is wasteful.
 203                            (> msglen 10000))
 204                        pop3-retr-regexp
 205                        (not (string-match pop3-retr-regexp
 206                                           (pop3-top process msgid)))))
 207               (message (format "Ignoring message %d of %d from %s..."
 208                                n message-count pop3-mailhost))
 209             (message (format "Retrieving message %d of %d from %s..."
 210                              n message-count pop3-mailhost))
 211             (if (pop3-retr process msgid crashbuf)
 212                 (setq retrieved-messages (cons msgid retrieved-messages))
 213               (message (format "Retrieving message %d of %d from %s...ignored"
 214                                n message-count pop3-mailhost))))
 215           ;; deleted a whole bunch of stuff here that updates the crashbox
 216           ;; incrementally. This is way slow and mostly uneccessary, gnus
 217           ;; and others will simply slurp the whole mail buffer anyway so
 218           ;; why bother?
 219           (setq n (+ 1 n)))
 220       ;; frob the crash buffer at the end
 221       (set-buffer crashbuf)
 222       (let ((coding-system-for-write 'binary))
 223         (append-to-file (point-min) (point-max) crashbox))
 224       ;; mark messages as read
 225       (when pop3-leave-mail-on-server
 226         (pop3-save-uidls))
 227       ;; now delete the messages we have retrieved
 228       (unless (and pop3-leave-mail-on-server (null pop3-delete-retrieved-mail))
 229         (mapcar
 230          '(lambda (n)
 231             (message (format "Deleting message %d of %d from %s..."
 232                              n message-count pop3-mailhost))
 233             (pop3-dele process n)) retrieved-messages))
 234       (pop3-quit process))
 235     (kill-buffer crashbuf)
 236     )
 237   t)
 238
 239 (defun pop3-open-server (mailhost port)
 240   "Open TCP connection to MAILHOST.
 241 Returns the process associated with the connection."
 242   (let ((process-buffer
 243          (get-buffer-create (format "trace of POP session to %s" mailhost)))
 244         (process)
 245         (coding-system-for-read 'binary)
 246         (coding-system-for-write 'binary))
 247     (save-excursion
 248       (set-buffer process-buffer)
 249       (erase-buffer))
 250     (setq process
 251           (open-network-stream "POP" process-buffer mailhost port))
 252     (setq pop3-read-point (point-min))
 253     (let ((response (pop3-read-response process t)))
 254       (setq pop3-timestamp
 255             (substring response (or (string-match "<" response) 0)
 256                        (+ 1 (or (string-match ">" response) -1)))))
 257     process
 258     ))
 259
 260 ;; Support functions
 261
 262 (defun pop3-process-filter (process output)
 263   (save-excursion
 264     (set-buffer (process-buffer process))
 265     (goto-char (point-max))
 266     (insert output)))
 267
 268 (defun pop3-send-command (process command)
 269     (set-buffer (process-buffer process))
 270     (goto-char (point-max))
 271 ;;    (if (= (aref command 0) ?P)
 272 ;;      (insert "PASS <omitted>\r\n")
 273 ;;      (insert command "\r\n"))
 274     (setq pop3-read-point (point))
 275     (goto-char (point-max))
 276     (process-send-string process (concat command "\r\n"))
 277     )
 278
 279 (defun pop3-read-response (process &optional return)
 280   "Read the response from the server.
 281 Return the response string if optional second argument is non-nil."
 282   (let ((case-fold-search nil)
 283         match-end)
 284     (save-excursion
 285       (set-buffer (process-buffer process))
 286       (goto-char pop3-read-point)
 287       (while (not (search-forward "\r\n" nil t))
 288         (accept-process-output process)
 289         (goto-char pop3-read-point))
 290       (setq match-end (point))
 291       (goto-char pop3-read-point)
 292       (if (looking-at "-ERR")
 293           (signal 'error (list (buffer-substring (point) (- match-end 2))))
 294         (if (not (looking-at "+OK"))
 295             (progn (setq pop3-read-point match-end) nil)
 296           (setq pop3-read-point match-end)
 297           (if return
 298               (buffer-substring (point) match-end)
 299             t)
 300           )))))
 301
 302 (defun pop3-string-to-list (string &optional regexp)
 303   "Chop up a string into a list."
 304   (let ((list)
 305         (regexp (or regexp " "))
 306         (string (if (string-match "\r" string)
 307                     (substring string 0 (match-beginning 0))
 308                   string)))
 309     (store-match-data nil)
 310     (while string
 311       (if (string-match regexp string)
 312           (setq list (cons (substring string 0 (- (match-end 0) 1)) list)
 313                 string (substring string (match-end 0)))
 314         (setq list (cons string list)
 315               string nil)))
 316     (nreverse list)))
 317
 318 (defvar pop3-read-passwd nil)
 319 (defun pop3-read-passwd (prompt)
 320   (if (not pop3-read-passwd)
 321       (if (load "passwd" t)
 322           (setq pop3-read-passwd 'read-passwd)
 323         (autoload 'ange-ftp-read-passwd "ange-ftp")
 324         (setq pop3-read-passwd 'ange-ftp-read-passwd)))
 325   (funcall pop3-read-passwd prompt))
 326
 327 (defun pop3-clean-region (start end)
 328   "Convert CRLF line endings to LF line endings.
 329 Also remove '.' from the beginning of lines.
 330 Also escape 'From ' after '\n\n' with '>' (for mbox)."
 331   (setq end (set-marker (make-marker) end))
 332   (save-excursion
 333     (goto-char start)
 334     (while (and (< (point) end) (search-forward "\r\n" end t))
 335       (replace-match "\n" t t))
 336     (goto-char start)
 337         (while (re-search-forward "\n\n\\(From \\)" end t)
 338           (replace-match "\n\n>\\1" t nil))
 339     (goto-char start)
 340     (while (and (< (point) end) (re-search-forward "^\\." end t))
 341       (replace-match "" t t)
 342       (forward-char)))
 343   (set-marker end nil))
 344
 345 (defun pop3-munge-message-separator (start end)
 346   "Check to see if a message separator exists.  If not, generate one."
 347   (if (not (fboundp 'message-make-date)) (autoload 'message-make-date "message"))
 348   (save-excursion
 349     (save-restriction
 350       (narrow-to-region start end)
 351       (goto-char (point-min))
 352       (if (not (or (looking-at "From .?") ; Unix mail
 353                    (looking-at "\001\001\001\001\n") ; MMDF
 354                    (looking-at "BABYL OPTIONS:") ; Babyl
 355                    ))
 356           (let ((from (mail-strip-quoted-names (mail-fetch-field "From")))
 357                 (date (pop3-string-to-list (or (mail-fetch-field "Date")
 358                                                (message-make-date))))
 359                 (From_))
 360             ;; sample date formats I have seen
 361             ;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT)
 362             ;; Date: 08 Jul 1996 23:22:24 -0400
 363             ;; should be
 364             ;; Tue Jul 9 09:04:21 1996
 365             (setq date
 366                   (cond ((string-match "[A-Z]" (nth 0 date))
 367                          (format "%s %s %s %s %s"
 368                                  (nth 0 date) (nth 2 date) (nth 1 date)
 369                                  (nth 4 date) (nth 3 date)))
 370                         (t
 371                          ;; this really needs to be better but I don't feel
 372                          ;; like writing a date to day converter.
 373                          (format "Sun %s %s %s %s"
 374                                  (nth 1 date) (nth 0 date)
 375                                  (nth 3 date) (nth 2 date)))
 376                         ))
 377             (setq From_ (format "\nFrom %s  %s\n" from date))
 378             (while (string-match "," From_)
 379               (setq From_ (concat (substring From_ 0 (match-beginning 0))
 380                                   (substring From_ (match-end 0)))))
 381             (goto-char (point-min))
 382             (insert From_)
 383             (re-search-forward "\n\n")
 384             (narrow-to-region (point) (point-max))
 385             (let ((size (- (point-max) (point-min))))
 386               (goto-char (point-min))
 387               (widen)
 388               (forward-line -1)
 389               (insert (format "Content-Length: %s\n" size)))
 390             )))))
 391
 392 ;; UIDL support, mostly copied from epop3
 393
 394 (defun pop3-get-message-numbers (process)
 395   "Get the list of message numbers and lengths to retrieve via PROCESS."
 396   ;; we use the LIST comand first anyway to get the message lengths.
 397   ;; then if we're leaving mail on the server, see if the UIDL command
 398   ;; is implemented. if so, we use it to get the message number list.
 399   (let ((msg-list (pop3-list process))
 400         (uidl (if pop3-leave-mail-on-server
 401                   (pop3-get-uidl process)))
 402         (tmplist '()))
 403     (when msg-list
 404       (setq msg-list (cdr msg-list))
 405       (if (eq pop3-uidl-support t)
 406           ;; remove elements not in the uidl, this assumes the uidl is short
 407           (mapcar '(lambda (elt)
 408                      (when (memq (car elt) uidl)
 409                        (push elt tmplist))) (reverse msg-list))
 410         (setq tmplist msg-list))
 411       tmplist)))
 412
 413 (defun pop3-get-list (process)
 414   "Use PROCESS to get a list of message numbers."
 415   (let ((pairs (pop3-list process))
 416         (tmplist '()))
 417     (when pairs
 418       (mapcar '(lambda (elt)
 419                  (push (car elt) tmplist))
 420               (cdr pairs)) tmplist)))
 421
 422 (defun pop3-get-uidl (process)
 423   "Use PROCESS to get a list of unread message numbers."
 424   (let ((pairs (pop3-uidl process)))
 425     (if (or (null pairs) (null pop3-uidl-support))
 426         (setq pop3-uidl-support nil)
 427       (setq pop3-uidl-support t)
 428       (pop3-init-uidl-tables)
 429       (mapcar 'pop3-update-tables (cdr pairs))
 430       (pop3-get-unread-message-numbers))))
 431
 432 (defun pop3-init-uidl-tables ()
 433   "Create the hash table for uidl processing.
 434 This is only sensible to do when 'pop3-leave-mail-on-server' is non-nil."
 435   (save-excursion
 436     (with-temp-buffer
 437       (let ((uid nil))
 438         (when (file-readable-p pop3-uidl-file-name)
 439           (insert-file-contents pop3-uidl-file-name))
 440         (setq pop3-utab (make-hash-table :test 'equal))
 441         (goto-char (point-min))
 442         (while (looking-at "\\([^ \n\t]+\\)")
 443           (setq uid (buffer-substring (match-beginning 1) (match-end 1)))
 444           (puthash uid (cons nil t) pop3-utab)
 445           (forward-line 1))))))
 446
 447 (defun pop3-get-unread-message-numbers ()
 448   "Return a sorted list of unread msg numbers to retrieve."
 449   (let ((pop3-tmplist '()))
 450     (maphash '(lambda (key val)
 451                 (if (not (cdr val))
 452                     (push (car val) pop3-tmplist))) pop3-utab)
 453     (sort pop3-tmplist '<)))
 454
 455 (defun pop3-update-tables (pair)
 456   "Update uidl hash-tables given a PAIR list (msgno uid)."
 457   (let ((msgno (car pair))
 458         (uid (cdr pair)))
 459     (if (null (gethash uid pop3-utab))
 460         (puthash uid (cons msgno nil) pop3-utab)
 461       (puthash uid (cons msgno t) pop3-utab))))
 462
 463 ;    (if (null (gethash msgno pop3-utab))
 464 ;        (puthash uid uid pop3-utab))))
 465
 466 (defun pop3-save-uidls ()
 467   "Save the updated UIDLs to disk for use next time."
 468   ;;
 469   ;; write the uidl, msgid to the local uidl file EXCEPT the ones which
 470   ;; don't have msgnos, since they've been deleted from the server
 471   ;;
 472
 473   (when (and pop3-leave-mail-on-server
 474              pop3-utab
 475              (hash-table-count pop3-utab))
 476     (save-excursion
 477       (with-temp-buffer
 478         ;; back this up because we'll write to it later.
 479         (when (file-readable-p pop3-uidl-file-name)
 480           (copy-file pop3-uidl-file-name
 481                      (concat pop3-uidl-file-name ".old")
 482                      t t))
 483         (maphash '(lambda (key val)
 484                     (when (car val)
 485                       (insert (format "%s\n" key))))
 486                  pop3-utab)
 487         (write-file pop3-uidl-file-name)))))
 488
 489 ;; The Command Set
 490
 491 ;; AUTHORIZATION STATE
 492
 493 (defun pop3-user (process user)
 494   "Send USER information to POP3 server."
 495   (pop3-send-command process (format "USER %s" user))
 496   (let ((response (pop3-read-response process t)))
 497     (if (not (and response (string-match "+OK" response)))
 498         (error (format "USER %s not valid." user)))))
 499
 500 (defun pop3-pass (process password)
 501   "Send authentication information to the server."
 502   (pop3-send-command process (format "PASS %s" password))
 503   (let ((response (pop3-read-response process t)))
 504     (if (not (and response (string-match "+OK" response)))
 505         (pop3-quit process))))
 506
 507 (defun pop3-apop (process password user)
 508   "Send alternate authentication information to the server."
 509   (if (not (fboundp 'md5)) (autoload 'md5 "md5"))
 510   (let ((hash (md5 (concat pop3-timestamp password))))
 511     (pop3-send-command process (format "APOP %s %s" user hash))
 512     (let ((response (pop3-read-response process t)))
 513       (if (not (and response (string-match "+OK" response)))
 514           (pop3-quit process)))))
 515
 516 ;; TRANSACTION STATE
 517
 518 (defun pop3-stat (process)
 519   "Return the number of messages in the maildrop and the maildrop's size."
 520   (pop3-send-command process "STAT")
 521   (let ((response (pop3-read-response process t)))
 522     (list (string-to-int (nth 1 (pop3-string-to-list response)))
 523           (string-to-int (nth 2 (pop3-string-to-list response))))
 524     ))
 525
 526 (defun pop3-retr (process msg crashbuf)
 527   "Retrieve message-id MSG to buffer CRASHBUF."
 528   (pop3-send-command process (format "RETR %s" msg))
 529   (pop3-read-response process)
 530 ;  (accept-process-output process)
 531   (save-excursion
 532     (let ((retrieved t))
 533       (pop3-get-extended-response process)
 534       (pop3-munge-message-separator pop3-extended-response-beginning
 535                                     pop3-extended-response-end)
 536       ;; only get message if it matches
 537       (if (or (null pop3-leave-mail-on-server)
 538               (null pop3-retr-regexp)
 539               (and (goto-char pop3-extended-response-beginning)
 540                    (re-search-forward pop3-retr-regexp pop3-extended-response-end t)))
 541           (append-to-buffer crashbuf pop3-extended-response-beginning
 542                             pop3-extended-response-end)
 543         ;; we didn't get it
 544         (setq retrieved nil))
 545       (delete-region pop3-extended-response-beginning
 546                      pop3-extended-response-end)
 547       retrieved)))
 548
 549 (defun pop3-dele (process msg)
 550   "Mark message-id MSG as deleted."
 551   (pop3-send-command process (format "DELE %s" msg))
 552   (pop3-read-response process))
 553
 554 (defun pop3-noop (process msg)
 555   "No-operation."
 556   (pop3-send-command process "NOOP")
 557   (pop3-read-response process))
 558
 559 (defun pop3-last (process)
 560   "Return highest accessed message-id number for the session."
 561   (pop3-send-command process "LAST")
 562   (let ((response (pop3-read-response process t)))
 563     (string-to-int (nth 1 (pop3-string-to-list response)))
 564     ))
 565
 566 (defun pop3-rset (process)
 567   "Remove all delete marks from current maildrop."
 568   (pop3-send-command process "RSET")
 569   (pop3-read-response process))
 570
 571 ;; UPDATE
 572
 573 (defun pop3-quit (process)
 574   "Close connection to POP3 server.
 575 Tell server to remove all messages marked as deleted, unlock the maildrop,
 576 and close the connection."
 577   (pop3-send-command process "QUIT")
 578   (pop3-read-response process t)
 579   (if process
 580       (save-excursion
 581         (set-buffer (process-buffer process))
 582         (goto-char (point-max))
 583         (delete-process process))))
 584
 585 (defun pop3-uidl (process &optional msgno)
 586   "Return the results of a UIDL command in PROCESS for optional MSGNO.
 587 If UIDL is unsupported on this mail server or if msgno is invalid, return nil.
 588 Otherwise, return a list in the form
 589
 590    (N (1 UIDL-1) (2 UIDL-2) ... (N UIDL-N))
 591
 592 where
 593
 594    N is an integer for the number of UIDLs returned (could be 0)
 595    UIDL-n is a string."
 596
 597   (if msgno
 598       (pop3-send-command process (format "UIDL %d" msgno))
 599     (pop3-send-command process "UIDL"))
 600
 601   (let ((uidl-not-supported nil))
 602     (condition-case ()
 603         (pop3-read-response process t)
 604       (error (setq uidl-not-supported t)))
 605
 606     (unless uidl-not-supported
 607       (let ((retlist '())
 608             (uidl nil)
 609             (msgno nil))
 610         (save-excursion
 611           (pop3-get-extended-response process)
 612           (goto-char pop3-extended-response-beginning)
 613
 614           (while (looking-at "\\([^ \n\t]*\\) \\([^ \n\t]*\\)")
 615             (setq msgno (string-to-int
 616                          (buffer-substring (match-beginning 1) (match-end 1))))
 617             (setq uidl (buffer-substring (match-beginning 2) (match-end 2)))
 618             (push (cons msgno uidl) retlist)
 619             (beginning-of-line 2))
 620           (cons (length retlist) (nreverse retlist)))))))
 621
 622 (defun pop3-list (process &optional msgno)
 623   "Return the results of a LIST command for PROCESS and optional MSGNO.
 624 If (optional) msgno is invalid, return nil.  Otherwise, return a list
 625 in the form
 626
 627    (N (1 LEN-1) (2 LEN-2) ... (N LEN-N))
 628
 629 where
 630
 631    N is an integer for the number of msg/len pairs (could be 0)
 632    LEN-n is an integer."
 633   (let ((bad-msgno nil))
 634
 635     (if msgno
 636         (pop3-send-command process (format "LIST %d" msgno))
 637       (pop3-send-command process "LIST"))
 638
 639     (condition-case ()
 640         (pop3-read-response process t)
 641       (error (setq bad-msgno t)))
 642
 643     (unless bad-msgno
 644       (let ((retlist '())
 645             (len nil)
 646             (msgno nil))
 647         (save-excursion
 648           (pop3-get-extended-response process)
 649           (goto-char pop3-extended-response-beginning)
 650
 651           (while (looking-at "\\([^ \n\t]*\\) \\([^ \n\t]*\\)")
 652             (setq msgno (string-to-int
 653                          (buffer-substring (match-beginning 1) (match-end 1))))
 654             (setq len (string-to-int
 655                        (buffer-substring (match-beginning 2) (match-end 2))))
 656             (push (cons msgno len) retlist)
 657             (beginning-of-line 2))
 658           (cons (length retlist) (nreverse retlist)))))))
 659
 660 (defun pop3-top (process msgno &optional lines)
 661   "Return the top LINES of messages for PROCESS and MSGNO.
 662 If msgno is invalid, return nil.  Otherwise, return a string."
 663   (let ((bad-msgno nil))
 664     (pop3-send-command process (format "TOP %d %d" msgno (or lines 1)))
 665     ;; get a response
 666     (condition-case ()
 667         (pop3-read-response process t)
 668       (error (setq bad-msgno t)))
 669
 670     (unless bad-msgno
 671       (save-excursion
 672         (pop3-get-extended-response process)
 673         (buffer-substring pop3-extended-response-beginning
 674                           pop3-extended-response-end)))))
 675
 676 ;;; Utility code
 677
 678 (defun pop3-get-extended-response (process)
 679   "Get the extended pop3 response in the PROCESS buffer."
 680   (let ((start pop3-read-point) end)
 681     (set-buffer (process-buffer process))
 682     (while (not (re-search-forward "^\\.\r\n" nil t))
 683       (accept-process-output process)
 684       (goto-char start))
 685     (setq pop3-extended-response-beginning start)
 686     (setq pop3-read-point (point-marker))
 687     (goto-char (match-beginning 0))
 688     (setq end (point-marker)
 689           pop3-extended-response-end (point-marker))
 690     (pop3-clean-region start end)))
 691
 692 \f
 693 ;; Summary of POP3 (Post Office Protocol version 3) commands and responses
 694
 695 ;;; AUTHORIZATION STATE
 696
 697 ;; Initial TCP connection
 698 ;; Arguments: none
 699 ;; Restrictions: none
 700 ;; Possible responses:
 701 ;;  +OK [POP3 server ready]
 702
 703 ;; USER name
 704 ;; Arguments: a server specific user-id (required)
 705 ;; Restrictions: authorization state [after unsuccessful USER or PASS
 706 ;; Possible responses:
 707 ;;  +OK [valid user-id]
 708 ;;  -ERR [invalid user-id]
 709
 710 ;; PASS string
 711 ;; Arguments: a server/user-id specific password (required)
 712 ;; Restrictions: authorization state, after successful USER
 713 ;; Possible responses:
 714 ;;  +OK [maildrop locked and ready]
 715 ;;  -ERR [invalid password]
 716 ;;  -ERR [unable to lock maildrop]
 717
 718 ;;; TRANSACTION STATE
 719
 720 ;; STAT
 721 ;; Arguments: none
 722 ;; Restrictions: transaction state
 723 ;; Possible responses:
 724 ;;  +OK nn mm [# of messages, size of maildrop]
 725
 726 ;; LIST [msg]
 727 ;; Arguments: a message-id (optional)
 728 ;; Restrictions: transaction state; msg must not be deleted
 729 ;; Possible responses:
 730 ;;  +OK [scan listing follows]
 731 ;;  -ERR [no such message]
 732
 733 ;; TOP msg [lines]
 734 ;; Arguments: a message-id (required), number of lines (optional)
 735 ;; Restrictions: transaction state; msg must not be deleted
 736 ;; Possible responses:
 737 ;;  +OK [partial message listing follows]
 738 ;;  -ERR [no such message]
 739
 740 ;; UIDL [msg]
 741 ;; Arguments: a message-id (optional)
 742 ;; Restrictions: transaction state; msg must not be deleted
 743 ;; Possible responses:
 744 ;;  +OK [uidl listing follows]
 745 ;;  -ERR [no such message]
 746
 747 ;; RETR msg
 748 ;; Arguments: a message-id (required)
 749 ;; Restrictions: transaction state; msg must not be deleted
 750 ;; Possible responses:
 751 ;;  +OK [message contents follow]
 752 ;;  -ERR [no such message]
 753
 754 ;; DELE msg
 755 ;; Arguments: a message-id (required)
 756 ;; Restrictions: transaction state; msg must not be deleted
 757 ;; Possible responses:
 758 ;;  +OK [message deleted]
 759 ;;  -ERR [no such message]
 760
 761 ;; NOOP
 762 ;; Arguments: none
 763 ;; Restrictions: transaction state
 764 ;; Possible responses:
 765 ;;  +OK
 766
 767 ;; LAST
 768 ;; Arguments: none
 769 ;; Restrictions: transaction state
 770 ;; Possible responses:
 771 ;;  +OK nn [highest numbered message accessed]
 772
 773 ;; RSET
 774 ;; Arguments: none
 775 ;; Restrictions: transaction state
 776 ;; Possible responses:
 777 ;;  +OK [all delete marks removed]
 778
 779 ;;; UPDATE STATE
 780
 781 ;; QUIT
 782 ;; Arguments: none
 783 ;; Restrictions: none
 784 ;; Possible responses:
 785 ;;  +OK [TCP connection closed]
 786
 787 ;; pop3 ends here
 788 (provide 'pop3)
 789