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                                                 group range last-check))
 100   (luna-define-internal-accessors 'elmo-shimbun-folder))
 101
 102 (defsubst elmo-shimbun-lapse-seconds (time)
 103   (let ((now (current-time)))
 104     (+ (* (- (car now) (car time)) 65536)
 105        (- (nth 1 now) (nth 1 time)))))
 106
 107 (defun elmo-shimbun-parse-time-string (string)
 108   "Parse the time-string STRING and return its time as Emacs style."
 109   (ignore-errors
 110     (let ((x (timezone-fix-time string nil nil)))
 111       (encode-time (aref x 5) (aref x 4) (aref x 3)
 112                    (aref x 2) (aref x 1) (aref x 0)
 113                    (aref x 6)))))
 114
 115 (defsubst elmo-shimbun-headers-check-p (folder)
 116   (or (null (elmo-shimbun-folder-last-check-internal folder))
 117       (and (elmo-shimbun-folder-last-check-internal folder)
 118            (> (elmo-shimbun-lapse-seconds
 119                (elmo-shimbun-folder-last-check-internal folder))
 120               elmo-shimbun-check-interval))))
 121
 122 (defun elmo-shimbun-msgdb-to-headers (folder expire-days)
 123   (let (headers message-id shimbun-id)
 124     (dolist (ov (elmo-msgdb-get-overview (elmo-folder-msgdb folder)))
 125       (when (and (elmo-msgdb-overview-entity-get-extra-field ov "xref")
 126                  (if expire-days
 127                      (< (elmo-shimbun-lapse-seconds
 128                          (elmo-shimbun-parse-time-string
 129                           (elmo-msgdb-overview-entity-get-date ov)))
 130                         (* expire-days 86400 ; seconds per day
 131                            ))
 132                    t))
 133         (if (setq message-id (elmo-msgdb-overview-entity-get-extra-field
 134                               ov "x-original-id"))
 135             (setq shimbun-id (elmo-msgdb-overview-entity-get-id ov))
 136           (setq message-id (elmo-msgdb-overview-entity-get-id ov)
 137                 shimbun-id nil))
 138         (setq headers
 139               (cons (shimbun-make-header
 140                      (elmo-msgdb-overview-entity-get-number ov)
 141                      (shimbun-mime-encode-string
 142                       (elmo-msgdb-overview-entity-get-subject ov))
 143                      (shimbun-mime-encode-string
 144                       (elmo-msgdb-overview-entity-get-from ov))
 145                      (elmo-msgdb-overview-entity-get-date ov)
 146                      message-id
 147                      (elmo-msgdb-overview-entity-get-references ov)
 148                      0
 149                      0
 150                      (elmo-msgdb-overview-entity-get-extra-field ov "xref")
 151                      (and shimbun-id
 152                           (list (cons "x-shimbun-id" shimbun-id))))
 153                     headers))))
 154     (nreverse headers)))
 155
 156 (defsubst elmo-shimbun-folder-header-hash-setup (folder headers)
 157   (let ((hash (elmo-make-hash (length headers)))
 158         shimbun-id)
 159     (dolist (header headers)
 160       (elmo-set-hash-val (shimbun-header-id header) header hash)
 161       (when (setq shimbun-id
 162                   (elmo-shimbun-header-extra-field header "x-shimbun-id"))
 163         (elmo-set-hash-val shimbun-id header hash)))
 164     (elmo-shimbun-folder-set-header-hash-internal folder hash)))
 165
 166 (defun elmo-shimbun-folder-setup (folder)
 167   ;; Resume headers from existing msgdb.
 168   (elmo-shimbun-folder-set-headers-internal
 169    folder
 170    (elmo-shimbun-msgdb-to-headers folder nil))
 171   (elmo-shimbun-folder-header-hash-setup
 172    folder
 173    (elmo-shimbun-folder-headers-internal folder)))
 174
 175 (defun elmo-shimbun-get-headers (folder)
 176   (let* ((shimbun (elmo-shimbun-folder-shimbun-internal folder))
 177          (key (concat (shimbun-server-internal shimbun)
 178                       "." (shimbun-current-group-internal shimbun)))
 179          (elmo-hash-minimum-size 0)
 180          entry headers hash)
 181     ;; new headers.
 182     (setq headers
 183           (delq nil
 184                 (mapcar
 185                  (lambda (x)
 186                    (unless (elmo-msgdb-overview-get-entity
 187                             (shimbun-header-id x)
 188                             (elmo-folder-msgdb folder))
 189                      x))
 190                  ;; This takes much time.
 191                  (shimbun-headers
 192                   (elmo-shimbun-folder-shimbun-internal folder)
 193                   (elmo-shimbun-folder-range-internal folder)))))
 194     (elmo-shimbun-folder-set-headers-internal
 195      folder
 196      (nconc (elmo-shimbun-msgdb-to-headers
 197              folder (shimbun-article-expiration-days
 198                      (elmo-shimbun-folder-shimbun-internal folder)))
 199             headers))
 200     (elmo-shimbun-folder-header-hash-setup
 201            folder
 202      (elmo-shimbun-folder-headers-internal folder))
 203     (elmo-shimbun-folder-set-last-check-internal folder (current-time))))
 204
 205 (luna-define-method elmo-folder-initialize ((folder
 206                                              elmo-shimbun-folder)
 207                                             name)
 208   (let ((server-group (if (string-match "\\([^.]+\\)\\." name)
 209                           (list (elmo-match-string 1 name)
 210                                 (substring name (match-end 0)))
 211                         (list name))))
 212     (when (nth 0 server-group) ; server
 213       (elmo-shimbun-folder-set-shimbun-internal
 214        folder
 215        (shimbun-open (nth 0 server-group)
 216                      (luna-make-entity 'shimbun-elmo-mua :folder folder))))
 217     (when (nth 1 server-group)
 218       (elmo-shimbun-folder-set-group-internal
 219        folder
 220        (nth 1 server-group)))
 221     (elmo-shimbun-folder-set-range-internal
 222      folder
 223      (or (cdr (elmo-string-matched-assoc (elmo-folder-name-internal folder)
 224                                          elmo-shimbun-index-range-alist))
 225          elmo-shimbun-default-index-range))
 226     folder))
 227
 228 (luna-define-method elmo-folder-open-internal ((folder elmo-shimbun-folder))
 229   (shimbun-open-group
 230    (elmo-shimbun-folder-shimbun-internal folder)
 231    (elmo-shimbun-folder-group-internal folder))
 232   (let ((inhibit-quit t))
 233     (unless (elmo-map-folder-location-alist-internal folder)
 234       (elmo-map-folder-location-setup
 235        folder
 236        (elmo-msgdb-location-load (elmo-folder-msgdb-path folder)))))
 237   (cond ((and (elmo-folder-plugged-p folder)
 238               (elmo-shimbun-headers-check-p folder))
 239          (elmo-shimbun-get-headers folder)
 240          (elmo-map-folder-update-locations
 241           folder
 242           (elmo-map-folder-list-message-locations folder)))
 243         ((null (elmo-shimbun-folder-headers-internal folder))
 244          ;; Resume headers from existing msgdb.
 245          (elmo-shimbun-folder-setup folder))))
 246
 247 (luna-define-method elmo-folder-reserve-status-p ((folder elmo-shimbun-folder))
 248   t)
 249
 250 (luna-define-method elmo-message-use-cache-p ((folder elmo-shimbun-folder)
 251                                               number)
 252   elmo-shimbun-use-cache)
 253
 254 (luna-define-method elmo-folder-creatable-p ((folder elmo-shimbun-folder))
 255   nil)
 256
 257 (luna-define-method elmo-folder-close-internal :after ((folder
 258                                                         elmo-shimbun-folder))
 259   (shimbun-close-group
 260    (elmo-shimbun-folder-shimbun-internal folder))
 261   (elmo-shimbun-folder-set-headers-internal
 262    folder nil)
 263   (elmo-shimbun-folder-set-header-hash-internal
 264    folder nil)
 265   (elmo-shimbun-folder-set-last-check-internal
 266    folder nil))
 267
 268 (luna-define-method elmo-folder-plugged-p ((folder elmo-shimbun-folder))
 269   (elmo-plugged-p
 270    "shimbun"
 271    (shimbun-server-internal (elmo-shimbun-folder-shimbun-internal folder))
 272    nil nil
 273    (shimbun-server-internal (elmo-shimbun-folder-shimbun-internal folder))))
 274
 275 (luna-define-method elmo-folder-set-plugged ((folder elmo-shimbun-folder)
 276                                              plugged &optional add)
 277   (elmo-set-plugged plugged
 278                     "shimbun"
 279                     (shimbun-server-internal
 280                      (elmo-shimbun-folder-shimbun-internal folder))
 281                     nil nil nil
 282                     (shimbun-server-internal
 283                      (elmo-shimbun-folder-shimbun-internal folder))
 284                     add))
 285
 286 (luna-define-method elmo-net-port-info ((folder elmo-shimbun-folder))
 287   (list "shimbun"
 288         (shimbun-server-internal
 289          (elmo-shimbun-folder-shimbun-internal folder))
 290         nil))
 291
 292 (luna-define-method elmo-folder-check :around ((folder elmo-shimbun-folder))
 293   (when (shimbun-current-group-internal
 294          (elmo-shimbun-folder-shimbun-internal folder))
 295     (when (and (elmo-folder-plugged-p folder)
 296                (elmo-shimbun-headers-check-p folder))
 297       (elmo-shimbun-get-headers folder)
 298       (luna-call-next-method))))
 299
 300 (luna-define-method elmo-folder-clear :around ((folder elmo-shimbun-folder)
 301                                                &optional keep-killed)
 302   (elmo-shimbun-folder-set-headers-internal folder nil)
 303   (elmo-shimbun-folder-set-header-hash-internal folder nil)
 304   (elmo-shimbun-folder-set-last-check-internal folder nil)
 305   (luna-call-next-method))
 306
 307 (luna-define-method elmo-folder-expand-msgdb-path ((folder
 308                                                     elmo-shimbun-folder))
 309   (expand-file-name
 310    (concat (shimbun-server-internal
 311             (elmo-shimbun-folder-shimbun-internal folder))
 312            "/"
 313            (elmo-shimbun-folder-group-internal folder))
 314    (expand-file-name "shimbun" elmo-msgdb-directory)))
 315
 316 (defun elmo-shimbun-msgdb-create-entity (folder number)
 317   (let ((header (elmo-get-hash-val
 318                  (elmo-map-message-location folder number)
 319                  (elmo-shimbun-folder-header-hash-internal folder)))
 320         ov)
 321     (when header
 322       (with-temp-buffer
 323         (shimbun-header-insert
 324          (elmo-shimbun-folder-shimbun-internal folder)
 325          header)
 326         (setq ov (elmo-msgdb-create-overview-from-buffer number))
 327         (elmo-msgdb-overview-entity-set-extra
 328          ov
 329          (nconc
 330           (elmo-msgdb-overview-entity-get-extra ov)
 331           (list (cons "xref" (shimbun-header-xref header)))))))))
 332
 333 (luna-define-method elmo-folder-msgdb-create ((folder elmo-shimbun-folder)
 334                                               numlist new-mark
 335                                               already-mark seen-mark
 336                                               important-mark
 337                                               seen-list)
 338   (let* (overview number-alist mark-alist entity
 339                   i percent number length pair msgid gmark seen)
 340     (setq length (length numlist))
 341     (setq i 0)
 342     (message "Creating msgdb...")
 343     (while numlist
 344       (setq entity
 345             (elmo-shimbun-msgdb-create-entity
 346              folder (car numlist)))
 347       (when entity
 348         (setq overview
 349               (elmo-msgdb-append-element
 350                overview entity))
 351         (setq number (elmo-msgdb-overview-entity-get-number entity))
 352         (setq msgid (elmo-msgdb-overview-entity-get-id entity))
 353         (setq number-alist
 354               (elmo-msgdb-number-add number-alist
 355                                      number msgid))
 356         (setq seen (member msgid seen-list))
 357         (if (setq gmark (or (elmo-msgdb-global-mark-get msgid)
 358                             (if (elmo-file-cache-status
 359                                  (elmo-file-cache-get msgid))
 360                                 (if seen nil already-mark)
 361                               (if seen
 362                                   (if elmo-shimbun-use-cache
 363                                       seen-mark)
 364                                 new-mark))))
 365             (setq mark-alist
 366                   (elmo-msgdb-mark-append mark-alist
 367                                           number gmark))))
 368       (when (> length elmo-display-progress-threshold)
 369         (setq i (1+ i))
 370         (setq percent (/ (* i 100) length))
 371         (elmo-display-progress
 372          'elmo-folder-msgdb-create "Creating msgdb..."
 373          percent))
 374       (setq numlist (cdr numlist)))
 375     (message "Creating msgdb...done.")
 376     (elmo-msgdb-sort-by-date
 377      (list overview number-alist mark-alist))))
 378
 379 (luna-define-method elmo-folder-message-file-p ((folder elmo-shimbun-folder))
 380   nil)
 381
 382 (defsubst elmo-shimbun-update-overview (folder shimbun-id header)
 383   (let ((entity (elmo-msgdb-overview-get-entity shimbun-id
 384                                                 (elmo-folder-msgdb folder)))
 385         (message-id (shimbun-header-id header))
 386         references)
 387     (unless (string= shimbun-id message-id)
 388       (elmo-msgdb-overview-entity-set-extra-field
 389        entity "x-original-id" message-id)
 390       (elmo-shimbun-header-set-extra-field
 391        header "x-shimbun-id" shimbun-id)
 392       (elmo-set-hash-val message-id
 393                          header
 394                          (elmo-shimbun-folder-header-hash-internal folder)))
 395     (elmo-msgdb-overview-entity-set-from
 396      entity
 397      (elmo-mime-string (shimbun-header-from header)))
 398     (elmo-msgdb-overview-entity-set-subject
 399      entity
 400      (elmo-mime-string (shimbun-header-subject header)))
 401     (elmo-msgdb-overview-entity-set-date
 402      entity (shimbun-header-date header))
 403     (when (setq references
 404                 (or (elmo-msgdb-get-last-message-id
 405                      (elmo-field-body "in-reply-to"))
 406                     (elmo-msgdb-get-last-message-id
 407                      (elmo-field-body "references"))))
 408       (elmo-msgdb-overview-entity-set-references
 409        entity
 410        (or (elmo-shimbun-header-extra-field
 411             (elmo-get-hash-val references
 412                                (elmo-shimbun-folder-header-hash-internal
 413                                 folder))
 414             "x-shimbun-id")
 415            references)))))
 416
 417 (luna-define-method elmo-map-message-fetch ((folder elmo-shimbun-folder)
 418                                             location strategy
 419                                             &optional section unseen)
 420   (if (elmo-folder-plugged-p folder)
 421       (let ((header (elmo-get-hash-val
 422                      location
 423                      (elmo-shimbun-folder-header-hash-internal folder)))
 424             shimbun-id)
 425         (shimbun-article (elmo-shimbun-folder-shimbun-internal folder)
 426                          header)
 427         (when (elmo-string-match-member
 428                (elmo-folder-name-internal folder)
 429                elmo-shimbun-update-overview-folder-list)
 430           (elmo-shimbun-update-overview folder location header))
 431         (when (setq shimbun-id
 432                     (elmo-shimbun-header-extra-field header "x-shimbun-id"))
 433           (goto-char (point-min))
 434           (insert (format "X-Shimbun-Id: %s\n" shimbun-id)))
 435         t)
 436     (error "Unplugged")))
 437
 438 (luna-define-method elmo-message-encache :around ((folder
 439                                                    elmo-shimbun-folder)
 440                                                   number &optional read)
 441   (if (elmo-folder-plugged-p folder)
 442       (luna-call-next-method)
 443     (if elmo-enable-disconnected-operation
 444         (elmo-message-encache-dop folder number read)
 445       (error "Unplugged"))))
 446
 447 (luna-define-method elmo-folder-list-messages-internal :around
 448   ((folder elmo-shimbun-folder) &optional nohide)
 449   (if (elmo-folder-plugged-p folder)
 450       (luna-call-next-method)
 451     t))
 452
 453 (luna-define-method elmo-map-folder-list-message-locations
 454   ((folder elmo-shimbun-folder))
 455   (mapcar
 456    (lambda (header)
 457      (or (elmo-shimbun-header-extra-field header "x-shimbun-id")
 458          (shimbun-header-id header)))
 459    (elmo-shimbun-folder-headers-internal folder)))
 460
 461 (luna-define-method elmo-folder-list-subfolders ((folder elmo-shimbun-folder)
 462                                                  &optional one-level)
 463   (unless (elmo-shimbun-folder-group-internal folder)
 464     (mapcar
 465      (lambda (x)
 466        (concat (elmo-folder-prefix-internal folder)
 467                (shimbun-server-internal
 468                 (elmo-shimbun-folder-shimbun-internal folder))
 469                "."
 470                x))
 471      (shimbun-groups (elmo-shimbun-folder-shimbun-internal folder)))))
 472
 473 (luna-define-method elmo-folder-exists-p ((folder elmo-shimbun-folder))
 474   (if (elmo-shimbun-folder-group-internal folder)
 475       (progn
 476         (member
 477          (elmo-shimbun-folder-group-internal folder)
 478          (shimbun-groups (elmo-shimbun-folder-shimbun-internal
 479                           folder))))
 480     t))
 481
 482 (luna-define-method elmo-folder-search ((folder elmo-shimbun-folder)
 483                                         condition &optional from-msgs)
 484   nil)
 485
 486 ;;; To override elmo-map-folder methods.
 487 (luna-define-method elmo-folder-list-unreads-internal
 488   ((folder elmo-shimbun-folder) unread-marks &optional mark-alist)
 489   t)
 490
 491 (luna-define-method elmo-folder-unmark-important ((folder elmo-shimbun-folder)
 492                                                   numbers)
 493   t)
 494
 495 (luna-define-method elmo-folder-mark-as-important ((folder elmo-shimbun-folder)
 496                                                    numbers)
 497   t)
 498
 499 (luna-define-method elmo-folder-unmark-read ((folder elmo-shimbun-folder)
 500                                              numbers)
 501   t)
 502
 503 (luna-define-method elmo-folder-mark-as-read ((folder elmo-shimbun-folder)
 504                                               numbers)
 505   t)
 506
 507 (require 'product)
 508 (product-provide (provide 'elmo-shimbun) (require 'elmo-version))
 509
 510 ;;; elmo-shimbun.el ends here