elmo/modb-standard.el

   1 ;;; modb-standard.el --- Standartd Implement of MODB.
   2
   3 ;; Copyright (C) 2003 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;;      Hiroya Murata <lapis-lazuli@pop06.odn.ne.jp>
   7 ;; Keywords: mail, net news
   8
   9 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25 ;;
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31 ;;
  32 (eval-when-compile (require 'cl))
  33
  34 (require 'elmo-util)
  35 (require 'mime)
  36 (require 'modb)
  37
  38 (defcustom modb-standard-divide-number 500
  39   "*Standard modb divide entity number."
  40   :type '(choice (const :tag "Not divide" nil)
  41                  number)
  42   :group 'elmo)
  43
  44 (defvar modb-standard-entity-filename "entity"
  45   "Message entity database.")
  46
  47 (defvar modb-standard-flag-filename "flag"
  48   "Message number <=> Flag status database.")
  49
  50 (defvar modb-standard-msgid-filename "msgid"
  51   "Message number <=> Message-Id database.")
  52
  53 (eval-and-compile
  54   (luna-define-class modb-standard (modb-generic)
  55                      (number-list       ; sorted list of message numbers.
  56                       entity-map        ; number, msg-id -> entity mapping.
  57                       flag-map          ; number -> flag-list mapping
  58                       flag-count        ; list of (FLAG . COUNT)
  59                       ))
  60   (luna-define-internal-accessors 'modb-standard))
  61
  62 ;; for internal use only
  63 (defsubst modb-standard-key (number)
  64   (concat "#" (number-to-string number)))
  65
  66 (defsubst modb-standard-entity-id (entity)
  67   (if (eq 'autoload (car-safe entity))
  68       (cddr entity)
  69     (elmo-msgdb-message-entity-field
  70      (elmo-message-entity-handler entity)
  71      entity 'message-id)))
  72
  73 (defsubst modb-standard-entity-map (modb)
  74   (or (modb-standard-entity-map-internal modb)
  75       (modb-standard-set-entity-map-internal
  76        modb
  77        (elmo-make-hash (elmo-msgdb-length modb)))))
  78
  79 (defsubst modb-standard-flag-map (modb)
  80   (or (modb-standard-flag-map-internal modb)
  81       (modb-standard-set-flag-map-internal
  82        modb
  83        (elmo-make-hash (elmo-msgdb-length modb)))))
  84
  85 (defsubst modb-standard-set-message-modified (modb number)
  86   (if modb-standard-divide-number
  87       (let ((section (/ number modb-standard-divide-number))
  88             (modified (modb-generic-message-modified-internal modb)))
  89         (unless (memq section modified)
  90           (modb-generic-set-message-modified-internal
  91            modb (cons section modified))))
  92     (modb-generic-set-message-modified-internal modb t)))
  93
  94 (defsubst modb-standard-set-flag-modified (modb number)
  95   (modb-generic-set-flag-modified-internal modb t))
  96
  97 (defsubst modb-standard-message-flags (modb number)
  98   (cdr (elmo-get-hash-val (modb-standard-key number)
  99                           (modb-standard-flag-map-internal modb))))
 100
 101 (defsubst modb-standard-match-flags (check-flags flags)
 102   (catch 'done
 103     (while check-flags
 104       (when (memq (car check-flags) flags)
 105         (throw 'done t))
 106       (setq check-flags (cdr check-flags)))))
 107
 108 (defsubst modb-standard-countup-flags (modb flags &optional delta)
 109   (let ((flag-count (modb-standard-flag-count-internal modb))
 110         (delta (or delta 1))
 111         elem)
 112     (dolist (flag flags)
 113       (if (setq elem (assq flag flag-count))
 114           (setcdr elem (+ (cdr elem) delta))
 115         (setq flag-count (cons (cons flag delta) flag-count))))
 116     (modb-standard-set-flag-count-internal modb flag-count)))
 117
 118 ;; save and load functions
 119 (defun modb-standard-load-msgid (modb path)
 120   (let* ((alist (elmo-object-load
 121                  (expand-file-name modb-standard-msgid-filename path)))
 122          (table (or (modb-standard-entity-map-internal modb)
 123                     (elmo-make-hash (length alist))))
 124          numbers info)
 125     (dolist (pair alist)
 126       (setq info (cons 'autoload pair))
 127       (elmo-set-hash-val (modb-standard-key (car pair)) info table)
 128       (elmo-set-hash-val (cdr pair) info table)
 129       (setq numbers (cons (car pair) numbers)))
 130     (modb-standard-set-number-list-internal modb (nreverse numbers))
 131     (modb-standard-set-entity-map-internal modb table)))
 132
 133 (defun modb-standard-save-msgid (modb path)
 134   (let ((table (modb-standard-entity-map-internal modb))
 135         entity alist)
 136     (dolist (number (modb-standard-number-list-internal modb))
 137       (setq entity (elmo-get-hash-val (modb-standard-key number) table))
 138       (setq alist (cons (cons number (modb-standard-entity-id entity))
 139                         alist)))
 140     (elmo-object-save
 141      (expand-file-name modb-standard-msgid-filename path)
 142      (nreverse alist))))
 143
 144 (defun modb-standard-load-flag (modb path)
 145   (let ((table (or (modb-standard-flag-map-internal modb)
 146                    (elmo-make-hash (elmo-msgdb-length modb)))))
 147     (dolist (info (elmo-object-load
 148                    (expand-file-name modb-standard-flag-filename path)))
 149       (modb-standard-countup-flags modb (cdr info))
 150       (elmo-set-hash-val (modb-standard-key (car info)) info table))
 151     (modb-standard-set-flag-map-internal modb table)))
 152
 153 (defun modb-standard-save-flag (modb path)
 154   (let (table flist info)
 155     (when (setq table (modb-standard-flag-map-internal modb))
 156       (mapatoms
 157        (lambda (atom)
 158          (setq info (symbol-value atom))
 159          (when (cdr info)
 160            (setq flist (cons info flist))))
 161        table))
 162     (elmo-object-save
 163      (expand-file-name modb-standard-flag-filename path)
 164      flist)))
 165
 166 (defsubst modb-standard-entity-filename (section)
 167   (if section
 168       (concat modb-standard-entity-filename
 169               "-"
 170               (number-to-string section))
 171     modb-standard-entity-filename))
 172
 173 (defun modb-standard-load-entity (modb path &optional section)
 174   (let ((table (or (modb-standard-entity-map-internal modb)
 175                    (elmo-make-hash (elmo-msgdb-length modb)))))
 176     (dolist (entity (elmo-object-load
 177                      (expand-file-name
 178                       (modb-standard-entity-filename section)
 179                       path)))
 180       (elmo-set-hash-val (modb-standard-key
 181                           (elmo-msgdb-message-entity-number
 182                            (elmo-message-entity-handler entity)
 183                            entity))
 184                          entity
 185                          table)
 186       (elmo-set-hash-val (elmo-msgdb-message-entity-field
 187                           (elmo-message-entity-handler entity)
 188                           entity 'message-id)
 189                          entity
 190                          table))
 191     (modb-standard-set-entity-map-internal modb table)))
 192
 193 (defsubst modb-standard-save-entity-1 (modb path &optional section)
 194   (let ((table (modb-standard-entity-map-internal modb))
 195         (filename (expand-file-name
 196                    (modb-standard-entity-filename section) path))
 197         entity entities)
 198     (dolist (number (modb-standard-number-list-internal modb))
 199       (when (and (or (null section)
 200                      (= section (/ number modb-standard-divide-number)))
 201                  (setq entity (elmo-msgdb-message-entity modb number)))
 202         (setq entities (cons entity entities))))
 203     (if entities
 204         (elmo-object-save filename entities)
 205       (ignore-errors (delete-file filename)))))
 206
 207 (defun modb-standard-save-entity (modb path)
 208   (let ((sections (modb-generic-message-modified-internal modb)))
 209     (cond ((listp sections)
 210            (dolist (section sections)
 211              (modb-standard-save-entity-1 modb path section)))
 212           (sections
 213            (modb-standard-save-entity-1 modb path)))))
 214
 215 ;;; Implement
 216 ;;
 217 (luna-define-method elmo-msgdb-load ((msgdb modb-standard))
 218   (let ((inhibit-quit t)
 219         (path (elmo-msgdb-location msgdb)))
 220     (when (file-exists-p (expand-file-name modb-standard-flag-filename path))
 221       (modb-standard-load-msgid msgdb path)
 222       (modb-standard-load-flag msgdb path)
 223       (unless modb-standard-divide-number
 224         (modb-standard-load-entity msgdb path))
 225       t)))
 226
 227 (luna-define-method elmo-msgdb-save ((msgdb modb-standard))
 228   (let ((path (elmo-msgdb-location msgdb)))
 229     (when (elmo-msgdb-message-modified-p msgdb)
 230       (modb-standard-save-msgid  msgdb path)
 231       (modb-standard-save-entity msgdb path)
 232       (modb-generic-set-message-modified-internal msgdb nil))
 233     (when (elmo-msgdb-flag-modified-p msgdb)
 234       (modb-standard-save-flag msgdb path)
 235       (modb-generic-set-flag-modified-internal msgdb nil))))
 236
 237 (luna-define-method elmo-msgdb-append :around ((msgdb modb-standard)
 238                                                msgdb-append)
 239   (when (> (elmo-msgdb-length msgdb-append) 0)
 240     (if (eq (luna-class-name msgdb-append) 'modb-standard)
 241         (let ((numbers (modb-standard-number-list-internal msgdb-append))
 242               duplicates)
 243           ;; number-list
 244           (modb-standard-set-number-list-internal
 245            msgdb
 246            (nconc (modb-standard-number-list-internal msgdb)
 247                   numbers))
 248           ;; entity-map
 249           (let ((table (modb-standard-entity-map msgdb))
 250                 entity msg-id)
 251             (dolist (number numbers)
 252               (setq entity (elmo-msgdb-message-entity msgdb-append number)
 253                     msg-id (modb-standard-entity-id entity))
 254               (if (elmo-get-hash-val msg-id table)
 255                   (setq duplicates (cons number duplicates))
 256                 (elmo-set-hash-val msg-id entity table))
 257               (elmo-set-hash-val (modb-standard-key number)
 258                                  entity
 259                                  table)))
 260           ;; flag-map
 261           (let ((table (modb-standard-flag-map msgdb)))
 262             (mapatoms
 263              (lambda (atom)
 264                (elmo-set-hash-val (symbol-name atom)
 265                                   (symbol-value atom)
 266                                   table))
 267              (modb-standard-flag-map msgdb-append)))
 268           ;; flag-count
 269           (dolist (pair (modb-standard-flag-count-internal msgdb-append))
 270             (modb-standard-countup-flags msgdb (list (car pair)) (cdr pair)))
 271           ;; modification flags
 272           (dolist (number (modb-standard-number-list-internal msgdb-append))
 273             (modb-standard-set-message-modified msgdb number)
 274             (modb-standard-set-flag-modified msgdb number))
 275           duplicates)
 276       (luna-call-next-method))))
 277
 278 (luna-define-method elmo-msgdb-clear :after ((msgdb modb-standard))
 279   (modb-standard-set-number-list-internal msgdb nil)
 280   (modb-standard-set-entity-map-internal msgdb nil)
 281   (modb-standard-set-flag-map-internal msgdb nil)
 282   (modb-standard-set-flag-count-internal msgdb nil))
 283
 284 (luna-define-method elmo-msgdb-length ((msgdb modb-standard))
 285   (length (modb-standard-number-list-internal msgdb)))
 286
 287 (luna-define-method elmo-msgdb-flags ((msgdb modb-standard) number)
 288   (modb-standard-message-flags msgdb number))
 289
 290 (luna-define-method elmo-msgdb-set-flag ((msgdb modb-standard)
 291                                          number flag)
 292   (case flag
 293     (read
 294      (elmo-msgdb-unset-flag msgdb number 'unread))
 295     (uncached
 296      (elmo-msgdb-unset-flag msgdb number 'cached))
 297     (t
 298      (let* ((cur-flags (modb-standard-message-flags msgdb number))
 299             (new-flags (copy-sequence cur-flags))
 300             diff)
 301        (and (memq 'new new-flags)
 302             (setq new-flags (delq 'new new-flags)))
 303        (or (memq flag new-flags)
 304            (setq new-flags (cons flag new-flags)))
 305        (when (and (eq flag 'unread)
 306                   (memq 'answered new-flags))
 307          (setq new-flags (delq 'answered new-flags)))
 308        (unless (equal new-flags cur-flags)
 309          (setq diff (elmo-list-diff new-flags cur-flags))
 310          (modb-standard-countup-flags msgdb (car diff))
 311          (modb-standard-countup-flags msgdb (cadr diff) -1)
 312          (elmo-set-hash-val (modb-standard-key number)
 313                             (cons number new-flags)
 314                             (modb-standard-flag-map msgdb))
 315          (modb-standard-set-flag-modified msgdb number))))))
 316
 317 (luna-define-method elmo-msgdb-unset-flag ((msgdb modb-standard)
 318                                            number flag)
 319   (case flag
 320     (read
 321      (elmo-msgdb-set-flag msgdb number 'unread))
 322     (uncached
 323      (elmo-msgdb-set-flag msgdb number 'cached))
 324     (all
 325      (modb-standard-countup-flags msgdb
 326                                   (modb-standard-message-flags msgdb number)
 327                                   -1)
 328      (elmo-clear-hash-val (modb-standard-key number)
 329                           (modb-standard-flag-map msgdb)))
 330     (t
 331      (let* ((cur-flags (modb-standard-message-flags msgdb number))
 332             (new-flags (copy-sequence cur-flags))
 333             diff)
 334        (and (memq 'new new-flags)
 335             (setq new-flags (delq 'new new-flags)))
 336        (and (memq flag new-flags)
 337             (setq new-flags (delq flag new-flags)))
 338        (when (and (eq flag 'unread)
 339                   (memq 'answered new-flags))
 340          (setq new-flags (delq 'answered new-flags)))
 341        (unless (equal new-flags cur-flags)
 342          (setq diff (elmo-list-diff new-flags cur-flags))
 343          (modb-standard-countup-flags msgdb (car diff))
 344          (modb-standard-countup-flags msgdb (cadr diff) -1)
 345          (elmo-set-hash-val (modb-standard-key number)
 346                             (cons number new-flags)
 347                             (modb-standard-flag-map msgdb))
 348          (modb-standard-set-flag-modified msgdb number))))))
 349
 350 (luna-define-method elmo-msgdb-flag-count ((msgdb modb-standard))
 351   (modb-standard-flag-count-internal msgdb))
 352
 353 (luna-define-method elmo-msgdb-list-messages ((msgdb modb-standard))
 354   (copy-sequence
 355    (modb-standard-number-list-internal msgdb)))
 356
 357 (luna-define-method elmo-msgdb-list-flagged ((msgdb modb-standard) flag)
 358   (let (entry matched)
 359     (case flag
 360       (read
 361        (dolist (number (modb-standard-number-list-internal msgdb))
 362          (unless (memq 'unread (modb-standard-message-flags msgdb number))
 363            (setq matched (cons number matched)))))
 364       (digest
 365        (mapatoms
 366         (lambda (atom)
 367           (setq entry (symbol-value atom))
 368           (when (modb-standard-match-flags '(unread important)
 369                                            (cdr entry))
 370             (setq matched (cons (car entry) matched))))
 371         (modb-standard-flag-map msgdb)))
 372       (any
 373        (mapatoms
 374         (lambda (atom)
 375           (setq entry (symbol-value atom))
 376           (when (modb-standard-match-flags '(unread important answered)
 377                                            (cdr entry))
 378             (setq matched (cons (car entry) matched))))
 379         (modb-standard-flag-map msgdb)))
 380       (t
 381        (mapatoms
 382         (lambda (atom)
 383           (setq entry (symbol-value atom))
 384           (when (memq flag (cdr entry))
 385             (setq matched (cons (car entry) matched))))
 386         (modb-standard-flag-map msgdb))))
 387     matched))
 388
 389 (luna-define-method elmo-msgdb-search ((msgdb modb-standard)
 390                                        condition &optional numbers)
 391   (if (vectorp condition)
 392       (let ((key (elmo-filter-key condition))
 393             results)
 394         (cond
 395          ((and (string= key "flag")
 396                (eq (elmo-filter-type condition) 'match))
 397           (setq results (elmo-msgdb-list-flagged
 398                          msgdb
 399                          (intern (elmo-filter-value condition))))
 400           (if numbers
 401               (elmo-list-filter numbers results)
 402             results))
 403          ((member key '("first" "last"))
 404           (let* ((numbers (or numbers
 405                               (modb-standard-number-list-internal msgdb)))
 406                  (len (length numbers))
 407                  (lastp (string= key "last"))
 408                  (value (string-to-number (elmo-filter-value condition))))
 409             (when (eq (elmo-filter-type condition) 'unmatch)
 410               (setq lastp (not lastp)
 411                     value (- len value)))
 412             (if lastp
 413                 (nthcdr (max (- len value) 0) numbers)
 414               (when (> value 0)
 415                 (let* ((numbers (copy-sequence numbers))
 416                        (last (nthcdr (1- value) numbers)))
 417                   (when last
 418                     (setcdr last nil))
 419                   numbers)))))
 420          (t
 421           t)))
 422     t))
 423
 424 (luna-define-method elmo-msgdb-append-entity ((msgdb modb-standard)
 425                                               entity &optional flags)
 426   (let ((number (elmo-msgdb-message-entity-number
 427                  (elmo-message-entity-handler entity) entity))
 428         (msg-id (elmo-msgdb-message-entity-field
 429                  (elmo-message-entity-handler entity) entity 'message-id))
 430         duplicate)
 431     ;; number-list
 432     (modb-standard-set-number-list-internal
 433      msgdb
 434      (nconc (modb-standard-number-list-internal msgdb)
 435             (list number)))
 436     ;; entity-map
 437     (let ((table (modb-standard-entity-map msgdb)))
 438       (setq duplicate (elmo-get-hash-val msg-id table))
 439       (elmo-set-hash-val (modb-standard-key number) entity table)
 440       (elmo-set-hash-val msg-id entity table))
 441     ;; modification flags
 442     (modb-standard-set-message-modified msgdb number)
 443     ;; flag-map
 444     (when flags
 445       (elmo-set-hash-val
 446        (modb-standard-key number)
 447        (cons number flags)
 448        (modb-standard-flag-map msgdb))
 449       (modb-standard-countup-flags msgdb flags)
 450       (modb-standard-set-flag-modified msgdb number))
 451     duplicate))
 452
 453 (luna-define-method elmo-msgdb-delete-messages ((msgdb modb-standard)
 454                                                 numbers)
 455   (let ((number-list (modb-standard-number-list-internal msgdb))
 456         (entity-map (modb-standard-entity-map-internal msgdb))
 457         (flag-map (modb-standard-flag-map-internal msgdb))
 458         key entity)
 459     (dolist (number numbers)
 460       (setq key (modb-standard-key number)
 461             entity (elmo-get-hash-val key entity-map))
 462       ;; number-list
 463       (setq number-list (delq number number-list))
 464       ;; entity-map
 465       (elmo-clear-hash-val key entity-map)
 466       (elmo-clear-hash-val (modb-standard-entity-id entity) entity-map)
 467       ;; flag-count (must be BEFORE flag-map)
 468       (modb-standard-countup-flags
 469        msgdb
 470        (modb-standard-message-flags msgdb number)
 471        -1)
 472       ;; flag-map
 473       (elmo-clear-hash-val key flag-map)
 474       (modb-standard-set-message-modified msgdb number)
 475       (modb-standard-set-flag-modified msgdb number))
 476     (modb-standard-set-number-list-internal msgdb number-list)
 477     (modb-standard-set-entity-map-internal msgdb entity-map)
 478     (modb-standard-set-flag-map-internal msgdb flag-map)))
 479
 480 (luna-define-method elmo-msgdb-sort-entities ((msgdb modb-standard)
 481                                               predicate &optional app-data)
 482   (message "Sorting...")
 483   (let ((numbers (modb-standard-number-list-internal msgdb)))
 484     (modb-standard-set-number-list-internal
 485      msgdb
 486      (sort numbers (lambda (a b)
 487                      (funcall predicate
 488                               (elmo-msgdb-message-entity msgdb a)
 489                               (elmo-msgdb-message-entity msgdb b)
 490                               app-data))))
 491     (message "Sorting...done")
 492     msgdb))
 493
 494 (luna-define-method elmo-msgdb-message-entity ((msgdb modb-standard) key)
 495   (let ((ret (elmo-get-hash-val
 496               (cond ((stringp key) key)
 497                     ((numberp key) (modb-standard-key key)))
 498               (modb-standard-entity-map-internal msgdb))))
 499     (if (eq 'autoload (car-safe ret))
 500         (when modb-standard-divide-number
 501           (modb-standard-load-entity
 502            msgdb
 503            (elmo-msgdb-location msgdb)
 504            (/ (nth 1 ret) modb-standard-divide-number))
 505           (elmo-get-hash-val
 506            (cond ((stringp key) key)
 507                  ((numberp key) (modb-standard-key key)))
 508            (modb-standard-entity-map-internal msgdb)))
 509       ret)))
 510
 511 (require 'product)
 512 (product-provide (provide 'modb-standard) (require 'elmo-version))
 513
 514 ;;; modb-standard.el ends here