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