elmo/elmo-shimbun.el

   1 ;;; elmo-shimbun.el --- Shimbun interface for ELMO.
   2
   3 ;; Copyright (C) 2001 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30 ;;
  31 (require 'elmo)
  32 (require 'elmo-map)
  33 (require 'elmo-dop)
  34 (require 'shimbun)
  35
  36 (defcustom elmo-shimbun-check-interval 60
  37   "*Check interval for shimbun."
  38   :type 'integer
  39   :group 'elmo)
  40
  41 (defcustom elmo-shimbun-default-index-range 2
  42   "*Default value for the range of header indices."
  43   :type '(choice (const :tag "all" all)
  44                  (const :tag "last" last)
  45                  (integer :tag "number"))
  46   :group 'elmo)
  47
  48 (defcustom elmo-shimbun-use-cache t
  49   "*If non-nil, use cache for each article."
  50   :type 'boolean
  51   :group 'elmo)
  52
  53 (defcustom elmo-shimbun-index-range-alist nil
  54   "*Alist of FOLDER-REGEXP and RANGE.
  55 FOLDER-REGEXP is the regexp for shimbun folder name.
  56 RANGE is the range of the header indices .
  57 See `shimbun-headers' for more detail about RANGE."
  58   :type '(repeat (cons (regexp :tag "Folder Regexp")
  59                        (choice (const :tag "all" all)
  60                                (const :tag "last" last)
  61                                (integer :tag "number"))))
  62   :group 'elmo)
  63
  64 (defcustom elmo-shimbun-update-overview-folder-list nil
  65   "*List of FOLDER-REGEXP.
  66 FOLDER-REGEXP is the regexp of shimbun folder name which should be
  67 update overview when message is fetched."
  68   :type '(repeat (regexp :tag "Folder Regexp"))
  69   :group 'elmo)
  70
  71 ;; Shimbun header.
  72 (defsubst elmo-shimbun-header-extra-field (header field-name)
  73   (let ((extra (and header (shimbun-header-extra header))))
  74     (and extra
  75          (cdr (assoc field-name extra)))))
  76
  77 (defsubst elmo-shimbun-header-set-extra-field (header field-name value)
  78   (let ((extras (and header (shimbun-header-extra header)))
  79         extra)
  80     (if (setq extra (assoc field-name extras))
  81         (setcdr extra value)
  82       (shimbun-header-set-extra
  83        header
  84        (cons (cons field-name value) extras)))))
  85
  86 ;; Shimbun mua.
  87 (eval-and-compile
  88   (luna-define-class shimbun-elmo-mua (shimbun-mua) (folder))
  89   (luna-define-internal-accessors 'shimbun-elmo-mua))
  90
  91 (luna-define-method shimbun-mua-search-id ((mua shimbun-elmo-mua) id)
  92   (elmo-msgdb-overview-get-entity id
  93                                   (elmo-folder-msgdb
  94                                    (shimbun-elmo-mua-folder-internal mua))))
  95
  96 (eval-and-compile
  97   (luna-define-class elmo-shimbun-folder
  98                      (elmo-map-folder) (shimbun headers header-hash
  99                                                 entity-hash
 100                                                 group range last-check))
 101   (luna-define-internal-accessors 'elmo-shimbun-folder))
 102
 103 (defun elmo-shimbun-folder-entity-hash (folder)
 104   (or (elmo-shimbun-folder-entity-hash-internal folder)
 105       (let ((overviews (elmo-msgdb-get-overview (elmo-folder-msgdb folder)))
 106             hash id)
 107         (when overviews
 108           (setq hash (elmo-make-hash (length overviews)))
 109           (dolist (entity overviews)
 110             (elmo-set-hash-val (elmo-msgdb-overview-entity-get-id entity)
 111                                entity hash)
 112             (when (setq id (elmo-msgdb-overview-entity-get-extra-field
 113                             entity "x-original-id"))
 114               (elmo-set-hash-val id entity hash)))
 115           (elmo-shimbun-folder-set-entity-hash-internal folder hash)))))
 116
 117 (defsubst elmo-shimbun-folder-shimbun-header (folder location)
 118   (let ((hash (elmo-shimbun-folder-header-hash-internal folder)))
 119     (or (and hash (elmo-get-hash-val location hash))
 120         (let ((entity (elmo-msgdb-overview-get-entity
 121                        location
 122                        (elmo-folder-msgdb folder)))
 123               (elmo-hash-minimum-size 63)
 124               header)
 125           (when entity
 126             (setq header (elmo-shimbun-entity-to-header entity))
 127             (unless hash
 128               (elmo-shimbun-folder-set-header-hash-internal
 129                folder
 130                (setq hash (elmo-make-hash))))
 131             (elmo-set-hash-val (elmo-msgdb-overview-entity-get-id entity)
 132                                header
 133                                hash)
 134             header)))))
 135
 136 (defsubst elmo-shimbun-lapse-seconds (time)
 137   (let ((now (current-time)))
 138     (+ (* (- (car now) (car time)) 65536)
 139        (- (nth 1 now) (nth 1 time)))))
 140
 141 (defun elmo-shimbun-parse-time-string (string)
 142   "Parse the time-string STRING and return its time as Emacs style."
 143   (ignore-errors
 144     (let ((x (timezone-fix-time string nil nil)))
 145       (encode-time (aref x 5) (aref x 4) (aref x 3)
 146                    (aref x 2) (aref x 1) (aref x 0)
 147                    (aref x 6)))))
 148
 149 (defsubst elmo-shimbun-headers-check-p (folder)
 150   (or (null (elmo-shimbun-folder-last-check-internal folder))
 151       (and (elmo-shimbun-folder-last-check-internal folder)
 152            (> (elmo-shimbun-lapse-seconds
 153                (elmo-shimbun-folder-last-check-internal folder))
 154               elmo-shimbun-check-interval))))
 155
 156 (defun elmo-shimbun-entity-to-header (entity)
 157   (let (message-id shimbun-id)
 158     (if (setq message-id (elmo-msgdb-overview-entity-get-extra-field
 159                           entity "x-original-id"))
 160         (setq shimbun-id (elmo-msgdb-overview-entity-get-id entity))
 161       (setq message-id (elmo-msgdb-overview-entity-get-id entity)
 162             shimbun-id nil))
 163     (elmo-set-work-buf
 164      (set-buffer-multibyte t)
 165      (shimbun-make-header
 166       (elmo-msgdb-overview-entity-get-number entity)
 167       (shimbun-mime-encode-string
 168        (decode-mime-charset-string
 169         (elmo-msgdb-overview-entity-get-subject-no-decode entity)
 170         elmo-mime-charset))
 171       (shimbun-mime-encode-string
 172        (decode-mime-charset-string
 173         (elmo-msgdb-overview-entity-get-from-no-decode entity)
 174         elmo-mime-charset))
 175       (elmo-msgdb-overview-entity-get-date entity)
 176       message-id
 177       (elmo-msgdb-overview-entity-get-references entity)
 178       0
 179       0
 180       (elmo-msgdb-overview-entity-get-extra-field entity "xref")
 181       (and shimbun-id
 182            (list (cons "x-shimbun-id" shimbun-id)))))))
 183
 184 (defsubst elmo-shimbun-folder-header-hash-setup (folder headers)
 185   (let ((hash (or (elmo-shimbun-folder-header-hash-internal folder)
 186                   (elmo-make-hash (length headers)))))
 187     (dolist (header headers)
 188       (elmo-set-hash-val (shimbun-header-id header) header hash))
 189     (elmo-shimbun-folder-set-header-hash-internal folder hash)))
 190
 191 (defun elmo-shimbun-get-headers (folder)
 192   (let* ((shimbun (elmo-shimbun-folder-shimbun-internal folder))
 193          (key (concat (shimbun-server-internal shimbun)
 194                       "." (shimbun-current-group-internal shimbun)))
 195          (elmo-hash-minimum-size 63)
 196          headers)
 197     ;; new headers.
 198     (setq headers
 199           (delq nil
 200                 (mapcar
 201                  (lambda (x)
 202                    (unless (elmo-msgdb-overview-get-entity
 203                             (shimbun-header-id x)
 204                             (elmo-folder-msgdb folder))
 205                      x))
 206                  ;; This takes much time.
 207                  (shimbun-headers
 208                   (elmo-shimbun-folder-shimbun-internal folder)
 209                   (elmo-shimbun-folder-range-internal folder)))))
 210     (elmo-shimbun-folder-set-headers-internal folder headers)
 211     (when headers
 212       (elmo-shimbun-folder-header-hash-setup folder headers))
 213     (elmo-shimbun-folder-set-last-check-internal folder (current-time))))
 214
 215 (luna-define-method elmo-folder-initialize ((folder
 216                                              elmo-shimbun-folder)
 217                                             name)
 218   (let ((server-group (if (string-match "\\([^.]+\\)\\." name)
 219                           (list (elmo-match-string 1 name)
 220                                 (substring name (match-end 0)))
 221                         (list name))))
 222     (when (nth 0 server-group) ; server
 223       (elmo-shimbun-folder-set-shimbun-internal
 224        folder
 225        (shimbun-open (nth 0 server-group)
 226                      (luna-make-entity 'shimbun-elmo-mua :folder folder))))
 227     (when (nth 1 server-group)
 228       (elmo-shimbun-folder-set-group-internal
 229        folder
 230        (nth 1 server-group)))
 231     (elmo-shimbun-folder-set-range-internal
 232      folder
 233      (or (cdr (elmo-string-matched-assoc (elmo-folder-name-internal folder)
 234                                          elmo-shimbun-index-range-alist))
 235          elmo-shimbun-default-index-range))
 236     folder))
 237
 238 (luna-define-method elmo-folder-open-internal ((folder elmo-shimbun-folder))
 239   (shimbun-open-group
 240    (elmo-shimbun-folder-shimbun-internal folder)
 241    (elmo-shimbun-folder-group-internal folder))
 242   (let ((inhibit-quit t))
 243     (unless (elmo-map-folder-location-alist-internal folder)
 244       (elmo-map-folder-location-setup
 245        folder
 246        (elmo-msgdb-location-load (elmo-folder-msgdb-path folder))))
 247     (when (and (elmo-folder-plugged-p folder)
 248                (elmo-shimbun-headers-check-p folder))
 249       (elmo-shimbun-get-headers folder)
 250       (elmo-map-folder-update-locations
 251        folder
 252        (elmo-map-folder-list-message-locations folder)))))
 253
 254 (luna-define-method elmo-folder-reserve-status-p ((folder elmo-shimbun-folder))
 255   t)
 256
 257 (luna-define-method elmo-folder-local-p ((folder elmo-shimbun-folder))
 258   nil)
 259
 260 (luna-define-method elmo-message-use-cache-p ((folder elmo-shimbun-folder)
 261                                               number)
 262   elmo-shimbun-use-cache)
 263
 264 (luna-define-method elmo-folder-close-internal :after ((folder
 265                                                         elmo-shimbun-folder))
 266   (shimbun-close-group
 267    (elmo-shimbun-folder-shimbun-internal folder))
 268   (elmo-shimbun-folder-set-headers-internal
 269    folder nil)
 270   (elmo-shimbun-folder-set-header-hash-internal
 271    folder nil)
 272   (elmo-shimbun-folder-set-entity-hash-internal
 273    folder nil)
 274   (elmo-shimbun-folder-set-last-check-internal
 275    folder nil))
 276
 277 (luna-define-method elmo-folder-plugged-p ((folder elmo-shimbun-folder))
 278   (elmo-plugged-p
 279    "shimbun"
 280    (shimbun-server-internal (elmo-shimbun-folder-shimbun-internal folder))
 281    nil nil
 282    (shimbun-server-internal (elmo-shimbun-folder-shimbun-internal folder))))
 283
 284 (luna-define-method elmo-folder-set-plugged ((folder elmo-shimbun-folder)
 285                                              plugged &optional add)
 286   (elmo-set-plugged plugged
 287                     "shimbun"
 288                     (shimbun-server-internal
 289                      (elmo-shimbun-folder-shimbun-internal folder))
 290                     nil nil nil
 291                     (shimbun-server-internal
 292                      (elmo-shimbun-folder-shimbun-internal folder))
 293                     add))
 294
 295 (luna-define-method elmo-net-port-info ((folder elmo-shimbun-folder))
 296   (list "shimbun"
 297         (shimbun-server-internal
 298          (elmo-shimbun-folder-shimbun-internal folder))
 299         nil))
 300
 301 (luna-define-method elmo-folder-check :around ((folder elmo-shimbun-folder))
 302   (when (shimbun-current-group-internal
 303          (elmo-shimbun-folder-shimbun-internal folder))
 304     (when (and (elmo-folder-plugged-p folder)
 305                (elmo-shimbun-headers-check-p folder))
 306       (elmo-shimbun-get-headers folder)
 307       (luna-call-next-method))))
 308
 309 (luna-define-method elmo-folder-clear :around ((folder elmo-shimbun-folder)
 310                                                &optional keep-killed)
 311   (elmo-shimbun-folder-set-headers-internal folder nil)
 312   (elmo-shimbun-folder-set-header-hash-internal folder nil)
 313   (elmo-shimbun-folder-set-entity-hash-internal folder nil)
 314   (elmo-shimbun-folder-set-last-check-internal folder nil)
 315   (luna-call-next-method))
 316
 317 (luna-define-method elmo-folder-expand-msgdb-path ((folder
 318                                                     elmo-shimbun-folder))
 319   (expand-file-name
 320    (concat (shimbun-server-internal
 321             (elmo-shimbun-folder-shimbun-internal folder))
 322            "/"
 323            (elmo-shimbun-folder-group-internal folder))
 324    (expand-file-name "shimbun" elmo-msgdb-directory)))
 325
 326 (defun elmo-shimbun-msgdb-create-entity (folder number)
 327   (let ((header (elmo-shimbun-folder-shimbun-header
 328                  folder
 329                  (elmo-map-message-location folder number)))
 330         ov)
 331     (when header
 332       (with-temp-buffer
 333         (shimbun-header-insert
 334          (elmo-shimbun-folder-shimbun-internal folder)
 335          header)
 336         (setq ov (elmo-msgdb-create-overview-from-buffer number))
 337         (elmo-msgdb-overview-entity-set-extra
 338          ov
 339          (nconc
 340           (elmo-msgdb-overview-entity-get-extra ov)
 341           (list (cons "xref" (shimbun-header-xref header)))))))))
 342
 343 (luna-define-method elmo-folder-msgdb-create ((folder elmo-shimbun-folder)
 344                                               numlist new-mark
 345                                               already-mark seen-mark
 346                                               important-mark
 347                                               seen-list)
 348   (let* (overview number-alist mark-alist entity
 349                   i percent number length pair msgid gmark seen)
 350     (setq length (length numlist))
 351     (setq i 0)
 352     (message "Creating msgdb...")
 353     (while numlist
 354       (setq entity
 355             (elmo-shimbun-msgdb-create-entity
 356              folder (car numlist)))
 357       (when entity
 358         (setq overview
 359               (elmo-msgdb-append-element
 360                overview entity))
 361         (setq number (elmo-msgdb-overview-entity-get-number entity))
 362         (setq msgid (elmo-msgdb-overview-entity-get-id entity))
 363         (setq number-alist
 364               (elmo-msgdb-number-add number-alist
 365                                      number msgid))
 366         (setq seen (member msgid seen-list))
 367         (if (setq gmark (or (elmo-msgdb-global-mark-get msgid)
 368                             (if (elmo-file-cache-status
 369                                  (elmo-file-cache-get msgid))
 370                                 (if seen nil already-mark)
 371                               (if seen
 372                                   (if elmo-shimbun-use-cache
 373                                       seen-mark)
 374                                 new-mark))))
 375             (setq mark-alist
 376                   (elmo-msgdb-mark-append mark-alist
 377                                           number gmark))))
 378       (when (> length elmo-display-progress-threshold)
 379         (setq i (1+ i))
 380         (setq percent (/ (* i 100) length))
 381         (elmo-display-progress
 382          'elmo-folder-msgdb-create "Creating msgdb..."
 383          percent))
 384       (setq numlist (cdr numlist)))
 385     (message "Creating msgdb...done.")
 386     (elmo-msgdb-sort-by-date
 387      (list overview number-alist mark-alist))))
 388
 389 (luna-define-method elmo-folder-message-file-p ((folder elmo-shimbun-folder))
 390   nil)
 391
 392 (defsubst elmo-shimbun-update-overview (folder shimbun-id header)
 393   (let ((entity (elmo-msgdb-overview-get-entity shimbun-id
 394                                                 (elmo-folder-msgdb folder)))
 395         (message-id (shimbun-header-id header))
 396         references)
 397     (unless (string= shimbun-id message-id)
 398       (elmo-msgdb-overview-entity-set-extra-field
 399        entity "x-original-id" message-id)
 400       (elmo-shimbun-header-set-extra-field
 401        header "x-shimbun-id" shimbun-id)
 402       (elmo-set-hash-val message-id
 403                          entity
 404                          (elmo-shimbun-folder-entity-hash folder))
 405       (elmo-set-hash-val shimbun-id
 406                          entity
 407                          (elmo-shimbun-folder-entity-hash folder)))
 408     (elmo-msgdb-overview-entity-set-from
 409      entity
 410      (elmo-mime-string (shimbun-header-from header)))
 411     (elmo-msgdb-overview-entity-set-subject
 412      entity
 413      (elmo-mime-string (shimbun-header-subject header)))
 414     (elmo-msgdb-overview-entity-set-date
 415      entity (shimbun-header-date header))
 416     (when (setq references
 417                 (or (elmo-msgdb-get-last-message-id
 418                      (elmo-field-body "in-reply-to"))
 419                     (elmo-msgdb-get-last-message-id
 420                      (elmo-field-body "references"))))
 421       (elmo-msgdb-overview-entity-set-references
 422        entity
 423        (or (elmo-msgdb-overview-entity-get-id
 424             (elmo-get-hash-val
 425              references
 426              (elmo-shimbun-folder-entity-hash folder)))
 427            references)))))
 428
 429 (luna-define-method elmo-map-message-fetch ((folder elmo-shimbun-folder)
 430                                             location strategy
 431                                             &optional section unseen)
 432   (if (elmo-folder-plugged-p folder)
 433       (let ((header (elmo-shimbun-folder-shimbun-header
 434                      folder
 435                      location))
 436             shimbun-id)
 437         (shimbun-article (elmo-shimbun-folder-shimbun-internal folder)
 438                          header)
 439         (when (elmo-string-match-member
 440                (elmo-folder-name-internal folder)
 441                elmo-shimbun-update-overview-folder-list)
 442           (elmo-shimbun-update-overview folder location header))
 443         (when (setq shimbun-id
 444                     (elmo-shimbun-header-extra-field header "x-shimbun-id"))
 445           (goto-char (point-min))
 446           (insert (format "X-Shimbun-Id: %s\n" shimbun-id)))
 447         t)
 448     (error "Unplugged")))
 449
 450 (luna-define-method elmo-message-encache :around ((folder
 451                                                    elmo-shimbun-folder)
 452                                                   number &optional read)
 453   (if (elmo-folder-plugged-p folder)
 454       (luna-call-next-method)
 455     (if elmo-enable-disconnected-operation
 456         (elmo-message-encache-dop folder number read)
 457       (error "Unplugged"))))
 458
 459 (luna-define-method elmo-folder-list-messages-internal :around
 460   ((folder elmo-shimbun-folder) &optional nohide)
 461   (if (elmo-folder-plugged-p folder)
 462       (luna-call-next-method)
 463     t))
 464
 465 (luna-define-method elmo-map-folder-list-message-locations
 466   ((folder elmo-shimbun-folder))
 467   (let ((expire-days (shimbun-article-expiration-days
 468                       (elmo-shimbun-folder-shimbun-internal folder))))
 469     (elmo-uniq-list
 470      (nconc
 471       (delq nil
 472             (mapcar
 473              (lambda (ov)
 474                (when (and (elmo-msgdb-overview-entity-get-extra-field
 475                            ov "xref")
 476                           (if expire-days
 477                               (< (elmo-shimbun-lapse-seconds
 478                                   (elmo-shimbun-parse-time-string
 479                                    (elmo-msgdb-overview-entity-get-date ov)))
 480                                  (* expire-days 86400 ; seconds per day
 481                                     ))
 482                             t))
 483                  (elmo-msgdb-overview-entity-get-id ov)))
 484              (elmo-msgdb-get-overview (elmo-folder-msgdb folder))))
 485       (mapcar
 486        (lambda (header)
 487          (or (elmo-shimbun-header-extra-field header "x-shimbun-id")
 488              (shimbun-header-id header)))
 489        (elmo-shimbun-folder-headers-internal folder))))))
 490
 491 (luna-define-method elmo-folder-list-subfolders ((folder elmo-shimbun-folder)
 492                                                  &optional one-level)
 493   (unless (elmo-shimbun-folder-group-internal folder)
 494     (mapcar
 495      (lambda (x)
 496        (concat (elmo-folder-prefix-internal folder)
 497                (shimbun-server-internal
 498                 (elmo-shimbun-folder-shimbun-internal folder))
 499                "."
 500                x))
 501      (shimbun-groups (elmo-shimbun-folder-shimbun-internal folder)))))
 502
 503 (luna-define-method elmo-folder-exists-p ((folder elmo-shimbun-folder))
 504   (if (elmo-shimbun-folder-group-internal folder)
 505       (progn
 506         (member
 507          (elmo-shimbun-folder-group-internal folder)
 508          (shimbun-groups (elmo-shimbun-folder-shimbun-internal
 509                           folder))))
 510     t))
 511
 512 ;;; To override elmo-map-folder methods.
 513 (luna-define-method elmo-folder-list-unreads-internal
 514   ((folder elmo-shimbun-folder) unread-marks &optional mark-alist)
 515   t)
 516
 517 (luna-define-method elmo-folder-unmark-important ((folder elmo-shimbun-folder)
 518                                                   numbers)
 519   t)
 520
 521 (luna-define-method elmo-folder-mark-as-important ((folder elmo-shimbun-folder)
 522                                                    numbers)
 523   t)
 524
 525 (luna-define-method elmo-folder-unmark-read ((folder elmo-shimbun-folder)
 526                                              numbers)
 527   t)
 528
 529 (luna-define-method elmo-folder-mark-as-read ((folder elmo-shimbun-folder)
 530                                               numbers)
 531   t)
 532
 533 (require 'product)
 534 (product-provide (provide 'elmo-shimbun) (require 'elmo-version))
 535
 536 ;;; elmo-shimbun.el ends here