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