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 (eval-when-compile
  37   (require 'cl)
  38   (defun-maybe shimbun-servers-list ()))
  39
  40 (defcustom elmo-shimbun-check-interval 60
  41   "*Check interval for shimbun."
  42   :type 'integer
  43   :group 'elmo)
  44
  45 (defcustom elmo-shimbun-default-index-range 2
  46   "*Default value for the range of header indices."
  47   :type '(choice (const :tag "all" all)
  48                  (const :tag "last" last)
  49                  (integer :tag "number"))
  50   :group 'elmo)
  51
  52 (defcustom elmo-shimbun-use-cache t
  53   "*If non-nil, use cache for each article."
  54   :type 'boolean
  55   :group 'elmo)
  56
  57 (defcustom elmo-shimbun-index-range-alist nil
  58   "*Alist of FOLDER-REGEXP and RANGE.
  59 FOLDER-REGEXP is the regexp for shimbun folder name.
  60 RANGE is the range of the header indices .
  61 See `shimbun-headers' for more detail about RANGE."
  62   :type '(repeat (cons (regexp :tag "Folder Regexp")
  63                        (choice (const :tag "all" all)
  64                                (const :tag "last" last)
  65                                (integer :tag "number"))))
  66   :group 'elmo)
  67
  68 (defcustom elmo-shimbun-update-overview-folder-list 'all
  69   "*List of FOLDER-REGEXP.
  70 FOLDER-REGEXP is the regexp of shimbun folder name which should be
  71 update overview when message is fetched.
  72 If it is the symbol `all', update overview for all shimbun folders."
  73   :type '(choice (const :tag "All shimbun folders" all)
  74                  (repeat (regexp :tag "Folder Regexp")))
  75   :group 'elmo)
  76
  77 ;; Shimbun header.
  78 (defsubst elmo-shimbun-header-extra-field (header field-name)
  79   (let ((extra (and header (shimbun-header-extra header))))
  80     (and extra
  81          (cdr (assoc field-name extra)))))
  82
  83 (defsubst elmo-shimbun-header-set-extra-field (header field-name value)
  84   (let ((extras (and header (shimbun-header-extra header)))
  85         extra)
  86     (if (setq extra (assoc field-name extras))
  87         (setcdr extra value)
  88       (shimbun-header-set-extra
  89        header
  90        (cons (cons field-name value) extras)))))
  91
  92 ;; Shimbun mua.
  93 (eval-and-compile
  94   (luna-define-class shimbun-elmo-mua (shimbun-mua) (folder))
  95   (luna-define-internal-accessors 'shimbun-elmo-mua))
  96
  97 (luna-define-method shimbun-mua-search-id ((mua shimbun-elmo-mua) id)
  98   (elmo-message-entity (shimbun-elmo-mua-folder-internal mua) id))
  99
 100 (eval-and-compile
 101   (luna-define-class elmo-shimbun-folder
 102                      (elmo-map-folder) (shimbun headers header-hash
 103                                                 entity-hash
 104                                                 group range last-check))
 105   (luna-define-internal-accessors 'elmo-shimbun-folder))
 106
 107 (defun elmo-shimbun-folder-entity-hash (folder)
 108   (or (elmo-shimbun-folder-entity-hash-internal folder)
 109       (let ((overviews (elmo-folder-list-message-entities folder))
 110             hash id)
 111         (when overviews
 112           (setq hash (elmo-make-hash (length overviews)))
 113           (dolist (entity overviews)
 114             (elmo-set-hash-val (elmo-message-entity-field entity 'message-id)
 115                                entity hash)
 116             (when (setq id (elmo-message-entity-field entity 'x-original-id))
 117               (elmo-set-hash-val id entity hash)))
 118           (elmo-shimbun-folder-set-entity-hash-internal folder hash)))))
 119
 120 (defsubst elmo-shimbun-folder-shimbun-header (folder location)
 121   (let ((hash (elmo-shimbun-folder-header-hash-internal folder)))
 122     (or (and hash (elmo-get-hash-val location hash))
 123         (let ((entity (elmo-message-entity folder location))
 124               (elmo-hash-minimum-size 63)
 125               header)
 126           (when entity
 127             (setq header (elmo-shimbun-entity-to-header entity))
 128             (unless hash
 129               (elmo-shimbun-folder-set-header-hash-internal
 130                folder
 131                (setq hash (elmo-make-hash))))
 132             (elmo-set-hash-val (elmo-message-entity-field entity 'message-id)
 133                                header
 134                                hash)
 135             header)))))
 136
 137 (defsubst elmo-shimbun-lapse-seconds (time)
 138   (let ((now (current-time)))
 139     (+ (* (- (car now) (car time)) 65536)
 140        (- (nth 1 now) (nth 1 time)))))
 141
 142 (defsubst elmo-shimbun-headers-check-p (folder)
 143   (or (null (elmo-shimbun-folder-last-check-internal folder))
 144       (and (elmo-shimbun-folder-last-check-internal folder)
 145            (> (elmo-shimbun-lapse-seconds
 146                (elmo-shimbun-folder-last-check-internal folder))
 147               elmo-shimbun-check-interval))))
 148
 149 (defun elmo-shimbun-entity-to-header (entity)
 150   (let (message-id shimbun-id)
 151     (if (setq message-id (elmo-message-entity-field entity 'x-original-id))
 152         (setq shimbun-id (elmo-message-entity-field entity 'message-id))
 153       (setq message-id (elmo-message-entity-field entity 'message-id)
 154             shimbun-id nil))
 155     (elmo-with-enable-multibyte
 156       (shimbun-create-header
 157        (elmo-message-entity-number entity)
 158        (elmo-message-entity-field entity 'subject)
 159        (elmo-message-entity-field entity 'from)
 160        (elmo-time-make-date-string
 161         (elmo-message-entity-field entity 'date))
 162        message-id
 163        (elmo-message-entity-field entity 'references)
 164        (elmo-message-entity-field entity 'size)
 165        0
 166        (elmo-message-entity-field entity 'xref)
 167        (and shimbun-id
 168             (list (cons "x-shimbun-id" shimbun-id)))))))
 169
 170 (defsubst elmo-shimbun-folder-header-hash-setup (folder headers)
 171   (let ((hash (or (elmo-shimbun-folder-header-hash-internal folder)
 172                   (elmo-make-hash (length headers)))))
 173     (dolist (header headers)
 174       (elmo-set-hash-val (shimbun-header-id header) header hash))
 175     (elmo-shimbun-folder-set-header-hash-internal folder hash)))
 176
 177 (defun elmo-shimbun-get-headers (folder)
 178   (let* ((shimbun (elmo-shimbun-folder-shimbun-internal folder))
 179          (key (concat (shimbun-server shimbun)
 180                       "." (shimbun-current-group shimbun)))
 181          (elmo-hash-minimum-size 63)
 182          headers)
 183     ;; new headers.
 184     (setq headers
 185           (delq nil
 186                 (mapcar
 187                  (lambda (x)
 188                    (unless (elmo-message-entity folder (shimbun-header-id x))
 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 folder headers)
 195     (when headers
 196       (elmo-shimbun-folder-header-hash-setup folder headers))
 197     (elmo-shimbun-folder-set-last-check-internal folder (current-time))))
 198
 199 (luna-define-method elmo-folder-initialize ((folder
 200                                              elmo-shimbun-folder)
 201                                             name)
 202   (if (string= name "")
 203       folder
 204     (let ((server-group (if (string-match "\\([^.]+\\)\\." name)
 205                             (list (elmo-match-string 1 name)
 206                                   (substring name (match-end 0)))
 207                           (list name))))
 208       (when (nth 0 server-group) ; server
 209         (elmo-shimbun-folder-set-shimbun-internal
 210          folder
 211          (condition-case nil
 212              (shimbun-open (nth 0 server-group)
 213                            (luna-make-entity 'shimbun-elmo-mua :folder folder))
 214            (file-error
 215             (luna-make-entity 'shimbun :server (nth 0 server-group))))))
 216       (when (nth 1 server-group)
 217         (elmo-shimbun-folder-set-group-internal
 218          folder
 219          (nth 1 server-group)))
 220       (elmo-shimbun-folder-set-range-internal
 221        folder
 222        (or (cdr (elmo-string-matched-assoc (elmo-folder-name-internal folder)
 223                                            elmo-shimbun-index-range-alist))
 224            elmo-shimbun-default-index-range))
 225       folder)))
 226
 227 (luna-define-method elmo-folder-open-internal ((folder elmo-shimbun-folder))
 228   (when (elmo-shimbun-folder-shimbun-internal 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-location-map-alist folder)
 234         (elmo-location-map-setup
 235          folder
 236          (elmo-msgdb-location-load (elmo-folder-msgdb-path folder))))
 237       (when (and (elmo-folder-plugged-p folder)
 238                  (elmo-shimbun-headers-check-p folder))
 239         (elmo-shimbun-get-headers folder)
 240         (elmo-location-map-update
 241          folder
 242          (elmo-map-folder-list-message-locations folder))))))
 243
 244 (luna-define-method elmo-folder-open-internal-p ((folder elmo-shimbun-folder))
 245   (elmo-location-map-alist folder))
 246
 247 (luna-define-method elmo-folder-reserve-status-p ((folder elmo-shimbun-folder))
 248   t)
 249
 250 (luna-define-method elmo-folder-local-p ((folder elmo-shimbun-folder))
 251   nil)
 252
 253 (luna-define-method elmo-message-use-cache-p ((folder elmo-shimbun-folder)
 254                                               number)
 255   elmo-shimbun-use-cache)
 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-entity-hash-internal
 266    folder nil)
 267   (elmo-shimbun-folder-set-last-check-internal
 268    folder nil))
 269
 270 (luna-define-method elmo-folder-plugged-p ((folder elmo-shimbun-folder))
 271   (if (elmo-shimbun-folder-shimbun-internal folder)
 272       (elmo-plugged-p
 273        "shimbun"
 274        (shimbun-server (elmo-shimbun-folder-shimbun-internal folder))
 275        nil nil
 276        (shimbun-server (elmo-shimbun-folder-shimbun-internal folder)))
 277     t))
 278
 279 (luna-define-method elmo-folder-set-plugged ((folder elmo-shimbun-folder)
 280                                              plugged &optional add)
 281   (elmo-set-plugged plugged
 282                     "shimbun"
 283                     (shimbun-server
 284                      (elmo-shimbun-folder-shimbun-internal folder))
 285                     nil nil nil
 286                     (shimbun-server
 287                      (elmo-shimbun-folder-shimbun-internal folder))
 288                     add))
 289
 290 (luna-define-method elmo-net-port-info ((folder elmo-shimbun-folder))
 291   (list "shimbun"
 292         (shimbun-server
 293          (elmo-shimbun-folder-shimbun-internal folder))
 294         nil))
 295
 296 (luna-define-method elmo-folder-check :around ((folder elmo-shimbun-folder))
 297   (when (shimbun-current-group
 298          (elmo-shimbun-folder-shimbun-internal folder))
 299     (when (and (elmo-folder-plugged-p folder)
 300                (elmo-shimbun-headers-check-p folder))
 301       (elmo-shimbun-get-headers folder)
 302       (luna-call-next-method))))
 303
 304 (luna-define-method elmo-folder-clear :around ((folder elmo-shimbun-folder)
 305                                                &optional keep-killed)
 306   (elmo-shimbun-folder-set-headers-internal folder nil)
 307   (elmo-shimbun-folder-set-header-hash-internal folder nil)
 308   (elmo-shimbun-folder-set-entity-hash-internal folder nil)
 309   (elmo-shimbun-folder-set-last-check-internal folder nil)
 310   (luna-call-next-method))
 311
 312 (luna-define-method elmo-folder-expand-msgdb-path ((folder
 313                                                     elmo-shimbun-folder))
 314   (expand-file-name
 315    (concat (shimbun-server
 316             (elmo-shimbun-folder-shimbun-internal folder))
 317            "/"
 318            (elmo-shimbun-folder-group-internal folder))
 319    (expand-file-name "shimbun" elmo-msgdb-directory)))
 320
 321 (defun elmo-shimbun-msgdb-create-entity (folder number)
 322   (let ((header (elmo-shimbun-folder-shimbun-header
 323                  folder
 324                  (elmo-map-message-location folder number)))
 325         ov)
 326     (when header
 327       (with-temp-buffer
 328         (shimbun-header-insert
 329          (elmo-shimbun-folder-shimbun-internal folder)
 330          header)
 331         (setq ov (elmo-msgdb-create-message-entity-from-buffer
 332                   (elmo-msgdb-message-entity-handler
 333                    (elmo-folder-msgdb-internal folder)) number))
 334         (elmo-message-entity-set-field
 335          ov
 336          'xref (shimbun-header-xref header)))
 337       ov)))
 338
 339 (luna-define-method elmo-folder-msgdb-create ((folder elmo-shimbun-folder)
 340                                               numlist flag-table)
 341   (let ((new-msgdb (elmo-make-msgdb))
 342         entity msgid flags)
 343     (elmo-with-progress-display (elmo-folder-msgdb-create (length numlist))
 344         "Creating msgdb"
 345       (dolist (number numlist)
 346         (setq entity (elmo-shimbun-msgdb-create-entity folder number))
 347         (when entity
 348           (setq msgid (elmo-message-entity-field entity 'message-id)
 349                 flags (elmo-flag-table-get flag-table msgid))
 350           (elmo-global-flags-set flags folder number msgid)
 351           (elmo-msgdb-append-entity new-msgdb entity flags))
 352         (elmo-progress-notify 'elmo-folder-msgdb-create)))
 353     new-msgdb))
 354
 355 (luna-define-method elmo-folder-message-file-p ((folder elmo-shimbun-folder))
 356   nil)
 357
 358 (defsubst elmo-shimbun-update-overview (folder entity shimbun-id header)
 359   (let ((message-id (shimbun-header-id header))
 360         references)
 361     (when (elmo-msgdb-update-entity
 362            (elmo-folder-msgdb folder)
 363            entity
 364            (nconc
 365             (unless (string= shimbun-id message-id)
 366               (elmo-shimbun-header-set-extra-field
 367                header "x-shimbun-id" shimbun-id)
 368               (elmo-set-hash-val message-id
 369                                  entity
 370                                  (elmo-shimbun-folder-entity-hash folder))
 371               (elmo-set-hash-val shimbun-id
 372                                  entity
 373                                  (elmo-shimbun-folder-entity-hash folder))
 374               (list (cons 'x-original-id message-id)))
 375             (list
 376              (cons 'from    (shimbun-header-from header 'no-encode))
 377              (cons 'subject (shimbun-header-subject header 'no-encode))
 378              (cons 'date    (shimbun-header-date header))
 379              (cons 'references
 380                    (elmo-msgdb-get-references-from-buffer)))))
 381       (elmo-emit-signal 'update-overview folder
 382                         (elmo-message-entity-number entity)))))
 383
 384 (luna-define-method elmo-map-message-fetch ((folder elmo-shimbun-folder)
 385                                             location strategy
 386                                             &optional section unseen)
 387   (if (elmo-folder-plugged-p folder)
 388       (let ((header (elmo-shimbun-folder-shimbun-header
 389                      folder
 390                      location))
 391             shimbun-id)
 392         (shimbun-article (elmo-shimbun-folder-shimbun-internal folder)
 393                          header)
 394         (when (or (eq elmo-shimbun-update-overview-folder-list 'all)
 395                   (elmo-string-match-member
 396                    (elmo-folder-name-internal folder)
 397                    elmo-shimbun-update-overview-folder-list))
 398           (let ((entity (elmo-message-entity folder location)))
 399             (when entity
 400               (elmo-shimbun-update-overview folder entity location header))))
 401         (when (setq shimbun-id
 402                     (elmo-shimbun-header-extra-field header "x-shimbun-id"))
 403           (goto-char (point-min))
 404           (insert (format "X-Shimbun-Id: %s\n" shimbun-id)))
 405         t)
 406     (error "Unplugged")))
 407
 408 (luna-define-method elmo-message-encache :around ((folder
 409                                                    elmo-shimbun-folder)
 410                                                   number &optional read)
 411   (if (elmo-folder-plugged-p folder)
 412       (luna-call-next-method)
 413     (if elmo-enable-disconnected-operation
 414         (elmo-message-encache-dop folder number read)
 415       (error "Unplugged"))))
 416
 417 (luna-define-method elmo-folder-list-messages-internal :around
 418   ((folder elmo-shimbun-folder) &optional nohide)
 419   (if (elmo-folder-plugged-p folder)
 420       (luna-call-next-method)
 421     t))
 422
 423 (luna-define-method elmo-map-folder-list-message-locations
 424   ((folder elmo-shimbun-folder))
 425   (let ((expire-days (shimbun-article-expiration-days
 426                       (elmo-shimbun-folder-shimbun-internal folder))))
 427     (elmo-uniq-list
 428      (nconc
 429       (delq nil
 430             (mapcar
 431              (lambda (ov)
 432                (when (and (elmo-message-entity-field ov 'xref)
 433                           (if expire-days
 434                               (< (elmo-shimbun-lapse-seconds
 435                                   (elmo-message-entity-field ov 'date))
 436                                  (* expire-days 86400 ; seconds per day
 437                                     ))
 438                             t))
 439                  (elmo-message-entity-field ov 'message-id)))
 440              (elmo-folder-list-message-entities folder)))
 441       (mapcar
 442        (lambda (header)
 443          (or (elmo-shimbun-header-extra-field header "x-shimbun-id")
 444              (shimbun-header-id header)))
 445        (elmo-shimbun-folder-headers-internal folder))))))
 446
 447 (luna-define-method elmo-folder-list-subfolders ((folder elmo-shimbun-folder)
 448                                                  &optional one-level)
 449   (let ((prefix (elmo-folder-prefix-internal folder)))
 450     (cond ((elmo-shimbun-folder-shimbun-internal folder)
 451            (unless (elmo-shimbun-folder-group-internal folder)
 452              (mapcar
 453               (lambda (fld)
 454                 (concat prefix
 455                         (shimbun-server
 456                          (elmo-shimbun-folder-shimbun-internal folder))
 457                         "." fld))
 458               (shimbun-groups (elmo-shimbun-folder-shimbun-internal folder)))))
 459           ;; the rest are for "@/" group
 460           (one-level
 461            (mapcar
 462             (lambda (server) (list (concat prefix server)))
 463             (shimbun-servers-list)))
 464           (t
 465            (let (folders)
 466              (dolist (server (shimbun-servers-list))
 467                (setq folders
 468                      (append folders
 469                              (mapcar
 470                               (lambda (group) (concat prefix server "." group))
 471                               (shimbun-groups
 472                                (elmo-shimbun-folder-shimbun-internal
 473                                 (elmo-get-folder (concat prefix server))))))))
 474              folders)))))
 475
 476 (luna-define-method elmo-folder-exists-p ((folder elmo-shimbun-folder))
 477   (if (elmo-shimbun-folder-group-internal folder)
 478       (if (fboundp 'shimbun-group-p)
 479           (shimbun-group-p (elmo-shimbun-folder-shimbun-internal folder)
 480                            (elmo-shimbun-folder-group-internal folder))
 481         (member
 482          (elmo-shimbun-folder-group-internal folder)
 483          (shimbun-groups (elmo-shimbun-folder-shimbun-internal folder))))
 484     t))
 485
 486 (luna-define-method elmo-folder-delete-messages ((folder elmo-shimbun-folder)
 487                                                  numbers)
 488   (elmo-folder-kill-messages folder numbers)
 489   t)
 490
 491 (luna-define-method elmo-message-entity-parent ((folder elmo-shimbun-folder)
 492                                                 entity)
 493   (let ((references (elmo-message-entity-field entity 'references)))
 494     (and references
 495          (elmo-get-hash-val references
 496                             (elmo-shimbun-folder-entity-hash folder)))))
 497
 498 (require 'product)
 499 (product-provide (provide 'elmo-shimbun) (require 'elmo-version))
 500
 501 ;;; elmo-shimbun.el ends here