elmo/elmo-msgdb.el

   1 ;;; elmo-msgdb.el --- Message Database for ELMO.
   2
   3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4 ;; Copyright (C) 2000           Masahiro MURATA <muse@ba2.so-net.ne.jp>
   5
   6 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   7 ;;      Masahiro MURATA <muse@ba2.so-net.ne.jp>
   8 ;; Keywords: mail, net news
   9
  10 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
  11
  12 ;; This program is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16 ;;
  17 ;; This program is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21 ;;
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26 ;;
  27
  28 ;;; Commentary:
  29 ;;
  30
  31 ;;; Code:
  32 ;;
  33
  34 (eval-when-compile (require 'cl))
  35 (require 'elmo-vars)
  36 (require 'elmo-util)
  37 (require 'emu)
  38 (require 'std11)
  39 (require 'mime)
  40 (require 'modb)
  41 (require 'modb-entity)
  42
  43 (defconst elmo-msgdb-new-mark "N"
  44   "Mark for new message.")
  45
  46 (defconst elmo-msgdb-unread-uncached-mark "U"
  47   "Mark for unread and uncached message.")
  48
  49 (defconst elmo-msgdb-unread-cached-mark "!"
  50   "Mark for unread but already cached message.")
  51
  52 (defconst elmo-msgdb-read-uncached-mark "u"
  53   "Mark for read but uncached message.")
  54
  55 (defconst elmo-msgdb-answered-cached-mark "&"
  56   "Mark for answered and cached message.")
  57
  58 (defconst elmo-msgdb-answered-uncached-mark "A"
  59   "Mark for answered but cached message.")
  60
  61 (defconst elmo-msgdb-important-mark "$"
  62   "Mark for important message.")
  63
  64 ;;; MSGDB interface.
  65 ;;
  66 ;; MSGDB elmo-load-msgdb PATH
  67
  68 ;; NUMBER elmo-msgdb-get-number MSGDB MESSAGE-ID
  69 ;; FIELD-VALUE elmo-msgdb-get-field MSGDB NUMBER FIELD
  70 ;; elmo-msgdb-sort-by-date MSGDB
  71
  72 ;; elmo-flag-table-load
  73 ;; elmo-flag-table-set
  74 ;; elmo-flag-table-get
  75 ;; elmo-flag-table-save
  76
  77 ;; elmo-msgdb-overview-save DIR OBJ
  78
  79 ;;; Abolish
  80 ;; elmo-msgdb-get-parent-entity ENTITY MSGDB
  81
  82 ;; elmo-msgdb-killed-list-load DIR
  83 ;; elmo-msgdb-killed-list-save DIR
  84 ;; elmo-msgdb-append-to-killed-list FOLDER MSG
  85 ;; elmo-msgdb-killed-list-length KILLED-LIST
  86 ;; elmo-msgdb-max-of-killed KILLED-LIST
  87 ;; elmo-msgdb-killed-message-p KILLED-LIST MSG
  88 ;; elmo-living-messages MESSAGES KILLED-LIST
  89
  90 ;; elmo-msgdb-finfo-load
  91 ;; elmo-msgdb-finfo-save
  92 ;; elmo-msgdb-flist-load
  93 ;; elmo-msgdb-flist-save
  94
  95 ;; elmo-crosspost-alist-load
  96 ;; elmo-crosspost-alist-save
  97
  98 ;; elmo-msgdb-create-overview-from-buffer NUMBER SIZE TIME
  99 ;; elmo-msgdb-create-overview-entity-from-file NUMBER FILE
 100
 101 ;; elmo-folder-get-info
 102 ;; elmo-folder-get-info-max
 103 ;; elmo-folder-get-info-length
 104 ;; elmo-folder-get-info-unread
 105
 106 ;;; Helper functions for MSGDB
 107 ;;
 108 (defun elmo-load-msgdb (location)
 109   "Load the MSGDB from PATH."
 110   (let ((msgdb (elmo-make-msgdb location)))
 111     (elmo-msgdb-load msgdb)
 112     msgdb))
 113
 114 (defun elmo-make-msgdb (&optional location type)
 115   "Make a MSGDB."
 116   (let* ((type (or type elmo-msgdb-default-type))
 117          (class (intern (format "modb-%s" type))))
 118     (require class)
 119     (luna-make-entity class
 120                       :location location)))
 121
 122 (defsubst elmo-msgdb-get-number (msgdb message-id)
 123   "Get number of the message which corrensponds to MESSAGE-ID from MSGDB."
 124   (elmo-msgdb-overview-entity-get-number
 125    (elmo-msgdb-message-entity msgdb message-id)))
 126
 127 (defsubst elmo-msgdb-get-field (msgdb number field)
 128   "Get FIELD value of the message with NUMBER from MSGDB."
 129   (case field
 130     (message-id (elmo-msgdb-overview-entity-get-id
 131                  (elmo-msgdb-message-entity
 132                   msgdb number)))
 133     (subject (elmo-msgdb-overview-entity-get-subject
 134               (elmo-msgdb-message-entity
 135                msgdb number)))
 136     (size (elmo-msgdb-overview-entity-get-size
 137            (elmo-msgdb-message-entity
 138             msgdb number)))
 139     (date (elmo-msgdb-overview-entity-get-date
 140            (elmo-msgdb-message-entity
 141             msgdb number)))
 142     (to (elmo-msgdb-overview-entity-get-to
 143          (elmo-msgdb-message-entity
 144           msgdb number)))
 145     (cc (elmo-msgdb-overview-entity-get-cc
 146          (elmo-msgdb-message-entity
 147           msgdb number)))))
 148
 149 (defun elmo-msgdb-sort-by-date (msgdb)
 150   (elmo-msgdb-sort-entities
 151    msgdb
 152    (lambda (x y app-data)
 153      (condition-case nil
 154          (string<
 155           (timezone-make-date-sortable
 156            (elmo-msgdb-overview-entity-get-date x))
 157           (timezone-make-date-sortable
 158            (elmo-msgdb-overview-entity-get-date y)))
 159        (error)))))
 160
 161 ;;;
 162 (defsubst elmo-msgdb-append-element (list element)
 163   (if list
 164 ;;;   (append list (list element))
 165       (nconc list (list element))
 166     ;; list is nil
 167     (list element)))
 168
 169 ;;
 170 ;; number <-> Message-ID handling
 171 ;;
 172 (defsubst elmo-msgdb-number-add (alist number id)
 173   (let ((ret-val alist))
 174     (setq ret-val
 175           (elmo-msgdb-append-element ret-val (cons number id)))
 176     ret-val))
 177
 178 ;;; flag table
 179 ;;
 180 (defvar elmo-flag-table-filename "flag-table")
 181 (defun elmo-flag-table-load (dir)
 182   "Load flag hashtable for MSGDB."
 183   (let ((table (elmo-make-hash))
 184         ;; For backward compatibility
 185         (seen-file (expand-file-name elmo-msgdb-seen-filename dir))
 186         value)
 187     (when (file-exists-p seen-file)
 188       (dolist (msgid (elmo-object-load seen-file))
 189         (elmo-set-hash-val msgid '(read) table))
 190       (delete-file seen-file))
 191     (dolist (pair (elmo-object-load
 192                    (expand-file-name elmo-flag-table-filename dir)))
 193       (setq value (cdr pair))
 194       (elmo-set-hash-val (car pair)
 195                          (cond ((consp value)
 196                                 value)
 197                                ;; Following cases for backward compatibility.
 198                                (value
 199                                 (list value))
 200                                (t
 201                                 '(unread)))
 202                          table))
 203     table))
 204
 205 (defun elmo-flag-table-set (flag-table msg-id flags)
 206   (elmo-set-hash-val msg-id (or flags '(read)) flag-table))
 207
 208 (defun elmo-flag-table-get (flag-table msg-id)
 209   (let ((flags (elmo-get-hash-val msg-id flag-table)))
 210     (if flags
 211         (append
 212          (and (elmo-msgdb-global-mark-get msg-id)
 213               '(important))
 214          (and (elmo-file-cache-exists-p msg-id)
 215               '(cached))
 216          (elmo-list-delete '(important cached read)
 217                            (copy-sequence flags)
 218                            #'delq))
 219       '(new unread))))
 220
 221 (defun elmo-flag-table-save (dir flag-table)
 222   (elmo-object-save
 223    (expand-file-name elmo-flag-table-filename dir)
 224    (if flag-table
 225        (let (list)
 226          (mapatoms (lambda (atom)
 227                      (setq list (cons (cons (symbol-name atom)
 228                                             (symbol-value atom))
 229                                       list)))
 230                    flag-table)
 231          list))))
 232 ;;;
 233 ;; persistent mark handling
 234 ;; (for each folder)
 235
 236 (defun elmo-msgdb-mark-append (alist id mark)
 237   "Append mark."
 238   (setq alist (elmo-msgdb-append-element alist
 239                                          (list id mark))))
 240
 241 (defun elmo-msgdb-flag-table (msgdb &optional flag-table)
 242   ;; Make a table of msgid flag (read, answered)
 243   (let ((flag-table (or flag-table
 244                         (elmo-make-hash (elmo-msgdb-length msgdb))))
 245         entity)
 246     (dolist (number (elmo-msgdb-list-messages msgdb))
 247       (setq entity (elmo-msgdb-message-entity msgdb number))
 248       (elmo-flag-table-set
 249        flag-table
 250        (elmo-msgdb-overview-entity-get-id entity)
 251        (elmo-msgdb-flags msgdb number)))
 252     flag-table))
 253
 254 ;;
 255 ;; overview handling
 256 ;;
 257 (defun elmo-multiple-field-body (name &optional boundary)
 258   (save-excursion
 259     (save-restriction
 260       (std11-narrow-to-header boundary)
 261       (goto-char (point-min))
 262       (let ((case-fold-search t)
 263             (field-body nil))
 264         (while (re-search-forward (concat "^" name ":[ \t]*") nil t)
 265           (setq field-body
 266                 (nconc field-body
 267                        (list (buffer-substring-no-properties
 268                               (match-end 0) (std11-field-end))))))
 269         field-body))))
 270
 271 (defun elmo-multiple-fields-body-list (field-names &optional boundary)
 272   "Return list of each field-bodies of FIELD-NAMES of the message header
 273 in current buffer. If BOUNDARY is not nil, it is used as message
 274 header separator."
 275   (save-excursion
 276     (save-restriction
 277       (std11-narrow-to-header boundary)
 278       (let* ((case-fold-search t)
 279              (s-rest field-names)
 280              field-name field-body)
 281         (while (setq field-name (car s-rest))
 282           (goto-char (point-min))
 283           (while (re-search-forward (concat "^" field-name ":[ \t]*") nil t)
 284             (setq field-body
 285                   (nconc field-body
 286                          (list (buffer-substring-no-properties
 287                                 (match-end 0) (std11-field-end))))))
 288           (setq s-rest (cdr s-rest)))
 289         field-body))))
 290
 291 (defsubst elmo-msgdb-remove-field-string (string)
 292   (if (string-match (concat std11-field-head-regexp "[ \t]*") string)
 293       (substring string (match-end 0))
 294     string))
 295
 296 (defsubst elmo-msgdb-get-last-message-id (string)
 297   (if string
 298       (save-match-data
 299         (let (beg)
 300           (elmo-set-work-buf
 301            (insert string)
 302            (goto-char (point-max))
 303            (when (search-backward "<" nil t)
 304              (setq beg (point))
 305              (if (search-forward ">" nil t)
 306                  (elmo-replace-in-string
 307                   (buffer-substring beg (point)) "\n[ \t]*" ""))))))))
 308
 309 (defun elmo-msgdb-number-load (dir)
 310   (elmo-object-load
 311    (expand-file-name elmo-msgdb-number-filename dir)))
 312
 313 (defun elmo-msgdb-overview-load (dir)
 314   (elmo-object-load
 315    (expand-file-name elmo-msgdb-overview-filename dir)))
 316
 317 (defun elmo-msgdb-mark-load (dir)
 318   (elmo-object-load
 319    (expand-file-name elmo-msgdb-mark-filename dir)))
 320
 321 (defsubst elmo-msgdb-seen-load (dir)
 322   (elmo-object-load (expand-file-name
 323                      elmo-msgdb-seen-filename
 324                      dir)))
 325
 326 (defun elmo-msgdb-number-save (dir obj)
 327   (elmo-object-save
 328    (expand-file-name elmo-msgdb-number-filename dir)
 329    obj))
 330
 331 (defun elmo-msgdb-mark-save (dir obj)
 332   (elmo-object-save
 333    (expand-file-name elmo-msgdb-mark-filename dir)
 334    obj))
 335
 336 (defsubst elmo-msgdb-out-of-date-messages (msgdb)
 337   (dolist (number (elmo-msgdb-list-flagged msgdb 'new))
 338     (elmo-msgdb-unset-flag msgdb number 'new)))
 339
 340 (defsubst elmo-msgdb-overview-save (dir overview)
 341   (elmo-object-save
 342    (expand-file-name elmo-msgdb-overview-filename dir)
 343    overview))
 344
 345 (defun elmo-msgdb-match-condition (msgdb condition number numbers)
 346   "Check whether the condition of the message is satisfied or not.
 347 MSGDB is the msgdb to search from.
 348 CONDITION is the search condition.
 349 NUMBER is the message number to check.
 350 NUMBERS is the target message number list.
 351 Return CONDITION itself if no entity exists in msgdb."
 352   (let ((entity (elmo-msgdb-message-entity msgdb number)))
 353     (if entity
 354         (elmo-msgdb-match-condition-internal condition
 355                                              entity
 356                                              (elmo-msgdb-flags msgdb number)
 357                                              numbers)
 358       condition)))
 359
 360 ;; entity -> parent-entity
 361 (defsubst elmo-msgdb-overview-get-parent-entity (entity database)
 362   (setq entity (elmo-msgdb-overview-entity-get-references entity))
 363   ;; entity is parent-id.
 364   (and entity (assoc entity database)))
 365
 366 (defsubst elmo-msgdb-get-parent-entity (entity msgdb)
 367   (setq entity (elmo-msgdb-overview-entity-get-references entity))
 368   ;; entity is parent-id.
 369   (and entity (elmo-msgdb-message-entity msgdb entity)))
 370
 371 ;;
 372 ;; deleted message handling
 373 ;;
 374 (defun elmo-msgdb-killed-list-load (dir)
 375   (elmo-object-load
 376    (expand-file-name elmo-msgdb-killed-filename dir)
 377    nil t))
 378
 379 (defun elmo-msgdb-killed-list-save (dir killed-list)
 380   (elmo-object-save
 381    (expand-file-name elmo-msgdb-killed-filename dir)
 382    killed-list))
 383
 384 (defun elmo-msgdb-killed-message-p (killed-list msg)
 385   (elmo-number-set-member msg killed-list))
 386
 387 (defun elmo-msgdb-set-as-killed (killed-list msg)
 388   (elmo-number-set-append killed-list msg))
 389
 390 (defun elmo-msgdb-killed-list-length (killed-list)
 391   (let ((killed killed-list)
 392         (ret-val 0))
 393     (while (car killed)
 394       (if (consp (car killed))
 395           (setq ret-val (+ ret-val 1 (- (cdar killed) (caar killed))))
 396         (setq ret-val (+ ret-val 1)))
 397       (setq killed (cdr killed)))
 398     ret-val))
 399
 400 (defun elmo-msgdb-max-of-killed (killed-list)
 401   (let ((klist killed-list)
 402         (max 0)
 403         k)
 404     (while (car klist)
 405       (if (< max
 406              (setq k
 407                    (if (consp (car klist))
 408                        (cdar klist)
 409                      (car klist))))
 410           (setq max k))
 411       (setq klist (cdr klist)))
 412     max))
 413
 414 (defun elmo-living-messages (messages killed-list)
 415   (if killed-list
 416       (delq nil
 417             (mapcar (lambda (number)
 418                       (unless (elmo-number-set-member number killed-list)
 419                         number))
 420                     messages))
 421     messages))
 422
 423 (defun elmo-msgdb-finfo-load ()
 424   (elmo-object-load (expand-file-name
 425                      elmo-msgdb-finfo-filename
 426                      elmo-msgdb-directory)
 427                     elmo-mime-charset t))
 428
 429 (defun elmo-msgdb-finfo-save (finfo)
 430   (elmo-object-save (expand-file-name
 431                      elmo-msgdb-finfo-filename
 432                      elmo-msgdb-directory)
 433                     finfo elmo-mime-charset))
 434
 435 (defun elmo-msgdb-flist-load (fname)
 436   (let ((flist-file (expand-file-name
 437                      elmo-msgdb-flist-filename
 438                      (expand-file-name
 439                       (elmo-safe-filename fname)
 440                       (expand-file-name "folder" elmo-msgdb-directory)))))
 441     (elmo-object-load flist-file elmo-mime-charset t)))
 442
 443 (defun elmo-msgdb-flist-save (fname flist)
 444   (let ((flist-file (expand-file-name
 445                      elmo-msgdb-flist-filename
 446                      (expand-file-name
 447                       (elmo-safe-filename fname)
 448                       (expand-file-name "folder" elmo-msgdb-directory)))))
 449     (elmo-object-save flist-file flist elmo-mime-charset)))
 450
 451 (defun elmo-crosspost-alist-load ()
 452   (elmo-object-load (expand-file-name
 453                      elmo-crosspost-alist-filename
 454                      elmo-msgdb-directory)
 455                     nil t))
 456
 457 (defun elmo-crosspost-alist-save (alist)
 458   (elmo-object-save (expand-file-name
 459                      elmo-crosspost-alist-filename
 460                      elmo-msgdb-directory)
 461                     alist))
 462
 463 (defun elmo-msgdb-get-message-id-from-buffer ()
 464   (let ((msgid (elmo-field-body "message-id")))
 465     (if msgid
 466         (if (string-match "<\\(.+\\)>$" msgid)
 467             msgid
 468           (concat "<" msgid ">")) ; Invaild message-id.
 469       ;; no message-id, so put dummy msgid.
 470       (concat "<" (timezone-make-date-sortable
 471                    (elmo-field-body "date"))
 472               (nth 1 (eword-extract-address-components
 473                       (or (elmo-field-body "from") "nobody"))) ">"))))
 474
 475 (defsubst elmo-msgdb-create-overview-from-buffer (number &optional size time)
 476   "Create overview entity from current buffer.
 477 Header region is supposed to be narrowed."
 478   (save-excursion
 479     (let ((extras elmo-msgdb-extra-fields)
 480           (default-mime-charset default-mime-charset)
 481           message-id references from subject to cc date
 482           extra field-body charset)
 483       (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 484       (setq message-id (elmo-msgdb-get-message-id-from-buffer))
 485       (and (setq charset (cdr (assoc "charset" (mime-read-Content-Type))))
 486            (setq charset (intern-soft charset))
 487            (setq default-mime-charset charset))
 488       (setq references
 489             (or (elmo-msgdb-get-last-message-id
 490                  (elmo-field-body "in-reply-to"))
 491                 (elmo-msgdb-get-last-message-id
 492                  (elmo-field-body "references"))))
 493       (setq from (elmo-replace-in-string
 494                   (elmo-mime-string (or (elmo-field-body "from")
 495                                         elmo-no-from))
 496                   "\t" " ")
 497             subject (elmo-replace-in-string
 498                      (elmo-mime-string (or (elmo-field-body "subject")
 499                                            elmo-no-subject))
 500                      "\t" " "))
 501       (setq date (or (elmo-field-body "date") time))
 502       (setq to   (mapconcat 'identity (elmo-multiple-field-body "to") ","))
 503       (setq cc   (mapconcat 'identity (elmo-multiple-field-body "cc") ","))
 504       (or size
 505           (if (setq size (elmo-field-body "content-length"))
 506               (setq size (string-to-int size))
 507             (setq size 0)));; No mean...
 508       (while extras
 509         (if (setq field-body (elmo-field-body (car extras)))
 510             (setq extra (cons (cons (downcase (car extras))
 511                                     field-body) extra)))
 512         (setq extras (cdr extras)))
 513       (cons message-id (vector number references
 514                                from subject date to cc
 515                                size extra))
 516       )))
 517
 518 (defsubst elmo-msgdb-insert-file-header (file)
 519   "Insert the header of the article."
 520   (let ((beg 0)
 521         insert-file-contents-pre-hook   ; To avoid autoconv-xmas...
 522         insert-file-contents-post-hook
 523         format-alist)
 524     (when (file-exists-p file)
 525       ;; Read until header separator is found.
 526       (while (and (eq elmo-msgdb-file-header-chop-length
 527                       (nth 1
 528                            (insert-file-contents-as-binary
 529                             file nil beg
 530                             (incf beg elmo-msgdb-file-header-chop-length))))
 531                   (prog1 (not (search-forward "\n\n" nil t))
 532                     (goto-char (point-max))))))))
 533
 534 (defsubst elmo-msgdb-create-overview-entity-from-file (number file)
 535   (let (insert-file-contents-pre-hook   ; To avoid autoconv-xmas...
 536         insert-file-contents-post-hook header-end
 537         (attrib (file-attributes file))
 538         ret-val size mtime)
 539     (with-temp-buffer
 540       (if (not (file-exists-p file))
 541           ()
 542         (setq size (nth 7 attrib))
 543         (setq mtime (timezone-make-date-arpa-standard
 544                      (current-time-string (nth 5 attrib)) (current-time-zone)))
 545         ;; insert header from file.
 546         (catch 'done
 547           (condition-case nil
 548               (elmo-msgdb-insert-file-header file)
 549             (error (throw 'done nil)))
 550           (goto-char (point-min))
 551           (setq header-end
 552                 (if (re-search-forward "\\(^--.*$\\)\\|\\(\n\n\\)" nil t)
 553                     (point)
 554                   (point-max)))
 555           (narrow-to-region (point-min) header-end)
 556           (elmo-msgdb-create-overview-from-buffer number size mtime))))))
 557
 558 (defsubst elmo-folder-get-info (folder &optional hashtb)
 559   (elmo-get-hash-val folder
 560                      (or hashtb elmo-folder-info-hashtb)))
 561
 562 (defun elmo-folder-get-info-max (folder)
 563   "Get folder info from cache."
 564   (nth 3 (elmo-folder-get-info folder)))
 565
 566 (defun elmo-folder-get-info-length (folder)
 567   (nth 2 (elmo-folder-get-info folder)))
 568
 569 (defun elmo-folder-get-info-unread (folder)
 570   (nth 1 (elmo-folder-get-info folder)))
 571
 572 (defsubst elmo-msgdb-location-load (dir)
 573   (elmo-object-load
 574    (expand-file-name
 575     elmo-msgdb-location-filename
 576     dir)))
 577
 578 (defsubst elmo-msgdb-location-add (alist number location)
 579   (let ((ret-val alist))
 580     (setq ret-val
 581           (elmo-msgdb-append-element ret-val (cons number location)))
 582     ret-val))
 583
 584 (defsubst elmo-msgdb-location-save (dir alist)
 585   (elmo-object-save
 586    (expand-file-name
 587     elmo-msgdb-location-filename
 588     dir) alist))
 589
 590 (require 'product)
 591 (product-provide (provide 'elmo-msgdb) (require 'elmo-version))
 592
 593 ;;; elmo-msgdb.el ends here