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