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