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-index-range-alist nil
  49   "*Alist of FOLDER-REGEXP and RANGE.
  50 FOLDER-REGEXP is the regexp for shimbun folder name.
  51 RANGE is the range of the header indices .
  52 See `shimbun-headers' for more detail about RANGE."
  53   :type '(repeat (cons (regexp :tag "Folder Regexp")
  54                        (choice (const :tag "all" all)
  55                                (const :tag "last" last)
  56                                (integer :tag "number"))))
  57   :group 'elmo)
  58
  59 ;; Shimbun mua.
  60 (eval-and-compile
  61   (luna-define-class shimbun-elmo-mua (shimbun-mua) (folder))
  62   (luna-define-internal-accessors 'shimbun-elmo-mua))
  63
  64 (luna-define-method shimbun-mua-search-id ((mua shimbun-elmo-mua) id)
  65   (elmo-msgdb-overview-get-entity id
  66                                   (elmo-folder-msgdb
  67                                    (shimbun-elmo-mua-folder-internal mua))))
  68
  69 (eval-and-compile
  70   (luna-define-class elmo-shimbun-folder
  71                      (elmo-map-folder) (shimbun headers header-hash
  72                                                 group range last-check))
  73   (luna-define-internal-accessors 'elmo-shimbun-folder))
  74
  75 (defsubst elmo-shimbun-lapse-seconds (time)
  76   (let ((now (current-time)))
  77     (+ (* (- (car now) (car time)) 65536)
  78        (- (nth 1 now) (nth 1 time)))))
  79
  80 (defun elmo-shimbun-parse-time-string (string)
  81   "Parse the time-string STRING and return its time as Emacs style."
  82   (ignore-errors
  83     (let ((x (timezone-fix-time string nil nil)))
  84       (encode-time (aref x 5) (aref x 4) (aref x 3)
  85                    (aref x 2) (aref x 1) (aref x 0)
  86                    (aref x 6)))))
  87
  88 (defsubst elmo-shimbun-headers-check-p (folder)
  89   (or (null (elmo-shimbun-folder-last-check-internal folder))
  90       (and (elmo-shimbun-folder-last-check-internal folder)
  91            (> (elmo-shimbun-lapse-seconds
  92                (elmo-shimbun-folder-last-check-internal folder))
  93               elmo-shimbun-check-interval))))
  94
  95 (defun elmo-shimbun-msgdb-to-headers (folder expire-days)
  96   (let (headers)
  97     (dolist (ov (elmo-msgdb-get-overview (elmo-folder-msgdb folder)))
  98       (when (and (elmo-msgdb-overview-entity-get-extra-field ov "xref")
  99                  (if expire-days
 100                      (< (elmo-shimbun-lapse-seconds
 101                          (elmo-shimbun-parse-time-string
 102                           (elmo-msgdb-overview-entity-get-date ov)))
 103                         (* expire-days 86400 ; seconds per day
 104                            ))
 105                    t))
 106         (setq headers
 107               (cons (shimbun-make-header
 108                      (elmo-msgdb-overview-entity-get-number ov)
 109                      (shimbun-mime-encode-string
 110                       (elmo-msgdb-overview-entity-get-subject ov))
 111                      (shimbun-mime-encode-string
 112                       (elmo-msgdb-overview-entity-get-from ov))
 113                      (elmo-msgdb-overview-entity-get-date ov)
 114                      (elmo-msgdb-overview-entity-get-id ov)
 115                      (elmo-msgdb-overview-entity-get-references ov)
 116                      0
 117                      0
 118                      (elmo-msgdb-overview-entity-get-extra-field ov "xref"))
 119                     headers))))
 120     (nreverse headers)))
 121
 122 (defun elmo-shimbun-folder-setup (folder)
 123   ;; Resume headers from existing msgdb.
 124   (elmo-shimbun-folder-set-headers-internal
 125    folder
 126    (elmo-shimbun-msgdb-to-headers folder nil))
 127   (elmo-shimbun-folder-set-header-hash-internal
 128    folder
 129    (elmo-make-hash
 130     (length (elmo-shimbun-folder-headers-internal folder))))
 131   (dolist (header (elmo-shimbun-folder-headers-internal folder))
 132     (elmo-set-hash-val
 133      (shimbun-header-id header) header
 134      (elmo-shimbun-folder-header-hash-internal folder))))
 135
 136 (defun elmo-shimbun-get-headers (folder)
 137   (shimbun-open-group
 138    (elmo-shimbun-folder-shimbun-internal folder)
 139    (elmo-shimbun-folder-group-internal folder))
 140   (let* ((shimbun (elmo-shimbun-folder-shimbun-internal folder))
 141          (key (concat (shimbun-server-internal shimbun)
 142                       "." (shimbun-current-group-internal shimbun)))
 143          (elmo-hash-minimum-size 0)
 144          entry headers hash)
 145     ;; new headers.
 146     (setq headers
 147           (delq nil
 148                 (mapcar
 149                  (lambda (x)
 150                    (unless (elmo-msgdb-overview-get-entity
 151                             (shimbun-header-id x)
 152                             (elmo-folder-msgdb folder))
 153                      x))
 154                  ;; This takes much time.
 155                  (shimbun-headers
 156                   (elmo-shimbun-folder-shimbun-internal folder)
 157                   (elmo-shimbun-folder-range-internal folder)))))
 158     (elmo-shimbun-folder-set-headers-internal
 159      folder
 160      (nconc (elmo-shimbun-msgdb-to-headers
 161              folder (shimbun-article-expiration-days
 162                      (elmo-shimbun-folder-shimbun-internal folder)))
 163             headers))
 164     (setq hash
 165           (elmo-shimbun-folder-set-header-hash-internal
 166            folder
 167            (elmo-make-hash
 168             (length (elmo-shimbun-folder-headers-internal folder)))))
 169     ;; Set up header hash.
 170     (dolist (header (elmo-shimbun-folder-headers-internal folder))
 171       (elmo-set-hash-val
 172        (shimbun-header-id header) header
 173        (elmo-shimbun-folder-header-hash-internal folder)))
 174     (elmo-shimbun-folder-set-last-check-internal folder (current-time))))
 175
 176 (luna-define-method elmo-folder-initialize ((folder
 177                                              elmo-shimbun-folder)
 178                                             name)
 179   (let ((server-group (if (string-match "\\([^.]+\\)\\." name)
 180                           (list (elmo-match-string 1 name)
 181                                 (substring name (match-end 0)))
 182                         (list name))))
 183     (when (nth 0 server-group) ; server
 184       (elmo-shimbun-folder-set-shimbun-internal
 185        folder
 186        (shimbun-open (nth 0 server-group)
 187                      (luna-make-entity 'shimbun-elmo-mua :folder folder))))
 188     (when (nth 1 server-group)
 189       (elmo-shimbun-folder-set-group-internal
 190        folder
 191        (nth 1 server-group)))
 192     (elmo-shimbun-folder-set-range-internal
 193      folder
 194      (or (cdr (elmo-string-matched-assoc (elmo-folder-name-internal folder)
 195                                          elmo-shimbun-index-range-alist))
 196          elmo-shimbun-default-index-range))
 197     folder))
 198
 199 (luna-define-method elmo-folder-open-internal ((folder elmo-shimbun-folder))
 200   (when (elmo-folder-plugged-p folder)
 201     (when (elmo-shimbun-headers-check-p folder)
 202       (let ((inhibit-quit t))
 203         (elmo-map-folder-location-setup
 204          folder
 205          (elmo-msgdb-location-load (elmo-folder-msgdb-path folder)))
 206         ;; Resume headers from existing msgdb.
 207         (elmo-shimbun-folder-setup folder))
 208       (elmo-shimbun-get-headers folder))
 209     (elmo-map-folder-update-locations
 210      folder
 211      (elmo-map-folder-list-message-locations folder))))
 212
 213 (luna-define-method elmo-folder-reserve-status-p ((folder elmo-shimbun-folder))
 214   t)
 215
 216 (luna-define-method elmo-folder-close-internal :after ((folder
 217                                                         elmo-shimbun-folder))
 218   (shimbun-close-group
 219    (elmo-shimbun-folder-shimbun-internal folder))
 220   (elmo-shimbun-folder-set-headers-internal
 221    folder nil)
 222   (elmo-shimbun-folder-set-header-hash-internal
 223    folder nil)
 224   (elmo-shimbun-folder-set-last-check-internal
 225    folder nil))
 226
 227 (luna-define-method elmo-folder-plugged-p ((folder elmo-shimbun-folder))
 228   (elmo-plugged-p
 229    "shimbun"
 230    (shimbun-server-internal (elmo-shimbun-folder-shimbun-internal folder))
 231    nil nil
 232    (shimbun-server-internal (elmo-shimbun-folder-shimbun-internal folder))))
 233
 234 (luna-define-method elmo-folder-set-plugged ((folder elmo-shimbun-folder)
 235                                              plugged &optional add)
 236   (elmo-set-plugged plugged
 237                     "shimbun"
 238                     (shimbun-server-internal
 239                      (elmo-shimbun-folder-shimbun-internal folder))
 240                     nil nil nil
 241                     (shimbun-server-internal
 242                      (elmo-shimbun-folder-shimbun-internal folder))
 243                     add))
 244
 245 (luna-define-method elmo-net-port-info ((folder elmo-shimbun-folder))
 246   (list "shimbun"
 247         (shimbun-server-internal
 248          (elmo-shimbun-folder-shimbun-internal folder))
 249         nil))
 250
 251 (luna-define-method elmo-folder-check :around ((folder elmo-shimbun-folder))
 252   (when (shimbun-current-group-internal
 253          (elmo-shimbun-folder-shimbun-internal folder))
 254     (when (and (elmo-folder-plugged-p folder)
 255                (elmo-shimbun-headers-check-p folder))
 256       (elmo-shimbun-get-headers folder)
 257       (luna-call-next-method))))
 258
 259 (luna-define-method elmo-folder-clear :around ((folder elmo-shimbun-folder)
 260                                                &optional keep-killed)
 261   (elmo-shimbun-folder-set-headers-internal folder nil)
 262   (elmo-shimbun-folder-set-header-hash-internal folder nil)
 263   (elmo-shimbun-folder-set-last-check-internal folder nil)
 264   (luna-call-next-method))
 265
 266 (luna-define-method elmo-folder-expand-msgdb-path ((folder
 267                                                     elmo-shimbun-folder))
 268   (expand-file-name
 269    (concat (shimbun-server-internal
 270             (elmo-shimbun-folder-shimbun-internal folder))
 271            "/"
 272            (elmo-shimbun-folder-group-internal folder))
 273    (expand-file-name "shimbun" elmo-msgdb-dir)))
 274
 275 (defun elmo-shimbun-msgdb-create-entity (folder number)
 276   (let ((header (elmo-get-hash-val
 277                  (elmo-map-message-location folder number)
 278                  (elmo-shimbun-folder-header-hash-internal folder)))
 279         ov)
 280     (when header
 281       (with-temp-buffer
 282         (shimbun-header-insert
 283          (elmo-shimbun-folder-shimbun-internal folder)
 284          header)
 285         (setq ov (elmo-msgdb-create-overview-from-buffer number))
 286         (elmo-msgdb-overview-entity-set-extra
 287          ov
 288          (nconc
 289           (elmo-msgdb-overview-entity-get-extra ov)
 290           (list (cons "xref" (shimbun-header-xref header)))))))))
 291
 292 (luna-define-method elmo-folder-msgdb-create ((folder elmo-shimbun-folder)
 293                                               numlist new-mark
 294                                               already-mark seen-mark
 295                                               important-mark
 296                                               seen-list)
 297   (let* (overview number-alist mark-alist entity
 298                   i percent num pair)
 299     (setq num (length numlist))
 300     (setq i 0)
 301     (message "Creating msgdb...")
 302     (while numlist
 303       (setq entity
 304             (elmo-shimbun-msgdb-create-entity
 305              folder (car numlist)))
 306       (when entity
 307         (setq overview
 308               (elmo-msgdb-append-element
 309                overview entity))
 310         (setq number-alist
 311               (elmo-msgdb-number-add number-alist
 312                                      (elmo-msgdb-overview-entity-get-number
 313                                       entity)
 314                                      (elmo-msgdb-overview-entity-get-id
 315                                       entity)))
 316         (setq mark-alist
 317               (elmo-msgdb-mark-append
 318                mark-alist
 319                (elmo-msgdb-overview-entity-get-number
 320                 entity)
 321                (or (elmo-msgdb-global-mark-get
 322                     (elmo-msgdb-overview-entity-get-id
 323                      entity))
 324                    new-mark))))
 325       (when (> num elmo-display-progress-threshold)
 326         (setq i (1+ i))
 327         (setq percent (/ (* i 100) num))
 328         (elmo-display-progress
 329          'elmo-folder-msgdb-create "Creating msgdb..."
 330          percent))
 331       (setq numlist (cdr numlist)))
 332     (message "Creating msgdb...done.")
 333     (elmo-msgdb-sort-by-date
 334      (list overview number-alist mark-alist))))
 335
 336 (luna-define-method elmo-folder-message-file-p ((folder elmo-shimbun-folder))
 337   nil)
 338
 339 (luna-define-method elmo-map-message-fetch ((folder elmo-shimbun-folder)
 340                                             location strategy
 341                                             &optional section unseen)
 342   (shimbun-article (elmo-shimbun-folder-shimbun-internal folder)
 343                    (elmo-get-hash-val
 344                     location
 345                     (elmo-shimbun-folder-header-hash-internal folder))))
 346
 347 (luna-define-method elmo-message-encache :around ((folder
 348                                                    elmo-shimbun-folder)
 349                                                   number)
 350   (if (elmo-folder-plugged-p folder)
 351       (luna-call-next-method)
 352     (if elmo-enable-disconnected-operation
 353         (elmo-message-encache-dop folder number)
 354       (error "Unplugged"))))
 355
 356 (luna-define-method elmo-folder-list-messages-internal :around
 357   ((folder elmo-shimbun-folder) &optional nohide)
 358   (if (elmo-folder-plugged-p folder)
 359       (luna-call-next-method)
 360     t))
 361
 362 (luna-define-method elmo-map-folder-list-message-locations
 363   ((folder elmo-shimbun-folder))
 364   (mapcar
 365    (function shimbun-header-id)
 366    (elmo-shimbun-folder-headers-internal folder)))
 367
 368 (luna-define-method elmo-folder-list-subfolders ((folder elmo-shimbun-folder)
 369                                                  &optional one-level)
 370   (unless (elmo-shimbun-folder-group-internal folder)
 371     (mapcar
 372      (lambda (x)
 373        (concat (elmo-folder-prefix-internal folder)
 374                (shimbun-server-internal
 375                 (elmo-shimbun-folder-shimbun-internal folder))
 376                "."
 377                x))
 378      (shimbun-groups (elmo-shimbun-folder-shimbun-internal folder)))))
 379
 380 (luna-define-method elmo-folder-exists-p ((folder elmo-shimbun-folder))
 381   (if (elmo-shimbun-folder-group-internal folder)
 382       (progn
 383         (member
 384          (elmo-shimbun-folder-group-internal folder)
 385          (shimbun-groups (elmo-shimbun-folder-shimbun-internal
 386                           folder))))
 387     t))
 388
 389 (luna-define-method elmo-folder-search ((folder elmo-shimbun-folder)
 390                                         condition &optional from-msgs)
 391   nil)
 392
 393 ;;; To override elmo-map-folder methods.
 394 (luna-define-method elmo-folder-list-unreads-internal
 395   ((folder elmo-shimbun-folder) unread-marks &optional mark-alist)
 396   t)
 397
 398 (luna-define-method elmo-folder-unmark-important ((folder elmo-shimbun-folder)
 399                                                   numbers)
 400   t)
 401
 402 (luna-define-method elmo-folder-mark-as-important ((folder elmo-shimbun-folder)
 403                                                    numbers)
 404   t)
 405
 406 (luna-define-method elmo-folder-unmark-read ((folder elmo-shimbun-folder)
 407                                              numbers)
 408   t)
 409
 410 (luna-define-method elmo-folder-mark-as-read ((folder elmo-shimbun-folder)
 411                                               numbers)
 412   t)
 413
 414 (require 'product)
 415 (product-provide (provide 'elmo-shimbun) (require 'elmo-version))
 416
 417 ;;; elmo-shimbun.el ends here