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