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