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 ;;; ELMO Multi folder
  35 (eval-and-compile
  36   (luna-define-class elmo-multi-folder (elmo-folder)
  37                      (children divide-number))
  38   (luna-define-internal-accessors 'elmo-multi-folder))
  39
  40 (luna-define-method elmo-folder-initialize ((folder
  41                                              elmo-multi-folder)
  42                                             name)
  43   (elmo-multi-folder-set-children-internal
  44    folder
  45    (mapcar 'elmo-make-folder (split-string name ",")))
  46   (elmo-multi-folder-set-divide-number-internal
  47    folder
  48    elmo-multi-divide-number)
  49   folder)
  50
  51 (luna-define-method elmo-folder-open-internal ((folder elmo-multi-folder))
  52   (dolist (fld (elmo-multi-folder-children-internal folder))
  53     (elmo-folder-open-internal fld)))
  54
  55 (luna-define-method elmo-folder-check ((folder elmo-multi-folder))
  56   (dolist (fld (elmo-multi-folder-children-internal folder))
  57     (elmo-folder-check fld)))
  58
  59 (luna-define-method elmo-folder-close-internal ((folder elmo-multi-folder))
  60   (dolist (fld (elmo-multi-folder-children-internal folder))
  61     (elmo-folder-close-internal fld)))
  62
  63 (luna-define-method elmo-folder-expand-msgdb-path ((folder
  64                                                     elmo-multi-folder))
  65   (expand-file-name (elmo-replace-string-as-filename
  66                      (elmo-folder-name-internal folder))
  67                     (expand-file-name "multi"
  68                                       elmo-msgdb-dir)))
  69
  70 (luna-define-method elmo-folder-get-primitive-list ((folder elmo-multi-folder))
  71   (elmo-flatten
  72    (mapcar
  73     'elmo-folder-get-primitive-list
  74     (elmo-multi-folder-children-internal folder))))
  75
  76 (luna-define-method elmo-folder-contains-type ((folder elmo-multi-folder) type)
  77   (let ((children (elmo-multi-folder-children-internal folder))
  78         match)
  79     (while children
  80       (when (elmo-folder-contains-type (car children) type)
  81         (setq match t)
  82         (setq children nil))
  83       (setq children (cdr children)))
  84     match))
  85
  86 (luna-define-method elmo-message-use-cache-p ((folder elmo-multi-folder)
  87                                              number)
  88   (elmo-message-use-cache-p
  89    (nth (- (/ number (elmo-multi-folder-divide-number-internal folder)) 1)
  90         (elmo-multi-folder-children-internal folder))
  91    (% number (elmo-multi-folder-divide-number-internal folder))))
  92
  93 (luna-define-method elmo-message-folder ((folder elmo-multi-folder)
  94                                          number)
  95   (nth (- (/ number (elmo-multi-folder-divide-number-internal folder)) 1)
  96        (elmo-multi-folder-children-internal folder)))
  97
  98 (defun elmo-multi-msgdb (msgdb base)
  99   (list (mapcar (function
 100                  (lambda (x)
 101                    (elmo-msgdb-overview-entity-set-number
 102                     x
 103                     (+ base
 104                        (elmo-msgdb-overview-entity-get-number x)))))
 105                 (nth 0 msgdb))
 106         (mapcar (function
 107                  (lambda (x) (cons
 108                               (+ base (car x))
 109                               (cdr x))))
 110                 (nth 1 msgdb))
 111         (mapcar (function
 112                  (lambda (x) (cons
 113                               (+ base (car x))
 114                               (cdr x)))) (nth 2 msgdb))))
 115
 116 (defun elmo-multi-split-numbers (folder numlist &optional as-is)
 117   (let ((numbers (sort numlist '<))
 118         (divider (elmo-multi-folder-divide-number-internal folder))
 119         (cur-number 0)
 120         one-list numbers-list)
 121     (while numbers
 122       (setq cur-number (+ cur-number 1))
 123       (setq one-list nil)
 124       (while (and numbers
 125                   (eq 0
 126                       (/ (- (car numbers)
 127                             (* divider cur-number))
 128                          divider)))
 129         (setq one-list (nconc
 130                         one-list
 131                         (list
 132                          (if as-is
 133                              (car numbers)
 134                            (% (car numbers)
 135                               (* divider cur-number))))))
 136         (setq numbers (cdr numbers)))
 137       (setq numbers-list (nconc numbers-list (list one-list))))
 138     numbers-list))
 139
 140 (luna-define-method elmo-folder-msgdb-create ((folder elmo-multi-folder)
 141                                               numbers new-mark already-mark
 142                                               seen-mark important-mark
 143                                               seen-list)
 144   (let* ((folders (elmo-multi-folder-children-internal folder))
 145          overview number-alist mark-alist entity
 146          numbers-list
 147          cur-number
 148          i percent num
 149          msgdb)
 150     (setq numbers-list (elmo-multi-split-numbers folder numbers))
 151     (setq cur-number 0)
 152     (while (< cur-number (length folders))
 153       (if (nth cur-number numbers-list)
 154           (setq msgdb
 155                 (elmo-msgdb-append
 156                  msgdb
 157                  (elmo-multi-msgdb
 158                   (elmo-folder-msgdb-create (nth cur-number folders)
 159                                             (nth cur-number numbers-list)
 160                                             new-mark already-mark
 161                                             seen-mark important-mark
 162                                             seen-list)
 163                   (* (elmo-multi-folder-divide-number-internal folder)
 164                      (1+ cur-number))))))
 165       (setq cur-number (1+ cur-number)))
 166     (elmo-msgdb-sort-by-date msgdb)))
 167
 168 (defsubst elmo-multi-folder-append-msgdb (folder append-msgdb)
 169   (let* ((number-alist (elmo-msgdb-get-number-alist append-msgdb))
 170          (all-alist (copy-sequence (append
 171                                     (elmo-msgdb-get-number-alist
 172                                      (elmo-folder-msgdb-internal folder))
 173                                     number-alist)))
 174          (cur number-alist)
 175          to-be-deleted
 176          mark-alist same)
 177     (while cur
 178       (setq all-alist (delq (car cur) all-alist))
 179       ;; same message id exists.
 180       (if (setq same (rassoc (cdr (car cur)) all-alist))
 181           (unless (= (/ (car (car cur))
 182                         (elmo-multi-folder-divide-number-internal folder))
 183                      (/ (car same)
 184                         (elmo-multi-folder-divide-number-internal folder)))
 185             ;; base is also same...delete it!
 186             (setq to-be-deleted (append to-be-deleted (list (car cur))))))
 187       (setq cur (cdr cur)))
 188     (setq mark-alist (elmo-delete-if
 189                       (function
 190                        (lambda (x)
 191                          (assq (car x) to-be-deleted)))
 192                       (elmo-msgdb-get-mark-alist append-msgdb)))
 193     (elmo-msgdb-set-mark-alist append-msgdb mark-alist)
 194     (elmo-folder-set-msgdb-internal folder
 195                                     (elmo-msgdb-append
 196                                      (elmo-folder-msgdb-internal folder)
 197                                      append-msgdb t))
 198     (length to-be-deleted)))
 199
 200 (luna-define-method elmo-folder-append-msgdb ((folder elmo-multi-folder)
 201                                               append-msgdb)
 202   (elmo-multi-folder-append-msgdb folder append-msgdb))
 203
 204 (defmacro elmo-multi-real-folder-number (folder number)
 205   "Returns a cons cell of real FOLDER and NUMBER."
 206   (` (cons (nth (-
 207                  (/ (, number)
 208                     (elmo-multi-folder-divide-number-internal (, folder)))
 209                  1) (elmo-multi-folder-children-internal (, folder)))
 210            (% (, number) (elmo-multi-folder-divide-number-internal
 211                           (, folder))))))
 212
 213 (defsubst elmo-multi-find-fetch-strategy (folder entity ignore-cache)
 214   (if entity
 215       (let ((pair (elmo-multi-real-folder-number
 216                    folder
 217                    (elmo-msgdb-overview-entity-get-number entity)))
 218             (new-entity (elmo-msgdb-copy-overview-entity entity)))
 219         (setq new-entity
 220               (elmo-msgdb-overview-entity-set-number new-entity (cdr pair)))
 221         (elmo-find-fetch-strategy (car pair) new-entity ignore-cache))
 222     (elmo-make-fetch-strategy 'entire)))
 223
 224 (luna-define-method elmo-find-fetch-strategy
 225   ((folder elmo-multi-folder)
 226    entity &optional ignore-cache)
 227   (elmo-multi-find-fetch-strategy folder entity ignore-cache))
 228
 229 (luna-define-method elmo-message-fetch ((folder elmo-multi-folder)
 230                                         number strategy
 231                                         &optional section outbuf unseen)
 232   (let ((pair (elmo-multi-real-folder-number folder number)))
 233     (elmo-message-fetch (car pair) (cdr pair) strategy section outbuf unseen)))
 234
 235 (luna-define-method elmo-folder-delete-messages ((folder elmo-multi-folder)
 236                                                  numbers)
 237   (let ((flds (elmo-multi-folder-children-internal folder))
 238         one-list-list
 239         (cur-number 0))
 240     (setq one-list-list (elmo-multi-split-numbers folder numbers))
 241     (while (< cur-number (length flds))
 242       (elmo-folder-delete-messages (nth cur-number flds)
 243                                    (nth cur-number one-list-list))
 244       (setq cur-number (+ 1 cur-number)))
 245     t))
 246
 247 (luna-define-method elmo-folder-diff ((folder elmo-multi-folder)
 248                                       &optional numbers)
 249   (elmo-multi-folder-diff folder numbers))
 250
 251 (defun elmo-multi-folder-diff (folder numbers)
 252   (let ((flds (elmo-multi-folder-children-internal folder))
 253         (numbers (mapcar 'car
 254                          (elmo-msgdb-number-load
 255                           (elmo-folder-msgdb-path folder))))
 256         (killed (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder)))
 257         (count 0)
 258         (unsync 0)
 259         (messages 0)
 260         num-list
 261         diffs)
 262     (setq num-list
 263           (elmo-multi-split-numbers folder
 264                                     (elmo-uniq-list
 265                                      (nconc
 266                                       (elmo-number-set-to-number-list killed)
 267                                       numbers))))
 268     (while flds
 269       (setq diffs (nconc diffs (list (elmo-folder-diff
 270                                       (car flds)
 271                                       (car num-list)))))
 272       (setq count (+ 1 count))
 273       (setq num-list (cdr num-list))
 274       (setq flds (cdr flds)))
 275     (while diffs
 276       (and (car (car diffs))
 277            (setq unsync (+ unsync (car (car diffs)))))
 278       (setq messages  (+ messages (cdr (car diffs))))
 279       (setq diffs (cdr diffs)))
 280     (elmo-folder-set-info-hashtb folder nil messages)
 281     (cons unsync messages)))
 282
 283 (defun elmo-multi-split-mark-alist (folder mark-alist)
 284   (let ((cur-number 0)
 285         (alist (sort (copy-sequence mark-alist)
 286                      (lambda (pair1 pair2)
 287                        (< (car pair1)(car pair2)))))
 288         one-alist result)
 289     (while alist
 290       (setq cur-number (+ cur-number 1))
 291       (setq one-alist nil)
 292       (while (and alist
 293                   (eq 0
 294                       (/ (- (car (car alist))
 295                             (* (elmo-multi-folder-divide-number-internal
 296                                 folder) cur-number))
 297                          (elmo-multi-folder-divide-number-internal folder))))
 298         (setq one-alist (nconc
 299                          one-alist
 300                          (list
 301                           (list (% (car (car alist))
 302                                    (* (elmo-multi-folder-divide-number-internal
 303                                        folder) cur-number))
 304                                 (cadr (car alist))))))
 305         (setq alist (cdr alist)))
 306       (setq result (nconc result (list one-alist))))
 307     result))
 308
 309 (luna-define-method elmo-folder-list-unreads-internal
 310   ((folder elmo-multi-folder) unread-marks)
 311   (elmo-multi-folder-list-unreads-internal folder unread-marks))
 312
 313 (defun elmo-multi-folder-list-unreads-internal (folder unread-marks)
 314   (let ((folders (elmo-multi-folder-children-internal folder))
 315         (mark-alists (elmo-multi-split-mark-alist
 316                       folder
 317                       (elmo-msgdb-get-mark-alist
 318                        (elmo-folder-msgdb-internal folder))))
 319         (cur-number 0)
 320         unreads
 321         all-unreads)
 322     (while folders
 323       (setq cur-number (+ cur-number 1))
 324       (unless (listp (setq unreads
 325                            (elmo-folder-list-unreads-internal
 326                             (car folders) unread-marks)))
 327         (setq unreads (delq  nil
 328                              (mapcar
 329                               (lambda (x)
 330                                 (if (member (cadr x) unread-marks)
 331                                     (car x)))
 332                               (car mark-alists)))))
 333       (setq all-unreads
 334             (nconc all-unreads
 335                    (mapcar
 336                     (lambda (x)
 337                       (+ x
 338                          (* cur-number
 339                             (elmo-multi-folder-divide-number-internal
 340                              folder))))
 341                     unreads)))
 342       (setq mark-alists (cdr mark-alists)
 343             folders (cdr folders)))
 344     all-unreads))
 345
 346 (luna-define-method elmo-folder-list-importants-internal
 347   ((folder elmo-multi-folder) important-mark)
 348   (let ((folders (elmo-multi-folder-children-internal folder))
 349         (mark-alists (elmo-multi-split-mark-alist
 350                       folder
 351                       (elmo-msgdb-get-mark-alist
 352                        (elmo-folder-msgdb-internal folder))))
 353         (cur-number 0)
 354         importants
 355         all-importants)
 356     (while folders
 357       (setq cur-number (+ cur-number 1))
 358       (unless (listp (setq importants
 359                            (elmo-folder-list-importants-internal
 360                             (car folders) important-mark)))
 361         (setq importants (delq  nil
 362                              (mapcar
 363                               (lambda (x)
 364                                 (if (string= (cadr x) important-mark)
 365                                     (car x)))
 366                               (car mark-alists)))))
 367       (setq all-importants
 368             (nconc all-importants
 369                    (mapcar
 370                     (lambda (x)
 371                       (+ x
 372                          (* cur-number
 373                             (elmo-multi-folder-divide-number-internal
 374                              folder))))
 375                     importants)))
 376       (setq mark-alists (cdr mark-alists)
 377             folders (cdr folders)))
 378     all-importants))
 379
 380 (luna-define-method elmo-folder-list-messages-internal
 381   ((folder elmo-multi-folder))
 382   (let* ((flds (elmo-multi-folder-children-internal folder))
 383          (cur-number 0)
 384          numbers)
 385     (while flds
 386       (setq cur-number (+ cur-number 1))
 387       (setq numbers (append
 388                      numbers
 389                      (mapcar
 390                       (function
 391                        (lambda (x)
 392                          (+
 393                           (* (elmo-multi-folder-divide-number-internal
 394                               folder) cur-number) x)))
 395                       (elmo-folder-list-messages-internal (car flds)))))
 396       (setq flds (cdr flds)))
 397     numbers))
 398
 399 (luna-define-method elmo-folder-exists-p ((folder elmo-multi-folder))
 400   (let ((flds (elmo-multi-folder-children-internal folder)))
 401     (catch 'exists
 402       (while flds
 403         (unless (elmo-folder-exists-p (car flds))
 404           (throw 'exists nil))
 405         (setq flds (cdr flds)))
 406       t)))
 407
 408 (luna-define-method elmo-folder-creatable-p ((folder elmo-multi-folder))
 409   (let ((flds (elmo-multi-folder-children-internal folder)))
 410     (catch 'creatable
 411       (while flds
 412         (when (and (elmo-folder-creatable-p (car flds))
 413                    (not (elmo-folder-exists-p (car flds))))
 414           ;; If folder already exists, don't to `creatable'.
 415           ;; Because this function is called, when folder doesn't exists.
 416           (throw 'creatable t))
 417         (setq flds (cdr flds)))
 418       nil)))
 419
 420 (luna-define-method elmo-folder-create ((folder elmo-multi-folder))
 421   (let ((flds (elmo-multi-folder-children-internal folder)))
 422     (catch 'create
 423       (while flds
 424         (unless (or (elmo-folder-exists-p (car flds))
 425                     (elmo-folder-create (car flds)))
 426           (throw 'create nil))
 427         (setq flds (cdr flds)))
 428       t)))
 429
 430 (luna-define-method elmo-folder-search ((folder elmo-multi-folder)
 431                                         condition &optional numlist)
 432   (let* ((flds (elmo-multi-folder-children-internal folder))
 433          (cur-number 0)
 434          numlist-list cur-numlist ; for filtered search.
 435          ret-val)
 436     (if numlist
 437         (setq numlist-list
 438               (elmo-multi-split-numbers folder numlist t)))
 439     (while flds
 440       (setq cur-number (+ cur-number 1))
 441       (when numlist
 442         (setq cur-numlist (car numlist-list))
 443         (if (null cur-numlist)
 444             ;; t means filter all.
 445             (setq cur-numlist t)))
 446       (setq ret-val (append
 447                      ret-val
 448                      (elmo-list-filter
 449                       cur-numlist
 450                       (mapcar
 451                        (function
 452                         (lambda (x)
 453                           (+
 454                            (* (elmo-multi-folder-divide-number-internal
 455                                folder) cur-number) x)))
 456                        (elmo-folder-search
 457                         (car flds) condition)))))
 458       (when numlist
 459         (setq numlist-list (cdr numlist-list)))
 460       (setq flds (cdr flds)))
 461     ret-val))
 462
 463 (luna-define-method elmo-message-use-cache-p ((folder elmo-multi-folder)
 464                                               number)
 465   (let ((pair (elmo-multi-real-folder-number folder number)))
 466     (elmo-message-use-cache-p (car pair) (cdr pair))))
 467
 468 (luna-define-method elmo-message-file-p ((folder elmo-multi-folder) number)
 469   (let ((pair (elmo-multi-real-folder-number folder number)))
 470     (elmo-message-file-p (car pair) (cdr pair))))
 471
 472 (luna-define-method elmo-message-file-name ((folder elmo-multi-folder) number)
 473   (let ((pair (elmo-multi-real-folder-number folder number)))
 474     (elmo-message-file-name (car pair) (cdr pair))))
 475
 476 (luna-define-method elmo-folder-plugged-p ((folder elmo-multi-folder))
 477   (let ((flds (elmo-multi-folder-children-internal folder)))
 478     (catch 'plugged
 479       (while flds
 480         (unless (elmo-folder-plugged-p (car flds))
 481           (throw 'plugged nil))
 482         (setq flds (cdr flds)))
 483       t)))
 484
 485 (luna-define-method elmo-folder-set-plugged ((folder elmo-multi-folder)
 486                                              plugged add)
 487   (let ((flds  (elmo-multi-folder-children-internal folder)))
 488     (dolist (fld flds)
 489       (elmo-folder-set-plugged fld plugged add))))
 490
 491 (defun elmo-multi-folder-numbers-list-assoc (folder folder-numbers)
 492   (let (ent)
 493     (while folder-numbers
 494       (when (string= (elmo-folder-name-internal (car (car folder-numbers)))
 495                      (elmo-folder-name-internal folder))
 496         (setq ent (car folder-numbers)
 497               folder-numbers nil))
 498       (setq folder-numbers (cdr folder-numbers)))
 499     ent))
 500
 501 (defun elmo-multi-make-folder-numbers-list (folder msgs)
 502   (let ((msg-list msgs)
 503         pair fld-list
 504         ret-val)
 505     (while msg-list
 506       (when (and (numberp (car msg-list))
 507                  (> (car msg-list) 0))
 508         (setq pair (elmo-multi-real-folder-number folder (car msg-list)))
 509         (if (setq fld-list (elmo-multi-folder-numbers-list-assoc
 510                             (car pair)
 511                             ret-val))
 512             (setcdr fld-list (cons (cdr pair) (cdr fld-list)))
 513           (setq ret-val (cons (cons (car pair) (list (cdr pair))) ret-val))))
 514       (setq msg-list (cdr msg-list)))
 515     ret-val))
 516
 517 (luna-define-method elmo-folder-mark-as-important ((folder elmo-multi-folder)
 518                                                    numbers)
 519   (dolist (folder-numbers (elmo-multi-make-folder-numbers-list folder numbers))
 520     (elmo-folder-mark-as-important (car folder-numbers)
 521                                    (cdr folder-numbers)))
 522   t)
 523
 524 (luna-define-method elmo-folder-unmark-important ((folder elmo-multi-folder)
 525                                                   numbers)
 526   (dolist (folder-numbers (elmo-multi-make-folder-numbers-list folder numbers))
 527     (elmo-folder-unmark-important (car folder-numbers)
 528                                   (cdr folder-numbers)))
 529   t)
 530
 531 (luna-define-method elmo-folder-mark-as-read ((folder elmo-multi-folder)
 532                                               numbers)
 533   (dolist (folder-numbers (elmo-multi-make-folder-numbers-list folder numbers))
 534     (elmo-folder-mark-as-read (car folder-numbers)
 535                               (cdr folder-numbers)))
 536   t)
 537
 538 (luna-define-method elmo-folder-unmark-read ((folder elmo-multi-folder)
 539                                              numbers)
 540   (dolist (folder-numbers (elmo-multi-make-folder-numbers-list folder numbers))
 541     (elmo-folder-unmark-read (car folder-numbers)
 542                              (cdr folder-numbers)))
 543   t)
 544
 545 (require 'product)
 546 (product-provide (provide 'elmo-multi) (require 'elmo-version))
 547
 548 ;;; elmo-multi.el ends here