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