elmo/elmo-multi.el

   1 ;;; elmo-multi.el --- Multiple Folder Interface for ELMO.
   2
   3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30 ;;
  31
  32 (require 'elmo)
  33 (require 'luna)
  34
  35 (defvar elmo-multi-divide-number 100000
  36   "*Multi divider number.")
  37
  38 ;;; ELMO Multi folder
  39 (eval-and-compile
  40   (luna-define-class elmo-multi-folder (elmo-folder)
  41                      (children divide-number))
  42   (luna-define-internal-accessors 'elmo-multi-folder))
  43
  44 (defmacro elmo-multi-real-folder-number (folder number)
  45   "Returns a cons cell of real FOLDER and NUMBER."
  46   (` (cons (nth (-
  47                  (/ (, number)
  48                     (elmo-multi-folder-divide-number-internal (, folder)))
  49                  1) (elmo-multi-folder-children-internal (, folder)))
  50            (% (, number) (elmo-multi-folder-divide-number-internal
  51                           (, folder))))))
  52
  53 (luna-define-method elmo-folder-initialize ((folder
  54                                              elmo-multi-folder)
  55                                             name)
  56   (while (> (length (car (setq name (elmo-parse-token name ",")))) 0)
  57     (elmo-multi-folder-set-children-internal
  58      folder
  59      (nconc (elmo-multi-folder-children-internal
  60              folder)
  61             (list (elmo-make-folder (car name)))))
  62     (setq name (cdr name))
  63     (when (and (> (length name) 0)
  64                (eq (aref name 0) ?,))
  65       (setq name (substring name 1))))
  66   (elmo-multi-folder-set-divide-number-internal
  67    folder
  68    elmo-multi-divide-number)
  69   folder)
  70
  71 (luna-define-method elmo-folder-open-internal ((folder elmo-multi-folder))
  72   (dolist (fld (elmo-multi-folder-children-internal folder))
  73     (elmo-folder-open-internal fld)))
  74
  75 (luna-define-method elmo-folder-check ((folder elmo-multi-folder))
  76   (dolist (fld (elmo-multi-folder-children-internal folder))
  77     (elmo-folder-check fld)))
  78
  79 (luna-define-method elmo-folder-close-internal ((folder elmo-multi-folder))
  80   (dolist (fld (elmo-multi-folder-children-internal folder))
  81     (elmo-folder-close-internal fld)))
  82
  83 (luna-define-method elmo-folder-close :after ((folder elmo-multi-folder))
  84   (dolist (fld (elmo-multi-folder-children-internal folder))
  85     (elmo-folder-set-msgdb-internal fld nil)))
  86
  87 (luna-define-method elmo-folder-synchronize ((folder elmo-multi-folder)
  88                                              &optional ignore-msgdb
  89                                              no-check)
  90   (dolist (fld (elmo-multi-folder-children-internal folder))
  91     (elmo-folder-synchronize fld ignore-msgdb no-check))
  92   0)
  93
  94 (luna-define-method elmo-folder-expand-msgdb-path ((folder
  95                                                     elmo-multi-folder))
  96   (expand-file-name (elmo-replace-string-as-filename
  97                      (elmo-folder-name-internal folder))
  98                     (expand-file-name "multi"
  99                                       elmo-msgdb-directory)))
 100
 101 (luna-define-method elmo-folder-newsgroups ((folder elmo-multi-folder))
 102   (delq nil
 103         (elmo-flatten
 104          (mapcar
 105           'elmo-folder-newsgroups
 106           (elmo-flatten
 107            (mapcar
 108             'elmo-folder-get-primitive-list
 109             (elmo-multi-folder-children-internal folder)))))))
 110
 111 (luna-define-method elmo-folder-get-primitive-list ((folder elmo-multi-folder))
 112   (elmo-flatten
 113    (mapcar
 114     'elmo-folder-get-primitive-list
 115     (elmo-multi-folder-children-internal folder))))
 116
 117 (luna-define-method elmo-folder-contains-type ((folder elmo-multi-folder) type)
 118   (let ((children (elmo-multi-folder-children-internal folder))
 119         match)
 120     (while children
 121       (when (elmo-folder-contains-type (car children) type)
 122         (setq match t)
 123         (setq children nil))
 124       (setq children (cdr children)))
 125     match))
 126
 127 (luna-define-method elmo-message-folder ((folder elmo-multi-folder)
 128                                          number)
 129   (nth (- (/ number (elmo-multi-folder-divide-number-internal folder)) 1)
 130        (elmo-multi-folder-children-internal folder)))
 131
 132 (luna-define-method elmo-message-entity ((folder elmo-multi-folder) key)
 133   (cond
 134    ((numberp key)
 135     (let* ((pair (elmo-multi-real-folder-number folder key))
 136            (entity
 137             (elmo-message-copy-entity
 138              (elmo-message-entity (car pair) (cdr pair)))))
 139       (elmo-message-entity-set-number entity key)))
 140    ((stringp key)
 141     (let ((children (elmo-multi-folder-children-internal folder))
 142           (cur-number 0)
 143           match)
 144       (while children
 145         (setq cur-number (+ cur-number 1))
 146         (when (setq match (elmo-message-entity (car children) key))
 147           (setq match (elmo-message-copy-entity match))
 148           (elmo-message-entity-set-number
 149            match
 150            (+ (* (elmo-multi-folder-divide-number-internal folder)
 151                  cur-number)
 152               (elmo-message-entity-number match)))
 153           (setq children nil))
 154         (setq children (cdr children)))
 155       match))))
 156
 157 (luna-define-method elmo-message-mark ((folder elmo-multi-folder) number)
 158   (let ((pair (elmo-multi-real-folder-number folder number)))
 159     (elmo-message-mark (car pair) (cdr pair))))
 160
 161 (defun elmo-multi-split-numbers (folder numlist &optional as-is)
 162   (let ((numbers (sort numlist '<))
 163         (divider (elmo-multi-folder-divide-number-internal folder))
 164         (cur-number 0)
 165         one-list numbers-list)
 166     (while numbers
 167       (setq cur-number (+ cur-number 1))
 168       (setq one-list nil)
 169       (while (and numbers
 170                   (eq 0
 171                       (/ (- (car numbers)
 172                             (* divider cur-number))
 173                          divider)))
 174         (setq one-list (nconc
 175                         one-list
 176                         (list
 177                          (if as-is
 178                              (car numbers)
 179                            (% (car numbers)
 180                               (* divider cur-number))))))
 181         (setq numbers (cdr numbers)))
 182       (setq numbers-list (nconc numbers-list (list one-list))))
 183     numbers-list))
 184
 185 (luna-define-method elmo-folder-process-crosspost ((folder elmo-multi-folder))
 186   (dolist (child (elmo-multi-folder-children-internal folder))
 187     (elmo-folder-process-crosspost child)))
 188
 189 (defsubst elmo-multi-find-fetch-strategy (folder entity ignore-cache)
 190   (if entity
 191       (let ((pair (elmo-multi-real-folder-number
 192                    folder
 193                    (elmo-msgdb-overview-entity-get-number entity)))
 194             (new-entity (elmo-msgdb-copy-overview-entity entity)))
 195         (setq new-entity
 196               (elmo-msgdb-overview-entity-set-number new-entity (cdr pair)))
 197         (elmo-find-fetch-strategy (car pair) new-entity ignore-cache))
 198     (elmo-make-fetch-strategy 'entire)))
 199
 200 (luna-define-method elmo-find-fetch-strategy
 201   ((folder elmo-multi-folder)
 202    entity &optional ignore-cache)
 203   (elmo-multi-find-fetch-strategy folder entity ignore-cache))
 204
 205 (luna-define-method elmo-message-fetch ((folder elmo-multi-folder)
 206                                         number strategy
 207                                         &optional section outbuf unseen)
 208   (let ((pair (elmo-multi-real-folder-number folder number)))
 209     (elmo-message-fetch (car pair) (cdr pair) strategy section outbuf unseen)))
 210
 211 (luna-define-method elmo-folder-delete-messages ((folder elmo-multi-folder)
 212                                                  numbers)
 213   (let ((flds (elmo-multi-folder-children-internal folder))
 214         one-list-list
 215         (cur-number 0))
 216     (setq one-list-list (elmo-multi-split-numbers folder numbers))
 217     (while (< cur-number (length flds))
 218       (elmo-folder-delete-messages (nth cur-number flds)
 219                                    (nth cur-number one-list-list))
 220       (setq cur-number (+ 1 cur-number)))
 221     t))
 222
 223 (luna-define-method elmo-folder-detach-messages ((folder elmo-multi-folder)
 224                                                  numbers)
 225   (let ((flds (elmo-multi-folder-children-internal folder))
 226         one-list-list
 227         (cur-number 0))
 228     (setq one-list-list (elmo-multi-split-numbers folder numbers))
 229     (while (< cur-number (length flds))
 230       (elmo-folder-detach-messages (nth cur-number flds)
 231                                    (nth cur-number one-list-list))
 232       (setq cur-number (+ 1 cur-number)))
 233     t))
 234
 235 (luna-define-method elmo-folder-diff ((folder elmo-multi-folder)
 236                                       &optional numbers)
 237   (elmo-multi-folder-diff folder numbers))
 238
 239 (defun elmo-multi-folder-diff (folder numbers)
 240   (let ((flds (elmo-multi-folder-children-internal folder))
 241         (num-list (and numbers (elmo-multi-split-numbers folder numbers)))
 242         (unsync 0)
 243         (messages 0)
 244         diffs)
 245     (while flds
 246       (setq diffs (nconc diffs (list (elmo-folder-diff (car flds)
 247                                                        (car num-list)))))
 248       (setq flds (cdr flds)))
 249     (while diffs
 250       (and (car (car diffs))
 251            (setq unsync (+ unsync (car (car diffs)))))
 252       (setq messages  (+ messages (cdr (car diffs))))
 253       (setq diffs (cdr diffs)))
 254     (elmo-folder-set-info-hashtb folder nil messages)
 255     (cons unsync messages)))
 256
 257 (luna-define-method elmo-folder-list-unreads ((folder elmo-multi-folder))
 258   (let ((cur-number 0)
 259         unreads)
 260     (dolist (child (elmo-multi-folder-children-internal folder))
 261       (setq cur-number (+ cur-number 1))
 262       (setq unreads
 263             (nconc
 264              unreads
 265              (mapcar (lambda (x)
 266                        (+ x (* cur-number
 267                                (elmo-multi-folder-divide-number-internal
 268                                 folder))))
 269                      (elmo-folder-list-unreads child)))))
 270     unreads))
 271
 272 (luna-define-method elmo-folder-list-answereds ((folder elmo-multi-folder))
 273   (let ((cur-number 0)
 274         answereds)
 275     (dolist (child (elmo-multi-folder-children-internal folder))
 276       (setq cur-number (+ cur-number 1))
 277       (setq answereds
 278             (nconc
 279              answereds
 280              (mapcar (lambda (x)
 281                        (+ x (* cur-number
 282                                (elmo-multi-folder-divide-number-internal
 283                                 folder))))
 284                      (elmo-folder-list-answereds child)))))
 285     answereds))
 286
 287 (luna-define-method elmo-folder-list-importants ((folder elmo-multi-folder))
 288   (let ((cur-number 0)
 289         importants)
 290     (dolist (child (elmo-multi-folder-children-internal folder))
 291       (setq cur-number (+ cur-number 1))
 292       (setq importants
 293             (nconc
 294              importants
 295              (mapcar (lambda (x)
 296                        (+ x (* cur-number
 297                                (elmo-multi-folder-divide-number-internal
 298                                 folder))))
 299                      (elmo-folder-list-importants child)))))
 300     (elmo-uniq-list
 301      (nconc importants
 302             (elmo-folder-list-messages-with-global-mark
 303              folder elmo-msgdb-important-mark)))))
 304
 305 (luna-define-method elmo-folder-list-messages
 306   ((folder elmo-multi-folder) &optional visible-only in-msgdb)
 307   (let* ((flds (elmo-multi-folder-children-internal folder))
 308          (cur-number 0)
 309          list numbers)
 310     (while flds
 311       (setq cur-number (+ cur-number 1))
 312       (setq list (elmo-folder-list-messages (car flds) visible-only in-msgdb))
 313       (setq numbers
 314             (nconc
 315              numbers
 316              (mapcar
 317               (function
 318                (lambda (x)
 319                  (+
 320                   (* (elmo-multi-folder-divide-number-internal
 321                       folder) cur-number) x)))
 322               list)))
 323       (setq flds (cdr flds)))
 324     numbers))
 325
 326 (luna-define-method elmo-folder-exists-p ((folder elmo-multi-folder))
 327   (let ((flds (elmo-multi-folder-children-internal folder)))
 328     (catch 'exists
 329       (while flds
 330         (unless (elmo-folder-exists-p (car flds))
 331           (throw 'exists nil))
 332         (setq flds (cdr flds)))
 333       t)))
 334
 335 (luna-define-method elmo-folder-creatable-p ((folder elmo-multi-folder))
 336   (let ((flds (elmo-multi-folder-children-internal folder)))
 337     (catch 'creatable
 338       (while flds
 339         (when (and (elmo-folder-creatable-p (car flds))
 340                    (not (elmo-folder-exists-p (car flds))))
 341           ;; If folder already exists, don't to `creatable'.
 342           ;; Because this function is called, when folder doesn't exists.
 343           (throw 'creatable t))
 344         (setq flds (cdr flds)))
 345       nil)))
 346
 347 (luna-define-method elmo-folder-create ((folder elmo-multi-folder))
 348   (let ((flds (elmo-multi-folder-children-internal folder)))
 349     (catch 'create
 350       (while flds
 351         (unless (or (elmo-folder-exists-p (car flds))
 352                     (elmo-folder-create (car flds)))
 353           (throw 'create nil))
 354         (setq flds (cdr flds)))
 355       t)))
 356
 357 (luna-define-method elmo-folder-search ((folder elmo-multi-folder)
 358                                         condition &optional numlist)
 359   (let* ((flds (elmo-multi-folder-children-internal folder))
 360          (cur-number 0)
 361          numlist-list cur-numlist ; for filtered search.
 362          ret-val)
 363     (if numlist
 364         (setq numlist-list
 365               (elmo-multi-split-numbers folder numlist t)))
 366     (while flds
 367       (setq cur-number (+ cur-number 1))
 368       (when numlist
 369         (setq cur-numlist (car numlist-list))
 370         (if (null cur-numlist)
 371             ;; t means filter all.
 372             (setq cur-numlist t)))
 373       (setq ret-val (append
 374                      ret-val
 375                      (elmo-list-filter
 376                       cur-numlist
 377                       (mapcar
 378                        (function
 379                         (lambda (x)
 380                           (+
 381                            (* (elmo-multi-folder-divide-number-internal
 382                                folder) cur-number) x)))
 383                        (elmo-folder-search
 384                         (car flds) condition)))))
 385       (when numlist
 386         (setq numlist-list (cdr numlist-list)))
 387       (setq flds (cdr flds)))
 388     ret-val))
 389
 390 (luna-define-method elmo-message-use-cache-p ((folder elmo-multi-folder)
 391                                               number)
 392   (let ((pair (elmo-multi-real-folder-number folder number)))
 393     (elmo-message-use-cache-p (car pair) (cdr pair))))
 394
 395 (luna-define-method elmo-message-file-p ((folder elmo-multi-folder) number)
 396   (let ((pair (elmo-multi-real-folder-number folder number)))
 397     (elmo-message-file-p (car pair) (cdr pair))))
 398
 399 (luna-define-method elmo-message-file-name ((folder elmo-multi-folder) number)
 400   (let ((pair (elmo-multi-real-folder-number folder number)))
 401     (elmo-message-file-name (car pair) (cdr pair))))
 402
 403 (luna-define-method elmo-folder-plugged-p ((folder elmo-multi-folder))
 404   (let ((flds (elmo-multi-folder-children-internal folder)))
 405     (catch 'plugged
 406       (while flds
 407         (unless (elmo-folder-plugged-p (car flds))
 408           (throw 'plugged nil))
 409         (setq flds (cdr flds)))
 410       t)))
 411
 412 (luna-define-method elmo-folder-set-plugged ((folder elmo-multi-folder)
 413                                              plugged add)
 414   (let ((flds  (elmo-multi-folder-children-internal folder)))
 415     (dolist (fld flds)
 416       (elmo-folder-set-plugged fld plugged add))))
 417
 418 (defun elmo-multi-folder-numbers-list-assoc (folder folder-numbers)
 419   (let (ent)
 420     (while folder-numbers
 421       (when (string= (elmo-folder-name-internal (car (car folder-numbers)))
 422                      (elmo-folder-name-internal folder))
 423         (setq ent (car folder-numbers)
 424               folder-numbers nil))
 425       (setq folder-numbers (cdr folder-numbers)))
 426     ent))
 427
 428 (defun elmo-multi-make-folder-numbers-list (folder msgs)
 429   (let ((msg-list msgs)
 430         pair fld-list
 431         ret-val)
 432     (while msg-list
 433       (when (and (numberp (car msg-list))
 434                  (> (car msg-list) 0))
 435         (setq pair (elmo-multi-real-folder-number folder (car msg-list)))
 436         (if (setq fld-list (elmo-multi-folder-numbers-list-assoc
 437                             (car pair)
 438                             ret-val))
 439             (setcdr fld-list (cons (cdr pair) (cdr fld-list)))
 440           (setq ret-val (cons (cons (car pair) (list (cdr pair))) ret-val))))
 441       (setq msg-list (cdr msg-list)))
 442     ret-val))
 443
 444 (luna-define-method elmo-folder-mark-as-important :before ((folder
 445                                                             elmo-multi-folder)
 446                                                            numbers
 447                                                            &optional
 448                                                            ignore-flags)
 449   (dolist (folder-numbers (elmo-multi-make-folder-numbers-list folder numbers))
 450     (elmo-folder-mark-as-important (car folder-numbers)
 451                                    (cdr folder-numbers)
 452                                    ignore-flags)))
 453
 454 (luna-define-method elmo-folder-unmark-important :before ((folder
 455                                                            elmo-multi-folder)
 456                                                           numbers
 457                                                           &optional
 458                                                           ignore-flags)
 459   (dolist (folder-numbers (elmo-multi-make-folder-numbers-list folder numbers))
 460     (elmo-folder-unmark-important (car folder-numbers)
 461                                   (cdr folder-numbers)
 462                                   ignore-flags)))
 463
 464 (luna-define-method elmo-folder-mark-as-read :before ((folder
 465                                                        elmo-multi-folder)
 466                                                       numbers
 467                                                       &optional ignore-flag)
 468   (dolist (folder-numbers (elmo-multi-make-folder-numbers-list folder numbers))
 469     (elmo-folder-mark-as-read (car folder-numbers)
 470                               (cdr folder-numbers)
 471                               ignore-flag)))
 472
 473 (luna-define-method elmo-folder-unmark-read :before ((folder
 474                                                       elmo-multi-folder)
 475                                                      numbers
 476                                                      &optional ignore-flag)
 477   (dolist (folder-numbers (elmo-multi-make-folder-numbers-list folder numbers))
 478     (elmo-folder-unmark-read (car folder-numbers)
 479                              (cdr folder-numbers)
 480                              ignore-flag)))
 481
 482 (luna-define-method elmo-folder-mark-as-answered :before ((folder
 483                                                            elmo-multi-folder)
 484                                                           numbers)
 485   (dolist (folder-numbers (elmo-multi-make-folder-numbers-list folder numbers))
 486     (elmo-folder-mark-as-answered (car folder-numbers)
 487                                   (cdr folder-numbers))))
 488
 489 (luna-define-method elmo-folder-unmark-answered :before ((folder
 490                                                           elmo-multi-folder)
 491                                                          numbers)
 492   (dolist (folder-numbers (elmo-multi-make-folder-numbers-list folder numbers))
 493     (elmo-folder-unmark-answered (car folder-numbers)
 494                                  (cdr folder-numbers))))
 495
 496 (require 'product)
 497 (product-provide (provide 'elmo-multi) (require 'elmo-version))
 498
 499 ;;; elmo-multi.el ends here