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 (- (point-max) 2)) ; Care of \r\n.\r[EOF] case
 476         (accept-process-output process 1))
 477       (elmo-delete-cr
 478        (buffer-substring elmo-pop3-read-point
 479                          (- (point) 3))))))
 480
 481 (luna-define-method elmo-folder-expand-msgdb-path ((folder elmo-pop3-folder))
 482   (convert-standard-filename
 483    (expand-file-name
 484     (elmo-safe-filename (elmo-net-folder-user-internal folder))
 485     (expand-file-name (elmo-net-folder-server-internal folder)
 486                       (expand-file-name
 487                        "pop"
 488                        elmo-msgdb-directory)))))
 489
 490 (luna-define-method elmo-folder-exists-p ((folder elmo-pop3-folder))
 491   (if (and elmo-pop3-exists-exactly
 492            (elmo-folder-plugged-p folder))
 493       (save-excursion
 494         (let (elmo-auto-change-plugged  ; don't change plug status.
 495               (elmo-inhibit-number-mapping t) ; No need to use uidl.
 496               session)
 497           (prog1
 498               (setq session (elmo-pop3-get-session folder))
 499             (if session
 500                 (elmo-network-close-session session)))))
 501     (or (file-directory-p (elmo-folder-msgdb-path folder))
 502         ;; First time.
 503         (when (elmo-folder-plugged-p folder)
 504           (let ((elmo-pop3-exists-exactly t))
 505             (elmo-folder-exists-p folder))))))
 506
 507 (defun elmo-pop3-parse-uidl-response (string)
 508   (let ((buffer (current-buffer))
 509         number list size)
 510     (with-temp-buffer
 511       (let (number uid list)
 512         (insert string)
 513         (goto-char (point-min))
 514         (while (re-search-forward "^\\([0-9]+\\)[\t ]+\\([^ \n]+\\)$" nil t)
 515           (setq number  (elmo-match-buffer 1))
 516           (setq uid (elmo-match-buffer 2))
 517           (with-current-buffer buffer
 518             (elmo-set-hash-val uid number elmo-pop3-uidl-number-hash)
 519             (elmo-set-hash-val (concat "#" number) uid
 520                                elmo-pop3-number-uidl-hash))
 521           (setq list (cons uid list)))
 522         (with-current-buffer buffer (setq elmo-pop3-uidl-done t))
 523         (nreverse list)))))
 524
 525 (defun elmo-pop3-parse-list-response (string)
 526   (let ((buffer (current-buffer))
 527         (count 0)
 528         alist)
 529     (with-temp-buffer
 530       (insert string)
 531       (goto-char (point-min))
 532       (while (re-search-forward "^\\([0-9]+\\)[\t ]+\\([0-9]+\\)$" nil t)
 533         (setq alist
 534               (cons
 535                (cons (elmo-match-buffer 1)
 536                      (elmo-match-buffer 2))
 537                alist))
 538         (setq count (1+ count)))
 539       (with-current-buffer buffer
 540         (setq elmo-pop3-size-hash (elmo-make-hash (* (length alist) 2)))
 541         (while alist
 542           (elmo-set-hash-val (concat "#" (car (car alist)))
 543                              (cdr (car alist))
 544                              elmo-pop3-size-hash)
 545           (setq alist (cdr alist)))
 546         (setq elmo-pop3-list-done t))
 547       count)))
 548
 549 (defun elmo-pop3-list-location (folder)
 550   (with-current-buffer (process-buffer
 551                         (elmo-network-session-process-internal
 552                          (elmo-pop3-get-session folder)))
 553     (let (locations)
 554       (if elmo-pop3-uidl-done
 555           (progn
 556             (mapatoms
 557              (lambda (atom)
 558                (setq locations (cons (symbol-name atom) locations)))
 559              elmo-pop3-uidl-number-hash)
 560             (sort locations
 561                   (lambda (loc1 loc2)
 562                     (< (elmo-pop3-uidl-to-number loc1)
 563                        (elmo-pop3-uidl-to-number loc2)))))
 564         (error "POP3: Error in UIDL")))))
 565
 566 (defun elmo-pop3-list-folder-by-location (folder locations)
 567   (mapcar #'car (elmo-location-map-update folder locations)))
 568
 569 (defun elmo-pop3-list-by-uidl-subr (folder &optional nonsort)
 570   (let ((flist (elmo-pop3-list-folder-by-location
 571                 folder
 572                 (elmo-pop3-list-location folder))))
 573     (if nonsort
 574         (cons (elmo-max-of-list flist) (length flist))
 575       (sort flist '<))))
 576
 577 (defun elmo-pop3-list-by-list (folder)
 578   (with-current-buffer (process-buffer
 579                         (elmo-network-session-process-internal
 580                          (elmo-pop3-get-session folder)))
 581     (let (list)
 582       (if elmo-pop3-list-done
 583           (progn
 584             (mapatoms (lambda (atom)
 585                         (setq list (cons (string-to-number
 586                                           (substring (symbol-name atom) 1))
 587                                          list)))
 588                       elmo-pop3-size-hash)
 589             (sort list '<))
 590         (error "POP3: Error in list")))))
 591
 592 (defsubst elmo-pop3-folder-list-messages (folder)
 593   (if (elmo-pop3-folder-use-uidl folder)
 594       (elmo-pop3-list-by-uidl-subr folder)
 595     (elmo-pop3-list-by-list folder)))
 596
 597 (luna-define-method elmo-folder-list-messages-plugged
 598   ((folder elmo-pop3-folder) &optional nohide)
 599   (elmo-pop3-folder-list-messages folder))
 600
 601 (luna-define-method elmo-folder-status ((folder elmo-pop3-folder))
 602   (elmo-folder-open-internal folder)
 603   (elmo-folder-check folder)
 604   (if (elmo-pop3-folder-use-uidl folder)
 605       (prog1
 606           (elmo-pop3-list-by-uidl-subr folder 'nonsort)
 607         (elmo-folder-close-internal folder))
 608     (let ((process
 609            (elmo-network-session-process-internal
 610             (elmo-pop3-get-session folder)))
 611           (total 0)
 612           response)
 613       (with-current-buffer (process-buffer process)
 614         (elmo-pop3-send-command process "STAT")
 615         (setq response (cdr (elmo-pop3-read-response process)))
 616         ;; response: "^\+OK 2 7570$"
 617         (if (not (string-match "^\+OK[ \t]*\\([0-9]*\\)" response))
 618             (error "POP STAT command failed")
 619           (setq total
 620                 (string-to-number
 621                  (substring response (match-beginning 1)(match-end 1 ))))
 622           (elmo-folder-close-internal folder)
 623           (cons total total))))))
 624
 625 (defvar elmo-pop3-header-fetch-chop-length 200)
 626
 627 (defsubst elmo-pop3-next-result-arrived-p ()
 628   (cond
 629    ((eq (following-char) ?+)
 630     (if (re-search-forward "\n\\.\r?\n" nil t)
 631         t
 632       nil))
 633    ((looking-at "-")
 634     (if (search-forward "\n" nil t)
 635         t
 636       nil))
 637    (t
 638     nil)))
 639
 640 (defun elmo-pop3-retrieve-headers (process tobuffer articles)
 641   (save-excursion
 642     (set-buffer (process-buffer process))
 643     (erase-buffer)
 644     (let ((count 0)
 645           (received 0)
 646           (last-point (point-min)))
 647       (elmo-with-progress-display (elmo-retrieve-header (length articles))
 648           "Getting headers"
 649         ;; Send HEAD commands.
 650         (while articles
 651           (elmo-pop3-send-command process
 652                                   (format "top %s 0" (car articles))
 653                                   'no-erase)
 654           ;;;   (accept-process-output process 1)
 655           (setq articles (cdr articles))
 656           (setq count (1+ count))
 657           ;; Every 200 requests we have to read the stream in
 658           ;; order to avoid deadlocks.
 659           (when (or elmo-pop3-send-command-synchronously
 660                     (null articles)     ;All requests have been sent.
 661                     (zerop (% count elmo-pop3-header-fetch-chop-length)))
 662             (unless elmo-pop3-send-command-synchronously
 663               (accept-process-output process 1))
 664             (discard-input)
 665             (while (progn
 666                      (goto-char last-point)
 667                      ;; Count replies.
 668                      (while (elmo-pop3-next-result-arrived-p)
 669                        (setq last-point (point))
 670                        (setq received (1+ received)))
 671                      (< received count))
 672               (elmo-progress-notify 'elmo-retrieve-header :set received)
 673               (accept-process-output process 1)
 674               ;;;           (accept-process-output process)
 675               (discard-input)))))
 676       ;; Replace all CRLF with LF.
 677       (elmo-delete-cr-buffer)
 678       (copy-to-buffer tobuffer (point-min) (point-max)))))
 679
 680 (luna-define-method elmo-folder-msgdb-create ((folder elmo-pop3-folder)
 681                                               numlist flag-table)
 682   (let ((process (elmo-network-session-process-internal
 683                   (elmo-pop3-get-session folder))))
 684     (with-current-buffer (process-buffer process)
 685       (elmo-pop3-msgdb-create-by-header
 686        folder
 687        process
 688        (sort numlist #'<)
 689        flag-table))))
 690
 691 (defun elmo-pop3-uidl-to-number (uidl)
 692   (string-to-number (elmo-get-hash-val uidl
 693                                        elmo-pop3-uidl-number-hash)))
 694
 695 (defun elmo-pop3-number-to-uidl (number)
 696   (elmo-get-hash-val (format "#%d" number)
 697                      elmo-pop3-number-uidl-hash))
 698
 699 (defun elmo-pop3-number-to-size (number)
 700   (string-to-number
 701    (elmo-get-hash-val (format "#%d" number) elmo-pop3-size-hash)))
 702
 703 (defun elmo-pop3-msgdb-create-by-header (folder process numlist
 704                                                 flag-table)
 705   (let ((tmp-buffer (get-buffer-create " *ELMO Overview TMP*")))
 706     (unwind-protect
 707         (with-current-buffer (process-buffer process)
 708           (when (elmo-pop3-folder-use-uidl folder)
 709             (setq numlist
 710                   (delq
 711                    nil
 712                    (mapcar
 713                     (lambda (number)
 714                       (elmo-pop3-uidl-to-number
 715                        (elmo-map-message-location folder number)))
 716                     numlist))))
 717           (elmo-pop3-retrieve-headers process tmp-buffer numlist)
 718           (elmo-pop3-msgdb-create-message
 719            folder
 720            tmp-buffer
 721            process
 722            (length numlist)
 723            numlist
 724            flag-table))
 725       (kill-buffer tmp-buffer))))
 726
 727 (defun elmo-pop3-msgdb-create-message (folder
 728                                        buffer
 729                                        process
 730                                        num
 731                                        numlist
 732                                        flag-table)
 733   (save-excursion
 734     (let ((new-msgdb (elmo-make-msgdb))
 735           beg entity number message-id flags)
 736       (set-buffer buffer)
 737       (set-buffer-multibyte default-enable-multibyte-characters)
 738       (goto-char (point-min))
 739       (elmo-with-progress-display (elmo-folder-msgdb-create num)
 740           "Creating msgdb"
 741         (while (not (eobp))
 742           (setq beg (save-excursion (forward-line 1) (point)))
 743           (elmo-pop3-next-result-arrived-p)
 744           (save-excursion
 745             (forward-line -1)
 746             (save-restriction
 747               (narrow-to-region beg (point))
 748               (setq entity
 749                     (elmo-msgdb-create-message-entity-from-buffer
 750                      (elmo-msgdb-message-entity-handler new-msgdb)
 751                      (car numlist)))
 752               (setq numlist (cdr numlist))
 753               (when entity
 754                 (with-current-buffer (process-buffer process)
 755                   (elmo-message-entity-set-field
 756                    entity
 757                    'size
 758                    (elmo-pop3-number-to-size
 759                     (elmo-message-entity-number entity)))
 760                   (when (setq number
 761                               (elmo-map-message-number
 762                                folder
 763                                (elmo-pop3-number-to-uidl
 764                                 (elmo-message-entity-number entity))))
 765                     (elmo-message-entity-set-number entity number)))
 766                 (setq message-id (elmo-message-entity-field entity 'message-id)
 767                       flags (elmo-flag-table-get flag-table message-id))
 768                 (elmo-global-flags-set flags folder number message-id)
 769                 (elmo-msgdb-append-entity new-msgdb entity flags))))
 770           (elmo-progress-notify 'elmo-folder-msgdb-create)))
 771       new-msgdb)))
 772
 773 (defun elmo-pop3-read-body (process outbuf)
 774   (with-current-buffer (process-buffer process)
 775     (let ((start elmo-pop3-read-point)
 776           end)
 777       (goto-char start)
 778       (while (not (re-search-forward "^\\.\r?\n" nil t))
 779         (accept-process-output process 1)
 780         (goto-char start))
 781       (setq end (point))
 782       (with-current-buffer outbuf
 783         (erase-buffer)
 784         (insert-buffer-substring (process-buffer process) start (- end 3)))
 785       t)))
 786
 787 (luna-define-method elmo-folder-open-internal ((folder elmo-pop3-folder))
 788   (when (elmo-pop3-folder-use-uidl folder)
 789     (elmo-location-map-load folder (elmo-folder-msgdb-path folder))))
 790
 791 (luna-define-method elmo-folder-commit :after ((folder elmo-pop3-folder))
 792   (when (and (not elmo-inhibit-number-mapping)
 793              (elmo-folder-persistent-p folder))
 794     (elmo-location-map-save folder (elmo-folder-msgdb-path folder))))
 795
 796 (luna-define-method elmo-folder-close-internal ((folder elmo-pop3-folder))
 797   (elmo-location-map-teardown folder)
 798   ;; Just close connection
 799   (elmo-folder-check folder))
 800
 801 (luna-define-method elmo-message-fetch-plugged ((folder elmo-pop3-folder)
 802                                                 number strategy
 803                                                 &optional section
 804                                                 outbuf unseen)
 805   (let ((process (elmo-network-session-process-internal
 806                   (elmo-pop3-get-session folder)))
 807         size  response errmsg msg)
 808     (with-current-buffer (process-buffer process)
 809       (when (elmo-pop3-folder-use-uidl folder)
 810         (setq number (elmo-pop3-uidl-to-number
 811                       (elmo-map-message-location folder number))))
 812       (setq size (elmo-pop3-number-to-size number))
 813       (when number
 814         (elmo-with-progress-display
 815             (elmo-retrieve-message size elmo-pop3-retrieve-progress-reporter)
 816             "Retrieving"
 817           (elmo-pop3-send-command process (format "retr %s" number))
 818           (when (null (setq response (cdr (elmo-pop3-read-response
 819                                            process t))))
 820             (error "Fetching message failed"))
 821           (setq response  (elmo-pop3-read-body process outbuf)))
 822         (set-buffer outbuf)
 823         (goto-char (point-min))
 824         (while (re-search-forward "^\\." nil t)
 825           (replace-match "")
 826           (forward-line))
 827         (elmo-delete-cr-buffer)
 828         response))))
 829
 830 (defun elmo-pop3-delete-msg (process number)
 831   (unless number
 832     (error "Deleting message failed"))
 833   (elmo-pop3-send-command process (format "dele %s" number))
 834   (when (null (cdr (elmo-pop3-read-response process t)))
 835     (error "Deleting message failed")))
 836
 837 (luna-define-method elmo-folder-delete-messages-plugged ((folder
 838                                                           elmo-pop3-folder)
 839                                                          msgs)
 840   (let ((process (elmo-network-session-process-internal
 841                   (elmo-pop3-get-session folder))))
 842     (with-current-buffer (process-buffer process)
 843       (dolist (number (if (elmo-pop3-folder-use-uidl folder)
 844                           (mapcar
 845                            (lambda (number)
 846                              (elmo-pop3-uidl-to-number
 847                               (elmo-map-message-location folder number)))
 848                            msgs)
 849                         msgs))
 850         (elmo-pop3-delete-msg process number))
 851       t)))
 852
 853 (luna-define-method elmo-message-use-cache-p ((folder elmo-pop3-folder) number)
 854   elmo-pop3-use-cache)
 855
 856 (luna-define-method elmo-folder-persistent-p ((folder elmo-pop3-folder))
 857   (and (elmo-folder-persistent-internal folder)
 858        (elmo-pop3-folder-use-uidl-internal folder)))
 859
 860 (luna-define-method elmo-folder-clear :around ((folder elmo-pop3-folder)
 861                                                &optional keep-killed)
 862   (unless keep-killed
 863     (elmo-location-map-setup folder))
 864   (luna-call-next-method))
 865
 866 (luna-define-method elmo-folder-check ((folder elmo-pop3-folder))
 867   (if (elmo-folder-plugged-p folder)
 868       (let ((session (elmo-pop3-get-session folder 'if-exists)))
 869         (when session
 870           (elmo-network-close-session session)))))
 871
 872 (require 'product)
 873 (product-provide (provide 'elmo-pop3) (require 'elmo-version))
 874
 875 ;;; elmo-pop3.el ends here