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