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