elmo/elmo-pop3.el

   1 ;;; elmo-pop3.el --- POP3 Interface for ELMO.
   2
   3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4 ;; Copyright (C) 1999,2000      Kenichi OKADA <okada@opaopa.org>
   5
   6 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   7 ;;      Kenichi OKADA <okada@opaopa.org>
   8 ;; Keywords: mail, net news
   9
  10 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
  11
  12 ;; This program is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16 ;;
  17 ;; This program is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21 ;;
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26 ;;
  27
  28 ;;; Commentary:
  29 ;;
  30
  31 ;;; Code:
  32 ;;
  33
  34 (require 'elmo-msgdb)
  35 (require 'elmo-net)
  36
  37 (eval-when-compile
  38   (require 'elmo-util))
  39
  40 (eval-and-compile
  41   (autoload 'md5 "md5"))
  42
  43 (defcustom elmo-pop3-default-use-uidl t
  44   "If non-nil, use UIDL on POP3."
  45   :type 'boolean
  46   :group 'elmo)
  47
  48 (defvar elmo-pop3-use-uidl-internal t
  49   "(Internal switch for using UIDL on POP3).")
  50
  51 (defvar elmo-pop3-use-cache t
  52   "Use cache in pop3 folder.")
  53
  54 (defvar elmo-pop3-send-command-synchronously nil
  55   "If non-nil, commands are send synchronously.
  56 If server doesn't accept asynchronous commands, this variable should be
  57 set as non-nil.")
  58
  59 (defcustom elmo-pop3-exists-exactly nil
  60   "If non-nil, POP3 folder existence is checked everytime before the session."
  61   :type 'boolean
  62   :group 'elmo)
  63
  64 (defconst elmo-pop3-folder-name-syntax `(([user ".+"])
  65                                          (?/ [auth ".+"])
  66                                          (?: [uidl "^[A-Za-z]+$"])
  67                                          ,@elmo-net-folder-name-syntax))
  68
  69 (defvar sasl-mechanism-alist)
  70
  71 (defvar elmo-pop3-total-size nil)
  72
  73 ;; For debugging.
  74 (defvar elmo-pop3-debug nil
  75   "Non-nil forces POP3 folder as debug mode.
  76 Debug information is inserted in the buffer \"*POP3 DEBUG*\"")
  77
  78 ;;; Debug
  79 (defsubst elmo-pop3-debug (message &rest args)
  80   (if elmo-pop3-debug
  81       (let ((biff (string-match "BIFF-" (buffer-name)))
  82             pos)
  83         (with-current-buffer (get-buffer-create (concat "*POP3 DEBUG*"
  84                                                         (if biff "BIFF")))
  85           (goto-char (point-max))
  86           (setq pos (point))
  87           (insert (apply 'format message args) "\n")))))
  88
  89 ;;; ELMO POP3 folder
  90 (eval-and-compile
  91   (luna-define-class elmo-pop3-folder (elmo-net-folder)
  92                      (use-uidl location-alist))
  93   (luna-define-internal-accessors 'elmo-pop3-folder))
  94
  95 (luna-define-method elmo-folder-initialize ((folder elmo-pop3-folder) name)
  96   (let ((elmo-network-stream-type-alist
  97          (if elmo-pop3-stream-type-alist
  98              (append elmo-pop3-stream-type-alist
  99                      elmo-network-stream-type-alist)
 100            elmo-network-stream-type-alist))
 101         tokens auth uidl)
 102     (setq tokens (car (elmo-parse-separated-tokens
 103                        name
 104                        elmo-pop3-folder-name-syntax)))
 105     ;; user
 106     (elmo-net-folder-set-user-internal folder
 107                                        (or (cdr (assq 'user tokens))
 108                                            elmo-pop3-default-user))
 109     ;; auth
 110     (setq auth (cdr (assq 'auth tokens)))
 111     (elmo-net-folder-set-auth-internal folder
 112                                        (if auth
 113                                            (intern (downcase auth))
 114                                          elmo-pop3-default-authenticate-type))
 115     ;; uidl
 116     (setq uidl (cdr (assq 'uidl tokens)))
 117     (elmo-pop3-folder-set-use-uidl-internal folder
 118                                             (if uidl
 119                                                 (string= uidl "uidl")
 120                                               elmo-pop3-default-use-uidl))
 121     ;; network
 122     (elmo-net-folder-set-parameters
 123      folder
 124      tokens
 125      (list :server      elmo-pop3-default-server
 126            :port        elmo-pop3-default-port
 127            :stream-type
 128            (elmo-get-network-stream-type elmo-pop3-default-stream-type)))
 129     folder))
 130
 131 ;;; POP3 session
 132 (luna-define-class elmo-pop3-session (elmo-network-session) ())
 133
 134 ;; buffer-local
 135 (defvar elmo-pop3-read-point nil)
 136 (defvar elmo-pop3-number-uidl-hash nil) ; number -> uidl
 137 (defvar elmo-pop3-uidl-number-hash nil) ; uidl -> number
 138 (defvar elmo-pop3-size-hash nil) ; number -> size
 139 (defvar elmo-pop3-uidl-done nil)
 140 (defvar elmo-pop3-list-done nil)
 141 (defvar elmo-pop3-lock nil)
 142
 143 (defvar elmo-pop3-local-variables '(elmo-pop3-read-point
 144                                     elmo-pop3-uidl-number-hash
 145                                     elmo-pop3-number-uidl-hash
 146                                     elmo-pop3-uidl-done
 147                                     elmo-pop3-size-hash
 148                                     elmo-pop3-list-done
 149                                     elmo-pop3-lock))
 150
 151 (luna-define-method elmo-network-close-session ((session elmo-pop3-session))
 152   (when (elmo-network-session-process-internal session)
 153     (when (memq (process-status
 154                  (elmo-network-session-process-internal session))
 155                 '(open run))
 156       (elmo-pop3-send-command (elmo-network-session-process-internal session)
 157                               "quit")
 158       ;; process is dead.
 159       (or (cdr (elmo-pop3-read-response
 160                 (elmo-network-session-process-internal session)
 161                 t))
 162           (error "POP error: QUIT failed")))
 163     (kill-buffer (process-buffer
 164                   (elmo-network-session-process-internal session)))
 165     (delete-process (elmo-network-session-process-internal session))))
 166
 167 (defun elmo-pop3-get-session (folder &optional if-exists)
 168   "Get POP3 session for FOLDER.
 169 If IF-EXISTS is non-nil, don't get new session.
 170 If IF-EXISTS is `any-exists', get BIFF session or normal session if exists."
 171   (let ((elmo-pop3-use-uidl-internal (if elmo-inhibit-number-mapping
 172                                          nil
 173                                        (elmo-pop3-folder-use-uidl-internal
 174                                         folder))))
 175     (prog1
 176         (if (eq if-exists 'any-exists)
 177             (or (elmo-network-get-session 'elmo-pop3-session
 178                                           "POP3"
 179                                           folder if-exists)
 180                 (elmo-network-get-session 'elmo-pop3-session
 181                                           "BIFF-POP3"
 182                                           folder if-exists))
 183           (elmo-network-get-session 'elmo-pop3-session
 184                                     (concat
 185                                      (if (elmo-folder-biff-internal folder)
 186                                          "BIFF-")
 187                                      "POP3")
 188                                     folder if-exists))
 189       ;; For saving existency.
 190       (unless (file-exists-p (elmo-folder-msgdb-path folder))
 191         (elmo-make-directory (elmo-folder-msgdb-path folder))))))
 192
 193 (defun elmo-pop3-send-command (process command &optional no-erase no-log)
 194   (with-current-buffer (process-buffer process)
 195     (unless no-erase
 196       (erase-buffer))
 197     (goto-char (point-min))
 198     (setq elmo-pop3-read-point (point))
 199     (elmo-pop3-debug "SEND: %s\n" (if no-log "<NO LOGGING>" command))
 200     (process-send-string process (concat command "\r\n"))))
 201
 202 (defun elmo-pop3-read-response (process &optional not-command)
 203   "Read response and return a cons cell of \(CODE . BODY\).
 204 PROCESS is the process to read response from.
 205 If optional NOT-COMMAND is non-nil, read only the first line.
 206 CODE is one of the following:
 207 'ok          ... response is OK.
 208 'err         ... response is ERROR.
 209 'login-delay ... user is not allowed to login until the login delay
 210                  period has expired.
 211 'in-use      ... authentication was successful but the mailbox is in use."
 212   ;; buffer is in case for process is dead.
 213   (with-current-buffer (process-buffer process)
 214     (let ((case-fold-search nil)
 215           (response-string nil)
 216           (response-continue t)
 217           (return-value nil)
 218           (err nil)
 219           match-end)
 220       (while response-continue
 221         (goto-char elmo-pop3-read-point)
 222         (while (not (re-search-forward "\r?\n" nil t))
 223           (accept-process-output process 1)
 224           (goto-char elmo-pop3-read-point))
 225         (setq match-end (point))
 226         (setq response-string
 227               (buffer-substring elmo-pop3-read-point (- match-end 2)))
 228         (goto-char elmo-pop3-read-point)
 229         (if (looking-at "\\+.*$")
 230             (progn
 231               (setq response-continue nil)
 232               (setq elmo-pop3-read-point match-end)
 233               (setq return-value
 234                     (if return-value
 235                         (concat return-value "\n" response-string)
 236                       response-string)))
 237           (if (looking-at "\\-.*$")
 238               (progn
 239                 (when (looking-at "[^ ]+ \\[\\([^]]+\\)\\]")
 240                   (setq return-value
 241                         (intern
 242                          (downcase
 243                           (buffer-substring (match-beginning 1)
 244                                             (match-end 1))))))
 245                 (setq err t
 246                       response-continue nil
 247                       elmo-pop3-read-point match-end
 248                       return-value (cons (or return-value 'err) nil)))
 249             (setq elmo-pop3-read-point match-end)
 250             (if not-command
 251                 (setq response-continue nil))
 252             (setq return-value
 253                   (if return-value
 254                       (concat return-value "\n" response-string)
 255                     response-string)))
 256           (setq elmo-pop3-read-point match-end)))
 257       (if err
 258           return-value
 259         (cons 'ok return-value)))))
 260
 261 (defun elmo-pop3-process-filter (process output)
 262   (when (buffer-live-p (process-buffer process))
 263     (with-current-buffer (process-buffer process)
 264       (goto-char (point-max))
 265       (insert output)
 266       (elmo-pop3-debug "RECEIVED: %s\n" output)
 267       (if (and elmo-pop3-total-size
 268                (> elmo-pop3-total-size
 269                   (min elmo-display-retrieval-progress-threshold 100)))
 270           (elmo-display-progress
 271            'elmo-display-retrieval-progress
 272            (format "Retrieving (%d/%d bytes)..."
 273                    (buffer-size)
 274                    elmo-pop3-total-size)
 275            (/ (buffer-size) (/ elmo-pop3-total-size 100)))))))
 276
 277 (defun elmo-pop3-auth-user (session)
 278   (let ((process (elmo-network-session-process-internal session))
 279         response)
 280     ;; try USER/PASS
 281     (elmo-pop3-send-command
 282      process
 283      (format "user %s" (elmo-network-session-user-internal session))
 284      nil 'no-log)
 285     (setq response (elmo-pop3-read-response process t))
 286     (unless (eq (car response) 'ok)
 287       (signal 'elmo-open-error '(elmo-pop-auth-user)))
 288     (elmo-pop3-send-command  process
 289                              (format
 290                               "pass %s"
 291                               (elmo-get-passwd
 292                                (elmo-network-session-password-key session)))
 293                              nil 'no-log)
 294     (setq response (elmo-pop3-read-response process t))
 295     (case (car response)
 296       (ok)
 297       (in-use
 298        (error "Maildrop is currently in use"))
 299       (login-delay
 300        (error "Not allowed to login until the login delay period has expired"))
 301       (t
 302        (signal 'elmo-authenticate-error '(elmo-pop-auth-user))))
 303     (car response)))
 304
 305 (defun elmo-pop3-auth-apop (session)
 306   (unless (string-match "^\+OK .*\\(<[^\>]+>\\)"
 307                         (elmo-network-session-greeting-internal session))
 308     (signal 'elmo-open-error '(elmo-pop3-auth-apop)))
 309   ;; good, APOP ready server
 310   (elmo-pop3-send-command
 311    (elmo-network-session-process-internal session)
 312    (format "apop %s %s"
 313            (elmo-network-session-user-internal session)
 314            (md5
 315             (concat (match-string
 316                      1
 317                      (elmo-network-session-greeting-internal session))
 318                     (elmo-get-passwd
 319                      (elmo-network-session-password-key session)))))
 320    nil 'no-log)
 321   (let ((response (elmo-pop3-read-response
 322                    (elmo-network-session-process-internal session)
 323                    t)))
 324     (case (car response)
 325       (ok)
 326       (in-use
 327        (error "Maildrop is currently in use"))
 328       (login-delay
 329        (error "Not allowed to login until the login delay period has expired"))
 330       (t
 331        (signal 'elmo-authenticate-error '(elmo-pop-auth-apop))))
 332     (car response)))
 333
 334 (luna-define-method elmo-network-initialize-session-buffer :after
 335   ((session elmo-pop3-session) buffer)
 336   (with-current-buffer buffer
 337     (mapcar 'make-variable-buffer-local elmo-pop3-local-variables)))
 338
 339 (luna-define-method elmo-network-initialize-session ((session
 340                                                       elmo-pop3-session))
 341   (let ((process (elmo-network-session-process-internal session))
 342         response mechanism)
 343     (with-current-buffer (process-buffer process)
 344       (set-process-filter process 'elmo-pop3-process-filter)
 345       (setq elmo-pop3-read-point (point-min))
 346       ;; Skip garbage output from process before greeting.
 347       (while (and (memq (process-status process) '(open run))
 348                   (goto-char (point-max))
 349                   (forward-line -1)
 350                   (not (looking-at "+OK")))
 351         (accept-process-output process 1))
 352       (setq elmo-pop3-read-point (point))
 353       (or (elmo-network-session-set-greeting-internal
 354            session
 355            (cdr (elmo-pop3-read-response process t))) ; if ok, cdr is non-nil.
 356           (signal 'elmo-open-error
 357                   '(elmo-network-intialize-session)))
 358       (when (eq (elmo-network-stream-type-symbol
 359                  (elmo-network-session-stream-type-internal session))
 360                 'starttls)
 361         (elmo-pop3-send-command process "stls")
 362         (if (eq 'ok (car (elmo-pop3-read-response process)))
 363             (starttls-negotiate process)
 364           (signal 'elmo-open-error '(elmo-pop3-starttls-error)))))))
 365
 366 (luna-define-method elmo-network-authenticate-session ((session
 367                                                         elmo-pop3-session))
 368   (with-current-buffer (process-buffer
 369                         (elmo-network-session-process-internal session))
 370     (let* ((process (elmo-network-session-process-internal session))
 371            (auth (elmo-network-session-auth-internal session))
 372            (auth (mapcar (lambda (mechanism) (upcase (symbol-name mechanism)))
 373                          (if (listp auth) auth (list auth)))))
 374       (or (and (string= "USER" (car auth))
 375                (elmo-pop3-auth-user session))
 376           (and (string= "APOP" (car auth))
 377                (elmo-pop3-auth-apop session))
 378           (let (sasl-mechanisms
 379                 client name step response mechanism
 380                 sasl-read-passphrase)
 381             (require 'sasl)
 382             (setq sasl-mechanisms (mapcar 'car sasl-mechanism-alist))
 383             (setq mechanism (sasl-find-mechanism auth))
 384             (unless mechanism
 385               (signal 'elmo-authenticate-error '(elmo-pop3-auth-no-mechanisms)))
 386             (setq client
 387                   (sasl-make-client
 388                    mechanism
 389                    (elmo-network-session-user-internal session)
 390                    "pop"
 391                    (elmo-network-session-server-internal session)))
 392 ;;;         (if elmo-pop3-auth-user-realm
 393 ;;;             (sasl-client-set-property client 'realm elmo-pop3-auth-user-realm))
 394             (setq name (sasl-mechanism-name mechanism))
 395             (elmo-network-session-set-auth-internal session
 396                                                     (intern (downcase name)))
 397             (setq sasl-read-passphrase
 398                   (lambda (prompt)
 399                     (elmo-get-passwd
 400                      (elmo-network-session-password-key session))))
 401             (setq step (sasl-next-step client nil))
 402             (elmo-pop3-send-command
 403              process
 404              (concat "AUTH " name
 405                      (and (sasl-step-data step)
 406                           (concat
 407                            " "
 408                            (elmo-base64-encode-string
 409                             (sasl-step-data step) 'no-line-break))))
 410              nil 'no-log)
 411             (catch 'done
 412               (while t
 413                 (setq response (elmo-pop3-read-response process t))
 414                 (case (car response)
 415                   (ok)
 416                   (in-use
 417                    (error "Maildrop is currently in use"))
 418                   (login-delay
 419                    (error "Not allowed to login \
 420 until the login delay period has expired"))
 421                   (t
 422                    (signal 'elmo-authenticate-error
 423                            (list (intern (concat "elmo-pop3-auth-"
 424                                                  (downcase name)))))))
 425                 (if (sasl-next-step client step)
 426                     ;; Bogus server?
 427                     (signal 'elmo-authenticate-error
 428                             (list (intern
 429                                    (concat "elmo-pop3-auth-"
 430                                            (downcase name)))))
 431                   ;; The authentication process is finished.
 432                   (throw 'done nil))
 433                 (sasl-step-set-data
 434                  step
 435                  (elmo-base64-decode-string
 436                   (cadr (split-string response " "))))
 437                 (setq step (sasl-next-step client step))
 438                 (elmo-pop3-send-command
 439                  process
 440                  (if (sasl-step-data step)
 441                      (elmo-base64-encode-string (sasl-step-data step)
 442                                                 'no-line-break)
 443                    "") nil 'no-log))))))))
 444
 445 (luna-define-method elmo-network-setup-session ((session
 446                                                  elmo-pop3-session))
 447   (let ((process (elmo-network-session-process-internal session))
 448         count response)
 449     (with-current-buffer (process-buffer process)
 450       (setq elmo-pop3-size-hash (elmo-make-hash 31))
 451       ;; To get obarray of uidl and size
 452       (elmo-pop3-send-command process "list")
 453       (if (null (cdr (elmo-pop3-read-response process)))
 454           (error "POP LIST command failed"))
 455       (if (null (setq response
 456                       (elmo-pop3-read-contents process)))
 457           (error "POP LIST command failed"))
 458       ;; POP server always returns a sequence of serial numbers.
 459       (setq count (elmo-pop3-parse-list-response response))
 460       ;; UIDL
 461       (when elmo-pop3-use-uidl-internal
 462         (setq elmo-pop3-uidl-number-hash (elmo-make-hash (* count 2)))
 463         (setq elmo-pop3-number-uidl-hash (elmo-make-hash (* count 2)))
 464         ;; UIDL
 465         (elmo-pop3-send-command process "uidl")
 466         (unless (cdr (elmo-pop3-read-response process))
 467           (error "POP UIDL failed"))
 468         (unless (setq response (elmo-pop3-read-contents process))
 469           (error "POP UIDL failed"))
 470         (elmo-pop3-parse-uidl-response response)))))
 471
 472 (defun elmo-pop3-read-contents (process)
 473   (with-current-buffer (process-buffer process)
 474     (let ((case-fold-search nil)
 475           match-end)
 476       (goto-char elmo-pop3-read-point)
 477       (while (not (re-search-forward "^\\.\r\n" nil t))
 478         (accept-process-output process 1)
 479         (goto-char elmo-pop3-read-point))
 480       (setq match-end (point))
 481       (elmo-delete-cr
 482        (buffer-substring elmo-pop3-read-point
 483                          (- match-end 3))))))
 484
 485 (luna-define-method elmo-folder-expand-msgdb-path ((folder elmo-pop3-folder))
 486   (convert-standard-filename
 487    (expand-file-name
 488     (elmo-safe-filename (elmo-net-folder-user-internal folder))
 489     (expand-file-name (elmo-net-folder-server-internal folder)
 490                       (expand-file-name
 491                        "pop"
 492                        elmo-msgdb-directory)))))
 493
 494 (luna-define-method elmo-folder-exists-p ((folder elmo-pop3-folder))
 495   (if (and elmo-pop3-exists-exactly
 496            (elmo-folder-plugged-p folder))
 497       (save-excursion
 498         (let (elmo-auto-change-plugged  ; don't change plug status.
 499               (elmo-inhibit-number-mapping t) ; No need to use uidl.
 500               session)
 501           (prog1
 502               (setq session (elmo-pop3-get-session folder))
 503             (if session
 504                 (elmo-network-close-session session)))))
 505     (or (file-directory-p (elmo-folder-msgdb-path folder))
 506         ;; First time.
 507         (when (elmo-folder-plugged-p folder)
 508           (let ((elmo-pop3-exists-exactly t))
 509             (elmo-folder-exists-p folder))))))
 510
 511 (defun elmo-pop3-parse-uidl-response (string)
 512   (let ((buffer (current-buffer))
 513         number list size)
 514     (with-temp-buffer
 515       (let (number uid list)
 516         (insert string)
 517         (goto-char (point-min))
 518         (while (re-search-forward "^\\([0-9]+\\)[\t ]+\\([^ \n]+\\)$" nil t)
 519           (setq number  (elmo-match-buffer 1))
 520           (setq uid (elmo-match-buffer 2))
 521           (with-current-buffer buffer
 522             (elmo-set-hash-val uid number elmo-pop3-uidl-number-hash)
 523             (elmo-set-hash-val (concat "#" number) uid
 524                                elmo-pop3-number-uidl-hash))
 525           (setq list (cons uid list)))
 526         (with-current-buffer buffer (setq elmo-pop3-uidl-done t))
 527         (nreverse list)))))
 528
 529 (defun elmo-pop3-parse-list-response (string)
 530   (let ((buffer (current-buffer))
 531         (count 0)
 532         alist)
 533     (with-temp-buffer
 534       (insert string)
 535       (goto-char (point-min))
 536       (while (re-search-forward "^\\([0-9]+\\)[\t ]+\\([0-9]+\\)$" nil t)
 537         (setq alist
 538               (cons
 539                (cons (elmo-match-buffer 1)
 540                      (elmo-match-buffer 2))
 541                alist))
 542         (setq count (1+ count)))
 543       (with-current-buffer buffer
 544         (setq elmo-pop3-size-hash (elmo-make-hash (* (length alist) 2)))
 545         (while alist
 546           (elmo-set-hash-val (concat "#" (car (car alist)))
 547                              (cdr (car alist))
 548                              elmo-pop3-size-hash)
 549           (setq alist (cdr alist)))
 550         (setq elmo-pop3-list-done t))
 551       count)))
 552
 553 (defun elmo-pop3-list-location (folder)
 554   (with-current-buffer (process-buffer
 555                         (elmo-network-session-process-internal
 556                          (elmo-pop3-get-session folder)))
 557     (let (locations)
 558       (if elmo-pop3-uidl-done
 559           (progn
 560             (mapatoms
 561              (lambda (atom)
 562                (setq locations (cons (symbol-name atom) locations)))
 563              elmo-pop3-uidl-number-hash)
 564             (sort locations
 565                   (lambda (loc1 loc2)
 566                     (< (elmo-pop3-uidl-to-number loc1)
 567                        (elmo-pop3-uidl-to-number loc2)))))
 568         (error "POP3: Error in UIDL")))))
 569
 570 (defun elmo-pop3-list-folder-by-location (folder locations)
 571   (let* ((location-alist (elmo-pop3-folder-location-alist-internal folder))
 572          (locations-in-db (mapcar 'cdr location-alist))
 573          result new-locs new-alist deleted-locs i)
 574     (setq new-locs
 575           (elmo-delete-if (function
 576                            (lambda (x) (member x locations-in-db)))
 577                           locations))
 578     (setq deleted-locs
 579           (elmo-delete-if (function
 580                            (lambda (x) (member x locations)))
 581                           locations-in-db))
 582     (setq i (or (elmo-max-of-list (mapcar 'car location-alist)) 0))
 583     (mapcar
 584      (function
 585       (lambda (x)
 586         (setq location-alist
 587               (delq (rassoc x location-alist) location-alist))))
 588      deleted-locs)
 589     (while new-locs
 590       (setq i (1+ i))
 591       (setq new-alist (cons (cons i (car new-locs)) new-alist))
 592       (setq new-locs (cdr new-locs)))
 593     (setq result (nconc location-alist new-alist))
 594     (setq result (sort result (lambda (x y) (< (car x)(car y)))))
 595     (elmo-pop3-folder-set-location-alist-internal folder result)
 596     (mapcar 'car result)))
 597
 598 (defun elmo-pop3-list-by-uidl-subr (folder &optional nonsort)
 599   (let ((flist (elmo-pop3-list-folder-by-location
 600                 folder
 601                 (elmo-pop3-list-location folder))))
 602     (if nonsort
 603         (cons (elmo-max-of-list flist) (length flist))
 604       (sort flist '<))))
 605
 606 (defun elmo-pop3-list-by-list (folder)
 607   (with-current-buffer (process-buffer
 608                         (elmo-network-session-process-internal
 609                          (elmo-pop3-get-session folder)))
 610     (let (list)
 611       (if elmo-pop3-list-done
 612           (progn
 613             (mapatoms (lambda (atom)
 614                         (setq list (cons (string-to-int
 615                                           (substring (symbol-name atom) 1))
 616                                          list)))
 617                       elmo-pop3-size-hash)
 618             (sort list '<))
 619         (error "POP3: Error in list")))))
 620
 621 (defsubst elmo-pop3-folder-list-messages (folder)
 622   (if (and (not elmo-inhibit-number-mapping)
 623            (elmo-pop3-folder-use-uidl-internal folder))
 624       (elmo-pop3-list-by-uidl-subr folder)
 625     (elmo-pop3-list-by-list folder)))
 626
 627 (luna-define-method elmo-folder-list-messages-plugged
 628   ((folder elmo-pop3-folder) &optional nohide)
 629   (elmo-pop3-folder-list-messages folder))
 630
 631 (luna-define-method elmo-folder-status ((folder elmo-pop3-folder))
 632   (elmo-folder-open-internal folder)
 633   (elmo-folder-check folder)
 634   (if (elmo-pop3-folder-use-uidl-internal folder)
 635       (prog1
 636           (elmo-pop3-list-by-uidl-subr folder 'nonsort)
 637         (elmo-folder-close-internal folder))
 638     (let* ((process
 639             (elmo-network-session-process-internal
 640              (elmo-pop3-get-session folder)))
 641            (total 0)
 642            response)
 643       (with-current-buffer (process-buffer process)
 644         (elmo-pop3-send-command process "STAT")
 645         (setq response (cdr (elmo-pop3-read-response process)))
 646         ;; response: "^\+OK 2 7570$"
 647         (if (not (string-match "^\+OK[ \t]*\\([0-9]*\\)" response))
 648             (error "POP STAT command failed")
 649           (setq total
 650                 (string-to-int
 651                  (substring response (match-beginning 1)(match-end 1 ))))
 652           (elmo-folder-close-internal folder)
 653           (cons total total))))))
 654
 655 (defvar elmo-pop3-header-fetch-chop-length 200)
 656
 657 (defsubst elmo-pop3-next-result-arrived-p ()
 658   (cond
 659    ((eq (following-char) ?+)
 660     (if (re-search-forward "\n\\.\r?\n" nil t)
 661         t
 662       nil))
 663    ((looking-at "-")
 664     (if (search-forward "\n" nil t)
 665         t
 666       nil))
 667    (t
 668     nil)))
 669
 670 (defun elmo-pop3-retrieve-headers (process tobuffer articles)
 671   (save-excursion
 672     (set-buffer (process-buffer process))
 673     (erase-buffer)
 674     (let ((number (length articles))
 675           (count 0)
 676           (received 0)
 677           (last-point (point-min)))
 678       ;; Send HEAD commands.
 679       (while articles
 680         (elmo-pop3-send-command process (format
 681                                          "top %s 0" (car articles))
 682                                 'no-erase)
 683 ;;;     (accept-process-output process 1)
 684         (setq articles (cdr articles))
 685         (setq count (1+ count))
 686         ;; Every 200 requests we have to read the stream in
 687         ;; order to avoid deadlocks.
 688         (when (or elmo-pop3-send-command-synchronously
 689                   (null articles)       ;All requests have been sent.
 690                   (zerop (% count elmo-pop3-header-fetch-chop-length)))
 691           (unless elmo-pop3-send-command-synchronously
 692             (accept-process-output process 1))
 693           (discard-input)
 694           (while (progn
 695                    (goto-char last-point)
 696                    ;; Count replies.
 697                    (while (elmo-pop3-next-result-arrived-p)
 698                      (setq last-point (point))
 699                      (setq received (1+ received)))
 700                    (< received count))
 701             (when (> number elmo-display-progress-threshold)
 702               (if (or (zerop (% received 5)) (= received number))
 703                   (elmo-display-progress
 704                    'elmo-pop3-retrieve-headers "Getting headers..."
 705                    (/ (* received 100) number))))
 706             (accept-process-output process 1)
 707 ;;;         (accept-process-output process)
 708             (discard-input))))
 709       ;; Replace all CRLF with LF.
 710       (elmo-delete-cr-buffer)
 711       (copy-to-buffer tobuffer (point-min) (point-max)))))
 712
 713 (luna-define-method elmo-folder-msgdb-create ((folder elmo-pop3-folder)
 714                                               numlist flag-table)
 715   (let ((process (elmo-network-session-process-internal
 716                   (elmo-pop3-get-session folder))))
 717     (with-current-buffer (process-buffer process)
 718       (elmo-pop3-sort-msgdb-by-original-number
 719        folder
 720        (elmo-pop3-msgdb-create-by-header
 721         folder
 722         process
 723         numlist
 724         flag-table
 725         (if (elmo-pop3-folder-use-uidl-internal folder)
 726             (elmo-pop3-folder-location-alist-internal folder)))))))
 727
 728 (defun elmo-pop3-sort-msgdb-by-original-number (folder msgdb)
 729   (let ((location-alist (elmo-pop3-folder-location-alist-internal folder)))
 730     (when location-alist
 731       (elmo-msgdb-sort-entities
 732        msgdb
 733        (lambda (ent1 ent2 loc-alist)
 734          (< (elmo-pop3-uidl-to-number
 735              (cdr (assq (elmo-message-entity-number ent1)
 736                         loc-alist)))
 737             (elmo-pop3-uidl-to-number
 738              (cdr (assq (elmo-message-entity-number ent2)
 739                         loc-alist)))))
 740        location-alist))
 741     msgdb))
 742
 743 (defun elmo-pop3-uidl-to-number (uidl)
 744   (string-to-number (elmo-get-hash-val uidl
 745                                        elmo-pop3-uidl-number-hash)))
 746
 747 (defun elmo-pop3-number-to-uidl (number)
 748   (elmo-get-hash-val (format "#%d" number)
 749                      elmo-pop3-number-uidl-hash))
 750
 751 (defun elmo-pop3-number-to-size (number)
 752   (elmo-get-hash-val (format "#%d" number)
 753                      elmo-pop3-size-hash))
 754
 755 (defun elmo-pop3-msgdb-create-by-header (folder process numlist
 756                                                 flag-table
 757                                                 loc-alist)
 758   (let ((tmp-buffer (get-buffer-create " *ELMO Overview TMP*")))
 759     (with-current-buffer (process-buffer process)
 760       (if loc-alist ; use uidl.
 761           (setq numlist
 762                 (delq
 763                  nil
 764                  (mapcar
 765                   (lambda (number)
 766                     (elmo-pop3-uidl-to-number (cdr (assq number loc-alist))))
 767                   numlist))))
 768       (elmo-pop3-retrieve-headers process tmp-buffer numlist)
 769       (prog1
 770           (elmo-pop3-msgdb-create-message
 771            folder
 772            tmp-buffer
 773            process
 774            (length numlist)
 775            numlist
 776            flag-table loc-alist)
 777         (kill-buffer tmp-buffer)))))
 778
 779 (defun elmo-pop3-msgdb-create-message (folder
 780                                        buffer
 781                                        process
 782                                        num
 783                                        numlist
 784                                        flag-table
 785                                        loc-alist)
 786   (save-excursion
 787     (let ((new-msgdb (elmo-make-msgdb))
 788           beg entity i number message-id flags)
 789       (set-buffer buffer)
 790       (set-buffer-multibyte default-enable-multibyte-characters)
 791       (goto-char (point-min))
 792       (setq i 0)
 793       (message "Creating msgdb...")
 794       (while (not (eobp))
 795         (setq beg (save-excursion (forward-line 1) (point)))
 796         (elmo-pop3-next-result-arrived-p)
 797         (save-excursion
 798           (forward-line -1)
 799           (save-restriction
 800             (narrow-to-region beg (point))
 801             (setq entity
 802                   (elmo-msgdb-create-message-entity-from-buffer
 803                    (elmo-msgdb-message-entity-handler new-msgdb)
 804                    (car numlist)))
 805             (setq numlist (cdr numlist))
 806             (when entity
 807               (with-current-buffer (process-buffer process)
 808                 (elmo-message-entity-set-field
 809                  entity
 810                  'size
 811                  (string-to-number
 812                   (elmo-pop3-number-to-size
 813                    (elmo-message-entity-number entity))))
 814                 (if (setq number
 815                           (car
 816                            (rassoc
 817                             (elmo-pop3-number-to-uidl
 818                              (elmo-message-entity-number entity))
 819                             loc-alist)))
 820                     (elmo-message-entity-set-number entity number)))
 821               (setq message-id (elmo-message-entity-field entity 'message-id)
 822                     flags (elmo-flag-table-get flag-table message-id))
 823               (elmo-global-flags-set flags folder number message-id)
 824               (elmo-msgdb-append-entity new-msgdb entity flags))))
 825         (when (> num elmo-display-progress-threshold)
 826           (setq i (1+ i))
 827           (if (or (zerop (% i 5)) (= i num))
 828               (elmo-display-progress
 829                'elmo-pop3-msgdb-create-message "Creating msgdb..."
 830                (/ (* i 100) num)))))
 831       new-msgdb)))
 832
 833 (defun elmo-pop3-read-body (process outbuf)
 834   (with-current-buffer (process-buffer process)
 835     (let ((start elmo-pop3-read-point)
 836           end)
 837       (goto-char start)
 838       (while (not (re-search-forward "^\\.\r?\n" nil t))
 839         (accept-process-output process 1)
 840         (goto-char start))
 841       (setq end (point))
 842       (with-current-buffer outbuf
 843         (erase-buffer)
 844         (insert-buffer-substring (process-buffer process) start (- end 3)))
 845       t)))
 846
 847 (luna-define-method elmo-folder-open-internal ((folder elmo-pop3-folder))
 848   (if (and (not elmo-inhibit-number-mapping)
 849            (elmo-pop3-folder-use-uidl-internal folder))
 850       (elmo-pop3-folder-set-location-alist-internal
 851        folder (elmo-msgdb-location-load (elmo-folder-msgdb-path folder)))))
 852
 853 (luna-define-method elmo-folder-commit :after ((folder elmo-pop3-folder))
 854   (when (elmo-folder-persistent-p folder)
 855     (elmo-msgdb-location-save (elmo-folder-msgdb-path folder)
 856                               (elmo-pop3-folder-location-alist-internal
 857                                folder))))
 858
 859 (luna-define-method elmo-folder-close-internal ((folder elmo-pop3-folder))
 860   (elmo-pop3-folder-set-location-alist-internal folder nil)
 861   ;; Just close connection
 862   (elmo-folder-check folder))
 863
 864 (luna-define-method elmo-message-fetch-plugged ((folder elmo-pop3-folder)
 865                                                 number strategy
 866                                                 &optional section
 867                                                 outbuf unseen)
 868   (let* ((loc-alist (elmo-pop3-folder-location-alist-internal folder))
 869          (process (elmo-network-session-process-internal
 870                    (elmo-pop3-get-session folder)))
 871         size  response errmsg msg)
 872     (with-current-buffer (process-buffer process)
 873       (if loc-alist
 874           (setq number (elmo-pop3-uidl-to-number
 875                         (cdr (assq number loc-alist)))))
 876       (setq size (string-to-number
 877                   (elmo-pop3-number-to-size number)))
 878       (when number
 879         (elmo-pop3-send-command process
 880                                 (format "retr %s" number))
 881         (unless elmo-inhibit-display-retrieval-progress
 882           (setq elmo-pop3-total-size size)
 883           (elmo-display-progress
 884            'elmo-display-retrieval-progress
 885            (format "Retrieving (0/%d bytes)..." elmo-pop3-total-size)
 886            0))
 887         (unwind-protect
 888             (progn
 889               (when (null (setq response (cdr (elmo-pop3-read-response
 890                                                process t))))
 891                 (error "Fetching message failed"))
 892               (setq response  (elmo-pop3-read-body process outbuf)))
 893           (setq elmo-pop3-total-size nil))
 894         (unless elmo-inhibit-display-retrieval-progress
 895           (elmo-display-progress
 896            'elmo-display-retrieval-progress
 897            "Retrieving..." 100)  ; remove progress bar.
 898           (message "Retrieving...done"))
 899         (set-buffer outbuf)
 900         (goto-char (point-min))
 901         (while (re-search-forward "^\\." nil t)
 902           (replace-match "")
 903           (forward-line))
 904         (elmo-delete-cr-buffer)
 905         response))))
 906
 907 (defun elmo-pop3-delete-msg (process number loc-alist)
 908   (with-current-buffer (process-buffer process)
 909     (let (response errmsg msg)
 910       (if loc-alist
 911           (setq number (elmo-pop3-uidl-to-number
 912                         (cdr (assq number loc-alist)))))
 913       (if number
 914           (progn
 915             (elmo-pop3-send-command process
 916                                     (format "dele %s" number))
 917             (when (null (setq response (cdr (elmo-pop3-read-response
 918                                              process t))))
 919               (error "Deleting message failed")))
 920         (error "Deleting message failed")))))
 921
 922 (luna-define-method elmo-folder-delete-messages-plugged ((folder
 923                                                           elmo-pop3-folder)
 924                                                          msgs)
 925   (let ((loc-alist (elmo-pop3-folder-location-alist-internal folder))
 926         (process (elmo-network-session-process-internal
 927                   (elmo-pop3-get-session folder))))
 928     (mapcar '(lambda (msg) (elmo-pop3-delete-msg process msg loc-alist))
 929             msgs)))
 930
 931 (luna-define-method elmo-message-use-cache-p ((folder elmo-pop3-folder) number)
 932   elmo-pop3-use-cache)
 933
 934 (luna-define-method elmo-folder-persistent-p ((folder elmo-pop3-folder))
 935   (and (elmo-folder-persistent-internal folder)
 936        (elmo-pop3-folder-use-uidl-internal folder)))
 937
 938 (luna-define-method elmo-folder-clear :around ((folder elmo-pop3-folder)
 939                                                &optional keep-killed)
 940   (unless keep-killed
 941     (elmo-pop3-folder-set-location-alist-internal folder nil))
 942   (luna-call-next-method))
 943
 944 (luna-define-method elmo-folder-check ((folder elmo-pop3-folder))
 945   (if (elmo-folder-plugged-p folder)
 946       (let ((session (elmo-pop3-get-session folder 'if-exists)))
 947         (when session
 948           (elmo-network-close-session session)))))
 949
 950 (require 'product)
 951 (product-provide (provide 'elmo-pop3) (require 'elmo-version))
 952
 953 ;;; elmo-pop3.el ends here