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-date)
  44 (require 'elmo-msgdb)
  45 (require 'elmo-cache)
  46 (require 'elmo)
  47 (require 'elmo-net)
  48 (require 'utf7)
  49 (require 'elmo-mime)
  50
  51 ;;; Code:
  52 (eval-when-compile (require 'cl))
  53
  54 (defvar elmo-imap4-disuse-server-flag-mailbox-regexp "^#mh" ; UW imapd
  55   "Regexp to match IMAP4 mailbox names whose message flags on server should be ignored.
  56 (Except `\\Deleted' flag).")
  57
  58 (defvar elmo-imap4-overview-fetch-chop-length 200
  59   "*Number of overviews to fetch in one request.")
  60
  61 ;; c.f. rfc2683 3.2.1.5 Long Command Lines
  62 ;;
  63 ;; "A client should limit the length of the command lines it generates
  64 ;;  to approximately 1000 octets (including all quoted strings but not
  65 ;;  including literals). If the client is unable to group things into
  66 ;;  ranges so that the command line is within that length, it should
  67 ;;  split the request into multiple commands. The client should use
  68 ;;  literals instead of long quoted strings, in order to keep the command
  69 ;;  length down.
  70 ;;  For its part, a server should allow for a command line of at least
  71 ;;  8000 octets. This provides plenty of leeway for accepting reasonable
  72 ;;  length commands from clients. The server should send a BAD response
  73 ;;  to a command that does not end within the server's maximum accepted
  74 ;;  command length. "
  75
  76 ;; To limit command line length, chop number set.
  77 (defvar elmo-imap4-number-set-chop-length 1000
  78   "*Number of messages to specify as a number-set argument for one request.")
  79
  80 (defvar elmo-imap4-force-login nil
  81   "*Non-nil forces to try 'login' if there is no 'auth' capability in imapd.")
  82
  83 (defvar elmo-imap4-use-select-to-update-status nil
  84   "*Some imapd have to send select command to update status.
  85 (ex. UW imapd 4.5-BETA?).  For these imapd, you must set this variable t.")
  86
  87 (defvar elmo-imap4-use-modified-utf7 nil
  88   "*Use mofidied UTF-7 (rfc2060) encoding for IMAP4 folder name.")
  89
  90 (defvar elmo-imap4-use-cache t
  91   "Use cache in imap4 folder.")
  92
  93 (defvar elmo-imap4-extra-namespace-alist
  94   '(("^{.*/nntp}.*$" . ".")) ; Default is for UW's remote nntp mailbox...
  95   "Extra namespace alist.  A list of cons cell like: (REGEXP . DELIMITER).")
  96 ;;
  97 ;;; internal variables
  98 ;;
  99 (defvar elmo-imap4-seq-prefix "elmo-imap4")
 100 (defvar elmo-imap4-seqno 0)
 101 (defvar elmo-imap4-use-uid t
 102   "Use UID as message number.")
 103
 104 (defvar elmo-imap4-current-response nil)
 105 (defvar elmo-imap4-status nil)
 106 (defvar elmo-imap4-reached-tag "elmo-imap40")
 107
 108 ;;; buffer local variables
 109 (defvar elmo-imap4-default-hierarchy-delimiter "/")
 110
 111 (defvar elmo-imap4-server-capability nil)
 112 (defvar elmo-imap4-server-namespace nil)
 113
 114 (defvar elmo-imap4-parsing nil) ; indicates parsing.
 115
 116 (defvar elmo-imap4-fetch-callback nil)
 117 (defvar elmo-imap4-fetch-callback-data nil)
 118 (defvar elmo-imap4-status-callback nil)
 119 (defvar elmo-imap4-status-callback-data nil)
 120
 121 (defvar elmo-imap4-server-diff-async-callback nil)
 122 (defvar elmo-imap4-server-diff-async-callback-data nil)
 123
 124 ;;; progress...(no use?)
 125 (defvar elmo-imap4-count-progress nil)
 126 (defvar elmo-imap4-count-progress-message nil)
 127 (defvar elmo-imap4-progress-count nil)
 128
 129 ;;; XXX Temporal implementation
 130 (defvar elmo-imap4-current-msgdb nil)
 131 (defvar elmo-imap4-seen-messages nil)
 132
 133 (defvar elmo-imap4-local-variables
 134   '(elmo-imap4-status
 135     elmo-imap4-current-response
 136     elmo-imap4-seqno
 137     elmo-imap4-parsing
 138     elmo-imap4-reached-tag
 139     elmo-imap4-count-progress
 140     elmo-imap4-count-progress-message
 141     elmo-imap4-progress-count
 142     elmo-imap4-fetch-callback
 143     elmo-imap4-fetch-callback-data
 144     elmo-imap4-status-callback
 145     elmo-imap4-status-callback-data
 146     elmo-imap4-current-msgdb
 147     elmo-imap4-seen-messages))
 148
 149 ;;;;
 150
 151 (defconst elmo-imap4-quoted-specials-list '(?\\ ?\"))
 152
 153 (defconst elmo-imap4-non-atom-char-regex
 154   (eval-when-compile
 155     (concat "[^" "]!#$&'+,./0-9:;<=>?@A-Z[^_`a-z|}~-" "]")))
 156
 157 (defconst elmo-imap4-non-text-char-regex
 158   (eval-when-compile
 159     (concat "[^"
 160             "]\x01-\x09\x0b\x0c\x0e-\x1f\x7f !\"#$%&'()*+,./0-9:;<=>?@A-Z[\\^_`a-z{|}~-"
 161             "]")))
 162
 163 (defconst elmo-imap4-literal-threshold 1024
 164  "Limitation of characters that can be used in a quoted string.")
 165
 166 ;; For debugging.
 167 (defvar elmo-imap4-debug nil
 168   "Non-nil forces IMAP4 folder as debug mode.
 169 Debug information is inserted in the buffer \"*IMAP4 DEBUG*\"")
 170
 171 (defvar elmo-imap4-debug-inhibit-logging nil)
 172
 173 ;;; ELMO IMAP4 folder
 174 (eval-and-compile
 175   (luna-define-class elmo-imap4-folder (elmo-net-folder)
 176                      (mailbox))
 177   (luna-define-internal-accessors 'elmo-imap4-folder))
 178
 179 ;;; Session
 180 (eval-and-compile
 181   (luna-define-class elmo-imap4-session (elmo-network-session)
 182                      (capability current-mailbox read-only))
 183   (luna-define-internal-accessors 'elmo-imap4-session))
 184
 185 ;;; MIME-ELMO-IMAP Location
 186 (eval-and-compile
 187   (luna-define-class mime-elmo-imap-location
 188                      (mime-imap-location)
 189                      (folder number rawbuf strategy))
 190   (luna-define-internal-accessors 'mime-elmo-imap-location))
 191
 192 ;;; Debug
 193 (defsubst elmo-imap4-debug (message &rest args)
 194   (if elmo-imap4-debug
 195       (with-current-buffer (get-buffer-create "*IMAP4 DEBUG*")
 196         (goto-char (point-max))
 197         (if elmo-imap4-debug-inhibit-logging
 198             (insert "NO LOGGING\n")
 199           (insert (apply 'format message args) "\n")))))
 200
 201 (defsubst elmo-imap4-decode-folder-string (string)
 202   (if elmo-imap4-use-modified-utf7
 203       (utf7-decode-string string 'imap)
 204     string))
 205
 206 (defsubst elmo-imap4-encode-folder-string (string)
 207   (if elmo-imap4-use-modified-utf7
 208       (utf7-encode-string string 'imap)
 209     string))
 210
 211 ;;; Response
 212
 213 (defmacro elmo-imap4-response-continue-req-p (response)
 214   "Returns non-nil if RESPONSE is '+' response."
 215   (` (assq 'continue-req (, response))))
 216
 217 (defmacro elmo-imap4-response-ok-p (response)
 218   "Returns non-nil if RESPONSE is an 'OK' response."
 219   (` (assq 'ok (, response))))
 220
 221 (defmacro elmo-imap4-response-bye-p (response)
 222   "Returns non-nil if RESPONSE is an 'BYE' response."
 223   (` (assq 'bye (, response))))
 224
 225 (defmacro elmo-imap4-response-value (response symbol)
 226   "Get value of the SYMBOL from RESPONSE."
 227   (` (nth 1 (assq (, symbol) (, response)))))
 228
 229 (defsubst elmo-imap4-response-value-all (response symbol)
 230   "Get all value of the SYMBOL from RESPONSE."
 231   (let (matched)
 232     (while response
 233       (if (eq (car (car response)) symbol)
 234           (setq matched (nconc matched (nth 1 (car response)))))
 235       (setq response (cdr response)))
 236     matched))
 237
 238 (defmacro elmo-imap4-response-error-text (response)
 239   "Returns text of NO, BAD, BYE response."
 240   (` (nth 1 (or (elmo-imap4-response-value (, response) 'no)
 241                 (elmo-imap4-response-value (, response) 'bad)
 242                 (elmo-imap4-response-value (, response) 'bye)))))
 243
 244 (defmacro elmo-imap4-response-bodydetail-text (response)
 245   "Returns text of BODY[section]<partial>."
 246   (` (nth 3 (assq 'bodydetail (, response)))))
 247
 248 ;;; Session commands.
 249
 250 ; (defun elmo-imap4-send-command-wait (session command)
 251 ;   "Send COMMAND to the SESSION and wait for response.
 252 ; Returns RESPONSE (parsed lisp object) of IMAP session."
 253 ;   (elmo-imap4-read-response session
 254 ;                           (elmo-imap4-send-command
 255 ;                            session
 256 ;                            command)))
 257
 258 (defun elmo-imap4-send-command-wait (session command)
 259   "Send COMMAND to the SESSION.
 260 Returns RESPONSE (parsed lisp object) of IMAP session.
 261 If response is not `OK', causes error with IMAP response text."
 262   (elmo-imap4-accept-ok session
 263                         (elmo-imap4-send-command
 264                          session
 265                          command)))
 266
 267 (defun elmo-imap4-send-command (session command)
 268   "Send COMMAND to the SESSION.
 269 Returns a TAG string which is assigned to the COMMAND."
 270   (let* ((command-args (if (listp command)
 271                            command
 272                          (list command)))
 273          (process (elmo-network-session-process-internal session))
 274          cmdstr tag token kind)
 275     (with-current-buffer (process-buffer process)
 276       (setq tag (concat elmo-imap4-seq-prefix
 277                         (number-to-string
 278                          (setq elmo-imap4-seqno (+ 1 elmo-imap4-seqno)))))
 279       (setq cmdstr (concat tag " "))
 280       ;; (erase-buffer) No need.
 281       (goto-char (point-min))
 282       (when (elmo-imap4-response-bye-p elmo-imap4-current-response)
 283         (elmo-imap4-process-bye session))
 284       (setq elmo-imap4-current-response nil)
 285       (if elmo-imap4-parsing
 286           (error "IMAP process is running. Please wait (or plug again)"))
 287       (setq elmo-imap4-parsing t)
 288       (elmo-imap4-debug "<-(%s)- %s" tag command)
 289       (while (setq token (car command-args))
 290         (cond ((stringp token)   ; formatted
 291                (setq cmdstr (concat cmdstr token)))
 292               ((listp token)     ; unformatted
 293                (setq kind (car token))
 294                (cond ((eq kind 'atom)
 295                       (setq cmdstr (concat cmdstr (nth 1 token))))
 296                      ((eq kind 'quoted)
 297                       (setq cmdstr (concat
 298                                     cmdstr
 299                                     (elmo-imap4-format-quoted (nth 1 token)))))
 300                      ((eq kind 'literal)
 301                       (setq cmdstr (concat cmdstr
 302                                            (format "{%d}" (nth 2 token))))
 303                       (process-send-string process cmdstr)
 304                       (process-send-string process "\r\n")
 305                       (setq cmdstr nil)
 306                       (elmo-imap4-accept-continue-req session)
 307                       (cond ((stringp (nth 1 token))
 308                              (setq cmdstr (nth 1 token)))
 309                             ((bufferp (nth 1 token))
 310                              (with-current-buffer (nth 1 token)
 311                                (process-send-region
 312                                 process
 313                                 (point-min)
 314                                 (+ (point-min) (nth 2 token)))))
 315                             (t
 316                              (error "Wrong argument for literal"))))
 317                      (t
 318                       (error "Unknown token kind %s" kind))))
 319               (t
 320                (error "Invalid argument")))
 321         (setq command-args (cdr command-args)))
 322       (if cmdstr
 323           (process-send-string process cmdstr))
 324       (process-send-string process "\r\n")
 325       tag)))
 326
 327 (defun elmo-imap4-send-string (session string)
 328   "Send STRING to the SESSION."
 329   (with-current-buffer (process-buffer
 330                         (elmo-network-session-process-internal session))
 331     (setq elmo-imap4-current-response nil)
 332     (goto-char (point-min))
 333     (elmo-imap4-debug "<-- %s" string)
 334     (process-send-string (elmo-network-session-process-internal session)
 335                          string)
 336     (process-send-string (elmo-network-session-process-internal session)
 337                          "\r\n")))
 338
 339 (defun elmo-imap4-read-response (session tag)
 340   "Read parsed response from SESSION.
 341 TAG is the tag of the command"
 342   (with-current-buffer (process-buffer
 343                         (elmo-network-session-process-internal session))
 344     (while (not (or (string= tag elmo-imap4-reached-tag)
 345                     (elmo-imap4-response-bye-p elmo-imap4-current-response)))
 346       (when (memq (process-status
 347                    (elmo-network-session-process-internal session))
 348                   '(open run))
 349         (accept-process-output (elmo-network-session-process-internal session)
 350                                1)))
 351     (elmo-imap4-debug "=>%s" (prin1-to-string elmo-imap4-current-response))
 352     (setq elmo-imap4-parsing nil)
 353     elmo-imap4-current-response))
 354
 355 (defsubst elmo-imap4-read-untagged (process)
 356   (with-current-buffer (process-buffer process)
 357     (while (not elmo-imap4-current-response)
 358       (accept-process-output process 1))
 359     (elmo-imap4-debug "=>%s" (prin1-to-string elmo-imap4-current-response))
 360     elmo-imap4-current-response))
 361
 362 (defun elmo-imap4-read-continue-req (session)
 363   "Returns a text following to continue-req in SESSION.
 364 If response is not `+' response, returns nil."
 365   (elmo-imap4-response-value
 366    (elmo-imap4-read-untagged
 367     (elmo-network-session-process-internal session))
 368    'continue-req))
 369
 370 (defun elmo-imap4-process-bye (session)
 371   (with-current-buffer (elmo-network-session-buffer session)
 372     (let ((r elmo-imap4-current-response))
 373       (setq elmo-imap4-current-response nil)
 374       (elmo-network-close-session session)
 375       (signal 'elmo-imap4-bye-error
 376               (list (concat (elmo-imap4-response-error-text r))
 377                     "Try Again")))))
 378
 379 (defun elmo-imap4-accept-continue-req (session)
 380   "Returns non-nil if `+' (continue-req) response is arrived in SESSION.
 381 If response is not `+' response, cause an error."
 382   (let (response)
 383     (setq response
 384           (elmo-imap4-read-untagged
 385            (elmo-network-session-process-internal session)))
 386     (or (elmo-imap4-response-continue-req-p response)
 387         (error "IMAP error: %s"
 388                (or (elmo-imap4-response-error-text response)
 389                    "No continut-req from server.")))))
 390
 391 (defun elmo-imap4-read-ok (session tag)
 392   "Returns non-nil if `OK' response of the command with TAG is arrived
 393 in SESSION. If response is not `OK' response, returns nil."
 394   (elmo-imap4-response-ok-p
 395    (elmo-imap4-read-response session tag)))
 396
 397 (defun elmo-imap4-accept-ok (session tag)
 398   "Accept only `OK' response from SESSION.
 399 If response is not `OK' response, causes error with IMAP response text."
 400   (let ((response (elmo-imap4-read-response session tag)))
 401     (if (elmo-imap4-response-ok-p response)
 402         response
 403       (if (elmo-imap4-response-bye-p response)
 404           (elmo-imap4-process-bye session)
 405         (error "IMAP error: %s"
 406                (or (elmo-imap4-response-error-text response)
 407                    "No `OK' response from server."))))))
 408
 409 ;;; MIME-ELMO-IMAP Location
 410 (luna-define-method mime-imap-location-section-body ((location
 411                                                       mime-elmo-imap-location)
 412                                                      section)
 413   (if (and (stringp section)
 414            (string= section "HEADER"))
 415       ;; Even in the section mode, header fields should be saved to the
 416       ;; raw buffer .
 417       (with-current-buffer (mime-elmo-imap-location-rawbuf-internal location)
 418         (erase-buffer)
 419         (elmo-message-fetch
 420          (mime-elmo-imap-location-folder-internal location)
 421          (mime-elmo-imap-location-number-internal location)
 422          (mime-elmo-imap-location-strategy-internal location)
 423          section
 424          (current-buffer)
 425          'unseen)
 426         (buffer-string))
 427     (elmo-message-fetch
 428      (mime-elmo-imap-location-folder-internal location)
 429      (mime-elmo-imap-location-number-internal location)
 430      (mime-elmo-imap-location-strategy-internal location)
 431      section
 432      nil 'unseen)))
 433
 434
 435 (luna-define-method mime-imap-location-bodystructure
 436   ((location mime-elmo-imap-location))
 437   (elmo-imap4-fetch-bodystructure
 438    (mime-elmo-imap-location-folder-internal location)
 439    (mime-elmo-imap-location-number-internal location)
 440    (mime-elmo-imap-location-strategy-internal location)))
 441
 442 (luna-define-method mime-imap-location-fetch-entity-p
 443   ((location mime-elmo-imap-location) entity)
 444   (or (not elmo-message-displaying) ; Fetching entity to save or force display.
 445       ;; cache exists
 446       (file-exists-p
 447        (expand-file-name
 448         (mmimap-entity-section (mime-entity-node-id-internal entity))
 449         (elmo-fetch-strategy-cache-path
 450          (mime-elmo-imap-location-strategy-internal location))))
 451       ;; not too large to fetch.
 452       (> elmo-message-fetch-threshold
 453          (or (mime-imap-entity-size-internal entity) 0))))
 454
 455 ;;;
 456
 457 (defun elmo-imap4-session-check (session)
 458   (with-current-buffer (elmo-network-session-buffer session)
 459     (setq elmo-imap4-fetch-callback nil)
 460     (setq elmo-imap4-fetch-callback-data nil))
 461   (elmo-imap4-send-command-wait session "check"))
 462
 463 (defun elmo-imap4-atom-p (string)
 464   "Return t if STRING is an atom defined in rfc2060."
 465   (if (string= string "")
 466       nil
 467     (save-match-data
 468       (not (string-match elmo-imap4-non-atom-char-regex string)))))
 469
 470 (defun elmo-imap4-quotable-p (string)
 471   "Return t if STRING can be formatted as a quoted defined in rfc2060."
 472   (save-match-data
 473     (not (string-match elmo-imap4-non-text-char-regex string))))
 474
 475 (defun elmo-imap4-nil (string)
 476   "Return a list represents the special atom \"NIL\" defined in rfc2060, \
 477 if STRING is nil.
 478 Otherwise return nil."
 479   (if (eq string nil)
 480       (list 'atom "NIL")))
 481
 482 (defun elmo-imap4-atom (string)
 483   "Return a list represents STRING as an atom defined in rfc2060.
 484 Return nil if STRING is not an atom.  See `elmo-imap4-atom-p'."
 485   (if (elmo-imap4-atom-p string)
 486       (list 'atom string)))
 487
 488 (defun elmo-imap4-quoted (string)
 489   "Return a list represents STRING as a quoted defined in rfc2060.
 490 Return nil if STRING can not be formatted as a quoted.  See `elmo-imap4-quotable-p'."
 491   (if (elmo-imap4-quotable-p string)
 492       (list 'quoted string)))
 493
 494 (defun elmo-imap4-literal-1 (string-or-buffer length)
 495   "Internal function for `elmo-imap4-literal' and `elmo-imap4-buffer-literal'.
 496 Return a list represents STRING-OR-BUFFER as a literal defined in rfc2060.
 497 STRING-OR-BUFFER must be an encoded string or a single-byte string or a single-byte buffer.
 498 LENGTH must be the number of octets for STRING-OR-BUFFER."
 499   (list 'literal string-or-buffer length))
 500
 501 (defun elmo-imap4-literal (string)
 502   "Return a list represents STRING as a literal defined in rfc2060.
 503 STRING must be an encoded or a single-byte string."
 504   (elmo-imap4-literal-1 string (length string)))
 505
 506 (defun elmo-imap4-buffer-literal (buffer)
 507   "Return a list represents BUFFER as a literal defined in rfc2060.
 508 BUFFER must be a single-byte buffer."
 509   (elmo-imap4-literal-1 buffer (with-current-buffer buffer
 510                                  (buffer-size))))
 511
 512 (defun elmo-imap4-string-1 (string length)
 513   "Internal function for `elmo-imap4-string' and `elmo-imap4-buffer-string'.
 514 Return a list represents STRING as a string defined in rfc2060.
 515 STRING must be an encoded or a single-byte string.
 516 LENGTH must be the number of octets for STRING."
 517   (or (elmo-imap4-quoted string)
 518       (elmo-imap4-literal-1 string length)))
 519
 520 (defun elmo-imap4-string (string)
 521   "Return a list represents STRING as a string defined in rfc2060.
 522 STRING must be an encoded or a single-byte string."
 523   (let ((length (length string)))
 524     (if (< elmo-imap4-literal-threshold length)
 525         (elmo-imap4-literal-1 string length)
 526       (elmo-imap4-string-1 string length))))
 527
 528 (defun elmo-imap4-buffer-string (buffer)
 529   "Return a list represents BUFFER as a string defined in rfc2060.
 530 BUFFER must be a single-byte buffer."
 531   (let ((length (with-current-buffer buffer
 532                   (buffer-size))))
 533     (if (< elmo-imap4-literal-threshold length)
 534         (elmo-imap4-literal-1 buffer length)
 535       (elmo-imap4-string-1 (with-current-buffer buffer
 536                              (buffer-string))
 537                            length))))
 538
 539 (defun elmo-imap4-astring-1 (string length)
 540   "Internal function for `elmo-imap4-astring' and `elmo-imap4-buffer-astring'.
 541 Return a list represents STRING as an astring defined in rfc2060.
 542 STRING must be an encoded or a single-byte string.
 543 LENGTH must be the number of octets for STRING."
 544   (or (elmo-imap4-atom string)
 545       (elmo-imap4-string-1 string length)))
 546
 547 (defun elmo-imap4-astring (string)
 548   "Return a list represents STRING as an astring defined in rfc2060.
 549 STRING must be an encoded or a single-byte string."
 550   (let ((length (length string)))
 551     (if (< elmo-imap4-literal-threshold length)
 552         (elmo-imap4-literal-1 string length)
 553       (elmo-imap4-astring-1 string length))))
 554
 555 (defun elmo-imap4-buffer-astring (buffer)
 556   "Return a list represents BUFFER as an astring defined in rfc2060.
 557 BUFFER must be a single-byte buffer."
 558   (let ((length (with-current-buffer buffer
 559                   (buffer-size))))
 560     (if (< elmo-imap4-literal-threshold length)
 561         (elmo-imap4-literal-1 buffer length)
 562       (elmo-imap4-astring-1 (with-current-buffer buffer
 563                               (buffer-string))
 564                             length))))
 565
 566 (defun elmo-imap4-nstring (string)
 567   "Return a list represents STRING as a nstring defined in rfc2060.
 568 STRING must be an encoded or a single-byte string."
 569    (or (elmo-imap4-nil string)
 570        (elmo-imap4-string string)))
 571
 572 (defun elmo-imap4-buffer-nstring (buffer)
 573   "Return a list represents BUFFER as a nstring defined in rfc2060.
 574 BUFFER must be a single-byte buffer."
 575    (or (elmo-imap4-nil buffer)
 576        (elmo-imap4-buffer-string buffer)))
 577
 578 (defalias 'elmo-imap4-mailbox 'elmo-imap4-astring)
 579 (defalias 'elmo-imap4-field-body 'elmo-imap4-astring)
 580 (defalias 'elmo-imap4-userid 'elmo-imap4-astring)
 581 (defalias 'elmo-imap4-password 'elmo-imap4-astring)
 582
 583 (defun elmo-imap4-format-quoted (string)
 584   "Return STRING in a form of the quoted-string defined in rfc2060."
 585   (concat "\""
 586           (std11-wrap-as-quoted-pairs string elmo-imap4-quoted-specials-list)
 587           "\""))
 588
 589 (defsubst elmo-imap4-response-get-selectable-mailbox-list (response)
 590   (delq nil
 591         (mapcar
 592          (lambda (entry)
 593            (if (and (eq 'list (car entry))
 594                     (not (member "\\NoSelect" (nth 1 (nth 1 entry)))))
 595                (car (nth 1 entry))))
 596          response)))
 597
 598 (defun elmo-imap4-fetch-bodystructure (folder number strategy)
 599   "Fetch BODYSTRUCTURE for the message in the FOLDER with NUMBER using STRATEGY."
 600   (if (elmo-fetch-strategy-use-cache strategy)
 601       (elmo-object-load
 602        (elmo-file-cache-expand-path
 603         (elmo-fetch-strategy-cache-path strategy)
 604         "bodystructure"))
 605     (let ((session (elmo-imap4-get-session folder))
 606           bodystructure)
 607       (elmo-imap4-session-select-mailbox
 608        session
 609        (elmo-imap4-folder-mailbox-internal folder))
 610       (with-current-buffer (elmo-network-session-buffer session)
 611         (setq elmo-imap4-fetch-callback nil)
 612         (setq elmo-imap4-fetch-callback-data nil))
 613       (prog1 (setq bodystructure
 614                    (elmo-imap4-response-value
 615                     (elmo-imap4-response-value
 616                      (elmo-imap4-send-command-wait
 617                       session
 618                       (format
 619                        (if elmo-imap4-use-uid
 620                            "uid fetch %s bodystructure"
 621                          "fetch %s bodystructure")
 622                        number))
 623                      'fetch)
 624                     'bodystructure))
 625         (when (elmo-fetch-strategy-save-cache strategy)
 626           (elmo-file-cache-delete
 627            (elmo-fetch-strategy-cache-path strategy))
 628           (elmo-object-save
 629            (elmo-file-cache-expand-path
 630             (elmo-fetch-strategy-cache-path strategy)
 631             "bodystructure")
 632            bodystructure))))))
 633
 634 ;;; Backend methods.
 635 (luna-define-method elmo-create-folder-plugged ((folder elmo-imap4-folder))
 636   (elmo-imap4-send-command-wait
 637    (elmo-imap4-get-session folder)
 638    (list "create " (elmo-imap4-mailbox
 639                     (elmo-imap4-folder-mailbox-internal folder)))))
 640
 641 (defun elmo-imap4-get-session (folder &optional if-exists)
 642   (elmo-network-get-session 'elmo-imap4-session
 643                             (concat
 644                              (if (elmo-folder-biff-internal folder)
 645                                  "BIFF-")
 646                              "IMAP")
 647                             folder if-exists))
 648
 649 (defun elmo-imap4-session-select-mailbox (session mailbox
 650                                                   &optional force no-error)
 651   "Select MAILBOX in SESSION.
 652 If optional argument FORCE is non-nil, select mailbox even if current mailbox
 653 is same as MAILBOX.
 654 If second optional argument NO-ERROR is non-nil, don't cause an error when
 655 selecting folder was failed.
 656 If NO-ERROR is 'notify-bye, only BYE response is reported as error.
 657 Returns response value if selecting folder succeed. "
 658   (when (or force
 659             (not (string=
 660                   (elmo-imap4-session-current-mailbox-internal session)
 661                   mailbox)))
 662     (let (response result)
 663       (unwind-protect
 664           (setq response
 665                 (elmo-imap4-read-response
 666                  session
 667                  (elmo-imap4-send-command
 668                   session
 669                   (list
 670                    "select "
 671                    (elmo-imap4-mailbox mailbox)))))
 672         (if (setq result (elmo-imap4-response-ok-p response))
 673             (progn
 674               (elmo-imap4-session-set-current-mailbox-internal session mailbox)
 675               (elmo-imap4-session-set-read-only-internal
 676                session
 677                (nth 1 (assq 'read-only (assq 'ok response)))))
 678           (elmo-imap4-session-set-current-mailbox-internal session nil)
 679           (if (and (eq no-error 'notify-bye)
 680                    (elmo-imap4-response-bye-p response))
 681               (elmo-imap4-process-bye session)
 682             (unless no-error
 683               (error (or
 684                       (elmo-imap4-response-error-text response)
 685                       (format "Select %s failed" mailbox)))))))
 686       (and result response))))
 687
 688 (defun elmo-imap4-check-validity (spec validity-file)
 689 ;;; Not used.
 690 ;;;(elmo-imap4-send-command-wait
 691 ;;;(elmo-imap4-get-session spec)
 692 ;;;(list "status "
 693 ;;;      (elmo-imap4-mailbox
 694 ;;;       (elmo-imap4-spec-mailbox spec))
 695 ;;;      " (uidvalidity)")))
 696   )
 697
 698 (defun elmo-imap4-sync-validity  (spec validity-file)
 699   ;; Not used.
 700   )
 701
 702 (defun elmo-imap4-list (folder flag)
 703   (let ((session (elmo-imap4-get-session folder)))
 704     (elmo-imap4-session-select-mailbox
 705      session
 706      (elmo-imap4-folder-mailbox-internal folder))
 707     (elmo-imap4-response-value
 708      (elmo-imap4-send-command-wait
 709       session
 710       (format (if elmo-imap4-use-uid "uid search %s"
 711                 "search %s") flag))
 712      'search)))
 713
 714 (static-cond
 715  ((fboundp 'float)
 716   ;; Emacs can parse dot symbol.
 717   (defvar elmo-imap4-rfc822-size "RFC822\.SIZE")
 718   (defvar elmo-imap4-rfc822-text "RFC822\.TEXT")
 719   (defvar elmo-imap4-rfc822-header "RFC822\.HEADER")
 720   (defvar elmo-imap4-rfc822-size "RFC822\.SIZE")
 721   (defvar elmo-imap4-header-fields "HEADER\.FIELDS")
 722   (defmacro elmo-imap4-replace-dot-symbols ()) ;; noop
 723   (defalias 'elmo-imap4-fetch-read 'read)
 724   )
 725  (t
 726   ;;; For Nemacs.
 727   ;; Cannot parse dot symbol.
 728   (defvar elmo-imap4-rfc822-size "RFC822_SIZE")
 729   (defvar elmo-imap4-header-fields "HEADER_FIELDS")
 730   (defvar elmo-imap4-rfc822-size "RFC822_SIZE")
 731   (defvar elmo-imap4-rfc822-text "RFC822_TEXT")
 732   (defvar elmo-imap4-rfc822-header "RFC822_HEADER")
 733   (defvar elmo-imap4-header-fields "HEADER_FIELDS")
 734   (defun elmo-imap4-fetch-read (buffer)
 735     (with-current-buffer buffer
 736       (let ((beg (point))
 737             token)
 738         (when (re-search-forward "[[ ]" nil t)
 739           (goto-char (match-beginning 0))
 740           (setq token (buffer-substring beg (point)))
 741           (cond ((string= token "RFC822.SIZE")
 742                  (intern elmo-imap4-rfc822-size))
 743                 ((string= token "RFC822.HEADER")
 744                  (intern elmo-imap4-rfc822-header))
 745                 ((string= token "RFC822.TEXT")
 746                  (intern elmo-imap4-rfc822-text))
 747                 ((string= token "HEADER\.FIELDS")
 748                  (intern elmo-imap4-header-fields))
 749                 (t (goto-char beg)
 750                    (elmo-read (current-buffer))))))))))
 751
 752 (defun elmo-imap4-make-number-set-list (msg-list &optional chop-length)
 753   "Make RFC2060's message set specifier from MSG-LIST.
 754 Returns a list of (NUMBER . SET-STRING).
 755 SET-STRING is the message set specifier described in RFC2060.
 756 NUMBER is contained message number in SET-STRING.
 757 Every SET-STRING does not contain number of messages longer than CHOP-LENGTH.
 758 If CHOP-LENGTH is not specified, message set is not chopped."
 759   (let (count cont-list set-list)
 760     (setq msg-list (sort (copy-sequence msg-list) '<))
 761     (while msg-list
 762       (setq cont-list nil)
 763       (setq count 0)
 764       (unless chop-length
 765         (setq chop-length (length msg-list)))
 766       (while (and (not (null msg-list))
 767                   (< count chop-length))
 768         (setq cont-list
 769               (elmo-number-set-append
 770                cont-list (car msg-list)))
 771         (incf count)
 772         (setq msg-list (cdr msg-list)))
 773       (setq set-list
 774             (cons
 775              (cons
 776               count
 777               (mapconcat
 778                (lambda (x)
 779                  (cond ((consp x)
 780                         (format "%s:%s" (car x) (cdr x)))
 781                        ((integerp x)
 782                         (int-to-string x))))
 783                cont-list
 784                ","))
 785              set-list)))
 786     (nreverse set-list)))
 787
 788 ;;
 789 ;; app-data:
 790 ;; cons of list
 791 ;; 0: new-mark 1: already-mark 2: seen-mark 3: important-mark
 792 ;; 4: seen-list
 793 ;; and result of use-flag-p.
 794 (defsubst elmo-imap4-fetch-callback-1-subr (entity flags app-data)
 795   "A msgdb entity callback function."
 796   (let* ((use-flag (cdr app-data))
 797          (app-data (car app-data))
 798          (seen (member (car entity) (nth 4 app-data)))
 799          mark)
 800     (if (member "\\Flagged" flags)
 801         (elmo-msgdb-global-mark-set (car entity) (nth 3 app-data)))
 802     (if (setq mark (elmo-msgdb-global-mark-get (car entity)))
 803         (unless (member "\\Seen" flags)
 804           (setq elmo-imap4-seen-messages
 805                 (cons
 806                  (elmo-msgdb-overview-entity-get-number entity)
 807                  elmo-imap4-seen-messages)))
 808       (setq mark (or (if (elmo-file-cache-status
 809                           (elmo-file-cache-get (car entity)))
 810                          (if (or seen
 811                                  (and use-flag
 812                                       (member "\\Seen" flags)))
 813                              nil
 814                            (nth 1 app-data))
 815                        (if (or seen
 816                                (and use-flag
 817                                     (member "\\Seen" flags)))
 818                            (if elmo-imap4-use-cache
 819                                (nth 2 app-data))
 820                          (nth 0 app-data))))))
 821     (setq elmo-imap4-current-msgdb
 822           (elmo-msgdb-append
 823            elmo-imap4-current-msgdb
 824            (list (list entity)
 825                  (list (cons (elmo-msgdb-overview-entity-get-number entity)
 826                              (car entity)))
 827                  (if mark
 828                      (list
 829                       (list (elmo-msgdb-overview-entity-get-number entity)
 830                             mark))))))))
 831
 832 ;; Current buffer is process buffer.
 833 (defun elmo-imap4-fetch-callback-1 (element app-data)
 834   (elmo-imap4-fetch-callback-1-subr
 835    (with-temp-buffer
 836      (insert (or (elmo-imap4-response-bodydetail-text element)
 837                  ""))
 838      ;; Delete CR.
 839      (goto-char (point-min))
 840      (while (search-forward "\r\n" nil t)
 841        (replace-match "\n"))
 842      (elmo-msgdb-create-overview-from-buffer
 843       (elmo-imap4-response-value element 'uid)
 844       (elmo-imap4-response-value element 'rfc822size)))
 845    (elmo-imap4-response-value element 'flags)
 846    app-data))
 847
 848 (defun elmo-imap4-parse-capability (string)
 849   (if (string-match "^\\*\\(.*\\)$" string)
 850       (elmo-read
 851        (concat "(" (downcase (elmo-match-string 1 string)) ")"))))
 852
 853 (defun elmo-imap4-clear-login (session)
 854   (let ((elmo-imap4-debug-inhibit-logging t))
 855     (or
 856      (elmo-imap4-read-ok
 857       session
 858       (elmo-imap4-send-command
 859        session
 860        (list "login "
 861              (elmo-imap4-userid (elmo-network-session-user-internal session))
 862              " "
 863              (elmo-imap4-password
 864               (elmo-get-passwd (elmo-network-session-password-key session))))))
 865      (signal 'elmo-authenticate-error '(elmo-imap4-clear-login)))))
 866
 867 (defun elmo-imap4-auth-login (session)
 868   (let ((tag (elmo-imap4-send-command session "authenticate login"))
 869         (elmo-imap4-debug-inhibit-logging t))
 870     (or (elmo-imap4-read-continue-req session)
 871         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
 872     (elmo-imap4-send-string session
 873                             (elmo-base64-encode-string
 874                              (elmo-network-session-user-internal session)))
 875     (or (elmo-imap4-read-continue-req session)
 876         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
 877     (elmo-imap4-send-string session
 878                             (elmo-base64-encode-string
 879                              (elmo-get-passwd
 880                               (elmo-network-session-password-key session))))
 881     (or (elmo-imap4-read-ok session tag)
 882         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
 883     (setq elmo-imap4-status 'auth)))
 884
 885 (luna-define-method
 886   elmo-network-initialize-session-buffer :after ((session
 887                                                   elmo-imap4-session) buffer)
 888   (with-current-buffer buffer
 889     (mapcar 'make-variable-buffer-local elmo-imap4-local-variables)
 890     (setq elmo-imap4-seqno 0)
 891     (setq elmo-imap4-status 'initial)))
 892
 893 (luna-define-method elmo-network-initialize-session ((session
 894                                                       elmo-imap4-session))
 895   (let ((process (elmo-network-session-process-internal session)))
 896     (with-current-buffer (process-buffer process)
 897       ;; Skip garbage output from process before greeting.
 898       (while (and (memq (process-status process) '(open run))
 899                   (goto-char (point-max))
 900                   (forward-line -1)
 901                   (not (elmo-imap4-parse-greeting)))
 902         (accept-process-output process 1))
 903       (set-process-filter process 'elmo-imap4-arrival-filter)
 904       (set-process-sentinel process 'elmo-imap4-sentinel)
 905 ;;;   (while (and (memq (process-status process) '(open run))
 906 ;;;               (eq elmo-imap4-status 'initial))
 907 ;;;     (message "Waiting for server response...")
 908 ;;;     (accept-process-output process 1))
 909 ;;;   (message "")
 910       (unless (memq elmo-imap4-status '(nonauth auth))
 911         (signal 'elmo-open-error
 912                 (list 'elmo-network-initialize-session)))
 913       (elmo-imap4-session-set-capability-internal
 914        session
 915        (elmo-imap4-response-value
 916         (elmo-imap4-send-command-wait session "capability")
 917         'capability))
 918       (when (eq (elmo-network-stream-type-symbol
 919                  (elmo-network-session-stream-type-internal session))
 920                 'starttls)
 921         (or (memq 'starttls
 922                   (elmo-imap4-session-capability-internal session))
 923             (signal 'elmo-open-error
 924                     '(elmo-imap4-starttls-error)))
 925         (elmo-imap4-send-command-wait session "starttls")
 926         (starttls-negotiate process)))))
 927
 928 (luna-define-method elmo-network-authenticate-session ((session
 929                                                         elmo-imap4-session))
 930   (with-current-buffer (process-buffer
 931                         (elmo-network-session-process-internal session))
 932     (let* ((auth (elmo-network-session-auth-internal session))
 933            (auth (if (listp auth) auth (list auth))))
 934       (unless (or (eq elmo-imap4-status 'auth)
 935                   (null auth))
 936         (cond
 937          ((eq 'clear (car auth))
 938           (elmo-imap4-clear-login session))
 939          ((eq 'login (car auth))
 940           (elmo-imap4-auth-login session))
 941          (t
 942           (let* ((elmo-imap4-debug-inhibit-logging t)
 943                  (sasl-mechanisms
 944                   (delq nil
 945                         (mapcar
 946                          '(lambda (cap)
 947                             (if (string-match "^auth=\\(.*\\)$"
 948                                               (symbol-name cap))
 949                                 (match-string 1 (upcase (symbol-name cap)))))
 950                          (elmo-imap4-session-capability-internal session))))
 951                  (mechanism
 952                   (sasl-find-mechanism
 953                    (delq nil
 954                          (mapcar '(lambda (cap) (upcase (symbol-name cap)))
 955                                  (if (listp auth)
 956                                      auth
 957                                    (list auth)))))) ;)
 958                  client name step response tag
 959                  sasl-read-passphrase)
 960             (unless mechanism
 961               (if (or elmo-imap4-force-login
 962                       (y-or-n-p
 963                        (format
 964                         "There's no %s capability in server. continue?"
 965                         (elmo-list-to-string
 966                          (elmo-network-session-auth-internal session)))))
 967                   (setq mechanism (sasl-find-mechanism
 968                                    sasl-mechanisms))
 969                 (signal 'elmo-authenticate-error
 970                         '(elmo-imap4-auth-no-mechanisms))))
 971             (setq client
 972                   (sasl-make-client
 973                    mechanism
 974                    (elmo-network-session-user-internal session)
 975                    "imap"
 976                    (elmo-network-session-server-internal session)))
 977 ;;;         (if elmo-imap4-auth-user-realm
 978 ;;;             (sasl-client-set-property client 'realm elmo-imap4-auth-user-realm))
 979             (setq name (sasl-mechanism-name mechanism)
 980                   step (sasl-next-step client nil))
 981             (elmo-network-session-set-auth-internal
 982              session
 983              (intern (downcase name)))
 984             (setq sasl-read-passphrase
 985                   (function
 986                    (lambda (prompt)
 987                      (elmo-get-passwd
 988                       (elmo-network-session-password-key session)))))
 989             (setq tag
 990                   (elmo-imap4-send-command
 991                    session
 992                    (concat "AUTHENTICATE " name
 993                            (and (sasl-step-data step)
 994                                 (concat
 995                                  " "
 996                                  (elmo-base64-encode-string
 997                                   (sasl-step-data step)
 998                                   'no-lin-break))))))
 999             (catch 'done
1000               (while t
1001                 (setq response
1002                       (elmo-imap4-read-untagged
1003                        (elmo-network-session-process-internal session)))
1004                 (if (elmo-imap4-response-ok-p response)
1005                     (if (sasl-next-step client step)
1006                         ;; Bogus server?
1007                         (signal 'elmo-authenticate-error
1008                                 (list (intern
1009                                        (concat "elmo-imap4-auth-"
1010                                                (downcase name)))))
1011                       ;; The authentication process is finished.
1012                       (throw 'done nil)))
1013                 (unless (elmo-imap4-response-continue-req-p response)
1014                   ;; response is NO or BAD.
1015                   (signal 'elmo-authenticate-error
1016                           (list (intern
1017                                  (concat "elmo-imap4-auth-"
1018                                          (downcase name))))))
1019                 (sasl-step-set-data
1020                  step
1021                  (elmo-base64-decode-string
1022                   (elmo-imap4-response-value response 'continue-req)))
1023                 (setq step (sasl-next-step client step))
1024                 (setq tag
1025                       (elmo-imap4-send-string
1026                        session
1027                        (if (sasl-step-data step)
1028                            (elmo-base64-encode-string (sasl-step-data step)
1029                                                       'no-line-break)
1030                          ""))))))))))))
1031
1032 (luna-define-method elmo-network-setup-session ((session
1033                                                  elmo-imap4-session))
1034   (with-current-buffer (elmo-network-session-buffer session)
1035     (when (memq 'namespace (elmo-imap4-session-capability-internal session))
1036       (setq elmo-imap4-server-namespace
1037             (elmo-imap4-response-value
1038              (elmo-imap4-send-command-wait session "namespace")
1039              'namespace)))))
1040
1041 (defun elmo-imap4-setup-send-buffer (&optional string)
1042   (let ((send-buf (get-buffer-create " *elmo-imap4-setup-send-buffer*"))
1043         (source-buf (unless string (current-buffer))))
1044     (save-excursion
1045       (save-match-data
1046         (set-buffer send-buf)
1047         (erase-buffer)
1048         (elmo-set-buffer-multibyte nil)
1049         (if string
1050             (insert string)
1051           (with-current-buffer source-buf
1052             (copy-to-buffer send-buf (point-min) (point-max))))
1053         (goto-char (point-min))
1054         (if (eq (re-search-forward "^$" nil t)
1055                 (point-max))
1056             (insert "\n"))
1057         (goto-char (point-min))
1058         (while (search-forward "\n" nil t)
1059           (replace-match "\r\n"))))
1060     send-buf))
1061
1062 (defun elmo-imap4-setup-send-buffer-from-file (file)
1063   (let ((tmp-buf (get-buffer-create
1064                   " *elmo-imap4-setup-send-buffer-from-file*")))
1065     (save-excursion
1066       (save-match-data
1067         (set-buffer tmp-buf)
1068         (erase-buffer)
1069         (as-binary-input-file
1070          (insert-file-contents file))
1071         (goto-char (point-min))
1072         (if (eq (re-search-forward "^$" nil t)
1073                 (point-max))
1074             (insert "\n"))
1075         (goto-char (point-min))
1076         (while (search-forward "\n" nil t)
1077           (replace-match "\r\n"))))
1078     tmp-buf))
1079
1080 (luna-define-method elmo-delete-message-safe ((folder elmo-imap4-folder)
1081                                               number msgid)
1082   (let ((session (elmo-imap4-get-session folder))
1083         candidates)
1084     (elmo-imap4-session-select-mailbox
1085      session
1086      (elmo-imap4-folder-mailbox-internal folder))
1087     (setq candidates
1088           (elmo-imap4-response-value
1089            (elmo-imap4-send-command-wait session
1090                                          (list
1091                                           (if elmo-imap4-use-uid
1092                                               "uid search header message-id "
1093                                             "search header message-id ")
1094                                           (elmo-imap4-field-body msgid)))
1095            'search))
1096     (if (memq number candidates)
1097         (elmo-folder-delete-messages folder (list number)))))
1098
1099 (defun elmo-imap4-server-diff-async-callback-1 (status data)
1100   (funcall elmo-imap4-server-diff-async-callback
1101            (list (elmo-imap4-response-value status 'recent)
1102                  (elmo-imap4-response-value status 'unseen)
1103                  (elmo-imap4-response-value status 'messages))
1104            data))
1105
1106 (defun elmo-imap4-server-diff-async (folder)
1107   (let ((session (elmo-imap4-get-session folder)))
1108     ;; We should `check' folder to obtain newest information here.
1109     ;; But since there's no asynchronous check mechanism in elmo yet,
1110     ;; checking is not done here.
1111     (with-current-buffer (elmo-network-session-buffer session)
1112       (setq elmo-imap4-status-callback
1113             'elmo-imap4-server-diff-async-callback-1)
1114       (setq elmo-imap4-status-callback-data
1115             elmo-imap4-server-diff-async-callback-data))
1116     (elmo-imap4-send-command session
1117                              (list
1118                               "status "
1119                               (elmo-imap4-mailbox
1120                                (elmo-imap4-folder-mailbox-internal folder))
1121                               " (recent unseen messages)"))))
1122
1123 (luna-define-method elmo-server-diff-async ((folder elmo-imap4-folder))
1124   (let ((session (elmo-imap4-get-session folder)))
1125     ;; commit.
1126     ;; (elmo-imap4-commit spec)
1127     (with-current-buffer (elmo-network-session-buffer session)
1128       (setq elmo-imap4-status-callback
1129             'elmo-imap4-server-diff-async-callback-1)
1130       (setq elmo-imap4-status-callback-data
1131             elmo-imap4-server-diff-async-callback-data))
1132     (elmo-imap4-send-command session
1133                              (list
1134                               "status "
1135                               (elmo-imap4-mailbox
1136                                (elmo-imap4-folder-mailbox-internal folder))
1137                               " (recent unseen messages)"))))
1138
1139 ;;; IMAP parser.
1140
1141 (defvar elmo-imap4-server-eol "\r\n"
1142   "The EOL string sent from the server.")
1143
1144 (defvar elmo-imap4-client-eol "\r\n"
1145   "The EOL string we send to the server.")
1146
1147 (defvar elmo-imap4-display-literal-progress nil)
1148
1149 (defun elmo-imap4-find-next-line ()
1150   "Return point at end of current line, taking into account literals.
1151 Return nil if no complete line has arrived."
1152   (when (re-search-forward (concat elmo-imap4-server-eol "\\|{\\([0-9]+\\)}"
1153                                    elmo-imap4-server-eol)
1154                            nil t)
1155     (if (match-string 1)
1156         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1157             (progn
1158               (if (and elmo-imap4-display-literal-progress
1159                        (> (string-to-number (match-string 1))
1160                           (min elmo-display-retrieval-progress-threshold 100)))
1161                   (elmo-display-progress
1162                    'elmo-imap4-display-literal-progress
1163                    (format "Retrieving (%d/%d bytes)..."
1164                            (- (point-max) (point))
1165                            (string-to-number (match-string 1)))
1166                    (/ (- (point-max) (point))
1167                       (/ (string-to-number (match-string 1)) 100))))
1168               nil)
1169           (goto-char (+ (point) (string-to-number (match-string 1))))
1170           (elmo-imap4-find-next-line))
1171       (point))))
1172
1173 (defun elmo-imap4-sentinel (process string)
1174   (delete-process process))
1175
1176 (defun elmo-imap4-arrival-filter (proc string)
1177   "IMAP process filter."
1178   (when (buffer-live-p (process-buffer proc))
1179   (with-current-buffer (process-buffer proc)
1180     (elmo-imap4-debug "-> %s" string)
1181     (goto-char (point-max))
1182     (insert string)
1183     (let (end)
1184       (goto-char (point-min))
1185       (while (setq end (elmo-imap4-find-next-line))
1186         (save-restriction
1187           (narrow-to-region (point-min) end)
1188           (delete-backward-char (length elmo-imap4-server-eol))
1189           (goto-char (point-min))
1190           (unwind-protect
1191               (cond ((eq elmo-imap4-status 'initial)
1192                      (setq elmo-imap4-current-response
1193                            (list
1194                             (list 'greeting (elmo-imap4-parse-greeting)))))
1195                     ((or (eq elmo-imap4-status 'auth)
1196                          (eq elmo-imap4-status 'nonauth)
1197                          (eq elmo-imap4-status 'selected)
1198                          (eq elmo-imap4-status 'examine))
1199                      (setq elmo-imap4-current-response
1200                            (cons
1201                             (elmo-imap4-parse-response)
1202                             elmo-imap4-current-response)))
1203                     (t
1204                      (message "Unknown state %s in arrival filter"
1205                               elmo-imap4-status))))
1206           (delete-region (point-min) (point-max))))))))
1207
1208 ;; IMAP parser.
1209
1210 (defsubst elmo-imap4-forward ()
1211   (or (eobp) (forward-char 1)))
1212
1213 (defsubst elmo-imap4-parse-number ()
1214   (when (looking-at "[0-9]+")
1215     (prog1
1216         (string-to-number (match-string 0))
1217       (goto-char (match-end 0)))))
1218
1219 (defsubst elmo-imap4-parse-literal ()
1220   (when (looking-at "{\\([0-9]+\\)}\r\n")
1221     (let ((pos (match-end 0))
1222           (len (string-to-number (match-string 1))))
1223       (if (< (point-max) (+ pos len))
1224           nil
1225         (goto-char (+ pos len))
1226         (buffer-substring pos (+ pos len))))))
1227 ;;;     (list ' pos (+ pos len))))))
1228
1229 (defsubst elmo-imap4-parse-string ()
1230   (cond ((eq (char-after (point)) ?\")
1231          (forward-char 1)
1232          (let ((p (point)) (name ""))
1233            (skip-chars-forward "^\"\\\\")
1234            (setq name (buffer-substring p (point)))
1235            (while (eq (char-after (point)) ?\\)
1236              (setq p (1+ (point)))
1237              (forward-char 2)
1238              (skip-chars-forward "^\"\\\\")
1239              (setq name (concat name (buffer-substring p (point)))))
1240            (forward-char 1)
1241            name))
1242         ((eq (char-after (point)) ?{)
1243          (elmo-imap4-parse-literal))))
1244
1245 (defsubst elmo-imap4-parse-nil ()
1246   (if (looking-at "NIL")
1247       (goto-char (match-end 0))))
1248
1249 (defsubst elmo-imap4-parse-nstring ()
1250   (or (elmo-imap4-parse-string)
1251       (and (elmo-imap4-parse-nil)
1252            nil)))
1253
1254 (defsubst elmo-imap4-parse-astring ()
1255   (or (elmo-imap4-parse-string)
1256       (buffer-substring (point)
1257                         (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
1258                             (goto-char (1- (match-end 0)))
1259                           (end-of-line)
1260                           (point)))))
1261
1262 (defsubst elmo-imap4-parse-address ()
1263   (let (address)
1264     (when (eq (char-after (point)) ?\()
1265       (elmo-imap4-forward)
1266       (setq address (vector (prog1 (elmo-imap4-parse-nstring)
1267                               (elmo-imap4-forward))
1268                             (prog1 (elmo-imap4-parse-nstring)
1269                               (elmo-imap4-forward))
1270                             (prog1 (elmo-imap4-parse-nstring)
1271                               (elmo-imap4-forward))
1272                             (elmo-imap4-parse-nstring)))
1273       (when (eq (char-after (point)) ?\))
1274         (elmo-imap4-forward)
1275         address))))
1276
1277 (defsubst elmo-imap4-parse-address-list ()
1278   (if (eq (char-after (point)) ?\()
1279       (let (address addresses)
1280         (elmo-imap4-forward)
1281         (while (and (not (eq (char-after (point)) ?\)))
1282                     ;; next line for MS Exchange bug
1283                     (progn (and (eq (char-after (point)) ? ) (elmo-imap4-forward)) t)
1284                     (setq address (elmo-imap4-parse-address)))
1285           (setq addresses (cons address addresses)))
1286         (when (eq (char-after (point)) ?\))
1287           (elmo-imap4-forward)
1288           (nreverse addresses)))
1289     (assert (elmo-imap4-parse-nil))))
1290
1291 (defsubst elmo-imap4-parse-mailbox ()
1292   (let ((mailbox (elmo-imap4-parse-astring)))
1293     (if (string-equal "INBOX" (upcase mailbox))
1294         "INBOX"
1295       mailbox)))
1296
1297 (defun elmo-imap4-parse-greeting ()
1298   "Parse a IMAP greeting."
1299   (cond ((looking-at "\\* OK ")
1300          (setq elmo-imap4-status 'nonauth))
1301         ((looking-at "\\* PREAUTH ")
1302          (setq elmo-imap4-status 'auth))
1303         ((looking-at "\\* BYE ")
1304          (setq elmo-imap4-status 'closed))))
1305
1306 (defun elmo-imap4-parse-response ()
1307   "Parse a IMAP command response."
1308   (let (token)
1309     (case (setq token (elmo-read (current-buffer)))
1310       (+ (progn
1311            (skip-chars-forward " ")
1312            (list 'continue-req (buffer-substring (point) (point-max)))))
1313       (* (case (prog1 (setq token (elmo-read (current-buffer)))
1314                  (elmo-imap4-forward))
1315            (OK         (elmo-imap4-parse-resp-text-code))
1316            (NO         (elmo-imap4-parse-resp-text-code))
1317            (BAD        (elmo-imap4-parse-resp-text-code))
1318            (BYE        (elmo-imap4-parse-bye))
1319            (FLAGS      (list 'flags
1320                              (elmo-imap4-parse-flag-list)))
1321            (LIST       (list 'list (elmo-imap4-parse-data-list)))
1322            (LSUB       (list 'lsub (elmo-imap4-parse-data-list)))
1323            (SEARCH     (list
1324                         'search
1325                         (elmo-read (concat "("
1326                                       (buffer-substring (point) (point-max))
1327                                       ")"))))
1328            (STATUS     (elmo-imap4-parse-status))
1329            ;; Added
1330            (NAMESPACE  (elmo-imap4-parse-namespace))
1331            (CAPABILITY (list 'capability
1332                              (elmo-read
1333                               (concat "(" (downcase (buffer-substring
1334                                                      (point) (point-max)))
1335                                       ")"))))
1336            (ACL (elmo-imap4-parse-acl))
1337            (t       (case (prog1 (elmo-read (current-buffer))
1338                             (elmo-imap4-forward))
1339                       (EXISTS  (list 'exists token))
1340                       (RECENT  (list 'recent token))
1341                       (EXPUNGE (list 'expunge token))
1342                       (FETCH   (elmo-imap4-parse-fetch token))
1343                       (t       (list 'garbage (buffer-string)))))))
1344       (t (if (not (string-match elmo-imap4-seq-prefix (symbol-name token)))
1345              (list 'garbage (buffer-string))
1346            (case (prog1 (elmo-read (current-buffer))
1347                    (elmo-imap4-forward))
1348              (OK  (progn
1349                     (setq elmo-imap4-parsing nil)
1350                     (setq token (symbol-name token))
1351                     (elmo-unintern token)
1352                     (elmo-imap4-debug "*%s* OK arrived" token)
1353                     (setq elmo-imap4-reached-tag token)
1354                     (list 'ok (elmo-imap4-parse-resp-text-code))))
1355              (NO  (progn
1356                     (setq elmo-imap4-parsing nil)
1357                     (setq token (symbol-name token))
1358                     (elmo-unintern token)
1359                     (elmo-imap4-debug "*%s* NO arrived" token)
1360                     (setq elmo-imap4-reached-tag token)
1361                     (let (code text)
1362                       (when (eq (char-after (point)) ?\[)
1363                         (setq code (buffer-substring (point)
1364                                                      (search-forward "]")))
1365                         (elmo-imap4-forward))
1366                       (setq text (buffer-substring (point) (point-max)))
1367                       (list 'no (list code text)))))
1368              (BAD (progn
1369                     (setq elmo-imap4-parsing nil)
1370                     (elmo-imap4-debug "*%s* BAD arrived" token)
1371                     (setq token (symbol-name token))
1372                     (elmo-unintern token)
1373                     (setq elmo-imap4-reached-tag token)
1374                     (let (code text)
1375                       (when (eq (char-after (point)) ?\[)
1376                         (setq code (buffer-substring (point)
1377                                                      (search-forward "]")))
1378                         (elmo-imap4-forward))
1379                       (setq text (buffer-substring (point) (point-max)))
1380                       (list 'bad (list code text)))))
1381              (t   (list 'garbage (buffer-string)))))))))
1382
1383 (defun elmo-imap4-parse-bye ()
1384   (let (code text)
1385     (when (eq (char-after (point)) ?\[)
1386       (setq code (buffer-substring (point)
1387                                    (search-forward "]")))
1388       (elmo-imap4-forward))
1389     (setq text (buffer-substring (point) (point-max)))
1390     (list 'bye (list code text))))
1391
1392 (defun elmo-imap4-parse-text ()
1393   (goto-char (point-min))
1394   (when (search-forward "[" nil t)
1395     (search-forward "]")
1396     (elmo-imap4-forward))
1397   (list 'text (buffer-substring (point) (point-max))))
1398
1399 (defun elmo-imap4-parse-resp-text-code ()
1400   (when (eq (char-after (point)) ?\[)
1401     (elmo-imap4-forward)
1402     (cond ((search-forward "PERMANENTFLAGS " nil t)
1403            (list 'permanentflags (elmo-imap4-parse-flag-list)))
1404           ((search-forward "UIDNEXT " nil t)
1405            (list 'uidnext (elmo-read (current-buffer))))
1406           ((search-forward "UNSEEN " nil t)
1407            (list 'unseen (elmo-read (current-buffer))))
1408           ((looking-at "UIDVALIDITY \\([0-9]+\\)")
1409            (list 'uidvalidity (match-string 1)))
1410           ((search-forward "READ-ONLY" nil t)
1411            (list 'read-only t))
1412           ((search-forward "READ-WRITE" nil t)
1413            (list 'read-write t))
1414           ((search-forward "NEWNAME " nil t)
1415            (let (oldname newname)
1416              (setq oldname (elmo-imap4-parse-string))
1417              (elmo-imap4-forward)
1418              (setq newname (elmo-imap4-parse-string))
1419              (list 'newname newname oldname)))
1420           ((search-forward "TRYCREATE" nil t)
1421            (list 'trycreate t))
1422           ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
1423            (list 'appenduid
1424                  (list (match-string 1)
1425                        (string-to-number (match-string 2)))))
1426           ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
1427            (list 'copyuid (list (match-string 1)
1428                                 (match-string 2)
1429                                 (match-string 3))))
1430           ((search-forward "ALERT] " nil t)
1431            (message "IMAP server information: %s"
1432                     (buffer-substring (point) (point-max))))
1433           (t (list 'unknown)))))
1434
1435 (defun elmo-imap4-parse-data-list ()
1436   (let (flags delimiter mailbox)
1437     (setq flags (elmo-imap4-parse-flag-list))
1438     (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
1439       (setq delimiter (match-string 1))
1440       (goto-char (1+ (match-end 0)))
1441       (when (setq mailbox (elmo-imap4-parse-mailbox))
1442         (list mailbox flags delimiter)))))
1443
1444 (defsubst elmo-imap4-parse-header-list ()
1445   (when (eq (char-after (point)) ?\()
1446     (let (strlist)
1447       (while (not (eq (char-after (point)) ?\)))
1448         (elmo-imap4-forward)
1449         (push (elmo-imap4-parse-astring) strlist))
1450       (elmo-imap4-forward)
1451       (nreverse strlist))))
1452
1453 (defsubst elmo-imap4-parse-fetch-body-section ()
1454   (let ((section
1455          (buffer-substring (point)
1456                            (1-
1457                             (progn (re-search-forward "[] ]" nil t)
1458                                    (point))))))
1459     (if (eq (char-before) ? )
1460         (prog1
1461             (mapconcat 'identity
1462                        (cons section (elmo-imap4-parse-header-list)) " ")
1463           (search-forward "]" nil t))
1464       section)))
1465
1466 (defun elmo-imap4-parse-fetch (response)
1467   (when (eq (char-after (point)) ?\()
1468     (let (element list)
1469       (while (not (eq (char-after (point)) ?\)))
1470         (elmo-imap4-forward)
1471         (let ((token (elmo-imap4-fetch-read (current-buffer))))
1472           (elmo-imap4-forward)
1473           (setq element
1474                 (cond ((eq token 'UID)
1475                        (list 'uid (condition-case nil
1476                                       (elmo-read (current-buffer))
1477                                     (error nil))))
1478                       ((eq token 'FLAGS)
1479                        (list 'flags (elmo-imap4-parse-flag-list)))
1480                       ((eq token 'ENVELOPE)
1481                        (list 'envelope (elmo-imap4-parse-envelope)))
1482                       ((eq token 'INTERNALDATE)
1483                        (list 'internaldate (elmo-imap4-parse-string)))
1484                       ((eq token 'RFC822)
1485                        (list 'rfc822 (elmo-imap4-parse-nstring)))
1486                       ((eq token (intern elmo-imap4-rfc822-header))
1487                        (list 'rfc822header (elmo-imap4-parse-nstring)))
1488                       ((eq token (intern elmo-imap4-rfc822-text))
1489                        (list 'rfc822text (elmo-imap4-parse-nstring)))
1490                       ((eq token (intern elmo-imap4-rfc822-size))
1491                        (list 'rfc822size (elmo-read (current-buffer))))
1492                       ((eq token 'BODY)
1493                        (if (eq (char-before) ?\[)
1494                            (list
1495                             'bodydetail
1496                             (upcase (elmo-imap4-parse-fetch-body-section))
1497                             (and
1498                              (eq (char-after (point)) ?<)
1499                              (buffer-substring (1+ (point))
1500                                                (progn
1501                                                  (search-forward ">" nil t)
1502                                                  (point))))
1503                             (progn (elmo-imap4-forward)
1504                                    (elmo-imap4-parse-nstring)))
1505                          (list 'body (elmo-imap4-parse-body))))
1506                       ((eq token 'BODYSTRUCTURE)
1507                        (list 'bodystructure (elmo-imap4-parse-body)))))
1508           (setq list (cons element list))))
1509       (and elmo-imap4-fetch-callback
1510            (funcall elmo-imap4-fetch-callback
1511                     list elmo-imap4-fetch-callback-data))
1512       (list 'fetch list))))
1513
1514 (defun elmo-imap4-parse-status ()
1515   (let ((mailbox (elmo-imap4-parse-mailbox))
1516         status)
1517     (when (and mailbox (search-forward "(" nil t))
1518       (while (not (eq (char-after (point)) ?\)))
1519         (setq status
1520               (cons
1521                (let ((token (elmo-read (current-buffer))))
1522                  (cond ((eq token 'MESSAGES)
1523                         (list 'messages (elmo-read (current-buffer))))
1524                        ((eq token 'RECENT)
1525                         (list 'recent (elmo-read (current-buffer))))
1526                        ((eq token 'UIDNEXT)
1527                         (list 'uidnext (elmo-read (current-buffer))))
1528                        ((eq token 'UIDVALIDITY)
1529                         (and (looking-at " \\([0-9]+\\)")
1530                              (prog1 (list 'uidvalidity (match-string 1))
1531                                (goto-char (match-end 1)))))
1532                        ((eq token 'UNSEEN)
1533                         (list 'unseen (elmo-read (current-buffer))))
1534                        (t
1535                         (message
1536                          "Unknown status data %s in mailbox %s ignored"
1537                          token mailbox))))
1538                status))))
1539     (and elmo-imap4-status-callback
1540          (funcall elmo-imap4-status-callback
1541                   status
1542                   elmo-imap4-status-callback-data))
1543     (list 'status status)))
1544
1545
1546 (defmacro elmo-imap4-value (value)
1547   (` (if (eq (, value) 'NIL) nil
1548        (, value))))
1549
1550 (defmacro elmo-imap4-nth (pos list)
1551   (` (let ((value (nth (, pos) (, list))))
1552        (elmo-imap4-value value))))
1553
1554 (defun elmo-imap4-parse-namespace ()
1555   (list 'namespace
1556         (nconc
1557          (copy-sequence elmo-imap4-extra-namespace-alist)
1558          (elmo-imap4-parse-namespace-subr
1559           (elmo-read (concat "(" (buffer-substring
1560                                   (point) (point-max))
1561                              ")"))))))
1562
1563 (defun elmo-imap4-parse-namespace-subr (ns)
1564   (let (prefix delim namespace-alist default-delim)
1565     ;; 0: personal, 1: other, 2: shared
1566     (dotimes (i 3)
1567       (setq namespace-alist
1568             (nconc namespace-alist
1569                    (delq nil
1570                          (mapcar
1571                           (lambda (namespace)
1572                             (setq prefix (elmo-imap4-nth 0 namespace)
1573                                   delim (elmo-imap4-nth 1 namespace))
1574                             (if (and prefix delim
1575                                      (string-match
1576                                       (concat (regexp-quote delim) "\\'")
1577                                       prefix))
1578                                 (setq prefix (substring prefix 0
1579                                                         (match-beginning 0))))
1580                             (if (eq (length prefix) 0)
1581                                 (progn (setq default-delim delim) nil)
1582                               (cons
1583                                (concat "^"
1584                                        (if (string= (downcase prefix) "inbox")
1585                                            "[Ii][Nn][Bb][Oo][Xx]"
1586                                          (regexp-quote prefix))
1587                                        ".*$")
1588                                delim)))
1589                           (elmo-imap4-nth i ns))))))
1590     (if default-delim
1591         (setq namespace-alist
1592               (nconc namespace-alist
1593                      (list (cons "^.*$" default-delim)))))
1594     namespace-alist))
1595
1596 (defun elmo-imap4-parse-acl ()
1597   (let ((mailbox (elmo-imap4-parse-mailbox))
1598         identifier rights acl)
1599     (while (eq (char-after (point)) ?\ )
1600       (elmo-imap4-forward)
1601       (setq identifier (elmo-imap4-parse-astring))
1602       (elmo-imap4-forward)
1603       (setq rights (elmo-imap4-parse-astring))
1604       (setq acl (append acl (list (cons identifier rights)))))
1605     (list 'acl acl mailbox)))
1606
1607 (defun elmo-imap4-parse-flag-list ()
1608   (let ((str (buffer-substring (+ (point) 1)
1609                                (progn (search-forward ")" nil t)
1610                                       (- (point) 1)))))
1611     (unless (eq (length str) 0)
1612       (split-string str))))
1613
1614 (defun elmo-imap4-parse-envelope ()
1615   (when (eq (char-after (point)) ?\()
1616     (elmo-imap4-forward)
1617     (vector (prog1 (elmo-imap4-parse-nstring);; date
1618               (elmo-imap4-forward))
1619             (prog1 (elmo-imap4-parse-nstring);; subject
1620               (elmo-imap4-forward))
1621             (prog1 (elmo-imap4-parse-address-list);; from
1622               (elmo-imap4-forward))
1623             (prog1 (elmo-imap4-parse-address-list);; sender
1624               (elmo-imap4-forward))
1625             (prog1 (elmo-imap4-parse-address-list);; reply-to
1626               (elmo-imap4-forward))
1627             (prog1 (elmo-imap4-parse-address-list);; to
1628               (elmo-imap4-forward))
1629             (prog1 (elmo-imap4-parse-address-list);; cc
1630               (elmo-imap4-forward))
1631             (prog1 (elmo-imap4-parse-address-list);; bcc
1632               (elmo-imap4-forward))
1633             (prog1 (elmo-imap4-parse-nstring);; in-reply-to
1634               (elmo-imap4-forward))
1635             (prog1 (elmo-imap4-parse-nstring);; message-id
1636               (elmo-imap4-forward)))))
1637
1638 (defsubst elmo-imap4-parse-string-list ()
1639   (cond ((eq (char-after (point)) ?\();; body-fld-param
1640          (let (strlist str)
1641            (elmo-imap4-forward)
1642            (while (setq str (elmo-imap4-parse-string))
1643              (push str strlist)
1644              (elmo-imap4-forward))
1645            (nreverse strlist)))
1646         ((elmo-imap4-parse-nil)
1647          nil)))
1648
1649 (defun elmo-imap4-parse-body-extension ()
1650   (if (eq (char-after (point)) ?\()
1651       (let (b-e)
1652         (elmo-imap4-forward)
1653         (push (elmo-imap4-parse-body-extension) b-e)
1654         (while (eq (char-after (point)) ?\ )
1655           (elmo-imap4-forward)
1656           (push (elmo-imap4-parse-body-extension) b-e))
1657         (assert (eq (char-after (point)) ?\)))
1658         (elmo-imap4-forward)
1659         (nreverse b-e))
1660     (or (elmo-imap4-parse-number)
1661         (elmo-imap4-parse-nstring))))
1662
1663 (defsubst elmo-imap4-parse-body-ext ()
1664   (let (ext)
1665     (when (eq (char-after (point)) ?\ );; body-fld-dsp
1666       (elmo-imap4-forward)
1667       (let (dsp)
1668         (if (eq (char-after (point)) ?\()
1669             (progn
1670               (elmo-imap4-forward)
1671               (push (elmo-imap4-parse-string) dsp)
1672               (elmo-imap4-forward)
1673               (push (elmo-imap4-parse-string-list) dsp)
1674               (elmo-imap4-forward))
1675           (assert (elmo-imap4-parse-nil)))
1676         (push (nreverse dsp) ext))
1677       (when (eq (char-after (point)) ?\ );; body-fld-lang
1678         (elmo-imap4-forward)
1679         (if (eq (char-after (point)) ?\()
1680             (push (elmo-imap4-parse-string-list) ext)
1681           (push (elmo-imap4-parse-nstring) ext))
1682         (while (eq (char-after (point)) ?\ );; body-extension
1683           (elmo-imap4-forward)
1684           (setq ext (append (elmo-imap4-parse-body-extension) ext)))))
1685     ext))
1686
1687 (defun elmo-imap4-parse-body ()
1688   (let (body)
1689     (when (eq (char-after (point)) ?\()
1690       (elmo-imap4-forward)
1691       (if (eq (char-after (point)) ?\()
1692           (let (subbody)
1693             (while (and (eq (char-after (point)) ?\()
1694                         (setq subbody (elmo-imap4-parse-body)))
1695               (push subbody body))
1696             (elmo-imap4-forward)
1697             (push (elmo-imap4-parse-string) body);; media-subtype
1698             (when (eq (char-after (point)) ?\ );; body-ext-mpart:
1699               (elmo-imap4-forward)
1700               (if (eq (char-after (point)) ?\();; body-fld-param
1701                   (push (elmo-imap4-parse-string-list) body)
1702                 (push (and (elmo-imap4-parse-nil) nil) body))
1703               (setq body
1704                     (append (elmo-imap4-parse-body-ext) body)));; body-ext-...
1705             (assert (eq (char-after (point)) ?\)))
1706             (elmo-imap4-forward)
1707             (nreverse body))
1708
1709         (push (elmo-imap4-parse-string) body);; media-type
1710         (elmo-imap4-forward)
1711         (push (elmo-imap4-parse-string) body);; media-subtype
1712         (elmo-imap4-forward)
1713         ;; next line for Sun SIMS bug
1714         (and (eq (char-after (point)) ? ) (elmo-imap4-forward))
1715         (if (eq (char-after (point)) ?\();; body-fld-param
1716             (push (elmo-imap4-parse-string-list) body)
1717           (push (and (elmo-imap4-parse-nil) nil) body))
1718         (elmo-imap4-forward)
1719         (push (elmo-imap4-parse-nstring) body);; body-fld-id
1720         (elmo-imap4-forward)
1721         (push (elmo-imap4-parse-nstring) body);; body-fld-desc
1722         (elmo-imap4-forward)
1723         (push (elmo-imap4-parse-string) body);; body-fld-enc
1724         (elmo-imap4-forward)
1725         (push (elmo-imap4-parse-number) body);; body-fld-octets
1726
1727         ;; ok, we're done parsing the required parts, what comes now is one
1728         ;; of three things:
1729         ;;
1730         ;; envelope       (then we're parsing body-type-msg)
1731         ;; body-fld-lines (then we're parsing body-type-text)
1732         ;; body-ext-1part (then we're parsing body-type-basic)
1733         ;;
1734         ;; the problem is that the two first are in turn optionally followed
1735         ;; by the third.  So we parse the first two here (if there are any)...
1736
1737         (when (eq (char-after (point)) ?\ )
1738           (elmo-imap4-forward)
1739           (let (lines)
1740             (cond ((eq (char-after (point)) ?\();; body-type-msg:
1741                    (push (elmo-imap4-parse-envelope) body);; envelope
1742                    (elmo-imap4-forward)
1743                    (push (elmo-imap4-parse-body) body);; body
1744                    (elmo-imap4-forward)
1745                    (push (elmo-imap4-parse-number) body));; body-fld-lines
1746                   ((setq lines (elmo-imap4-parse-number));; body-type-text:
1747                    (push lines body));; body-fld-lines
1748                   (t
1749                    (backward-char)))));; no match...
1750
1751         ;; ...and then parse the third one here...
1752
1753         (when (eq (char-after (point)) ?\ );; body-ext-1part:
1754           (elmo-imap4-forward)
1755           (push (elmo-imap4-parse-nstring) body);; body-fld-md5
1756           (setq body
1757                 (append (elmo-imap4-parse-body-ext) body)));; body-ext-1part..
1758
1759         (assert (eq (char-after (point)) ?\)))
1760         (elmo-imap4-forward)
1761         (nreverse body)))))
1762
1763 (luna-define-method elmo-folder-initialize :around ((folder
1764                                                      elmo-imap4-folder)
1765                                                     name)
1766   (let ((default-user   elmo-imap4-default-user)
1767         (default-server elmo-imap4-default-server)
1768         (default-port   elmo-imap4-default-port)
1769         (elmo-network-stream-type-alist
1770          (if elmo-imap4-stream-type-alist
1771              (append elmo-imap4-stream-type-alist
1772                      elmo-network-stream-type-alist)
1773            elmo-network-stream-type-alist))
1774         parse)
1775     (when (string-match "\\(.*\\)@\\(.*\\)" default-server)
1776       ;; case: imap4-default-server is specified like
1777       ;; "hoge%imap.server@gateway".
1778       (setq default-user (elmo-match-string 1 default-server))
1779       (setq default-server (elmo-match-string 2 default-server)))
1780     (setq name (luna-call-next-method))
1781     ;; mailbox
1782     (setq parse (elmo-parse-token name ":"))
1783     (elmo-imap4-folder-set-mailbox-internal folder
1784                                             (elmo-imap4-encode-folder-string
1785                                              (if (eq (length (car parse)) 0)
1786                                                  elmo-imap4-default-mailbox
1787                                                (car parse))))
1788     ;; user
1789     (setq parse (elmo-parse-prefixed-element ?: (cdr parse) "/"))
1790     (elmo-net-folder-set-user-internal folder
1791                                        (if (eq (length (car parse)) 0)
1792                                            default-user
1793                                          (car parse)))
1794     ;; auth
1795     (setq parse (elmo-parse-prefixed-element ?/ (cdr parse)))
1796     (elmo-net-folder-set-auth-internal
1797      folder
1798      (if (eq (length (car parse)) 0)
1799          (or elmo-imap4-default-authenticate-type 'clear)
1800        (intern (car parse))))
1801     (unless (elmo-net-folder-server-internal folder)
1802       (elmo-net-folder-set-server-internal folder default-server))
1803     (unless (elmo-net-folder-port-internal folder)
1804       (elmo-net-folder-set-port-internal folder default-port))
1805     (unless (elmo-net-folder-stream-type-internal folder)
1806       (elmo-net-folder-set-stream-type-internal
1807        folder
1808        (elmo-get-network-stream-type elmo-imap4-default-stream-type)))
1809     folder))
1810
1811 ;;; ELMO IMAP4 folder
1812 (luna-define-method elmo-folder-expand-msgdb-path ((folder
1813                                                     elmo-imap4-folder))
1814   (convert-standard-filename
1815    (let ((mailbox (elmo-imap4-folder-mailbox-internal folder)))
1816      (if (string= "inbox" (downcase mailbox))
1817          (setq mailbox "inbox"))
1818      (if (eq (string-to-char mailbox) ?/)
1819          (setq mailbox (substring mailbox 1 (length mailbox))))
1820      (expand-file-name
1821       mailbox
1822       (expand-file-name
1823        (or (elmo-net-folder-user-internal folder) "nobody")
1824        (expand-file-name (or (elmo-net-folder-server-internal folder)
1825                              "nowhere")
1826                          (expand-file-name
1827                           "imap"
1828                           elmo-msgdb-directory)))))))
1829
1830 (luna-define-method elmo-folder-status-plugged ((folder
1831                                                  elmo-imap4-folder))
1832   (elmo-imap4-folder-status-plugged folder))
1833
1834 (defun elmo-imap4-folder-status-plugged (folder)
1835   (let ((session (elmo-imap4-get-session folder))
1836         (killed (elmo-msgdb-killed-list-load
1837                  (elmo-folder-msgdb-path folder)))
1838         status)
1839     (with-current-buffer (elmo-network-session-buffer session)
1840       (setq elmo-imap4-status-callback nil)
1841       (setq elmo-imap4-status-callback-data nil))
1842     (setq status (elmo-imap4-response-value
1843                   (elmo-imap4-send-command-wait
1844                    session
1845                    (list "status "
1846                          (elmo-imap4-mailbox
1847                           (elmo-imap4-folder-mailbox-internal folder))
1848                          " (uidnext messages)"))
1849                   'status))
1850     (cons
1851      (- (elmo-imap4-response-value status 'uidnext) 1)
1852      (if killed
1853          (-
1854           (elmo-imap4-response-value status 'messages)
1855           (elmo-msgdb-killed-list-length killed))
1856        (elmo-imap4-response-value status 'messages)))))
1857
1858 (luna-define-method elmo-folder-list-messages-plugged ((folder
1859                                                         elmo-imap4-folder)
1860                                                        &optional nohide)
1861   (elmo-imap4-list folder
1862                    (let ((max (elmo-msgdb-max-of-killed
1863                                (elmo-folder-killed-list-internal folder))))
1864                      (if (or nohide
1865                              (null (eq max 0)))
1866                          (format "uid %d:*" (1+ max))
1867                        "all"))))
1868
1869 (luna-define-method elmo-folder-list-unreads-plugged
1870   ((folder elmo-imap4-folder))
1871   (elmo-imap4-list folder "unseen"))
1872
1873 (luna-define-method elmo-folder-list-importants-plugged
1874   ((folder elmo-imap4-folder))
1875   (elmo-imap4-list folder "flagged"))
1876
1877 (luna-define-method elmo-folder-use-flag-p ((folder elmo-imap4-folder))
1878   (not (string-match elmo-imap4-disuse-server-flag-mailbox-regexp
1879                      (elmo-imap4-folder-mailbox-internal folder))))
1880
1881 (luna-define-method elmo-folder-list-subfolders ((folder elmo-imap4-folder)
1882                                                  &optional one-level)
1883   (let* ((root (elmo-imap4-folder-mailbox-internal folder))
1884          (session (elmo-imap4-get-session folder))
1885          (prefix (elmo-folder-prefix-internal folder))
1886          (delim (or
1887                  (cdr
1888                   (elmo-string-matched-assoc
1889                    root
1890                    (with-current-buffer (elmo-network-session-buffer session)
1891                      elmo-imap4-server-namespace)))
1892                  elmo-imap4-default-hierarchy-delimiter))
1893          result append-serv type)
1894     (setq result (elmo-imap4-response-get-selectable-mailbox-list
1895                   (elmo-imap4-send-command-wait
1896                    session
1897                    (list "list " (elmo-imap4-mailbox root) " *"))))
1898     (unless (string= (elmo-net-folder-user-internal folder)
1899                      elmo-imap4-default-user)
1900       (setq append-serv (concat ":" (elmo-net-folder-user-internal folder))))
1901     (unless (eq (elmo-net-folder-auth-internal folder)
1902                 (or elmo-imap4-default-authenticate-type 'clear))
1903       (setq append-serv
1904             (concat append-serv "/"
1905                     (symbol-name (elmo-net-folder-auth-internal folder)))))
1906     (unless (string= (elmo-net-folder-server-internal folder)
1907                      elmo-imap4-default-server)
1908       (setq append-serv (concat append-serv "@"
1909                                 (elmo-net-folder-server-internal folder))))
1910     (unless (eq (elmo-net-folder-port-internal folder) elmo-imap4-default-port)
1911       (setq append-serv (concat append-serv ":"
1912                                 (int-to-string
1913                                  (elmo-net-folder-port-internal folder)))))
1914     (setq type (elmo-net-folder-stream-type-internal folder))
1915     (unless (eq (elmo-network-stream-type-symbol type)
1916                 elmo-imap4-default-stream-type)
1917       (if type
1918           (setq append-serv (concat append-serv
1919                                     (elmo-network-stream-type-spec-string
1920                                      type)))))
1921     (if one-level
1922         (let ((re-delim (regexp-quote delim))
1923               folder ret has-child-p)
1924           ;; Append delimiter
1925           (when (and root
1926                      (not (string= root ""))
1927                      (not (string-match
1928                            (concat "\\(.*\\)" re-delim "\\'")
1929                            root)))
1930             (setq root (concat root delim)))
1931           (while (setq folder (car result))
1932             (when (string-match
1933                    (concat "^\\(" (regexp-quote root) "[^" re-delim "]" "+\\)"
1934                            re-delim)
1935                    folder)
1936               (setq folder (match-string 1 folder)))
1937             (setq has-child-p nil
1938                   result (delq
1939                           nil
1940                           (mapcar (lambda (fld)
1941                                     (if (string-match
1942                                          (concat "^" (regexp-quote folder)
1943                                                  "\\(" re-delim "\\|\\'\\)")
1944                                          fld)
1945                                         (progn (setq has-child-p t) nil)
1946                                       fld))
1947                                   (cdr result)))
1948                   folder (concat prefix
1949                                  (elmo-imap4-decode-folder-string folder)
1950                                  (and append-serv
1951                                       (eval append-serv)))
1952                   ret (append ret (if has-child-p
1953                                       (list (list folder))
1954                                     (list folder)))))
1955           ret)
1956       (mapcar (lambda (fld)
1957                 (concat prefix (elmo-imap4-decode-folder-string fld)
1958                         (and append-serv
1959                              (eval append-serv))))
1960               result))))
1961
1962 (luna-define-method elmo-folder-exists-p-plugged ((folder elmo-imap4-folder))
1963   (let ((session (elmo-imap4-get-session folder)))
1964     (if (string=
1965          (elmo-imap4-session-current-mailbox-internal session)
1966          (elmo-imap4-folder-mailbox-internal folder))
1967         t
1968       (elmo-imap4-session-select-mailbox
1969        session
1970        (elmo-imap4-folder-mailbox-internal folder)
1971        'force 'notify-bye))))
1972
1973 (luna-define-method elmo-folder-writable-p ((folder elmo-imap4-folder))
1974   t)
1975
1976 (luna-define-method elmo-folder-delete :before ((folder elmo-imap4-folder))
1977   (let ((session (elmo-imap4-get-session folder))
1978         msgs)
1979     (when (elmo-imap4-folder-mailbox-internal folder)
1980       (when (setq msgs (elmo-folder-list-messages folder))
1981         (elmo-folder-delete-messages folder msgs))
1982       (elmo-imap4-send-command-wait session "close")
1983       (elmo-imap4-send-command-wait
1984        session
1985        (list "delete "
1986              (elmo-imap4-mailbox
1987               (elmo-imap4-folder-mailbox-internal folder)))))))
1988
1989 (luna-define-method elmo-folder-rename-internal ((folder elmo-imap4-folder)
1990                                                  new-folder)
1991   (let ((session (elmo-imap4-get-session folder)))
1992     ;; make sure the folder is selected.
1993     (elmo-imap4-session-select-mailbox session
1994                                        (elmo-imap4-folder-mailbox-internal
1995                                         folder))
1996     (elmo-imap4-send-command-wait session "close")
1997     (elmo-imap4-send-command-wait
1998      session
1999      (list "rename "
2000            (elmo-imap4-mailbox
2001             (elmo-imap4-folder-mailbox-internal folder))
2002            " "
2003            (elmo-imap4-mailbox
2004             (elmo-imap4-folder-mailbox-internal new-folder))))))
2005
2006 (defun elmo-imap4-copy-messages (src-folder dst-folder numbers)
2007   (let ((session (elmo-imap4-get-session src-folder))
2008         (set-list (elmo-imap4-make-number-set-list
2009                    numbers
2010                    elmo-imap4-number-set-chop-length))
2011         succeeds)
2012     (elmo-imap4-session-select-mailbox session
2013                                        (elmo-imap4-folder-mailbox-internal
2014                                         src-folder))
2015     (while set-list
2016       (if (elmo-imap4-send-command-wait session
2017                                         (list
2018                                          (format
2019                                           (if elmo-imap4-use-uid
2020                                               "uid copy %s "
2021                                             "copy %s ")
2022                                           (cdr (car set-list)))
2023                                          (elmo-imap4-mailbox
2024                                           (elmo-imap4-folder-mailbox-internal
2025                                            dst-folder))))
2026           (setq succeeds (append succeeds numbers)))
2027       (setq set-list (cdr set-list)))
2028     succeeds))
2029
2030 (defun elmo-imap4-set-flag (folder numbers flag &optional remove)
2031   "Set flag on messages.
2032 FOLDER is the ELMO folder structure.
2033 NUMBERS is the message numbers to be flagged.
2034 FLAG is the flag name.
2035 If optional argument REMOVE is non-nil, remove FLAG."
2036   (let ((session (elmo-imap4-get-session folder))
2037         response set-list)
2038     (elmo-imap4-session-select-mailbox session
2039                                        (elmo-imap4-folder-mailbox-internal
2040                                         folder))
2041     (setq set-list (elmo-imap4-make-number-set-list
2042                     numbers
2043                     elmo-imap4-number-set-chop-length))
2044     (while set-list
2045       (with-current-buffer (elmo-network-session-buffer session)
2046         (setq elmo-imap4-fetch-callback nil)
2047         (setq elmo-imap4-fetch-callback-data nil))
2048       (unless (elmo-imap4-response-ok-p
2049                (elmo-imap4-send-command-wait
2050                 session
2051                 (format
2052                  (if elmo-imap4-use-uid
2053                      "uid store %s %sflags.silent (%s)"
2054                    "store %s %sflags.silent (%s)")
2055                  (cdr (car set-list))
2056                  (if remove "-" "+")
2057                  flag)))
2058         (setq response 'fail))
2059       (setq set-list (cdr set-list)))
2060     (not (eq response 'fail))))
2061
2062 (luna-define-method elmo-folder-delete-messages-plugged
2063   ((folder elmo-imap4-folder) numbers)
2064   (let ((session (elmo-imap4-get-session folder)))
2065     (elmo-imap4-set-flag folder numbers "\\Deleted")
2066     (elmo-imap4-send-command-wait session "expunge")))
2067
2068 (defmacro elmo-imap4-detect-search-charset (string)
2069   (` (with-temp-buffer
2070        (insert (, string))
2071        (detect-mime-charset-region (point-min) (point-max)))))
2072
2073 (defun elmo-imap4-search-internal-primitive (folder session filter from-msgs)
2074   (let ((search-key (elmo-filter-key filter))
2075         (imap-search-keys '("bcc" "body" "cc" "from" "subject" "to"))
2076         (total 0)
2077         (length (length from-msgs))
2078         charset set-list end results)
2079     (message "Searching...")
2080     (cond
2081      ((string= "last" search-key)
2082       (let ((numbers (or from-msgs (elmo-folder-list-messages folder))))
2083         (nthcdr (max (- (length numbers)
2084                         (string-to-int (elmo-filter-value filter)))
2085                      0)
2086                 numbers)))
2087      ((string= "first" search-key)
2088       (let* ((numbers (or from-msgs (elmo-folder-list-messages folder)))
2089              (rest (nthcdr (string-to-int (elmo-filter-value filter) )
2090                            numbers)))
2091         (mapcar '(lambda (x) (delete x numbers)) rest)
2092         numbers))
2093      ((or (string= "since" search-key)
2094           (string= "before" search-key))
2095       (setq search-key (concat "sent" search-key)
2096             set-list (elmo-imap4-make-number-set-list
2097                       from-msgs
2098                       elmo-imap4-number-set-chop-length)
2099             end nil)
2100       (while (not end)
2101         (setq results
2102               (append
2103                results
2104                (elmo-imap4-response-value
2105                 (elmo-imap4-send-command-wait
2106                  session
2107                  (format
2108                   (if elmo-imap4-use-uid
2109                       "uid search %s%s%s %s"
2110                     "search %s%s%s %s")
2111                   (if from-msgs
2112                       (concat
2113                        (if elmo-imap4-use-uid "uid ")
2114                        (cdr (car set-list))
2115                        " ")
2116                     "")
2117                   (if (eq (elmo-filter-type filter)
2118                           'unmatch)
2119                       "not " "")
2120                   search-key
2121                   (elmo-date-get-description
2122                    (elmo-date-get-datevec
2123                     (elmo-filter-value filter)))))
2124                 'search)))
2125         (when (> length elmo-display-progress-threshold)
2126           (setq total (+ total (car (car set-list))))
2127           (elmo-display-progress
2128            'elmo-imap4-search "Searching..."
2129            (/ (* total 100) length)))
2130         (setq set-list (cdr set-list)
2131               end (null set-list)))
2132       results)
2133      (t
2134       (setq charset
2135             (if (eq (length (elmo-filter-value filter)) 0)
2136                 (setq charset 'us-ascii)
2137               (elmo-imap4-detect-search-charset
2138                (elmo-filter-value filter)))
2139             set-list (elmo-imap4-make-number-set-list
2140                       from-msgs
2141                       elmo-imap4-number-set-chop-length)
2142             end nil)
2143       (while (not end)
2144         (setq results
2145               (append
2146                results
2147                (elmo-imap4-response-value
2148                 (elmo-imap4-send-command-wait
2149                  session
2150                  (list
2151                   (if elmo-imap4-use-uid "uid ")
2152                   "search "
2153                   "CHARSET "
2154                   (elmo-imap4-astring
2155                    (symbol-name charset))
2156                   " "
2157                   (if from-msgs
2158                       (concat
2159                        (if elmo-imap4-use-uid "uid ")
2160                        (cdr (car set-list))
2161                        " ")
2162                     "")
2163                   (if (eq (elmo-filter-type filter)
2164                           'unmatch)
2165                       "not " "")
2166                   (format "%s%s "
2167                           (if (member
2168                                (elmo-filter-key filter)
2169                                imap-search-keys)
2170                               ""
2171                             "header ")
2172                           (elmo-filter-key filter))
2173                   (elmo-imap4-astring
2174                    (encode-mime-charset-string
2175                     (elmo-filter-value filter) charset))))
2176                 'search)))
2177         (when (> length elmo-display-progress-threshold)
2178           (setq total (+ total (car (car set-list))))
2179           (elmo-display-progress
2180            'elmo-imap4-search "Searching..."
2181            (/ (* total 100) length)))
2182         (setq set-list (cdr set-list)
2183               end (null set-list)))
2184       results))))
2185
2186 (defun elmo-imap4-search-internal (folder session condition from-msgs)
2187   (let (result)
2188     (cond
2189      ((vectorp condition)
2190       (setq result (elmo-imap4-search-internal-primitive
2191                     folder session condition from-msgs)))
2192      ((eq (car condition) 'and)
2193       (setq result (elmo-imap4-search-internal folder session (nth 1 condition)
2194                                                from-msgs)
2195             result (elmo-list-filter result
2196                                      (elmo-imap4-search-internal
2197                                       folder session (nth 2 condition)
2198                                       from-msgs))))
2199      ((eq (car condition) 'or)
2200       (setq result (elmo-imap4-search-internal
2201                     folder session (nth 1 condition) from-msgs)
2202             result (elmo-uniq-list
2203                     (nconc result
2204                            (elmo-imap4-search-internal
2205                             folder session (nth 2 condition) from-msgs)))
2206             result (sort result '<))))))
2207
2208 (luna-define-method elmo-folder-search ((folder elmo-imap4-folder)
2209                                         condition &optional numbers)
2210   (save-excursion
2211     (let ((session (elmo-imap4-get-session folder)))
2212       (elmo-imap4-session-select-mailbox
2213        session
2214        (elmo-imap4-folder-mailbox-internal folder))
2215       (elmo-imap4-search-internal folder session condition numbers))))
2216
2217 (luna-define-method elmo-folder-msgdb-create-plugged
2218   ((folder elmo-imap4-folder) numbers &rest args)
2219   (when numbers
2220     (let ((session (elmo-imap4-get-session folder))
2221           (headers
2222            (append
2223             '("Subject" "From" "To" "Cc" "Date"
2224               "Message-Id" "References" "In-Reply-To")
2225             elmo-msgdb-extra-fields))
2226           (total 0)
2227           (length (length numbers))
2228           rfc2060 set-list)
2229       (setq rfc2060 (memq 'imap4rev1
2230                           (elmo-imap4-session-capability-internal
2231                            session)))
2232       (message "Getting overview...")
2233       (elmo-imap4-session-select-mailbox
2234        session (elmo-imap4-folder-mailbox-internal folder))
2235       (setq set-list (elmo-imap4-make-number-set-list
2236                       numbers
2237                       elmo-imap4-overview-fetch-chop-length))
2238       ;; Setup callback.
2239       (with-current-buffer (elmo-network-session-buffer session)
2240         (setq elmo-imap4-current-msgdb nil
2241               elmo-imap4-seen-messages nil
2242               elmo-imap4-fetch-callback 'elmo-imap4-fetch-callback-1
2243               elmo-imap4-fetch-callback-data (cons args
2244                                                    (elmo-folder-use-flag-p
2245                                                     folder)))
2246         (while set-list
2247           (elmo-imap4-send-command-wait
2248            session
2249            ;; get overview entity from IMAP4
2250            (format "%sfetch %s (%s rfc822.size flags)"
2251                    (if elmo-imap4-use-uid "uid " "")
2252                    (cdr (car set-list))
2253                    (if rfc2060
2254                        (format "body.peek[header.fields %s]" headers)
2255                      (format "%s" headers))))
2256           (when (> length elmo-display-progress-threshold)
2257             (setq total (+ total (car (car set-list))))
2258             (elmo-display-progress
2259              'elmo-imap4-msgdb-create "Getting overview..."
2260              (/ (* total 100) length)))
2261           (setq set-list (cdr set-list)))
2262         (message "Getting overview...done")
2263         (when elmo-imap4-seen-messages
2264           (elmo-imap4-set-flag folder elmo-imap4-seen-messages "\\Seen"))
2265         elmo-imap4-current-msgdb))))
2266
2267 (luna-define-method elmo-folder-unmark-important-plugged
2268   ((folder elmo-imap4-folder) numbers)
2269   (elmo-imap4-set-flag folder numbers "\\Flagged" 'remove))
2270
2271 (luna-define-method elmo-folder-mark-as-important-plugged
2272   ((folder elmo-imap4-folder) numbers)
2273   (elmo-imap4-set-flag folder numbers "\\Flagged"))
2274
2275 (luna-define-method elmo-folder-unmark-read-plugged
2276   ((folder elmo-imap4-folder) numbers)
2277   (elmo-imap4-set-flag folder numbers "\\Seen" 'remove))
2278
2279 (luna-define-method elmo-folder-mark-as-read-plugged
2280   ((folder elmo-imap4-folder) numbers)
2281   (elmo-imap4-set-flag folder numbers "\\Seen"))
2282
2283 (luna-define-method elmo-message-use-cache-p ((folder elmo-imap4-folder)
2284                                               number)
2285   elmo-imap4-use-cache)
2286
2287 (luna-define-method elmo-folder-message-appendable-p ((folder elmo-imap4-folder))
2288   (if (elmo-folder-plugged-p folder)
2289       (not (elmo-imap4-session-read-only-internal
2290             (elmo-imap4-get-session folder)))
2291     elmo-enable-disconnected-operation)) ; offline refile.
2292
2293 (luna-define-method elmo-folder-check-plugged ((folder elmo-imap4-folder))
2294   (let ((session (elmo-imap4-get-session folder 'if-exists)))
2295     (when session
2296       (if (string=
2297            (elmo-imap4-session-current-mailbox-internal session)
2298            (elmo-imap4-folder-mailbox-internal folder))
2299           (if elmo-imap4-use-select-to-update-status
2300               (elmo-imap4-session-select-mailbox
2301                session
2302                (elmo-imap4-folder-mailbox-internal folder)
2303                'force)
2304             (elmo-imap4-session-check session))))))
2305
2306 (defsubst elmo-imap4-folder-diff-plugged (folder)
2307   (let ((session (elmo-imap4-get-session folder))
2308         messages
2309         response killed)
2310 ;;; (elmo-imap4-commit spec)
2311     (with-current-buffer (elmo-network-session-buffer session)
2312       (setq elmo-imap4-status-callback nil)
2313       (setq elmo-imap4-status-callback-data nil))
2314     (setq response
2315           (elmo-imap4-send-command-wait session
2316                                         (list
2317                                          "status "
2318                                          (elmo-imap4-mailbox
2319                                           (elmo-imap4-folder-mailbox-internal
2320                                            folder))
2321                                          " (recent unseen messages)")))
2322     (setq response (elmo-imap4-response-value response 'status))
2323     (setq messages (elmo-imap4-response-value response 'messages))
2324     (setq killed (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder)))
2325     (if killed
2326         (setq messages (- messages
2327                           (elmo-msgdb-killed-list-length
2328                            killed))))
2329     (list (elmo-imap4-response-value response 'recent)
2330           (elmo-imap4-response-value response 'unseen)
2331           messages)))
2332
2333 (luna-define-method elmo-folder-diff-plugged ((folder elmo-imap4-folder))
2334   (elmo-imap4-folder-diff-plugged folder))
2335
2336 (luna-define-method elmo-folder-diff-async ((folder elmo-imap4-folder)
2337                                             &optional number-alist)
2338   (setq elmo-imap4-server-diff-async-callback
2339         elmo-folder-diff-async-callback)
2340   (setq elmo-imap4-server-diff-async-callback-data
2341         elmo-folder-diff-async-callback-data)
2342   (elmo-imap4-server-diff-async folder))
2343
2344 (luna-define-method elmo-folder-open :around ((folder elmo-imap4-folder)
2345                                               &optional load-msgdb)
2346   (if (elmo-folder-plugged-p folder)
2347       (let (session mailbox msgdb response tag)
2348         (condition-case err
2349             (progn
2350               (setq session (elmo-imap4-get-session folder)
2351                     mailbox (elmo-imap4-folder-mailbox-internal folder)
2352                     tag (elmo-imap4-send-command session
2353                                                  (list "select "
2354                                                        (elmo-imap4-mailbox
2355                                                         mailbox))))
2356               (if load-msgdb
2357                   (setq msgdb (elmo-msgdb-load folder)))
2358               (elmo-folder-set-killed-list-internal
2359                folder
2360                (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder)))
2361               (setq response (elmo-imap4-read-response session tag)))
2362           (quit
2363            (if response
2364                (elmo-imap4-session-set-current-mailbox-internal
2365                 session mailbox)
2366              (and session
2367                   (elmo-imap4-session-set-current-mailbox-internal
2368                    session nil))))
2369           (error
2370            (if response
2371                (elmo-imap4-session-set-current-mailbox-internal
2372                 session mailbox)
2373              (and session
2374                   (elmo-imap4-session-set-current-mailbox-internal
2375                    session nil)))))
2376         (if load-msgdb
2377             (elmo-folder-set-msgdb-internal
2378              folder
2379              (or msgdb (elmo-msgdb-load folder)))))
2380     (luna-call-next-method)))
2381
2382 ;; elmo-folder-open-internal: do nothing.
2383
2384 (luna-define-method elmo-find-fetch-strategy
2385   ((folder elmo-imap4-folder) entity &optional ignore-cache)
2386   (let ((number (elmo-msgdb-overview-entity-get-number entity))
2387         cache-file size message-id)
2388     (setq size (elmo-msgdb-overview-entity-get-size entity))
2389     (setq message-id (elmo-msgdb-overview-entity-get-id entity))
2390     (setq cache-file (elmo-file-cache-get message-id))
2391     (if (or ignore-cache
2392             (null (elmo-file-cache-status cache-file)))
2393         (if (and elmo-message-fetch-threshold
2394                  (integerp size)
2395                  (>= size elmo-message-fetch-threshold)
2396                  (or (not elmo-message-fetch-confirm)
2397                      (not (prog1 (y-or-n-p
2398                                   (format
2399                                    "Fetch entire message at once? (%dbytes)"
2400                                    size))
2401                             (message "")))))
2402             ;; Fetch message as imap message.
2403             (elmo-make-fetch-strategy 'section
2404                                       nil
2405                                       (elmo-message-use-cache-p
2406                                        folder number)
2407                                       (elmo-file-cache-path
2408                                        cache-file))
2409           ;; Don't use existing cache and fetch entire message at once.
2410           (elmo-make-fetch-strategy 'entire nil
2411                                     (elmo-message-use-cache-p
2412                                      folder number)
2413                                     (elmo-file-cache-path cache-file)))
2414       ;; Cache found and use it.
2415       (if (not ignore-cache)
2416           (if (eq (elmo-file-cache-status cache-file) 'section)
2417               ;; Fetch message with imap message.
2418               (elmo-make-fetch-strategy 'section
2419                                         t
2420                                         (elmo-message-use-cache-p
2421                                          folder number)
2422                                         (elmo-file-cache-path
2423                                          cache-file))
2424             (elmo-make-fetch-strategy 'entire
2425                                       t
2426                                       (elmo-message-use-cache-p
2427                                        folder number)
2428                                       (elmo-file-cache-path
2429                                        cache-file)))))))
2430
2431 (luna-define-method elmo-folder-create ((folder elmo-imap4-folder))
2432   (elmo-imap4-send-command-wait
2433    (elmo-imap4-get-session folder)
2434    (list "create "
2435          (elmo-imap4-mailbox
2436           (elmo-imap4-folder-mailbox-internal folder)))))
2437
2438 (luna-define-method elmo-folder-append-buffer
2439   ((folder elmo-imap4-folder) unread &optional number)
2440   (if (elmo-folder-plugged-p folder)
2441       (let ((session (elmo-imap4-get-session folder))
2442             send-buffer result)
2443         (elmo-imap4-session-select-mailbox session
2444                                            (elmo-imap4-folder-mailbox-internal
2445                                             folder))
2446         (setq send-buffer (elmo-imap4-setup-send-buffer))
2447         (unwind-protect
2448             (setq result
2449                   (elmo-imap4-send-command-wait
2450                    session
2451                    (list
2452                     "append "
2453                     (elmo-imap4-mailbox (elmo-imap4-folder-mailbox-internal
2454                                          folder))
2455                     (if unread " " " (\\Seen) ")
2456                     (elmo-imap4-buffer-literal send-buffer))))
2457           (kill-buffer send-buffer))
2458         result)
2459     ;; Unplugged
2460     (if elmo-enable-disconnected-operation
2461         (elmo-folder-append-buffer-dop folder unread number)
2462       (error "Unplugged"))))
2463
2464 (eval-when-compile
2465   (defmacro elmo-imap4-identical-system-p (folder1 folder2)
2466     "Return t if FOLDER1 and FOLDER2 are in the same IMAP4 system."
2467     (` (and (string= (elmo-net-folder-server-internal (, folder1))
2468                      (elmo-net-folder-server-internal (, folder2)))
2469             (eq (elmo-net-folder-port-internal (, folder1))
2470                 (elmo-net-folder-port-internal (, folder2)))
2471             (string= (elmo-net-folder-user-internal (, folder1))
2472                      (elmo-net-folder-user-internal (, folder2)))))))
2473
2474 (luna-define-method elmo-folder-append-messages :around
2475   ((folder elmo-imap4-folder) src-folder numbers unread-marks
2476    &optional same-number)
2477   (if (and (eq (elmo-folder-type-internal src-folder) 'imap4)
2478            (elmo-imap4-identical-system-p folder src-folder)
2479            (elmo-folder-plugged-p folder))
2480       ;; Plugged
2481       (prog1
2482           (elmo-imap4-copy-messages src-folder folder numbers)
2483         (elmo-progress-notify 'elmo-folder-move-messages (length numbers)))
2484     (luna-call-next-method)))
2485
2486 (luna-define-method elmo-message-deletable-p ((folder elmo-imap4-folder)
2487                                               number)
2488   (if (elmo-folder-plugged-p folder)
2489       (not (elmo-imap4-session-read-only-internal
2490             (elmo-imap4-get-session folder)))
2491     elmo-enable-disconnected-operation)) ; offline refile.
2492
2493 ;(luna-define-method elmo-message-fetch-unplugged
2494 ;  ((folder elmo-imap4-folder)
2495 ;   number strategy  &optional section outbuf unseen)
2496 ;  (error "%d%s is not cached." number (if section
2497 ;                                         (format "(%s)" section)
2498 ;                                       "")))
2499
2500 (defsubst elmo-imap4-message-fetch (folder number strategy
2501                                            section outbuf unseen)
2502   (let ((session (elmo-imap4-get-session folder))
2503         response)
2504     (elmo-imap4-session-select-mailbox session
2505                                        (elmo-imap4-folder-mailbox-internal
2506                                         folder))
2507     (with-current-buffer (elmo-network-session-buffer session)
2508       (setq elmo-imap4-fetch-callback nil)
2509       (setq elmo-imap4-fetch-callback-data nil))
2510     (unless elmo-inhibit-display-retrieval-progress
2511       (setq elmo-imap4-display-literal-progress t))
2512     (unwind-protect
2513         (setq response
2514               (elmo-imap4-send-command-wait session
2515                                             (format
2516                                              (if elmo-imap4-use-uid
2517                                                  "uid fetch %s body%s[%s]"
2518                                                "fetch %s body%s[%s]")
2519                                              number
2520                                              (if unseen ".peek" "")
2521                                              (or section "")
2522                                              )))
2523       (setq elmo-imap4-display-literal-progress nil))
2524     (unless elmo-inhibit-display-retrieval-progress
2525       (elmo-display-progress 'elmo-imap4-display-literal-progress
2526                              "Retrieving..." 100)  ; remove progress bar.
2527       (message "Retrieving...done."))
2528     (if (setq response (elmo-imap4-response-bodydetail-text
2529                         (elmo-imap4-response-value-all
2530                          response 'fetch)))
2531         (with-current-buffer outbuf
2532           (erase-buffer)
2533           (insert response)
2534           t))))
2535
2536 (luna-define-method elmo-message-fetch-plugged ((folder elmo-imap4-folder)
2537                                                 number strategy
2538                                                 &optional section
2539                                                 outbuf unseen)
2540   (elmo-imap4-message-fetch folder number strategy section outbuf unseen))
2541
2542 (luna-define-method elmo-message-fetch-field ((folder elmo-imap4-folder)
2543                                               number field)
2544   (let ((session (elmo-imap4-get-session folder)))
2545     (elmo-imap4-session-select-mailbox session
2546                                        (elmo-imap4-folder-mailbox-internal
2547                                         folder))
2548     (with-current-buffer (elmo-network-session-buffer session)
2549       (setq elmo-imap4-fetch-callback nil)
2550       (setq elmo-imap4-fetch-callback-data nil))
2551     (with-temp-buffer
2552       (insert
2553        (elmo-imap4-response-bodydetail-text
2554         (elmo-imap4-response-value
2555          (elmo-imap4-send-command-wait session
2556                                        (concat
2557                                         (if elmo-imap4-use-uid
2558                                             "uid ")
2559                                         (format
2560                                          "fetch %s (body.peek[header.fields (%s)])"
2561                                          number field)))
2562          'fetch)))
2563       (elmo-delete-cr-buffer)
2564       (goto-char (point-min))
2565       (std11-field-body (symbol-name field)))))
2566
2567
2568
2569 (require 'product)
2570 (product-provide (provide 'elmo-imap4) (require 'elmo-version))
2571
2572 ;;; elmo-imap4.el ends here