elmo/elmo-imap4.el

   1 ;;; elmo-imap4.el -- IMAP4 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 ;; Copyright (C) 2000           OKAZAKI Tetsurou <okazaki@be.to>
   6 ;; Copyright (C) 2000           Daiki Ueno <ueno@unixuser.org>
   7
   8 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   9 ;;      Kenichi OKADA <okada@opaopa.org>
  10 ;;      OKAZAKI Tetsurou <okazaki@be.to>
  11 ;;      Daiki Ueno <ueno@unixuser.org>
  12 ;; Keywords: mail, net news
  13
  14 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
  15
  16 ;; This program is free software; you can redistribute it and/or modify
  17 ;; it under the terms of the GNU General Public License as published by
  18 ;; the Free Software Foundation; either version 2, or (at your option)
  19 ;; any later version.
  20 ;;
  21 ;; This program is distributed in the hope that it will be useful,
  22 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 ;; GNU General Public License for more details.
  25 ;;
  26 ;; You should have received a copy of the GNU General Public License
  27 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  28 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  29 ;; Boston, MA 02111-1307, USA.
  30 ;;
  31
  32 ;;; Commentary:
  33 ;;
  34 ;; Origin of IMAP parser part is imap.el, included in Gnus.
  35 ;;
  36 ;;    Copyright (C) 1998, 1999, 2000
  37 ;;    Free Software Foundation, Inc.
  38 ;;    Author: Simon Josefsson <jas@pdc.kth.se>
  39 ;;
  40
  41 (require 'elmo-vars)
  42 (require 'elmo-util)
  43 (require 'elmo-msgdb)
  44 (require 'elmo-date)
  45 (require 'elmo-cache)
  46 (require 'elmo-net)
  47 (require 'utf7)
  48
  49 ;;; Code:
  50 ;; silence byte compiler.
  51 (eval-when-compile (require 'cl))
  52
  53 (defvar elmo-imap4-use-lock t
  54   "USE IMAP4 with locking process.")
  55 ;;
  56 ;;; internal variables
  57 ;;
  58 (defvar elmo-imap4-seq-prefix "elmo-imap4")
  59 (defvar elmo-imap4-seqno 0)
  60 (defvar elmo-imap4-use-uid t
  61   "Use UID as message number.")
  62
  63 (defvar elmo-imap4-current-response nil)
  64 (defvar elmo-imap4-status nil)
  65 (defvar elmo-imap4-reached-tag "elmo-imap40")
  66
  67 ;;; buffer local variables
  68
  69 (defvar elmo-imap4-extra-namespace-alist
  70   '(("^{.*/nntp}.*$" . ".")) ; Default is for UW's remote nntp mailbox...
  71   "Extra namespace alist.  A list of cons cell like: (REGEXP . DELIMITER).")
  72 (defvar elmo-imap4-default-hierarchy-delimiter "/")
  73
  74 (defvar elmo-imap4-server-capability nil)
  75 (defvar elmo-imap4-server-namespace nil)
  76
  77 (defvar elmo-imap4-parsing nil) ; indicates parsing.
  78
  79 (defvar elmo-imap4-fetch-callback nil)
  80 (defvar elmo-imap4-fetch-callback-data nil)
  81 (defvar elmo-imap4-status-callback nil)
  82 (defvar elmo-imap4-status-callback-data nil)
  83
  84 (defvar elmo-imap4-server-diff-async-callback nil)
  85 (defvar elmo-imap4-server-diff-async-callback-data nil)
  86
  87 ;;; progress...(no use?)
  88 (defvar elmo-imap4-count-progress nil)
  89 (defvar elmo-imap4-count-progress-message nil)
  90 (defvar elmo-imap4-progress-count nil)
  91
  92 ;;; XXX Temporal implementation
  93 (defvar elmo-imap4-current-msgdb nil)
  94
  95 (defvar elmo-imap4-local-variables
  96   '(elmo-imap4-status
  97     elmo-imap4-current-response
  98     elmo-imap4-seqno
  99     elmo-imap4-parsing
 100     elmo-imap4-reached-tag
 101     elmo-imap4-count-progress
 102     elmo-imap4-count-progress-message
 103     elmo-imap4-progress-count
 104     elmo-imap4-fetch-callback
 105     elmo-imap4-fetch-callback-data
 106     elmo-imap4-status-callback
 107     elmo-imap4-status-callback-data
 108     elmo-imap4-current-msgdb))
 109
 110 ;;;;
 111
 112 (defconst elmo-imap4-quoted-specials-list '(?\\ ?\"))
 113
 114 (defconst elmo-imap4-non-atom-char-regex
 115   (eval-when-compile
 116     (concat "[^" "]!#$&'+,./0-9:;<=>?@A-Z[^_`a-z|}~-" "]")))
 117
 118 (defconst elmo-imap4-non-text-char-regex
 119   (eval-when-compile
 120     (concat "[^"
 121             "]\x01-\x09\x0b\x0c\x0e-\x1f\x7f !\"#$%&'()*+,./0-9:;<=>?@A-Z[\\^_`a-z{|}~-"
 122             "]")))
 123
 124 (defconst elmo-imap4-literal-threshold 1024
 125  "Limitation of characters that can be used in a quoted string.")
 126
 127 ;; For debugging.
 128 (defvar elmo-imap4-debug nil
 129   "Non-nil forces IMAP4 folder as debug mode.
 130 Debug information is inserted in the buffer \"*IMAP4 DEBUG*\"")
 131
 132 (defvar elmo-imap4-debug-inhibit-logging nil)
 133
 134 ;;;
 135
 136 (eval-and-compile
 137   (luna-define-class elmo-imap4-session (elmo-network-session)
 138                      (capability current-mailbox read-only))
 139   (luna-define-internal-accessors 'elmo-imap4-session))
 140
 141 ;;; imap4 spec
 142
 143 (defsubst elmo-imap4-spec-mailbox (spec)
 144   (nth 1 spec))
 145
 146 (defsubst elmo-imap4-spec-username (spec)
 147   (nth 2 spec))
 148
 149 (defsubst elmo-imap4-spec-auth (spec)
 150   (nth 3 spec))
 151
 152 (defsubst elmo-imap4-spec-hostname (spec)
 153   (nth 4 spec))
 154
 155 (defsubst elmo-imap4-spec-port (spec)
 156   (nth 5 spec))
 157
 158 (defsubst elmo-imap4-spec-stream-type (spec)
 159   (nth 6 spec))
 160
 161
 162 ;;; Debug
 163
 164 (defsubst elmo-imap4-debug (message &rest args)
 165   (if elmo-imap4-debug
 166       (with-current-buffer (get-buffer-create "*IMAP4 DEBUG*")
 167         (goto-char (point-max))
 168         (if elmo-imap4-debug-inhibit-logging
 169             (insert "NO LOGGING\n")
 170           (insert (apply 'format message args) "\n")))))
 171
 172 ;;; Response
 173
 174 (defmacro elmo-imap4-response-continue-req-p (response)
 175   "Returns non-nil if RESPONSE is '+' response."
 176   (` (assq 'continue-req (, response))))
 177
 178 (defmacro elmo-imap4-response-ok-p (response)
 179   "Returns non-nil if RESPONSE is an 'OK' response."
 180   (` (assq 'ok (, response))))
 181
 182 (defmacro elmo-imap4-response-bye-p (response)
 183   "Returns non-nil if RESPONSE is an 'BYE' response."
 184   (` (assq 'bye (, response))))
 185
 186 (defmacro elmo-imap4-response-value (response symbol)
 187   "Get value of the SYMBOL from RESPONSE."
 188   (` (nth 1 (assq (, symbol) (, response)))))
 189
 190 (defsubst elmo-imap4-response-value-all (response symbol)
 191   "Get all value of the SYMBOL from RESPONSE."
 192   (let (matched)
 193     (while response
 194       (if (eq (car (car response)) symbol)
 195           (setq matched (nconc matched (nth 1 (car response)))))
 196       (setq response (cdr response)))
 197     matched))
 198
 199 (defmacro elmo-imap4-response-error-text (response)
 200   "Returns text of NO, BAD, BYE response."
 201   (` (nth 1 (or (elmo-imap4-response-value (, response) 'no)
 202                 (elmo-imap4-response-value (, response) 'bad)
 203                 (elmo-imap4-response-value (, response) 'bye)))))
 204
 205 (defmacro elmo-imap4-response-bodydetail-text (response)
 206   "Returns text of BODY[section]<partial>."
 207   (` (nth 3 (assq 'bodydetail (, response)))))
 208
 209 ;;; Session commands.
 210
 211 ; (defun elmo-imap4-send-command-wait (session command)
 212 ;   "Send COMMAND to the SESSION and wait for response.
 213 ; Returns RESPONSE (parsed lisp object) of IMAP session."
 214 ;   (elmo-imap4-read-response session
 215 ;                           (elmo-imap4-send-command
 216 ;                            session
 217 ;                            command)))
 218
 219 (defun elmo-imap4-send-command-wait (session command)
 220   "Send COMMAND to the SESSION.
 221 Returns RESPONSE (parsed lisp object) of IMAP session.
 222 If response is not `OK', causes error with IMAP response text."
 223   (elmo-imap4-accept-ok session
 224                         (elmo-imap4-send-command
 225                          session
 226                          command)))
 227
 228 (defun elmo-imap4-send-command (session command)
 229   "Send COMMAND to the SESSION.
 230 Returns a TAG string which is assigned to the COMAND."
 231   (let* ((command-args (if (listp command)
 232                            command
 233                          (list command)))
 234          (process (elmo-network-session-process-internal session))
 235          cmdstr tag token kind)
 236     (with-current-buffer (process-buffer process)
 237       (setq tag (concat elmo-imap4-seq-prefix
 238                         (number-to-string
 239                          (setq elmo-imap4-seqno (+ 1 elmo-imap4-seqno)))))
 240       (setq cmdstr (concat tag " "))
 241       ;; (erase-buffer) No need.
 242       (goto-char (point-min))
 243       (if (elmo-imap4-response-bye-p elmo-imap4-current-response)
 244           (signal 'elmo-imap4-bye-error
 245                   (list (elmo-imap4-response-error-text
 246                          elmo-imap4-current-response))))
 247       (setq elmo-imap4-current-response nil)
 248       (if elmo-imap4-parsing
 249           (error "IMAP process is running. Please wait (or plug again.)"))
 250       (setq elmo-imap4-parsing t)
 251       (elmo-imap4-debug "<-(%s)- %s" tag command)
 252       (while (setq token (car command-args))
 253         (cond ((stringp token)   ; formatted
 254                (setq cmdstr (concat cmdstr token)))
 255               ((listp token)     ; unformatted
 256                (setq kind (car token))
 257                (cond ((eq kind 'atom)
 258                       (setq cmdstr (concat cmdstr (nth 1 token))))
 259                      ((eq kind 'quoted)
 260                       (setq cmdstr (concat
 261                                     cmdstr
 262                                     (elmo-imap4-format-quoted (nth 1 token)))))
 263                      ((eq kind 'literal)
 264                       (setq cmdstr (concat cmdstr
 265                                            (format "{%d}" (nth 2 token))))
 266                       (process-send-string process cmdstr)
 267                       (process-send-string process "\r\n")
 268                       (setq cmdstr nil)
 269                       (elmo-imap4-accept-continue-req session)
 270                       (cond ((stringp (nth 1 token))
 271                              (setq cmdstr (nth 1 token)))
 272                             ((bufferp (nth 1 token))
 273                              (with-current-buffer (nth 1 token)
 274                                (process-send-region
 275                                 process
 276                                 (point-min)
 277                                 (+ (point-min) (nth 2 token)))))
 278                             (t
 279                              (error "Wrong argument for literal"))))
 280                      (t
 281                       (error "Unknown token kind %s" kind))))
 282               (t
 283                (error "Invalid argument")))
 284         (setq command-args (cdr command-args)))
 285       (if cmdstr
 286           (process-send-string process cmdstr))
 287       (process-send-string process "\r\n")
 288       tag)))
 289
 290 (defun elmo-imap4-send-string (session string)
 291   "Send STRING to the SESSION."
 292   (with-current-buffer (process-buffer
 293                         (elmo-network-session-process-internal session))
 294     (setq elmo-imap4-current-response nil)
 295     (goto-char (point-min))
 296     (elmo-imap4-debug "<-- %s" string)
 297     (process-send-string (elmo-network-session-process-internal session)
 298                          string)
 299     (process-send-string (elmo-network-session-process-internal session)
 300                          "\r\n")))
 301
 302 (defun elmo-imap4-read-response (session tag)
 303   "Read parsed response from SESSION.
 304 TAG is the tag of the command"
 305   (with-current-buffer (process-buffer
 306                         (elmo-network-session-process-internal session))
 307     (while (not (or (string= tag elmo-imap4-reached-tag)
 308                     (elmo-imap4-response-bye-p elmo-imap4-current-response)))
 309       (when (memq (process-status
 310                    (elmo-network-session-process-internal session))
 311                   '(open run))
 312         (accept-process-output (elmo-network-session-process-internal session)
 313                                1)))
 314     (elmo-imap4-debug "=>%s" (prin1-to-string elmo-imap4-current-response))
 315     (setq elmo-imap4-parsing nil)
 316     elmo-imap4-current-response))
 317
 318 (defsubst elmo-imap4-read-untagged (process)
 319   (with-current-buffer (process-buffer process)
 320     (while (not elmo-imap4-current-response)
 321       (accept-process-output process 1))
 322     (elmo-imap4-debug "=>%s" (prin1-to-string elmo-imap4-current-response))
 323     elmo-imap4-current-response))
 324
 325 (defun elmo-imap4-read-continue-req (session)
 326   "Returns a text following to continue-req in SESSION.
 327 If response is not `+' response, returns nil."
 328   (elmo-imap4-response-value
 329    (elmo-imap4-read-untagged
 330     (elmo-network-session-process-internal session))
 331    'continue-req))
 332
 333 (defun elmo-imap4-accept-continue-req (session)
 334   "Returns non-nil if `+' (continue-req) response is arrived in SESSION.
 335 If response is not `+' response, cause an error."
 336   (let (response)
 337     (setq response
 338           (elmo-imap4-read-untagged
 339            (elmo-network-session-process-internal session)))
 340     (or (elmo-imap4-response-continue-req-p response)
 341         (error "IMAP error: %s"
 342                (or (elmo-imap4-response-error-text response)
 343                    "No continut-req from server.")))))
 344
 345 (defun elmo-imap4-read-ok (session tag)
 346   "Returns non-nil if `OK' response of the command with TAG is arrived
 347 in SESSION. If response is not `OK' response, returns nil."
 348   (elmo-imap4-response-ok-p
 349    (elmo-imap4-read-response session tag)))
 350
 351 (defun elmo-imap4-accept-ok (session tag)
 352   "Accept only `OK' response from SESSION.
 353 If response is not `OK' response, causes error with IMAP response text."
 354   (let ((response (elmo-imap4-read-response session tag)))
 355     (if (elmo-imap4-response-ok-p response)
 356         response
 357       (if (elmo-imap4-response-bye-p response)
 358           (signal 'elmo-imap4-bye-error
 359                   (list (elmo-imap4-response-error-text response)))
 360         (error "IMAP error: %s"
 361                (or (elmo-imap4-response-error-text response)
 362                    "No `OK' response from server."))))))
 363 ;;;
 364
 365 (defun elmo-imap4-session-check (session)
 366   (elmo-imap4-send-command-wait session "check"))
 367
 368 (defun elmo-imap4-atom-p (string)
 369   "Return t if STRING is an atom defined in rfc2060."
 370   (if (string= string "")
 371       nil
 372     (save-match-data
 373       (not (string-match elmo-imap4-non-atom-char-regex string)))))
 374
 375 (defun elmo-imap4-quotable-p (string)
 376   "Return t if STRING can be formatted as a quoted defined in rfc2060."
 377   (save-match-data
 378     (not (string-match elmo-imap4-non-text-char-regex string))))
 379
 380 (defun elmo-imap4-nil (string)
 381   "Return a list represents the special atom \"NIL\" defined in rfc2060, \
 382 if STRING is nil.
 383 Otherwise return nil."
 384   (if (eq string nil)
 385       (list 'atom "NIL")))
 386
 387 (defun elmo-imap4-atom (string)
 388   "Return a list represents STRING as an atom defined in rfc2060.
 389 Return nil if STRING is not an atom.  See `elmo-imap4-atom-p'."
 390   (if (elmo-imap4-atom-p string)
 391       (list 'atom string)))
 392
 393 (defun elmo-imap4-quoted (string)
 394   "Return a list represents STRING as a quoted defined in rfc2060.
 395 Return nil if STRING can not be formatted as a quoted.  See `elmo-imap4-quotable-p'."
 396   (if (elmo-imap4-quotable-p string)
 397       (list 'quoted string)))
 398
 399 (defun elmo-imap4-literal-1 (string-or-buffer length)
 400   "Internal function for `elmo-imap4-literal' and `elmo-imap4-buffer-literal'.
 401 Return a list represents STRING-OR-BUFFER as a literal defined in rfc2060.
 402 STRING-OR-BUFFER must be an encoded string or a single-byte string or a single-byte buffer.
 403 LENGTH must be the number of octets for STRING-OR-BUFFER."
 404   (list 'literal string-or-buffer length))
 405
 406 (defun elmo-imap4-literal (string)
 407   "Return a list represents STRING as a literal defined in rfc2060.
 408 STRING must be an encoded or a single-byte string."
 409   (elmo-imap4-literal-1 string (length string)))
 410
 411 (defun elmo-imap4-buffer-literal (buffer)
 412   "Return a list represents BUFFER as a literal defined in rfc2060.
 413 BUFFER must be a single-byte buffer."
 414   (elmo-imap4-literal-1 buffer (with-current-buffer buffer
 415                                  (buffer-size))))
 416
 417 (defun elmo-imap4-string-1 (string length)
 418   "Internal function for `elmo-imap4-string' and `elmo-imap4-buffer-string'.
 419 Return a list represents STRING as a string defined in rfc2060.
 420 STRING must be an encoded or a single-byte string.
 421 LENGTH must be the number of octets for STRING."
 422   (or (elmo-imap4-quoted string)
 423       (elmo-imap4-literal-1 string length)))
 424
 425 (defun elmo-imap4-string (string)
 426   "Return a list represents STRING as a string defined in rfc2060.
 427 STRING must be an encoded or a single-byte string."
 428   (let ((length (length string)))
 429     (if (< elmo-imap4-literal-threshold length)
 430         (elmo-imap4-literal-1 string length)
 431       (elmo-imap4-string-1 string length))))
 432
 433 (defun elmo-imap4-buffer-string (buffer)
 434   "Return a list represents BUFFER as a string defined in rfc2060.
 435 BUFFER must be a single-byte buffer."
 436   (let ((length (with-current-buffer buffer
 437                   (buffer-size))))
 438     (if (< elmo-imap4-literal-threshold length)
 439         (elmo-imap4-literal-1 buffer length)
 440       (elmo-imap4-string-1 (with-current-buffer buffer
 441                              (buffer-string))
 442                            length))))
 443
 444 (defun elmo-imap4-astring-1 (string length)
 445   "Internal function for `elmo-imap4-astring' and `elmo-imap4-buffer-astring'.
 446 Return a list represents STRING as an astring defined in rfc2060.
 447 STRING must be an encoded or a single-byte string.
 448 LENGTH must be the number of octets for STRING."
 449   (or (elmo-imap4-atom string)
 450       (elmo-imap4-string-1 string length)))
 451
 452 (defun elmo-imap4-astring (string)
 453   "Return a list represents STRING as an astring defined in rfc2060.
 454 STRING must be an encoded or a single-byte string."
 455   (let ((length (length string)))
 456     (if (< elmo-imap4-literal-threshold length)
 457         (elmo-imap4-literal-1 string length)
 458       (elmo-imap4-astring-1 string length))))
 459
 460 (defun elmo-imap4-buffer-astring (buffer)
 461   "Return a list represents BUFFER as an astring defined in rfc2060.
 462 BUFFER must be a single-byte buffer."
 463   (let ((length (with-current-buffer buffer
 464                   (buffer-size))))
 465     (if (< elmo-imap4-literal-threshold length)
 466         (elmo-imap4-literal-1 buffer length)
 467       (elmo-imap4-astring-1 (with-current-buffer buffer
 468                               (buffer-string))
 469                             length))))
 470
 471 (defun elmo-imap4-nstring (string)
 472   "Return a list represents STRING as a nstring defined in rfc2060.
 473 STRING must be an encoded or a single-byte string."
 474    (or (elmo-imap4-nil string)
 475        (elmo-imap4-string string)))
 476
 477 (defun elmo-imap4-buffer-nstring (buffer)
 478   "Return a list represents BUFFER as a nstring defined in rfc2060.
 479 BUFFER must be a single-byte buffer."
 480    (or (elmo-imap4-nil buffer)
 481        (elmo-imap4-buffer-string buffer)))
 482
 483 (defalias 'elmo-imap4-mailbox 'elmo-imap4-astring)
 484 (defalias 'elmo-imap4-field-body 'elmo-imap4-astring)
 485 (defalias 'elmo-imap4-userid 'elmo-imap4-astring)
 486 (defalias 'elmo-imap4-password 'elmo-imap4-astring)
 487
 488 (defun elmo-imap4-format-quoted (string)
 489   "Return STRING in a form of the quoted-string defined in rfc2060."
 490   (concat "\""
 491           (std11-wrap-as-quoted-pairs string elmo-imap4-quoted-specials-list)
 492           "\""))
 493
 494 (defsubst elmo-imap4-response-get-selectable-mailbox-list (response)
 495   (delq nil
 496         (mapcar
 497          (lambda (entry)
 498            (if (and (eq 'list (car entry))
 499                     (not (member "\\NoSelect" (nth 1 (nth 1 entry)))))
 500                (car (nth 1 entry))))
 501          response)))
 502
 503 ;;; Backend methods.
 504 (defun elmo-imap4-list-folders (spec &optional hierarchy)
 505   (let* ((root (elmo-imap4-spec-mailbox spec))
 506          (session (elmo-imap4-get-session spec))
 507          (delim (or
 508                  (cdr
 509                   (elmo-string-matched-assoc
 510                    root
 511                    (with-current-buffer (elmo-network-session-buffer session)
 512                      elmo-imap4-server-namespace)))
 513                  elmo-imap4-default-hierarchy-delimiter))
 514          result append-serv type)
 515     ;; Append delimiter
 516     (if (and root
 517              (not (string= root ""))
 518              (not (string-match (concat "\\(.*\\)"
 519                                         (regexp-quote delim)
 520                                         "\\'")
 521                                 root)))
 522         (setq root (concat root delim)))
 523     (setq result (elmo-imap4-response-get-selectable-mailbox-list
 524                   (elmo-imap4-send-command-wait
 525                    session
 526                    (list "list " (elmo-imap4-mailbox root) " *"))))
 527     (unless (string= (elmo-imap4-spec-username spec)
 528                      elmo-default-imap4-user)
 529       (setq append-serv (concat ":" (elmo-imap4-spec-username spec))))
 530     (unless (eq (elmo-imap4-spec-auth spec)
 531                      elmo-default-imap4-authenticate-type)
 532       (setq append-serv
 533             (concat append-serv "/" (symbol-name (elmo-imap4-spec-auth spec)))))
 534     (unless (string= (elmo-imap4-spec-hostname spec)
 535                      elmo-default-imap4-server)
 536       (setq append-serv (concat append-serv "@" (elmo-imap4-spec-hostname
 537                                                  spec))))
 538     (unless (eq (elmo-imap4-spec-port spec)
 539                 elmo-default-imap4-port)
 540       (setq append-serv (concat append-serv ":"
 541                                 (int-to-string
 542                                  (elmo-imap4-spec-port spec)))))
 543     (setq type (elmo-imap4-spec-stream-type spec))
 544     (unless (eq (elmo-network-stream-type-symbol type)
 545                 elmo-default-imap4-stream-type)
 546       (if type
 547           (setq append-serv (concat append-serv
 548                                     (elmo-network-stream-type-spec-string
 549                                      type)))))
 550     (if hierarchy
 551         (let (folder folders ret)
 552           (while (setq folders (car result))
 553             (if (prog1
 554                     (string-match
 555                      (concat "^\\(" root "[^" delim "]" "+\\)" delim)
 556                           folders)
 557                   (setq folder (match-string 1 folders)))
 558                 (progn
 559                   (setq ret
 560                         (append ret (list (list
 561                                            (concat "%" (elmo-imap4-decode-folder-string folder)
 562                                                    (and append-serv
 563                                                         (eval append-serv)))))))
 564                   (setq result
 565                         (delq nil
 566                               (mapcar '(lambda (fld)
 567                                          (unless
 568                                              (string-match
 569                                               (concat "^" (regexp-quote folder))
 570                                               fld)
 571                                            fld))
 572                                       result))))
 573               (setq ret (append ret (list
 574                                      (concat "%" (elmo-imap4-decode-folder-string folders)
 575                                              (and append-serv
 576                                                   (eval append-serv))))))
 577               (setq result (cdr result))))
 578           ret)
 579       (mapcar (lambda (fld)
 580                 (concat "%" (elmo-imap4-decode-folder-string fld)
 581                         (and append-serv
 582                              (eval append-serv))))
 583               result))))
 584
 585 (defun elmo-imap4-folder-exists-p (spec)
 586   (let ((session (elmo-imap4-get-session spec)))
 587     (if (string=
 588          (elmo-imap4-session-current-mailbox-internal session)
 589          (elmo-imap4-spec-mailbox spec))
 590         t
 591       (elmo-imap4-session-select-mailbox
 592        session
 593        (elmo-imap4-spec-mailbox spec)
 594        'force 'no-error))))
 595
 596 (defun elmo-imap4-folder-creatable-p (spec)
 597   t)
 598
 599 (defun elmo-imap4-create-folder-maybe (spec dummy)
 600   (unless (elmo-imap4-folder-exists-p spec)
 601     (elmo-imap4-create-folder spec)))
 602
 603 (defun elmo-imap4-create-folder (spec)
 604   (elmo-imap4-send-command-wait
 605    (elmo-imap4-get-session spec)
 606    (list "create " (elmo-imap4-mailbox
 607                     (elmo-imap4-spec-mailbox spec)))))
 608
 609 (defun elmo-imap4-delete-folder (spec)
 610   (let ((session (elmo-imap4-get-session spec))
 611         msgs)
 612     (when (elmo-imap4-spec-mailbox spec)
 613       (when (setq msgs (elmo-imap4-list-folder spec))
 614         (elmo-imap4-delete-msgs spec msgs))
 615       (elmo-imap4-send-command-wait session "close")
 616       (elmo-imap4-send-command-wait
 617        session
 618        (list "delete "
 619              (elmo-imap4-mailbox (elmo-imap4-spec-mailbox spec)))))))
 620
 621 (defun elmo-imap4-rename-folder (old-spec new-spec)
 622   (let ((session (elmo-imap4-get-session old-spec)))
 623     (elmo-imap4-send-command-wait session "close")
 624     (elmo-imap4-send-command-wait
 625      session
 626      (list "rename "
 627            (elmo-imap4-mailbox
 628             (elmo-imap4-spec-mailbox old-spec))
 629            " "
 630            (elmo-imap4-mailbox
 631             (elmo-imap4-spec-mailbox new-spec))))))
 632
 633 (defun elmo-imap4-max-of-folder (spec)
 634   (let ((session (elmo-imap4-get-session spec))
 635          (killed (and elmo-use-killed-list
 636                       (elmo-msgdb-killed-list-load
 637                        (elmo-msgdb-expand-path spec))))
 638         status)
 639     (with-current-buffer (elmo-network-session-buffer session)
 640       (setq elmo-imap4-status-callback nil)
 641       (setq elmo-imap4-status-callback-data nil))
 642     (setq status (elmo-imap4-response-value
 643                   (elmo-imap4-send-command-wait
 644                    session
 645                    (list "status "
 646                          (elmo-imap4-mailbox
 647                           (elmo-imap4-spec-mailbox spec))
 648                          " (uidnext messages)"))
 649                   'status))
 650     (cons
 651      (- (elmo-imap4-response-value status 'uidnext) 1)
 652      (if killed
 653          (-
 654           (elmo-imap4-response-value status 'messages)
 655           (elmo-msgdb-killed-list-length killed))
 656        (elmo-imap4-response-value status 'messages)))))
 657
 658 (defun elmo-imap4-folder-diff (spec folder &optional number-list)
 659   (if elmo-use-server-diff
 660       (elmo-imap4-server-diff spec)
 661     (elmo-generic-folder-diff spec folder number-list)))
 662
 663 (defun elmo-imap4-get-session (spec &optional if-exists)
 664   (elmo-network-get-session
 665    'elmo-imap4-session
 666    "IMAP"
 667    (elmo-imap4-spec-hostname spec)
 668    (elmo-imap4-spec-port spec)
 669    (elmo-imap4-spec-username spec)
 670    (elmo-imap4-spec-auth spec)
 671    (elmo-imap4-spec-stream-type spec)
 672    if-exists))
 673
 674 (defun elmo-imap4-commit (spec)
 675   (if (elmo-imap4-plugged-p spec)
 676       (let ((session (elmo-imap4-get-session spec 'if-exists)))
 677         (when session
 678           (if (string=
 679                (elmo-imap4-session-current-mailbox-internal session)
 680                (elmo-imap4-spec-mailbox spec))
 681               (if elmo-imap4-use-select-to-update-status
 682                   (elmo-imap4-session-select-mailbox
 683                    session
 684                    (elmo-imap4-spec-mailbox spec)
 685                    'force)
 686                 (elmo-imap4-session-check session)))))))
 687
 688 (defun elmo-imap4-session-select-mailbox (session mailbox
 689                                                   &optional force no-error)
 690   "Select MAILBOX in SESSION.
 691 If optional argument FORCE is non-nil, select mailbox even if current mailbox
 692 is same as MAILBOX.
 693 If second optional argument NO-ERROR is non-nil, don't cause an error when
 694 selecting folder was failed.
 695 Returns response value if selecting folder succeed. "
 696   (when (or force
 697             (not (string=
 698                   (elmo-imap4-session-current-mailbox-internal session)
 699                   mailbox)))
 700     (let (response result)
 701       (unwind-protect
 702           (setq response
 703                 (elmo-imap4-read-response
 704                  session
 705                  (elmo-imap4-send-command
 706                   session
 707                   (list
 708                    "select "
 709                    (elmo-imap4-mailbox mailbox)))))
 710         (if (setq result (elmo-imap4-response-ok-p response))
 711             (progn
 712               (elmo-imap4-session-set-current-mailbox-internal session mailbox)
 713               (elmo-imap4-session-set-read-only-internal
 714                session
 715                (nth 1 (assq 'read-only (assq 'ok response)))))
 716           (elmo-imap4-session-set-current-mailbox-internal session nil)
 717           (unless no-error
 718             (error (or
 719                     (elmo-imap4-response-error-text response)
 720                     (format "Select %s failed" mailbox))))))
 721       (and result response))))
 722
 723 (defun elmo-imap4-check-validity (spec validity-file)
 724 ;;; Not used.
 725 ;;;(elmo-imap4-send-command-wait
 726 ;;;(elmo-imap4-get-session spec)
 727 ;;;(list "status "
 728 ;;;      (elmo-imap4-mailbox
 729 ;;;       (elmo-imap4-spec-mailbox spec))
 730 ;;;      " (uidvalidity)")))
 731   )
 732
 733 (defun elmo-imap4-sync-validity  (spec validity-file)
 734   ;; Not used.
 735   )
 736
 737 (defun elmo-imap4-list (spec flag)
 738   (let ((session (elmo-imap4-get-session spec)))
 739     (elmo-imap4-session-select-mailbox session
 740                                        (elmo-imap4-spec-mailbox spec))
 741     (elmo-imap4-response-value
 742      (elmo-imap4-send-command-wait
 743       session
 744       (format (if elmo-imap4-use-uid "uid search %s"
 745                 "search %s") flag))
 746      'search)))
 747
 748 (defun elmo-imap4-list-folder (spec)
 749   (let ((killed (and elmo-use-killed-list
 750                      (elmo-msgdb-killed-list-load
 751                       (elmo-msgdb-expand-path spec))))
 752         numbers)
 753     (setq numbers (elmo-imap4-list spec "all"))
 754     (elmo-living-messages numbers killed)))
 755
 756 (defun elmo-imap4-list-folder-unread (spec number-alist mark-alist
 757                                            unread-marks)
 758   (if (and (elmo-imap4-plugged-p spec)
 759            (elmo-imap4-use-flag-p spec))
 760       (elmo-imap4-list spec "unseen")
 761     (elmo-generic-list-folder-unread spec number-alist mark-alist
 762                                      unread-marks)))
 763
 764 (defun elmo-imap4-list-folder-important (spec number-alist)
 765   (if (and (elmo-imap4-plugged-p spec)
 766            (elmo-imap4-use-flag-p spec))
 767       (elmo-imap4-list spec "flagged")))
 768
 769 (defmacro elmo-imap4-detect-search-charset (string)
 770   (` (with-temp-buffer
 771        (insert (, string))
 772        (detect-mime-charset-region (point-min) (point-max)))))
 773
 774 (defun elmo-imap4-search-internal-primitive (spec session filter from-msgs)
 775   (let ((search-key (elmo-filter-key filter))
 776         (imap-search-keys '("bcc" "body" "cc" "from" "subject" "to"))
 777         charset)
 778     (cond
 779      ((string= "last" search-key)
 780       (let ((numbers (or from-msgs (elmo-imap4-list-folder spec))))
 781         (nthcdr (max (- (length numbers)
 782                         (string-to-int (elmo-filter-value filter)))
 783                      0)
 784                 numbers)))
 785      ((string= "first" search-key)
 786       (let* ((numbers (or from-msgs (elmo-imap4-list-folder spec)))
 787              (rest (nthcdr (string-to-int (elmo-filter-value filter) )
 788                            numbers)))
 789         (mapcar '(lambda (x) (delete x numbers)) rest)
 790         numbers))
 791      ((or (string= "since" search-key)
 792           (string= "before" search-key))
 793       (setq search-key (concat "sent" search-key))
 794       (elmo-imap4-response-value
 795        (elmo-imap4-send-command-wait session
 796                                      (format
 797                                       (if elmo-imap4-use-uid
 798                                           "uid search %s%s%s %s"
 799                                         "search %s%s%s %s")
 800                                       (if from-msgs
 801                                           (concat
 802                                            (if elmo-imap4-use-uid "uid ")
 803                                            (cdr
 804                                             (car
 805                                              (elmo-imap4-make-number-set-list
 806                                               from-msgs)))
 807                                            " ")
 808                                         "")
 809                                       (if (eq (elmo-filter-type filter)
 810                                               'unmatch)
 811                                           "not " "")
 812                                       search-key
 813                                       (elmo-date-get-description
 814                                        (elmo-date-get-datevec
 815                                         (elmo-filter-value filter)))))
 816        'search))
 817      (t
 818       (setq charset
 819             (if (eq (length (elmo-filter-value filter)) 0)
 820                 (setq charset 'us-ascii)
 821               (elmo-imap4-detect-search-charset
 822                (elmo-filter-value filter))))
 823       (elmo-imap4-response-value
 824        (elmo-imap4-send-command-wait session
 825                                      (list
 826                                       (if elmo-imap4-use-uid "uid ")
 827                                       "search "
 828                                       "CHARSET "
 829                                       (elmo-imap4-astring
 830                                        (symbol-name charset))
 831                                       " "
 832                                       (if from-msgs
 833                                           (concat
 834                                            (if elmo-imap4-use-uid "uid ")
 835                                            (cdr
 836                                             (car
 837                                              (elmo-imap4-make-number-set-list
 838                                               from-msgs)))
 839                                            " ")
 840                                         "")
 841                                       (if (eq (elmo-filter-type filter)
 842                                               'unmatch)
 843                                           "not " "")
 844                                       (format "%s%s "
 845                                               (if (member
 846                                                    (elmo-filter-key filter)
 847                                                    imap-search-keys)
 848                                                   ""
 849                                                 "header ")
 850                                               (elmo-filter-key filter))
 851                                       (elmo-imap4-astring
 852                                        (encode-mime-charset-string
 853                                         (elmo-filter-value filter) charset))))
 854        'search)))))
 855
 856 (defun elmo-imap4-search-internal (spec session condition from-msgs)
 857   (let (result)
 858     (cond
 859      ((vectorp condition)
 860       (setq result (elmo-imap4-search-internal-primitive
 861                     spec session condition from-msgs)))
 862      ((eq (car condition) 'and)
 863       (setq result (elmo-imap4-search-internal spec session (nth 1 condition)
 864                                                from-msgs)
 865             result (elmo-list-filter result
 866                                      (elmo-imap4-search-internal
 867                                       spec session (nth 2 condition)
 868                                       from-msgs))))
 869      ((eq (car condition) 'or)
 870       (setq result (elmo-imap4-search-internal
 871                     spec session (nth 1 condition) from-msgs)
 872             result (elmo-uniq-list
 873                     (nconc result
 874                            (elmo-imap4-search-internal
 875                             spec session (nth 2 condition) from-msgs)))
 876             result (sort result '<))))))
 877
 878
 879 (defun elmo-imap4-search (spec condition &optional from-msgs)
 880   (save-excursion
 881     (let ((session (elmo-imap4-get-session spec)))
 882       (elmo-imap4-session-select-mailbox
 883        session
 884        (elmo-imap4-spec-mailbox spec))
 885       (elmo-imap4-search-internal spec session condition from-msgs))))
 886
 887 (defun elmo-imap4-use-flag-p (spec)
 888   (not (string-match elmo-imap4-disuse-server-flag-mailbox-regexp
 889                      (elmo-imap4-spec-mailbox spec))))
 890
 891 (static-cond
 892  ((fboundp 'float)
 893   ;; Emacs can parse dot symbol.
 894   (defvar elmo-imap4-rfc822-size "RFC822\.SIZE")
 895   (defvar elmo-imap4-rfc822-text "RFC822\.TEXT")
 896   (defvar elmo-imap4-rfc822-header "RFC822\.HEADER")
 897   (defvar elmo-imap4-rfc822-size "RFC822\.SIZE")
 898   (defvar elmo-imap4-header-fields "HEADER\.FIELDS")
 899   (defmacro elmo-imap4-replace-dot-symbols ()) ;; noop
 900   (defalias 'elmo-imap4-fetch-read 'read)
 901   )
 902  (t
 903   ;;; For Nemacs.
 904   ;; Cannot parse dot symbol.
 905   (defvar elmo-imap4-rfc822-size "RFC822_SIZE")
 906   (defvar elmo-imap4-header-fields "HEADER_FIELDS")
 907   (defvar elmo-imap4-rfc822-size "RFC822_SIZE")
 908   (defvar elmo-imap4-rfc822-text "RFC822_TEXT")
 909   (defvar elmo-imap4-rfc822-header "RFC822_HEADER")
 910   (defvar elmo-imap4-header-fields "HEADER_FIELDS")
 911   (defun elmo-imap4-fetch-read (buffer)
 912     (with-current-buffer buffer
 913       (let ((beg (point))
 914             token)
 915         (when (re-search-forward "[[ ]" nil t)
 916           (goto-char (match-beginning 0))
 917           (setq token (buffer-substring beg (point)))
 918           (cond ((string= token "RFC822.SIZE")
 919                  (intern elmo-imap4-rfc822-size))
 920                 ((string= token "RFC822.HEADER")
 921                  (intern elmo-imap4-rfc822-header))
 922                 ((string= token "RFC822.TEXT")
 923                  (intern elmo-imap4-rfc822-text))
 924                 ((string= token "HEADER\.FIELDS")
 925                  (intern elmo-imap4-header-fields))
 926                 (t (goto-char beg)
 927                    (elmo-read (current-buffer))))))))))
 928
 929 (defun elmo-imap4-make-number-set-list (msg-list &optional chop-length)
 930   "Make RFC2060's message set specifier from MSG-LIST.
 931 Returns a list of (NUMBER . SET-STRING).
 932 SET-STRING is the message set specifier described in RFC2060.
 933 NUMBER is contained message number in SET-STRING.
 934 Every SET-STRING does not contain number of messages longer than CHOP-LENGTH.
 935 If CHOP-LENGTH is not specified, message set is not chopped."
 936   (let (count cont-list set-list)
 937     (setq msg-list (sort (copy-sequence msg-list) '<))
 938     (while msg-list
 939       (setq cont-list nil)
 940       (setq count 0)
 941       (unless chop-length
 942         (setq chop-length (length msg-list)))
 943       (while (and (not (null msg-list))
 944                   (< count chop-length))
 945         (setq cont-list
 946               (elmo-number-set-append
 947                cont-list (car msg-list)))
 948         (incf count)
 949         (setq msg-list (cdr msg-list)))
 950       (setq set-list
 951             (cons
 952              (cons
 953               count
 954               (mapconcat
 955                (lambda (x)
 956                  (cond ((consp x)
 957                         (format "%s:%s" (car x) (cdr x)))
 958                        ((integerp x)
 959                         (int-to-string x))))
 960                cont-list
 961                ","))
 962              set-list)))
 963     (nreverse set-list)))
 964
 965 ;;
 966 ;; set mark
 967 ;; read-mark -> "\\Seen"
 968 ;; important -> "\\Flagged"
 969 ;;
 970 ;; (delete -> \\Deleted)
 971 (defun elmo-imap4-mark-set-on-msgs (spec msgs mark &optional unmark no-expunge)
 972   "SET flag of MSGS as MARK.
 973 If optional argument UNMARK is non-nil, unmark."
 974   (let ((session (elmo-imap4-get-session spec))
 975         set-list)
 976     (elmo-imap4-session-select-mailbox session
 977                                        (elmo-imap4-spec-mailbox spec))
 978     (setq set-list (elmo-imap4-make-number-set-list msgs))
 979     (when set-list
 980       (with-current-buffer (elmo-network-session-buffer session)
 981         (setq elmo-imap4-fetch-callback nil)
 982         (setq elmo-imap4-fetch-callback-data nil))
 983       (elmo-imap4-send-command-wait
 984        session
 985        (format
 986         (if elmo-imap4-use-uid
 987             "uid store %s %sflags.silent (%s)"
 988           "store %s %sflags.silent (%s)")
 989         (cdr (car set-list))
 990         (if unmark "-" "+")
 991         mark))
 992       (unless no-expunge
 993         (elmo-imap4-send-command-wait session "expunge")))
 994     t))
 995
 996 (defun elmo-imap4-mark-as-important (spec msgs)
 997   (and (elmo-imap4-use-flag-p spec)
 998        (elmo-imap4-mark-set-on-msgs spec msgs "\\Flagged" nil 'no-expunge)))
 999
1000 (defun elmo-imap4-mark-as-read (spec msgs)
1001   (and (elmo-imap4-use-flag-p spec)
1002        (elmo-imap4-mark-set-on-msgs spec msgs "\\Seen" nil 'no-expunge)))
1003
1004 (defun elmo-imap4-unmark-important (spec msgs)
1005   (and (elmo-imap4-use-flag-p spec)
1006        (elmo-imap4-mark-set-on-msgs spec msgs "\\Flagged" 'unmark
1007                                     'no-expunge)))
1008
1009 (defun elmo-imap4-mark-as-unread (spec msgs)
1010   (and (elmo-imap4-use-flag-p spec)
1011        (elmo-imap4-mark-set-on-msgs spec msgs "\\Seen" 'unmark 'no-expunge)))
1012
1013 (defun elmo-imap4-delete-msgs (spec msgs)
1014   (elmo-imap4-mark-set-on-msgs spec msgs "\\Deleted"))
1015
1016 (defun elmo-imap4-delete-msgs-no-expunge (spec msgs)
1017   (elmo-imap4-mark-set-on-msgs spec msgs "\\Deleted" nil 'no-expunge))
1018
1019 (defun elmo-imap4-msgdb-create-as-numlist (spec numlist new-mark already-mark
1020                                                 seen-mark important-mark
1021                                                 seen-list)
1022   "Create msgdb for SPEC for NUMLIST."
1023   (elmo-imap4-msgdb-create spec numlist new-mark already-mark
1024                            seen-mark important-mark seen-list t))
1025
1026 ;; Current buffer is process buffer.
1027 (defun elmo-imap4-fetch-callback (element app-data)
1028   (funcall elmo-imap4-fetch-callback
1029            (with-temp-buffer
1030              (insert (or (elmo-imap4-response-bodydetail-text element)
1031                          ""))
1032              ;; Delete CR.
1033              (goto-char (point-min))
1034              (while (search-forward "\r\n" nil t)
1035                (replace-match "\n"))
1036              (elmo-msgdb-create-overview-from-buffer
1037               (elmo-imap4-response-value element 'uid)
1038               (elmo-imap4-response-value element 'rfc822size)))
1039            (elmo-imap4-response-value element 'flags)
1040            app-data))
1041
1042 ;;
1043 ;; app-data:
1044 ;; 0: new-mark 1: already-mark 2: seen-mark 3: important-mark
1045 ;; 4: seen-list 5: as-number
1046 (defun elmo-imap4-fetch-callback-1 (entity flags app-data)
1047   "A msgdb entity callback function."
1048   (let ((seen (member (car entity) (nth 4 app-data)))
1049         mark)
1050     (if (member "\\Flagged" flags)
1051         (elmo-msgdb-global-mark-set (car entity) (nth 3 app-data)))
1052     (setq mark (or (elmo-msgdb-global-mark-get (car entity))
1053                    (if (elmo-cache-exists-p (car entity)) ;; XXX
1054                        (if (or (member "\\Seen" flags) seen)
1055                            nil
1056                          (nth 1 app-data))
1057                      (if (or (member "\\Seen" flags) seen)
1058                          (if elmo-imap4-use-cache
1059                              (nth 2 app-data))
1060                        (nth 0 app-data)))))
1061     (setq elmo-imap4-current-msgdb
1062           (elmo-msgdb-append
1063            elmo-imap4-current-msgdb
1064            (list (list entity)
1065                  (list (cons (elmo-msgdb-overview-entity-get-number entity)
1066                              (car entity)))
1067                  (if mark
1068                      (list
1069                       (list (elmo-msgdb-overview-entity-get-number entity)
1070                             mark))))))))
1071
1072 (defun elmo-imap4-msgdb-create (spec numlist &rest args)
1073   "Create msgdb for SPEC."
1074   (when numlist
1075     (let ((session (elmo-imap4-get-session spec))
1076           (headers
1077            (append
1078             '("Subject" "From" "To" "Cc" "Date"
1079               "Message-Id" "References" "In-Reply-To")
1080             elmo-msgdb-extra-fields))
1081           (total 0)
1082           (length (length numlist))
1083           rfc2060 set-list)
1084       (setq rfc2060 (memq 'imap4rev1
1085                           (elmo-imap4-session-capability-internal
1086                            session)))
1087       (message "Getting overview...")
1088       (elmo-imap4-session-select-mailbox session
1089                                          (elmo-imap4-spec-mailbox spec))
1090       (setq set-list (elmo-imap4-make-number-set-list
1091                       numlist
1092                       elmo-imap4-overview-fetch-chop-length))
1093       ;; Setup callback.
1094       (with-current-buffer (elmo-network-session-buffer session)
1095         (setq elmo-imap4-current-msgdb nil
1096               elmo-imap4-fetch-callback 'elmo-imap4-fetch-callback-1
1097               elmo-imap4-fetch-callback-data args)
1098         (while set-list
1099           (elmo-imap4-send-command-wait
1100            session
1101            ;; get overview entity from IMAP4
1102            (format "%sfetch %s (%s rfc822.size flags)"
1103                    (if elmo-imap4-use-uid "uid " "")
1104                    (cdr (car set-list))
1105                    (if rfc2060
1106                        (format "body.peek[header.fields %s]" headers)
1107                      (format "%s" headers))))
1108           (when (> length elmo-display-progress-threshold)
1109             (setq total (+ total (car (car set-list))))
1110             (elmo-display-progress
1111              'elmo-imap4-msgdb-create "Getting overview..."
1112              (/ (* total 100) length)))
1113           (setq set-list (cdr set-list)))
1114         (message "Getting overview...done")
1115         elmo-imap4-current-msgdb))))
1116
1117 (defun elmo-imap4-parse-capability (string)
1118   (if (string-match "^\\*\\(.*\\)$" string)
1119       (elmo-read
1120        (concat "(" (downcase (elmo-match-string 1 string)) ")"))))
1121
1122 (defun elmo-imap4-login (session)
1123   (let ((elmo-imap4-debug-inhibit-logging t))
1124     (or
1125      (elmo-imap4-read-ok
1126       session
1127       (elmo-imap4-send-command
1128        session
1129        (list "login "
1130              (elmo-imap4-userid (elmo-network-session-user-internal session))
1131              " "
1132              (elmo-imap4-password
1133               (elmo-get-passwd (elmo-network-session-password-key session))))))
1134      (signal 'elmo-authenticate-error '(login)))))
1135
1136 (luna-define-method
1137   elmo-network-initialize-session-buffer :after ((session
1138                                                   elmo-imap4-session) buffer)
1139   (with-current-buffer buffer
1140     (mapcar 'make-variable-buffer-local elmo-imap4-local-variables)
1141     (setq elmo-imap4-seqno 0)
1142     (setq elmo-imap4-status 'initial)))
1143
1144 (luna-define-method elmo-network-initialize-session ((session
1145                                                       elmo-imap4-session))
1146   (let ((process (elmo-network-session-process-internal session)))
1147     (with-current-buffer (process-buffer process)
1148       ;; Skip garbage output from process before greeting.
1149       (while (and (memq (process-status process) '(open run))
1150                   (goto-char (point-max))
1151                   (forward-line -1)
1152                   (not (elmo-imap4-parse-greeting)))
1153         (accept-process-output process 1))
1154       (set-process-filter process 'elmo-imap4-arrival-filter)
1155       (set-process-sentinel process 'elmo-imap4-sentinel)
1156 ;;;   (while (and (memq (process-status process) '(open run))
1157 ;;;               (eq elmo-imap4-status 'initial))
1158 ;;;     (message "Waiting for server response...")
1159 ;;;     (accept-process-output process 1))
1160 ;;;   (message "")
1161       (unless (memq elmo-imap4-status '(nonauth auth))
1162         (signal 'elmo-open-error
1163                 (list 'elmo-network-initialize-session)))
1164       (elmo-imap4-session-set-capability-internal
1165        session
1166        (elmo-imap4-response-value
1167         (elmo-imap4-send-command-wait session "capability")
1168         'capability))
1169       (when (eq (elmo-network-stream-type-symbol
1170                  (elmo-network-session-stream-type-internal session))
1171                 'starttls)
1172         (or (memq 'starttls
1173                   (elmo-imap4-session-capability-internal session))
1174             (signal 'elmo-open-error
1175                     '(elmo-imap4-starttls-error)))
1176         (elmo-imap4-send-command-wait session "starttls")
1177         (starttls-negotiate process)))))
1178
1179 (luna-define-method elmo-network-authenticate-session ((session
1180                                                         elmo-imap4-session))
1181   (with-current-buffer (process-buffer
1182                         (elmo-network-session-process-internal session))
1183     (let* ((auth (elmo-network-session-auth-internal session))
1184            (auth (if (listp auth) auth (list auth))))
1185       (unless (or (eq elmo-imap4-status 'auth)
1186                   (null auth))
1187         (if (eq 'plain (car auth))
1188             (elmo-imap4-login session)
1189           (let* ((elmo-imap4-debug-inhibit-logging t)
1190                  (sasl-mechanisms
1191                   (delq nil
1192                         (mapcar '(lambda (cap)
1193                                    (if (string-match "^auth=\\(.*\\)$"
1194                                                      (symbol-name cap))
1195                                        (match-string 1 (upcase (symbol-name cap)))))
1196                                 (elmo-imap4-session-capability-internal session))))
1197                  (mechanism
1198                   (sasl-find-mechanism
1199                    (delq nil
1200                          (mapcar '(lambda (cap) (upcase (symbol-name cap)))
1201                                  (if (listp auth)
1202                                      auth
1203                                    (list auth)))))) ;)
1204                  client name step response tag
1205                  sasl-read-passphrase)
1206             (unless mechanism
1207               (if (or elmo-imap4-force-login
1208                       (y-or-n-p
1209                        (format
1210                         "There's no %s capability in server. continue?"
1211                         (elmo-list-to-string
1212                          (elmo-network-session-auth-internal session)))))
1213                   (setq mechanism (sasl-find-mechanism
1214                                    sasl-mechanisms))
1215                 (signal 'elmo-authenticate-error '(elmo-imap4-auth-no-mechanisms))))
1216             (setq client
1217                   (sasl-make-client
1218                    mechanism
1219                    (elmo-network-session-user-internal session)
1220                    "imap"
1221                    (elmo-network-session-host-internal session)))
1222 ;;;         (if elmo-imap4-auth-user-realm
1223 ;;;             (sasl-client-set-property client 'realm elmo-imap4-auth-user-realm))
1224             (setq name (sasl-mechanism-name mechanism)
1225                   step (sasl-next-step client nil))
1226             (elmo-network-session-set-auth-internal session
1227                                                     (intern (downcase name)))
1228             (setq sasl-read-passphrase
1229                   (function
1230                    (lambda (prompt)
1231                      (elmo-get-passwd
1232                       (elmo-network-session-password-key session)))))
1233             (setq tag
1234                   (elmo-imap4-send-command
1235                    session
1236                    (concat "AUTHENTICATE " name
1237                            (and (sasl-step-data step)
1238                                 (concat
1239                                  " "
1240                                  (elmo-base64-encode-string
1241                                   (sasl-step-data step)
1242                                   'no-lin-break)))))) ;)
1243             (catch 'done
1244               (while t
1245                 (setq response
1246                       (elmo-imap4-read-untagged
1247                        (elmo-network-session-process-internal session)))
1248                 (if (elmo-imap4-response-continue-req-p response)
1249                     (unless (sasl-next-step client step)
1250                       ;; response is '+' but there's no next step.
1251                       (signal 'elmo-authenticate-error
1252                               (list (intern
1253                                      (concat "elmo-imap4-auth-"
1254                                              (downcase name))))))
1255                   ;; response is OK.
1256                   (if (elmo-imap4-response-ok-p response)
1257                       (throw 'done nil) ; finished.
1258                     ;; response is NO or BAD.
1259                     (signal 'elmo-authenticate-error
1260                             (list (intern
1261                                    (concat "elmo-imap4-auth-"
1262                                            (downcase name)))))))
1263                 (sasl-step-set-data
1264                  step
1265                  (elmo-base64-decode-string
1266                   (elmo-imap4-response-value response 'continue-req)))
1267                 (setq step (sasl-next-step client step))
1268                 (setq tag
1269                       (elmo-imap4-send-string
1270                        session
1271                        (if (sasl-step-data step)
1272                            (elmo-base64-encode-string (sasl-step-data step)
1273                                                       'no-line-break)
1274                          "")))))))))))
1275
1276 (luna-define-method elmo-network-setup-session ((session
1277                                                  elmo-imap4-session))
1278   (with-current-buffer (elmo-network-session-buffer session)
1279     (when (memq 'namespace (elmo-imap4-session-capability-internal session))
1280       (setq elmo-imap4-server-namespace
1281             (elmo-imap4-response-value
1282              (elmo-imap4-send-command-wait session "namespace")
1283              'namespace)))))
1284
1285 (defun elmo-imap4-setup-send-buffer (string)
1286   (let ((tmp-buf (get-buffer-create " *elmo-imap4-setup-send-buffer*")))
1287     (save-excursion
1288       (save-match-data
1289         (set-buffer tmp-buf)
1290         (erase-buffer)
1291         (elmo-set-buffer-multibyte nil)
1292         (insert string)
1293         (goto-char (point-min))
1294         (if (eq (re-search-forward "^$" nil t)
1295                 (point-max))
1296             (insert "\n"))
1297         (goto-char (point-min))
1298         (while (search-forward "\n" nil t)
1299           (replace-match "\r\n"))))
1300     tmp-buf))
1301
1302 (defun elmo-imap4-read-part (folder msg part)
1303   (let* ((spec (elmo-folder-get-spec folder))
1304          (session (elmo-imap4-get-session spec)))
1305     (elmo-imap4-session-select-mailbox session
1306                                        (elmo-imap4-spec-mailbox spec))
1307     (with-current-buffer (elmo-network-session-buffer session)
1308       (setq elmo-imap4-fetch-callback nil)
1309       (setq elmo-imap4-fetch-callback-data nil))
1310     (elmo-delete-cr
1311      (elmo-imap4-response-bodydetail-text
1312       (elmo-imap4-response-value-all
1313        (elmo-imap4-send-command-wait session
1314                                      (format
1315                                       (if elmo-imap4-use-uid
1316                                           "uid fetch %s body.peek[%s]"
1317                                         "fetch %s body.peek[%s]")
1318                                       msg part))
1319        'fetch)))))
1320
1321 (defun elmo-imap4-prefetch-msg (spec msg outbuf)
1322   (elmo-imap4-read-msg spec msg outbuf 'unseen))
1323
1324 (defun elmo-imap4-read-msg (spec msg outbuf
1325                                  &optional leave-seen-flag-untouched)
1326   (let ((session (elmo-imap4-get-session spec))
1327         response)
1328     (elmo-imap4-session-select-mailbox session
1329                                        (elmo-imap4-spec-mailbox spec))
1330     (with-current-buffer (elmo-network-session-buffer session)
1331       (setq elmo-imap4-fetch-callback nil)
1332       (setq elmo-imap4-fetch-callback-data nil))
1333     (setq response
1334           (elmo-imap4-send-command-wait session
1335                                         (format
1336                                          (if elmo-imap4-use-uid
1337                                              "uid fetch %s rfc822%s"
1338                                            "fetch %s rfc822%s")
1339                                          msg
1340                                          (if leave-seen-flag-untouched
1341                                              ".peek" ""))))
1342     (and (setq response (elmo-imap4-response-value
1343                          (elmo-imap4-response-value-all
1344                           response 'fetch )
1345                          'rfc822))
1346          (with-current-buffer outbuf
1347            (erase-buffer)
1348            (insert response)
1349            (elmo-delete-cr-get-content-type)))))
1350
1351 (defun elmo-imap4-setup-send-buffer-from-file (file)
1352   (let ((tmp-buf (get-buffer-create
1353                   " *elmo-imap4-setup-send-buffer-from-file*")))
1354     (save-excursion
1355       (save-match-data
1356         (set-buffer tmp-buf)
1357         (erase-buffer)
1358         (as-binary-input-file
1359          (insert-file-contents file))
1360         (goto-char (point-min))
1361         (if (eq (re-search-forward "^$" nil t)
1362                 (point-max))
1363             (insert "\n"))
1364         (goto-char (point-min))
1365         (while (search-forward "\n" nil t)
1366           (replace-match "\r\n"))))
1367     tmp-buf))
1368
1369 (defun elmo-imap4-delete-msgids (spec msgids)
1370   "If actual message-id is matched, then delete it."
1371   (let ((message-ids msgids)
1372         (i 0)
1373         (num (length msgids)))
1374     (while message-ids
1375       (setq i (+ 1 i))
1376       (message "Deleting message...%d/%d" i num)
1377       (elmo-imap4-delete-msg-by-id spec (car message-ids))
1378       (setq message-ids (cdr message-ids)))
1379     (elmo-imap4-send-command-wait (elmo-imap4-get-session spec) "expunge")))
1380
1381 (defun elmo-imap4-delete-msg-by-id (spec msgid)
1382   (let ((session (elmo-imap4-get-session spec)))
1383     (elmo-imap4-session-select-mailbox session
1384                                        (elmo-imap4-spec-mailbox spec))
1385     (elmo-imap4-delete-msgs-no-expunge
1386      spec
1387      (elmo-imap4-response-value
1388       (elmo-imap4-send-command-wait session
1389                                     (list
1390                                      (if elmo-imap4-use-uid
1391                                          "uid search header message-id "
1392                                        "search header message-id ")
1393                                      (elmo-imap4-field-body msgid)))
1394       'search))))
1395
1396 (defun elmo-imap4-append-msg-by-id (spec msgid)
1397   (let ((session (elmo-imap4-get-session spec))
1398         send-buf)
1399     (elmo-imap4-session-select-mailbox session
1400                                        (elmo-imap4-spec-mailbox spec))
1401     (setq send-buf (elmo-imap4-setup-send-buffer-from-file
1402                     (elmo-cache-get-path msgid)))
1403     (unwind-protect
1404         (elmo-imap4-send-command-wait
1405          session
1406          (list
1407           "append "
1408           (elmo-imap4-mailbox (elmo-imap4-spec-mailbox spec))
1409           " (\\Seen) "
1410           (elmo-imap4-buffer-literal send-buf)))
1411       (kill-buffer send-buf)))
1412   t)
1413
1414 (defun elmo-imap4-append-msg (spec string &optional msg no-see)
1415   (let ((session (elmo-imap4-get-session spec))
1416         send-buf)
1417     (elmo-imap4-session-select-mailbox session
1418                                        (elmo-imap4-spec-mailbox spec))
1419     (setq send-buf (elmo-imap4-setup-send-buffer string))
1420     (unwind-protect
1421         (elmo-imap4-send-command-wait
1422          session
1423          (list
1424           "append "
1425           (elmo-imap4-mailbox (elmo-imap4-spec-mailbox spec))
1426           (if no-see " " " (\\Seen) ")
1427           (elmo-imap4-buffer-literal send-buf)))
1428       (kill-buffer send-buf)))
1429   t)
1430
1431 (defun elmo-imap4-copy-msgs (dst-spec
1432                              msgs src-spec &optional expunge-it same-number)
1433   "Equivalence of hostname, username is assumed."
1434   (let ((session (elmo-imap4-get-session src-spec)))
1435     (elmo-imap4-session-select-mailbox session
1436                                        (elmo-imap4-spec-mailbox src-spec))
1437     (while msgs
1438       (elmo-imap4-send-command-wait session
1439                                     (list
1440                                      (format
1441                                       (if elmo-imap4-use-uid
1442                                           "uid copy %s "
1443                                         "copy %s ")
1444                                       (car msgs))
1445                                      (elmo-imap4-mailbox
1446                                       (elmo-imap4-spec-mailbox dst-spec))))
1447       (setq msgs (cdr msgs)))
1448     (when expunge-it
1449       (elmo-imap4-send-command-wait session "expunge"))
1450     t))
1451
1452 (defun elmo-imap4-server-diff-async-callback-1 (status data)
1453   (funcall elmo-imap4-server-diff-async-callback
1454            (cons (elmo-imap4-response-value status 'unseen)
1455                  (elmo-imap4-response-value status 'messages))
1456            data))
1457
1458 (defun elmo-imap4-server-diff-async (spec)
1459   (let ((session (elmo-imap4-get-session spec)))
1460     ;; commit.
1461     ;; (elmo-imap4-commit spec)
1462     (with-current-buffer (elmo-network-session-buffer session)
1463       (setq elmo-imap4-status-callback
1464             'elmo-imap4-server-diff-async-callback-1)
1465       (setq elmo-imap4-status-callback-data
1466             elmo-imap4-server-diff-async-callback-data))
1467     (elmo-imap4-send-command session
1468                              (list
1469                               "status "
1470                               (elmo-imap4-mailbox
1471                                (elmo-imap4-spec-mailbox spec))
1472                               " (unseen messages)"))))
1473
1474 (defun elmo-imap4-server-diff (spec)
1475   "Get server status"
1476   (let ((session (elmo-imap4-get-session spec))
1477         response)
1478     ;; commit.
1479 ;;; (elmo-imap4-commit spec)
1480     (with-current-buffer (elmo-network-session-buffer session)
1481       (setq elmo-imap4-status-callback nil)
1482       (setq elmo-imap4-status-callback-data nil))
1483     (setq response
1484           (elmo-imap4-send-command-wait session
1485                                         (list
1486                                          "status "
1487                                          (elmo-imap4-mailbox
1488                                           (elmo-imap4-spec-mailbox spec))
1489                                          " (unseen messages)")))
1490     (setq response (elmo-imap4-response-value response 'status))
1491     (cons (elmo-imap4-response-value response 'unseen)
1492           (elmo-imap4-response-value response 'messages))))
1493
1494 (defun elmo-imap4-use-cache-p (spec number)
1495   elmo-imap4-use-cache)
1496
1497 (defun elmo-imap4-local-file-p (spec number)
1498   nil)
1499
1500 (defun elmo-imap4-port-label (spec)
1501   (concat "imap4"
1502           (if (elmo-imap4-spec-stream-type spec)
1503               (concat "!" (symbol-name
1504                            (elmo-network-stream-type-symbol
1505                             (elmo-imap4-spec-stream-type spec)))))))
1506
1507
1508 (defsubst elmo-imap4-portinfo (spec)
1509   (list (elmo-imap4-spec-hostname spec) (elmo-imap4-spec-port spec)))
1510
1511 (defun elmo-imap4-plugged-p (spec)
1512   (apply 'elmo-plugged-p
1513          (append (elmo-imap4-portinfo spec)
1514                  (list nil (quote (elmo-imap4-port-label spec))))))
1515
1516 (defun elmo-imap4-set-plugged (spec plugged add)
1517   (apply 'elmo-set-plugged plugged
1518          (append (elmo-imap4-portinfo spec)
1519                  (list nil nil (quote (elmo-imap4-port-label spec)) add))))
1520
1521 (defalias 'elmo-imap4-sync-number-alist 'elmo-generic-sync-number-alist)
1522
1523 ;;; IMAP parser.
1524
1525 (defvar elmo-imap4-server-eol "\r\n"
1526   "The EOL string sent from the server.")
1527
1528 (defvar elmo-imap4-client-eol "\r\n"
1529   "The EOL string we send to the server.")
1530
1531 (defun elmo-imap4-find-next-line ()
1532   "Return point at end of current line, taking into account literals.
1533 Return nil if no complete line has arrived."
1534   (when (re-search-forward (concat elmo-imap4-server-eol "\\|{\\([0-9]+\\)}"
1535                                    elmo-imap4-server-eol)
1536                            nil t)
1537     (if (match-string 1)
1538         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1539             nil
1540           (goto-char (+ (point) (string-to-number (match-string 1))))
1541           (elmo-imap4-find-next-line))
1542       (point))))
1543
1544 (defun elmo-imap4-sentinel (process string)
1545   (delete-process process))
1546
1547 (defun elmo-imap4-arrival-filter (proc string)
1548   "IMAP process filter."
1549   (with-current-buffer (process-buffer proc)
1550     (elmo-imap4-debug "-> %s" string)
1551     (goto-char (point-max))
1552     (insert string)
1553     (let (end)
1554       (goto-char (point-min))
1555       (while (setq end (elmo-imap4-find-next-line))
1556         (save-restriction
1557           (narrow-to-region (point-min) end)
1558           (delete-backward-char (length elmo-imap4-server-eol))
1559           (goto-char (point-min))
1560           (unwind-protect
1561               (cond ((eq elmo-imap4-status 'initial)
1562                      (setq elmo-imap4-current-response
1563                            (list
1564                             (list 'greeting (elmo-imap4-parse-greeting)))))
1565                     ((or (eq elmo-imap4-status 'auth)
1566                          (eq elmo-imap4-status 'nonauth)
1567                          (eq elmo-imap4-status 'selected)
1568                          (eq elmo-imap4-status 'examine))
1569                      (setq elmo-imap4-current-response
1570                            (cons
1571                             (elmo-imap4-parse-response)
1572                             elmo-imap4-current-response)))
1573                     (t
1574                      (message "Unknown state %s in arrival filter"
1575                               elmo-imap4-status))))
1576           (delete-region (point-min) (point-max)))))))
1577
1578 ;; IMAP parser.
1579
1580 (defsubst elmo-imap4-forward ()
1581   (or (eobp) (forward-char 1)))
1582
1583 (defsubst elmo-imap4-parse-number ()
1584   (when (looking-at "[0-9]+")
1585     (prog1
1586         (string-to-number (match-string 0))
1587       (goto-char (match-end 0)))))
1588
1589 (defsubst elmo-imap4-parse-literal ()
1590   (when (looking-at "{\\([0-9]+\\)}\r\n")
1591     (let ((pos (match-end 0))
1592           (len (string-to-number (match-string 1))))
1593       (if (< (point-max) (+ pos len))
1594           nil
1595         (goto-char (+ pos len))
1596         (buffer-substring pos (+ pos len))))))
1597 ;;;     (list ' pos (+ pos len))))))
1598
1599 (defsubst elmo-imap4-parse-string ()
1600   (cond ((eq (char-after (point)) ?\")
1601          (forward-char 1)
1602          (let ((p (point)) (name ""))
1603            (skip-chars-forward "^\"\\\\")
1604            (setq name (buffer-substring p (point)))
1605            (while (eq (char-after (point)) ?\\)
1606              (setq p (1+ (point)))
1607              (forward-char 2)
1608              (skip-chars-forward "^\"\\\\")
1609              (setq name (concat name (buffer-substring p (point)))))
1610            (forward-char 1)
1611            name))
1612         ((eq (char-after (point)) ?{)
1613          (elmo-imap4-parse-literal))))
1614
1615 (defsubst elmo-imap4-parse-nil ()
1616   (if (looking-at "NIL")
1617       (goto-char (match-end 0))))
1618
1619 (defsubst elmo-imap4-parse-nstring ()
1620   (or (elmo-imap4-parse-string)
1621       (and (elmo-imap4-parse-nil)
1622            nil)))
1623
1624 (defsubst elmo-imap4-parse-astring ()
1625   (or (elmo-imap4-parse-string)
1626       (buffer-substring (point)
1627                         (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
1628                             (goto-char (1- (match-end 0)))
1629                           (end-of-line)
1630                           (point)))))
1631
1632 (defsubst elmo-imap4-parse-address ()
1633   (let (address)
1634     (when (eq (char-after (point)) ?\()
1635       (elmo-imap4-forward)
1636       (setq address (vector (prog1 (elmo-imap4-parse-nstring)
1637                               (elmo-imap4-forward))
1638                             (prog1 (elmo-imap4-parse-nstring)
1639                               (elmo-imap4-forward))
1640                             (prog1 (elmo-imap4-parse-nstring)
1641                               (elmo-imap4-forward))
1642                             (elmo-imap4-parse-nstring)))
1643       (when (eq (char-after (point)) ?\))
1644         (elmo-imap4-forward)
1645         address))))
1646
1647 (defsubst elmo-imap4-parse-address-list ()
1648   (if (eq (char-after (point)) ?\()
1649       (let (address addresses)
1650         (elmo-imap4-forward)
1651         (while (and (not (eq (char-after (point)) ?\)))
1652                     ;; next line for MS Exchange bug
1653                     (progn (and (eq (char-after (point)) ? ) (elmo-imap4-forward)) t)
1654                     (setq address (elmo-imap4-parse-address)))
1655           (setq addresses (cons address addresses)))
1656         (when (eq (char-after (point)) ?\))
1657           (elmo-imap4-forward)
1658           (nreverse addresses)))
1659     (assert (elmo-imap4-parse-nil))))
1660
1661 (defsubst elmo-imap4-parse-mailbox ()
1662   (let ((mailbox (elmo-imap4-parse-astring)))
1663     (if (string-equal "INBOX" (upcase mailbox))
1664         "INBOX"
1665       mailbox)))
1666
1667 (defun elmo-imap4-parse-greeting ()
1668   "Parse a IMAP greeting."
1669   (cond ((looking-at "\\* OK ")
1670          (setq elmo-imap4-status 'nonauth))
1671         ((looking-at "\\* PREAUTH ")
1672          (setq elmo-imap4-status 'auth))
1673         ((looking-at "\\* BYE ")
1674          (setq elmo-imap4-status 'closed))))
1675
1676 (defun elmo-imap4-parse-response ()
1677   "Parse a IMAP command response."
1678   (let (token)
1679     (case (setq token (elmo-read (current-buffer)))
1680       (+ (progn
1681            (skip-chars-forward " ")
1682            (list 'continue-req (buffer-substring (point) (point-max)))))
1683       (* (case (prog1 (setq token (elmo-read (current-buffer)))
1684                  (elmo-imap4-forward))
1685            (OK         (elmo-imap4-parse-resp-text-code))
1686            (NO         (elmo-imap4-parse-resp-text-code))
1687            (BAD        (elmo-imap4-parse-resp-text-code))
1688            (BYE        (elmo-imap4-parse-bye))
1689            (FLAGS      (list 'flags
1690                              (elmo-imap4-parse-flag-list)))
1691            (LIST       (list 'list (elmo-imap4-parse-data-list)))
1692            (LSUB       (list 'lsub (elmo-imap4-parse-data-list)))
1693            (SEARCH     (list
1694                         'search
1695                         (elmo-read (concat "("
1696                                       (buffer-substring (point) (point-max))
1697                                       ")"))))
1698            (STATUS     (elmo-imap4-parse-status))
1699            ;; Added
1700            (NAMESPACE  (elmo-imap4-parse-namespace))
1701            (CAPABILITY (list 'capability
1702                              (elmo-read
1703                               (concat "(" (downcase (buffer-substring
1704                                                      (point) (point-max)))
1705                                       ")"))))
1706            (ACL        (elmo-imap4-parse-acl))
1707            (t       (case (prog1 (elmo-read (current-buffer))
1708                             (elmo-imap4-forward))
1709                       (EXISTS  (list 'exists token))
1710                       (RECENT  (list 'recent token))
1711                       (EXPUNGE (list 'expunge token))
1712                       (FETCH   (elmo-imap4-parse-fetch token))
1713                       (t       (list 'garbage (buffer-string)))))))
1714       (t (if (not (string-match elmo-imap4-seq-prefix (symbol-name token)))
1715              (list 'garbage (buffer-string))
1716            (case (prog1 (elmo-read (current-buffer))
1717                    (elmo-imap4-forward))
1718              (OK  (progn
1719                     (setq elmo-imap4-parsing nil)
1720                     (setq token (symbol-name token))
1721                     (elmo-unintern token)
1722                     (elmo-imap4-debug "*%s* OK arrived" token)
1723                     (setq elmo-imap4-reached-tag token)
1724                     (list 'ok (elmo-imap4-parse-resp-text-code))))
1725              (NO  (progn
1726                     (setq elmo-imap4-parsing nil)
1727                     (setq token (symbol-name token))
1728                     (elmo-unintern token)
1729                     (elmo-imap4-debug "*%s* NO arrived" token)
1730                     (setq elmo-imap4-reached-tag token)
1731                     (let (code text)
1732                       (when (eq (char-after (point)) ?\[)
1733                         (setq code (buffer-substring (point)
1734                                                      (search-forward "]")))
1735                         (elmo-imap4-forward))
1736                       (setq text (buffer-substring (point) (point-max)))
1737                       (list 'no (list code text)))))
1738              (BAD (progn
1739                     (setq elmo-imap4-parsing nil)
1740                     (elmo-imap4-debug "*%s* BAD arrived" token)
1741                     (setq token (symbol-name token))
1742                     (elmo-unintern token)
1743                     (setq elmo-imap4-reached-tag token)
1744                     (let (code text)
1745                       (when (eq (char-after (point)) ?\[)
1746                         (setq code (buffer-substring (point)
1747                                                      (search-forward "]")))
1748                         (elmo-imap4-forward))
1749                       (setq text (buffer-substring (point) (point-max)))
1750                       (list 'bad (list code text)))))
1751              (t   (list 'garbage (buffer-string)))))))))
1752
1753 (defun elmo-imap4-parse-bye ()
1754   (let (code text)
1755     (when (eq (char-after (point)) ?\[)
1756       (setq code (buffer-substring (point)
1757                                    (search-forward "]")))
1758       (elmo-imap4-forward))
1759     (setq text (buffer-substring (point) (point-max)))
1760     (list 'bye (list code text))))
1761
1762 (defun elmo-imap4-parse-text ()
1763   (goto-char (point-min))
1764   (when (search-forward "[" nil t)
1765     (search-forward "]")
1766     (elmo-imap4-forward))
1767   (list 'text (buffer-substring (point) (point-max))))
1768
1769 (defun elmo-imap4-parse-resp-text-code ()
1770   (when (eq (char-after (point)) ?\[)
1771     (elmo-imap4-forward)
1772     (cond ((search-forward "PERMANENTFLAGS " nil t)
1773            (list 'permanentflags (elmo-imap4-parse-flag-list)))
1774           ((search-forward "UIDNEXT " nil t)
1775            (list 'uidnext (elmo-read (current-buffer))))
1776           ((search-forward "UNSEEN " nil t)
1777            (list 'unseen (elmo-read (current-buffer))))
1778           ((looking-at "UIDVALIDITY \\([0-9]+\\)")
1779            (list 'uidvalidity (match-string 1)))
1780           ((search-forward "READ-ONLY" nil t)
1781            (list 'read-only t))
1782           ((search-forward "READ-WRITE" nil t)
1783            (list 'read-write t))
1784           ((search-forward "NEWNAME " nil t)
1785            (let (oldname newname)
1786              (setq oldname (elmo-imap4-parse-string))
1787              (elmo-imap4-forward)
1788              (setq newname (elmo-imap4-parse-string))
1789              (list 'newname newname oldname)))
1790           ((search-forward "TRYCREATE" nil t)
1791            (list 'trycreate t))
1792           ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
1793            (list 'appenduid
1794                  (list (match-string 1)
1795                        (string-to-number (match-string 2)))))
1796           ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
1797            (list 'copyuid (list (match-string 1)
1798                                 (match-string 2)
1799                                 (match-string 3))))
1800           ((search-forward "ALERT] " nil t)
1801            (message "IMAP server information: %s"
1802                     (buffer-substring (point) (point-max))))
1803           (t (list 'unknown)))))
1804
1805 (defun elmo-imap4-parse-data-list ()
1806   (let (flags delimiter mailbox)
1807     (setq flags (elmo-imap4-parse-flag-list))
1808     (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
1809       (setq delimiter (match-string 1))
1810       (goto-char (1+ (match-end 0)))
1811       (when (setq mailbox (elmo-imap4-parse-mailbox))
1812         (list mailbox flags delimiter)))))
1813
1814 (defsubst elmo-imap4-parse-header-list ()
1815   (when (eq (char-after (point)) ?\()
1816     (let (strlist)
1817       (while (not (eq (char-after (point)) ?\)))
1818         (elmo-imap4-forward)
1819         (push (elmo-imap4-parse-astring) strlist))
1820       (elmo-imap4-forward)
1821       (nreverse strlist))))
1822
1823 (defsubst elmo-imap4-parse-fetch-body-section ()
1824   (let ((section
1825          (buffer-substring (point)
1826                            (1-
1827                             (progn (re-search-forward "[] ]" nil t)
1828                                    (point))))))
1829     (if (eq (char-before) ? )
1830         (prog1
1831             (mapconcat 'identity
1832                        (cons section (elmo-imap4-parse-header-list)) " ")
1833           (search-forward "]" nil t))
1834       section)))
1835
1836 (defun elmo-imap4-parse-fetch (response)
1837   (when (eq (char-after (point)) ?\()
1838     (let (element list)
1839       (while (not (eq (char-after (point)) ?\)))
1840         (elmo-imap4-forward)
1841         (let ((token (elmo-imap4-fetch-read (current-buffer))))
1842           (elmo-imap4-forward)
1843           (setq element
1844                 (cond ((eq token 'UID)
1845                        (list 'uid (condition-case nil
1846                                       (elmo-read (current-buffer))
1847                                     (error nil))))
1848                       ((eq token 'FLAGS)
1849                        (list 'flags (elmo-imap4-parse-flag-list)))
1850                       ((eq token 'ENVELOPE)
1851                        (list 'envelope (elmo-imap4-parse-envelope)))
1852                       ((eq token 'INTERNALDATE)
1853                        (list 'internaldate (elmo-imap4-parse-string)))
1854                       ((eq token 'RFC822)
1855                        (list 'rfc822 (elmo-imap4-parse-nstring)))
1856                       ((eq token (intern elmo-imap4-rfc822-header))
1857                        (list 'rfc822header (elmo-imap4-parse-nstring)))
1858                       ((eq token (intern elmo-imap4-rfc822-text))
1859                        (list 'rfc822text (elmo-imap4-parse-nstring)))
1860                       ((eq token (intern elmo-imap4-rfc822-size))
1861                        (list 'rfc822size (elmo-read (current-buffer))))
1862                       ((eq token 'BODY)
1863                        (if (eq (char-before) ?\[)
1864                            (list
1865                             'bodydetail
1866                             (upcase (elmo-imap4-parse-fetch-body-section))
1867                             (and
1868                              (eq (char-after (point)) ?<)
1869                              (buffer-substring (1+ (point))
1870                                                (progn
1871                                                  (search-forward ">" nil t)
1872                                                  (point))))
1873                             (progn (elmo-imap4-forward)
1874                                    (elmo-imap4-parse-nstring)))
1875                          (list 'body (elmo-imap4-parse-body))))
1876                       ((eq token 'BODYSTRUCTURE)
1877                        (list 'bodystructure (elmo-imap4-parse-body)))))
1878           (setq list (cons element list))))
1879       (and elmo-imap4-fetch-callback
1880            (elmo-imap4-fetch-callback list elmo-imap4-fetch-callback-data))
1881       (list 'fetch list))))
1882
1883 (defun elmo-imap4-parse-status ()
1884   (let ((mailbox (elmo-imap4-parse-mailbox))
1885         status)
1886     (when (and mailbox (search-forward "(" nil t))
1887       (while (not (eq (char-after (point)) ?\)))
1888         (setq status
1889               (cons
1890                (let ((token (elmo-read (current-buffer))))
1891                  (cond ((eq token 'MESSAGES)
1892                         (list 'messages (elmo-read (current-buffer))))
1893                        ((eq token 'RECENT)
1894                         (list 'recent (elmo-read (current-buffer))))
1895                        ((eq token 'UIDNEXT)
1896                         (list 'uidnext (elmo-read (current-buffer))))
1897                        ((eq token 'UIDVALIDITY)
1898                         (and (looking-at " \\([0-9]+\\)")
1899                              (prog1 (list 'uidvalidity (match-string 1))
1900                                (goto-char (match-end 1)))))
1901                        ((eq token 'UNSEEN)
1902                         (list 'unseen (elmo-read (current-buffer))))
1903                        (t
1904                         (message
1905                          "Unknown status data %s in mailbox %s ignored"
1906                          token mailbox))))
1907                status))))
1908     (and elmo-imap4-status-callback
1909          (funcall elmo-imap4-status-callback
1910                   status
1911                   elmo-imap4-status-callback-data))
1912     (list 'status status)))
1913
1914
1915 (defmacro elmo-imap4-value (value)
1916   (` (if (eq (, value) 'NIL) nil
1917        (, value))))
1918
1919 (defmacro elmo-imap4-nth (pos list)
1920   (` (let ((value (nth (, pos) (, list))))
1921        (elmo-imap4-value value))))
1922
1923 (defun elmo-imap4-parse-namespace ()
1924   (list 'namespace
1925         (nconc
1926          (copy-sequence elmo-imap4-extra-namespace-alist)
1927          (elmo-imap4-parse-namespace-subr
1928           (elmo-read (concat "(" (buffer-substring
1929                                   (point) (point-max))
1930                              ")"))))))
1931
1932 (defun elmo-imap4-parse-namespace-subr (ns)
1933   (let (prefix delim namespace-alist default-delim)
1934     ;; 0: personal, 1: other, 2: shared
1935     (dotimes (i 3)
1936       (setq namespace-alist
1937             (nconc namespace-alist
1938                    (delq nil
1939                          (mapcar
1940                           (lambda (namespace)
1941                             (setq prefix (elmo-imap4-nth 0 namespace)
1942                                   delim (elmo-imap4-nth 1 namespace))
1943                             (if (and prefix delim
1944                                      (string-match
1945                                       (concat (regexp-quote delim) "\\'")
1946                                       prefix))
1947                                 (setq prefix (substring prefix 0
1948                                                         (match-beginning 0))))
1949                             (if (eq (length prefix) 0)
1950                                 (progn (setq default-delim delim) nil)
1951                               (cons
1952                                (concat "^"
1953                                        (if (string= (downcase prefix) "inbox")
1954                                            "[Ii][Nn][Bb][Oo][Xx]"
1955                                          (regexp-quote prefix))
1956                                        ".*$")
1957                                delim)))
1958                           (elmo-imap4-nth i ns))))))
1959     (if default-delim
1960         (setq namespace-alist
1961               (nconc namespace-alist
1962                      (list (cons "^.*$" default-delim)))))
1963     namespace-alist))
1964
1965 (defun elmo-imap4-parse-acl ()
1966   (let ((mailbox (elmo-imap4-parse-mailbox))
1967         identifier rights acl)
1968     (while (eq (char-after (point)) ?\ )
1969       (elmo-imap4-forward)
1970       (setq identifier (elmo-imap4-parse-astring))
1971       (elmo-imap4-forward)
1972       (setq rights (elmo-imap4-parse-astring))
1973       (setq acl (append acl (list (cons identifier rights)))))
1974     (list 'acl acl mailbox)))
1975
1976 (defun elmo-imap4-parse-flag-list ()
1977   (let ((str (buffer-substring (+ (point) 1)
1978                                (progn (search-forward ")" nil t)
1979                                       (- (point) 1)))))
1980     (unless (eq (length str) 0)
1981       (split-string str))))
1982
1983 (defun elmo-imap4-parse-envelope ()
1984   (when (eq (char-after (point)) ?\()
1985     (elmo-imap4-forward)
1986     (vector (prog1 (elmo-imap4-parse-nstring);; date
1987               (elmo-imap4-forward))
1988             (prog1 (elmo-imap4-parse-nstring);; subject
1989               (elmo-imap4-forward))
1990             (prog1 (elmo-imap4-parse-address-list);; from
1991               (elmo-imap4-forward))
1992             (prog1 (elmo-imap4-parse-address-list);; sender
1993               (elmo-imap4-forward))
1994             (prog1 (elmo-imap4-parse-address-list);; reply-to
1995               (elmo-imap4-forward))
1996             (prog1 (elmo-imap4-parse-address-list);; to
1997               (elmo-imap4-forward))
1998             (prog1 (elmo-imap4-parse-address-list);; cc
1999               (elmo-imap4-forward))
2000             (prog1 (elmo-imap4-parse-address-list);; bcc
2001               (elmo-imap4-forward))
2002             (prog1 (elmo-imap4-parse-nstring);; in-reply-to
2003               (elmo-imap4-forward))
2004             (prog1 (elmo-imap4-parse-nstring);; message-id
2005               (elmo-imap4-forward)))))
2006
2007 (defsubst elmo-imap4-parse-string-list ()
2008   (cond ((eq (char-after (point)) ?\();; body-fld-param
2009          (let (strlist str)
2010            (elmo-imap4-forward)
2011            (while (setq str (elmo-imap4-parse-string))
2012              (push str strlist)
2013              (elmo-imap4-forward))
2014            (nreverse strlist)))
2015         ((elmo-imap4-parse-nil)
2016          nil)))
2017
2018 (defun elmo-imap4-parse-body-extension ()
2019   (if (eq (char-after (point)) ?\()
2020       (let (b-e)
2021         (elmo-imap4-forward)
2022         (push (elmo-imap4-parse-body-extension) b-e)
2023         (while (eq (char-after (point)) ?\ )
2024           (elmo-imap4-forward)
2025           (push (elmo-imap4-parse-body-extension) b-e))
2026         (assert (eq (char-after (point)) ?\)))
2027         (elmo-imap4-forward)
2028         (nreverse b-e))
2029     (or (elmo-imap4-parse-number)
2030         (elmo-imap4-parse-nstring))))
2031
2032 (defsubst elmo-imap4-parse-body-ext ()
2033   (let (ext)
2034     (when (eq (char-after (point)) ?\ );; body-fld-dsp
2035       (elmo-imap4-forward)
2036       (let (dsp)
2037         (if (eq (char-after (point)) ?\()
2038             (progn
2039               (elmo-imap4-forward)
2040               (push (elmo-imap4-parse-string) dsp)
2041               (elmo-imap4-forward)
2042               (push (elmo-imap4-parse-string-list) dsp)
2043               (elmo-imap4-forward))
2044           (assert (elmo-imap4-parse-nil)))
2045         (push (nreverse dsp) ext))
2046       (when (eq (char-after (point)) ?\ );; body-fld-lang
2047         (elmo-imap4-forward)
2048         (if (eq (char-after (point)) ?\()
2049             (push (elmo-imap4-parse-string-list) ext)
2050           (push (elmo-imap4-parse-nstring) ext))
2051         (while (eq (char-after (point)) ?\ );; body-extension
2052           (elmo-imap4-forward)
2053           (setq ext (append (elmo-imap4-parse-body-extension) ext)))))
2054     ext))
2055
2056 (defun elmo-imap4-parse-body ()
2057   (let (body)
2058     (when (eq (char-after (point)) ?\()
2059       (elmo-imap4-forward)
2060       (if (eq (char-after (point)) ?\()
2061           (let (subbody)
2062             (while (and (eq (char-after (point)) ?\()
2063                         (setq subbody (elmo-imap4-parse-body)))
2064               (push subbody body))
2065             (elmo-imap4-forward)
2066             (push (elmo-imap4-parse-string) body);; media-subtype
2067             (when (eq (char-after (point)) ?\ );; body-ext-mpart:
2068               (elmo-imap4-forward)
2069               (if (eq (char-after (point)) ?\();; body-fld-param
2070                   (push (elmo-imap4-parse-string-list) body)
2071                 (push (and (elmo-imap4-parse-nil) nil) body))
2072               (setq body
2073                     (append (elmo-imap4-parse-body-ext) body)));; body-ext-...
2074             (assert (eq (char-after (point)) ?\)))
2075             (elmo-imap4-forward)
2076             (nreverse body))
2077
2078         (push (elmo-imap4-parse-string) body);; media-type
2079         (elmo-imap4-forward)
2080         (push (elmo-imap4-parse-string) body);; media-subtype
2081         (elmo-imap4-forward)
2082         ;; next line for Sun SIMS bug
2083         (and (eq (char-after (point)) ? ) (elmo-imap4-forward))
2084         (if (eq (char-after (point)) ?\();; body-fld-param
2085             (push (elmo-imap4-parse-string-list) body)
2086           (push (and (elmo-imap4-parse-nil) nil) body))
2087         (elmo-imap4-forward)
2088         (push (elmo-imap4-parse-nstring) body);; body-fld-id
2089         (elmo-imap4-forward)
2090         (push (elmo-imap4-parse-nstring) body);; body-fld-desc
2091         (elmo-imap4-forward)
2092         (push (elmo-imap4-parse-string) body);; body-fld-enc
2093         (elmo-imap4-forward)
2094         (push (elmo-imap4-parse-number) body);; body-fld-octets
2095
2096         ;; ok, we're done parsing the required parts, what comes now is one
2097         ;; of three things:
2098         ;;
2099         ;; envelope       (then we're parsing body-type-msg)
2100         ;; body-fld-lines (then we're parsing body-type-text)
2101         ;; body-ext-1part (then we're parsing body-type-basic)
2102         ;;
2103         ;; the problem is that the two first are in turn optionally followed
2104         ;; by the third.  So we parse the first two here (if there are any)...
2105
2106         (when (eq (char-after (point)) ?\ )
2107           (elmo-imap4-forward)
2108           (let (lines)
2109             (cond ((eq (char-after (point)) ?\();; body-type-msg:
2110                    (push (elmo-imap4-parse-envelope) body);; envelope
2111                    (elmo-imap4-forward)
2112                    (push (elmo-imap4-parse-body) body);; body
2113                    (elmo-imap4-forward)
2114                    (push (elmo-imap4-parse-number) body));; body-fld-lines
2115                   ((setq lines (elmo-imap4-parse-number));; body-type-text:
2116                    (push lines body));; body-fld-lines
2117                   (t
2118                    (backward-char)))));; no match...
2119
2120         ;; ...and then parse the third one here...
2121
2122         (when (eq (char-after (point)) ?\ );; body-ext-1part:
2123           (elmo-imap4-forward)
2124           (push (elmo-imap4-parse-nstring) body);; body-fld-md5
2125           (setq body
2126                 (append (elmo-imap4-parse-body-ext) body)));; body-ext-1part..
2127
2128         (assert (eq (char-after (point)) ?\)))
2129         (elmo-imap4-forward)
2130         (nreverse body)))))
2131
2132 (require 'product)
2133 (product-provide (provide 'elmo-imap4) (require 'elmo-version))
2134
2135 ;;; elmo-imap4.el ends here