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