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                       ))
  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
 108 ;; save and load functions
 109 (defun modb-standard-load-msgid (modb path)
 110   (let* ((alist (elmo-object-load
 111                  (expand-file-name modb-standard-msgid-filename path)))
 112          (table (or (modb-standard-entity-map-internal modb)
 113                     (elmo-make-hash (length alist))))
 114          numbers info)
 115     (dolist (pair alist)
 116       (setq info (cons 'autoload pair))
 117       (elmo-set-hash-val (modb-standard-key (car pair)) info table)
 118       (elmo-set-hash-val (cdr pair) info table)
 119       (setq numbers (cons (car pair) numbers)))
 120     (modb-standard-set-number-list-internal modb (nreverse numbers))
 121     (modb-standard-set-entity-map-internal modb table)))
 122
 123 (defun modb-standard-save-msgid (modb path)
 124   (let ((table (modb-standard-entity-map-internal modb))
 125         entity alist)
 126     (dolist (number (modb-standard-number-list-internal modb))
 127       (setq entity (elmo-get-hash-val (modb-standard-key number) table))
 128       (setq alist (cons (cons number (modb-standard-entity-id entity))
 129                         alist)))
 130     (elmo-object-save
 131      (expand-file-name modb-standard-msgid-filename path)
 132      (nreverse alist))))
 133
 134 (defun modb-standard-load-flag (modb path)
 135   (let ((table (or (modb-standard-flag-map-internal modb)
 136                    (elmo-make-hash (elmo-msgdb-length modb)))))
 137     (dolist (info (elmo-object-load
 138                    (expand-file-name modb-standard-flag-filename path)))
 139       (elmo-set-hash-val (modb-standard-key (car info)) info table))
 140     (modb-standard-set-flag-map-internal modb table)))
 141
 142 (defun modb-standard-save-flag (modb path)
 143   (let (table flist info)
 144     (when (setq table (modb-standard-flag-map-internal modb))
 145       (mapatoms
 146        (lambda (atom)
 147          (setq info (symbol-value atom))
 148          (when (cdr info)
 149            (setq flist (cons info flist))))
 150        table))
 151     (elmo-object-save
 152      (expand-file-name modb-standard-flag-filename path)
 153      flist)))
 154
 155 (defsubst modb-standard-entity-filename (section)
 156   (if section
 157       (concat modb-standard-entity-filename
 158               "-"
 159               (number-to-string section))
 160     modb-standard-entity-filename))
 161
 162 (defun modb-standard-load-entity (modb path &optional section)
 163   (let ((table (or (modb-standard-entity-map-internal modb)
 164                    (elmo-make-hash (elmo-msgdb-length modb)))))
 165     (dolist (entity (elmo-object-load
 166                      (expand-file-name
 167                       (modb-standard-entity-filename section)
 168                       path)))
 169       (elmo-set-hash-val (modb-standard-key
 170                           (elmo-msgdb-message-entity-number
 171                            (elmo-message-entity-handler entity)
 172                            entity))
 173                          entity
 174                          table)
 175       (elmo-set-hash-val (elmo-msgdb-message-entity-field
 176                           (elmo-message-entity-handler entity)
 177                           entity 'message-id)
 178                          entity
 179                          table))
 180     (modb-standard-set-entity-map-internal modb table)))
 181
 182 (defsubst modb-standard-save-entity-1 (modb path &optional section)
 183   (let ((table (modb-standard-entity-map-internal modb))
 184         (filename (expand-file-name
 185                    (modb-standard-entity-filename section) path))
 186         entity entities)
 187     (dolist (number (modb-standard-number-list-internal modb))
 188       (when (and (or (null section)
 189                      (= section (/ number modb-standard-divide-number)))
 190                  (setq entity (elmo-msgdb-message-entity modb number)))
 191         (setq entities (cons entity entities))))
 192     (if entities
 193         (elmo-object-save filename entities)
 194       (ignore-errors (delete-file filename)))))
 195
 196 (defun modb-standard-save-entity (modb path)
 197   (let ((sections (modb-generic-message-modified-internal modb)))
 198     (cond ((listp sections)
 199            (dolist (section sections)
 200              (modb-standard-save-entity-1 modb path section)))
 201           (sections
 202            (modb-standard-save-entity-1 modb path)))))
 203
 204 ;;; Implement
 205 ;;
 206 (luna-define-method elmo-msgdb-load ((msgdb modb-standard))
 207   (let ((inhibit-quit t)
 208         (path (elmo-msgdb-location msgdb)))
 209     (when (file-exists-p (expand-file-name modb-standard-flag-filename path))
 210       (modb-standard-load-msgid msgdb path)
 211       (modb-standard-load-flag msgdb path)
 212       (unless modb-standard-divide-number
 213         (modb-standard-load-entity msgdb path))
 214       t)))
 215
 216 (luna-define-method elmo-msgdb-save ((msgdb modb-standard))
 217   (let ((path (elmo-msgdb-location msgdb)))
 218     (when (elmo-msgdb-message-modified-p msgdb)
 219       (modb-standard-save-msgid  msgdb path)
 220       (modb-standard-save-entity msgdb path)
 221       (modb-generic-set-message-modified-internal msgdb nil))
 222     (when (elmo-msgdb-flag-modified-p msgdb)
 223       (modb-standard-save-flag msgdb path)
 224       (modb-generic-set-flag-modified-internal msgdb nil))))
 225
 226 (luna-define-method elmo-msgdb-append :around ((msgdb modb-standard)
 227                                                msgdb-append)
 228   (when (> (elmo-msgdb-length msgdb-append) 0)
 229     (if (eq (luna-class-name msgdb-append) 'modb-standard)
 230         (let ((numbers (modb-standard-number-list-internal msgdb-append))
 231               duplicates)
 232           ;; number-list
 233           (modb-standard-set-number-list-internal
 234            msgdb
 235            (nconc (modb-standard-number-list-internal msgdb)
 236                   numbers))
 237           ;; entity-map
 238           (let ((table (modb-standard-entity-map msgdb))
 239                 entity msg-id)
 240             (dolist (number numbers)
 241               (setq entity (elmo-msgdb-message-entity msgdb-append number)
 242                     msg-id (modb-standard-entity-id entity))
 243               (if (elmo-get-hash-val msg-id table)
 244                   (setq duplicates (cons number duplicates))
 245                 (elmo-set-hash-val msg-id entity table))
 246               (elmo-set-hash-val (modb-standard-key number)
 247                                  entity
 248                                  table)))
 249           ;; flag-map
 250           (let ((table (modb-standard-flag-map msgdb)))
 251             (mapatoms
 252              (lambda (atom)
 253                (elmo-set-hash-val (symbol-name atom)
 254                                   (symbol-value atom)
 255                                   table))
 256              (modb-standard-flag-map msgdb-append)))
 257           ;; modification flags
 258           (dolist (number (modb-standard-number-list-internal msgdb-append))
 259             (modb-standard-set-message-modified msgdb number)
 260             (modb-standard-set-flag-modified msgdb number))
 261           duplicates)
 262       (luna-call-next-method))))
 263
 264 (luna-define-method elmo-msgdb-clear :after ((msgdb modb-standard))
 265   (modb-standard-set-number-list-internal msgdb nil)
 266   (modb-standard-set-entity-map-internal msgdb nil)
 267   (modb-standard-set-flag-map-internal msgdb nil))
 268
 269 (luna-define-method elmo-msgdb-length ((msgdb modb-standard))
 270   (length (modb-standard-number-list-internal msgdb)))
 271
 272 (luna-define-method elmo-msgdb-flags ((msgdb modb-standard) number)
 273   (modb-standard-message-flags msgdb number))
 274
 275 (luna-define-method elmo-msgdb-set-flag ((msgdb modb-standard)
 276                                          number flag)
 277   (case flag
 278     (read
 279      (elmo-msgdb-unset-flag msgdb number 'unread))
 280     (uncached
 281      (elmo-msgdb-unset-flag msgdb number 'cached))
 282     (t
 283      (let* ((cur-flags (modb-standard-message-flags msgdb number))
 284             (new-flags (copy-sequence cur-flags)))
 285        (and (memq 'new new-flags)
 286             (setq new-flags (delq 'new new-flags)))
 287        (or (memq flag new-flags)
 288            (setq new-flags (cons flag new-flags)))
 289        (when (and (eq flag 'unread)
 290                   (memq 'answered new-flags))
 291          (setq new-flags (delq 'answered new-flags)))
 292        (unless (equal new-flags cur-flags)
 293          (elmo-set-hash-val (modb-standard-key number)
 294                             (cons number new-flags)
 295                             (modb-standard-flag-map msgdb))
 296          (modb-standard-set-flag-modified msgdb number))))))
 297
 298 (luna-define-method elmo-msgdb-unset-flag ((msgdb modb-standard)
 299                                            number flag)
 300   (case flag
 301     (read
 302      (elmo-msgdb-set-flag msgdb number 'unread))
 303     (uncached
 304      (elmo-msgdb-set-flag msgdb number 'cached))
 305     (t
 306      (let* ((cur-flags (modb-standard-message-flags msgdb number))
 307             (new-flags (copy-sequence cur-flags)))
 308        (and (memq 'new new-flags)
 309             (setq new-flags (delq 'new new-flags)))
 310        (and (memq flag new-flags)
 311             (setq new-flags (delq flag new-flags)))
 312        (when (and (eq flag 'unread)
 313                   (memq 'answered new-flags))
 314          (setq new-flags (delq 'answered new-flags)))
 315        (unless (equal new-flags cur-flags)
 316          (elmo-set-hash-val (modb-standard-key number)
 317                             (cons number new-flags)
 318                             (modb-standard-flag-map msgdb))
 319          (modb-standard-set-flag-modified msgdb number))))))
 320
 321 (luna-define-method elmo-msgdb-list-messages ((msgdb modb-standard))
 322   (copy-sequence
 323    (modb-standard-number-list-internal msgdb)))
 324
 325 (luna-define-method elmo-msgdb-list-flagged ((msgdb modb-standard) flag)
 326   (let (entry matched)
 327     (case flag
 328       (read
 329        (dolist (number (modb-standard-number-list-internal msgdb))
 330          (unless (memq 'unread (modb-standard-message-flags msgdb number))
 331            (setq matched (cons number matched)))))
 332       (digest
 333        (mapatoms
 334         (lambda (atom)
 335           (setq entry (symbol-value atom))
 336           (when (modb-standard-match-flags '(unread important)
 337                                            (cdr entry))
 338             (setq matched (cons (car entry) matched))))
 339         (modb-standard-flag-map msgdb)))
 340       (any
 341        (mapatoms
 342         (lambda (atom)
 343           (setq entry (symbol-value atom))
 344           (when (modb-standard-match-flags '(unread important answered)
 345                                            (cdr entry))
 346             (setq matched (cons (car entry) matched))))
 347         (modb-standard-flag-map msgdb)))
 348       (t
 349        (mapatoms
 350         (lambda (atom)
 351           (setq entry (symbol-value atom))
 352           (when (memq flag (cdr entry))
 353             (setq matched (cons (car entry) matched))))
 354         (modb-standard-flag-map msgdb))))
 355     matched))
 356
 357 (luna-define-method elmo-msgdb-append-entity ((msgdb modb-standard)
 358                                               entity &optional flags)
 359   (let ((number (elmo-msgdb-message-entity-number
 360                  (elmo-message-entity-handler entity) entity))
 361         (msg-id (elmo-msgdb-message-entity-field
 362                  (elmo-message-entity-handler entity) entity 'message-id))
 363         duplicate)
 364     ;; number-list
 365     (modb-standard-set-number-list-internal
 366      msgdb
 367      (nconc (modb-standard-number-list-internal msgdb)
 368             (list number)))
 369     ;; entity-map
 370     (let ((table (modb-standard-entity-map msgdb)))
 371       (setq duplicate (elmo-get-hash-val msg-id table))
 372       (elmo-set-hash-val (modb-standard-key number) entity table)
 373       (elmo-set-hash-val msg-id entity table))
 374     ;; modification flags
 375     (modb-standard-set-message-modified msgdb number)
 376     ;; flag-map
 377     (when flags
 378       (elmo-set-hash-val
 379        (modb-standard-key number)
 380        (cons number flags)
 381        (modb-standard-flag-map msgdb))
 382       (modb-standard-set-flag-modified msgdb number))
 383     duplicate))
 384
 385 (luna-define-method elmo-msgdb-delete-messages ((msgdb modb-standard)
 386                                                 numbers)
 387   (let ((number-list (modb-standard-number-list-internal msgdb))
 388         (entity-map (modb-standard-entity-map-internal msgdb))
 389         (flag-map (modb-standard-flag-map-internal msgdb))
 390         key entity)
 391     (dolist (number numbers)
 392       (setq key (modb-standard-key number)
 393             entity (elmo-get-hash-val key entity-map))
 394       ;; number-list
 395       (setq number-list (delq number number-list))
 396       ;; entity-map
 397       (elmo-clear-hash-val key entity-map)
 398       (elmo-clear-hash-val (modb-standard-entity-id entity) entity-map)
 399       ;; flag-map
 400       (elmo-clear-hash-val key flag-map)
 401       (modb-standard-set-message-modified msgdb number)
 402       (modb-standard-set-flag-modified msgdb number))
 403     (modb-standard-set-number-list-internal msgdb number-list)
 404     (modb-standard-set-entity-map-internal msgdb entity-map)
 405     (modb-standard-set-flag-map-internal msgdb flag-map)))
 406
 407 (luna-define-method elmo-msgdb-sort-entities ((msgdb modb-standard)
 408                                               predicate &optional app-data)
 409   (message "Sorting...")
 410   (let ((numbers (modb-standard-number-list-internal msgdb)))
 411     (modb-standard-set-number-list-internal
 412      msgdb
 413      (sort numbers (lambda (a b)
 414                      (funcall predicate
 415                               (elmo-msgdb-message-entity msgdb a)
 416                               (elmo-msgdb-message-entity msgdb b)
 417                               app-data))))
 418     (message "Sorting...done")
 419     msgdb))
 420
 421 (luna-define-method elmo-msgdb-message-entity ((msgdb modb-standard) key)
 422   (let ((ret (elmo-get-hash-val
 423               (cond ((stringp key) key)
 424                     ((numberp key) (modb-standard-key key)))
 425               (modb-standard-entity-map-internal msgdb))))
 426     (if (eq 'autoload (car-safe ret))
 427         (when modb-standard-divide-number
 428           (modb-standard-load-entity
 429            msgdb
 430            (elmo-msgdb-location msgdb)
 431            (/ (nth 1 ret) modb-standard-divide-number))
 432           (elmo-get-hash-val
 433            (cond ((stringp key) key)
 434                  ((numberp key) (modb-standard-key key)))
 435            (modb-standard-entity-map-internal msgdb)))
 436       ret)))
 437
 438 ;;; Message entity handling.
 439 (defsubst modb-standard-make-message-entity (args)
 440   "Make an message entity."
 441   (cons (plist-get args :message-id)
 442         (vector (plist-get args :number)
 443                 (plist-get args :references)
 444                 (plist-get args :from)
 445                 (plist-get args :subject)
 446                 (plist-get args :date)
 447                 (plist-get args :to)
 448                 (plist-get args :cc)
 449                 (plist-get args :size)
 450                 (plist-get args :extra))))
 451
 452 (luna-define-method elmo-msgdb-make-message-entity ((msgdb modb-standard)
 453                                                     args)
 454   (modb-standard-make-message-entity args))
 455
 456 (luna-define-method elmo-msgdb-create-message-entity-from-buffer
 457   ((msgdb modb-standard) number args)
 458   (let ((extras elmo-msgdb-extra-fields)
 459         (default-mime-charset default-mime-charset)
 460         entity message-id references from subject to cc date
 461         extra field-body charset size)
 462     (save-excursion
 463       (setq entity (modb-standard-make-message-entity args)
 464             ;; For compatibility.
 465             msgdb (elmo-message-entity-handler entity))
 466       (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 467       (setq message-id (elmo-msgdb-get-message-id-from-buffer))
 468       (and (setq charset (cdr (assoc "charset" (mime-read-Content-Type))))
 469            (setq charset (intern-soft charset))
 470            (setq default-mime-charset charset))
 471       (setq references
 472             (or (elmo-msgdb-get-last-message-id
 473                  (elmo-field-body "in-reply-to"))
 474                 (elmo-msgdb-get-last-message-id
 475                  (elmo-field-body "references")))
 476             from (elmo-replace-in-string
 477                   (elmo-mime-string (or (elmo-field-body "from")
 478                                         elmo-no-from))
 479                   "\t" " ")
 480             subject (elmo-replace-in-string
 481                      (elmo-mime-string (or (elmo-field-body "subject")
 482                                            elmo-no-subject))
 483                      "\t" " ")
 484             date (elmo-field-body "date")
 485             to   (mapconcat 'identity (elmo-multiple-field-body "to") ",")
 486             cc   (mapconcat 'identity (elmo-multiple-field-body "cc") ","))
 487       (unless (elmo-msgdb-message-entity-field msgdb entity 'size)
 488         (if (setq size (elmo-field-body "content-length"))
 489             (setq size (string-to-int size))
 490           (setq size 0)))
 491       (while extras
 492         (if (setq field-body (elmo-field-body (car extras)))
 493             (elmo-msgdb-message-entity-set-field
 494              msgdb entity (intern (downcase (car extras))) field-body))
 495         (setq extras (cdr extras)))
 496       (dolist (field '(number message-id references from subject
 497                               date to cc size))
 498         (when (symbol-value field)
 499           (elmo-msgdb-message-entity-set-field
 500            msgdb entity field (symbol-value field))))
 501       entity)))
 502
 503 ;;; Message entity interface
 504 ;;
 505 (luna-define-method elmo-msgdb-message-entity-number ((msgdb modb-standard)
 506                                                       entity)
 507   ;; To be implemented.
 508   )
 509
 510 (luna-define-method elmo-msgdb-message-entity-set-number ((msgdb modb-standard)
 511                                                           entity
 512                                                           number)
 513   ;; To be implemented.
 514   )
 515
 516 (luna-define-method elmo-msgdb-message-entity-field ((msgdb modb-standard)
 517                                                      entity field
 518                                                      &optional decode)
 519   ;; To be implemented.
 520   )
 521
 522 (luna-define-method elmo-msgdb-message-entity-set-field ((msgdb modb-standard)
 523                                                          entity field value)
 524   ;; To be implemented.
 525   )
 526
 527 (luna-define-method elmo-msgdb-copy-message-entity ((msgdb modb-standard)
 528                                                     entity)
 529   ;; To be implemented.
 530   )
 531
 532 (luna-define-method elmo-msgdb-match-condition-internal ((msgdb modb-standard)
 533                                                          condition
 534                                                          entity flags numbers)
 535   ;; To be implemented.
 536   )
 537
 538 (require 'product)
 539 (product-provide (provide 'modb-standard) (require 'elmo-version))
 540
 541 ;;; modb-standard.el ends here