git.chise.org Git - elisp/gnus.git-/blob - lisp/nnshimbun.el

   1 ;;; nnshimbun.el --- interfacing with web newspapers -*- coding: junet; -*-
   2
   3 ;; Authors: TSUCHIYA Masatoshi <tsuchiya@namazu.org>,
   4 ;;          Akihiro Arisawa    <ari@atesoft.advantest.co.jp>,
   5 ;;          Katsumi Yamaoka    <yamaoka@jpl.org>,
   6 ;;          Yuuichi Teranishi  <teranisi@gohome.org>
   7 ;; Keywords: news
   8
   9 ;;; Copyright:
  10
  11 ;; This file is a part of Semi-Gnus.
  12
  13 ;; This program is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program; if not, you can either send email to this
  25 ;; program's maintainer or write to: The Free Software Foundation,
  26 ;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; Gnus (or gnus) backend to read newspapers on the World Wide Web.
  31 ;; This module requires the Emacs-W3M and the external command W3M.
  32 ;; Visit the following pages for more information.
  33 ;;
  34 ;;      http://namazu.org/~tsuchiya/emacs-w3m/
  35 ;;      http://ei5nazha.yz.yamagata-u.ac.jp/~aito/w3m/
  36
  37 ;; If you would like to use this module in Gnus (not T-gnus), put this
  38 ;; file into the lisp/ directory in the Gnus source tree and run
  39 ;; `make install'.  And then, copy the function definition of
  40 ;; `gnus-group-make-shimbun-group' from the file gnus-group.el of
  41 ;; T-gnus to somewhere else, for example .gnus file as follows:
  42 ;;
  43 ;;(eval-after-load "gnus-group"
  44 ;;  '(if (not (fboundp 'gnus-group-make-shimbun-group))
  45 ;;       (defun gnus-group-make-shimbun-group ()
  46 ;;         "Create a nnshimbun group."
  47 ;;         [...a function definition...])))
  48
  49 ;;; Definitions:
  50
  51 (gnus-declare-backend "nnshimbun" 'address)
  52
  53 (eval-when-compile (require 'cl))
  54
  55 (require 'nnheader)
  56 (require 'nnmail)
  57 (require 'nnoo)
  58 (require 'gnus-bcklg)
  59 (require 'shimbun)
  60
  61
  62 (nnoo-declare nnshimbun)
  63
  64 (defvoo nnshimbun-directory (nnheader-concat gnus-directory "shimbun/")
  65   "Where nnshimbun will save its files.")
  66
  67 (defvoo nnshimbun-nov-is-evil nil
  68   "*Non-nil means that nnshimbun will never retrieve NOV headers.")
  69
  70 (defvoo nnshimbun-nov-file-name ".overview")
  71
  72 (defvoo nnshimbun-pre-fetch-article nil
  73   "*Non nil means that nnshimbun fetch unread articles when scanning groups.")
  74
  75 (defvoo nnshimbun-use-entire-index t
  76   "*Nil means that nnshimbun check the last index of articles.")
  77
  78 ;; set by nnshimbun-possibly-change-group
  79 (defvoo nnshimbun-buffer nil)
  80 (defvoo nnshimbun-current-directory nil)
  81 (defvoo nnshimbun-current-group nil)
  82
  83 ;; set by nnshimbun-open-server
  84 (defvoo nnshimbun-shimbun nil)
  85 (defvoo nnshimbun-server-directory nil)
  86
  87 (defvoo nnshimbun-status-string "")
  88 (defvoo nnshimbun-nov-last-check nil)
  89 (defvoo nnshimbun-nov-buffer-alist nil)
  90 (defvoo nnshimbun-nov-buffer-file-name nil)
  91
  92 (defvoo nnshimbun-keep-backlog 300)
  93 (defvoo nnshimbun-backlog-articles nil)
  94 (defvoo nnshimbun-backlog-hashtb nil)
  95
  96 ;;; backlog
  97 (defmacro nnshimbun-backlog (&rest form)
  98   `(let ((gnus-keep-backlog nnshimbun-keep-backlog)
  99          (gnus-backlog-buffer (format " *nnshimbun backlog %s*" (nnoo-current-server 'nnshimbun)))
 100          (gnus-backlog-articles nnshimbun-backlog-articles)
 101          (gnus-backlog-hashtb nnshimbun-backlog-hashtb))
 102      (unwind-protect
 103          (progn ,@form)
 104        (setq nnshimbun-backlog-articles gnus-backlog-articles
 105              nnshimbun-backlog-hashtb gnus-backlog-hashtb))))
 106 (put 'nnshimbun-backlog 'lisp-indent-function 0)
 107 (put 'nnshimbun-backlog 'edebug-form-spec '(form body))
 108
 109
 110 ;;; Interface Functions
 111 (nnoo-define-basics nnshimbun)
 112
 113 (deffoo nnshimbun-open-server (server &optional defs)
 114   (push (list 'nnshimbun-shimbun
 115               (condition-case err
 116                   (shimbun-open server (luna-make-entity 'shimbun-gnus-mua))
 117                 (error (nnheader-report 'nnshimbun "%s" (error-message-string err)))))
 118         defs)
 119   ;; Set directory for server working files.
 120   (push (list 'nnshimbun-server-directory
 121               (file-name-as-directory
 122                (expand-file-name server nnshimbun-directory)))
 123         defs)
 124   (nnoo-change-server 'nnshimbun server defs)
 125   (nnshimbun-possibly-change-group nil server)
 126   ;; Make directories.
 127   (unless (file-exists-p nnshimbun-directory)
 128     (ignore-errors (make-directory nnshimbun-directory t)))
 129   (cond
 130    ((not (file-exists-p nnshimbun-directory))
 131     (nnshimbun-close-server)
 132     (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-directory))
 133    ((not (file-directory-p (file-truename nnshimbun-directory)))
 134     (nnshimbun-close-server)
 135     (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-directory))
 136    (t
 137     (unless (file-exists-p nnshimbun-server-directory)
 138       (ignore-errors (make-directory nnshimbun-server-directory t)))
 139     (cond
 140      ((not (file-exists-p nnshimbun-server-directory))
 141       (nnshimbun-close-server)
 142       (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-server-directory))
 143      ((not (file-directory-p (file-truename nnshimbun-server-directory)))
 144       (nnshimbun-close-server)
 145       (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-server-directory))
 146      (t
 147       (nnheader-report 'nnshimbun "Opened server %s using directory %s"
 148                        server nnshimbun-server-directory)
 149       t)))))
 150
 151 (deffoo nnshimbun-close-server (&optional server)
 152   (shimbun-close nnshimbun-shimbun)
 153   (and (nnshimbun-server-opened server)
 154        (gnus-buffer-live-p nnshimbun-buffer)
 155        (kill-buffer nnshimbun-buffer))
 156   (nnshimbun-backlog (gnus-backlog-shutdown))
 157   (nnshimbun-save-nov)
 158   (nnoo-close-server 'nnshimbun server)
 159   t)
 160
 161 (defsubst nnshimbun-header-xref (x)
 162   (if (and (setq x (mail-header-xref x))
 163            (string-match "^Xref: " x))
 164       (substring x 6)
 165     x))
 166
 167 (eval-and-compile
 168   (let ((Gnus-p
 169          (eval-when-compile
 170            (let ((gnus (locate-library "gnus"))
 171                  ;; Gnus has mailcap.el in the same directory of gnus.el.
 172                  (mailcap (locate-library "mailcap")))
 173              (and gnus mailcap
 174                   (string-equal (file-name-directory gnus)
 175                                 (file-name-directory mailcap)))))))
 176     (if Gnus-p
 177         (progn
 178           (defmacro nnshimbun-mail-header-subject (header)
 179             `(mail-header-subject ,header))
 180           (defmacro nnshimbun-mail-header-from (header)
 181             `(mail-header-from ,header)))
 182       (defmacro nnshimbun-mail-header-subject (header)
 183         `(mime-entity-fetch-field ,header 'Subject))
 184       (defmacro nnshimbun-mail-header-from (header)
 185         `(mime-entity-fetch-field ,header 'From)))))
 186
 187 (defun nnshimbun-make-shimbun-header (header)
 188   (shimbun-make-header
 189    (mail-header-number header)
 190    (nnshimbun-mail-header-subject header)
 191    (nnshimbun-mail-header-from header)
 192    (mail-header-date header)
 193    (or (cdr (assq 'X-Nnshimbun-Id (mail-header-extra header)))
 194        (mail-header-id header))
 195    (mail-header-references header)
 196    (mail-header-chars header)
 197    (mail-header-lines header)
 198    (nnshimbun-header-xref header)))
 199
 200 (defsubst nnshimbun-check-header (group header)
 201   (let (flag)
 202     ;; Check message-id.
 203     (let ((id (std11-field-body "message-id")))
 204       (when (and id (not (string= id (mail-header-id header))))
 205         (let ((extra (mail-header-extra header)))
 206           (unless (assq 'X-Nnshimbun-Id extra)
 207             (push (cons 'X-Nnshimbun-Id (mail-header-id header)) extra)
 208             (mail-header-set-extra header extra)))
 209         (mail-header-set-id header id)
 210         (setq flag t)))
 211     ;; Check references.
 212     (when (string= "" (mail-header-references header))
 213       (let ((refs (std11-field-body "references")))
 214         (when refs
 215           (mail-header-set-references header (std11-unfold-string refs))))
 216       (setq flag t))
 217     (when flag
 218       ;; Replace header.
 219       (with-current-buffer (nnshimbun-open-nov group)
 220         (when (nnheader-find-nov-line (mail-header-number header))
 221           (mail-header-set-xref header (nnshimbun-header-xref header))
 222           (delete-region (point) (progn (forward-line 1) (point)))
 223           (nnheader-insert-nov header))))))
 224
 225 (defun nnshimbun-request-article-1 (article &optional group server to-buffer)
 226   (if (nnshimbun-backlog
 227         (gnus-backlog-request-article
 228          group article (or to-buffer nntp-server-buffer)))
 229       (cons group article)
 230     (let ((header (with-current-buffer (nnshimbun-open-nov group)
 231                     (and (nnheader-find-nov-line article)
 232                          (nnheader-parse-nov)))))
 233       (when header
 234         (with-current-buffer (or to-buffer nntp-server-buffer)
 235           (delete-region (point-min) (point-max))
 236           (shimbun-article nnshimbun-shimbun
 237                            (nnshimbun-make-shimbun-header header))
 238           (when (> (buffer-size) 0)
 239             (nnshimbun-check-header group header)
 240             (nnshimbun-backlog
 241               (gnus-backlog-enter-article group article (current-buffer)))
 242             (nnheader-report 'nnshimbun "Article %s retrieved"
 243                              (mail-header-id header))
 244             (cons group (mail-header-number header))))))))
 245
 246 (deffoo nnshimbun-request-article (article &optional group server to-buffer)
 247   (when (nnshimbun-possibly-change-group group server)
 248     (when (stringp article)
 249       (setq article (nnshimbun-search-id group article)))
 250     (if (integerp article)
 251         (nnshimbun-request-article-1 article group server to-buffer)
 252       (nnheader-report 'nnshimbun "Couldn't retrieve article: %s"
 253                        (prin1-to-string article))
 254       nil)))
 255
 256 (deffoo nnshimbun-request-group (group &optional server dont-check)
 257   (let ((file-name-coding-system nnmail-pathname-coding-system)
 258         (pathname-coding-system nnmail-pathname-coding-system))
 259     (cond
 260      ((not (nnshimbun-possibly-change-group group server))
 261       (nnheader-report 'nnshimbun "Invalid group (no such directory)"))
 262      ((not (file-exists-p nnshimbun-current-directory))
 263       (nnheader-report 'nnshimbun "Directory %s does not exist"
 264                        nnshimbun-current-directory))
 265      ((not (file-directory-p nnshimbun-current-directory))
 266       (nnheader-report 'nnshimbun "%s is not a directory" nnshimbun-current-directory))
 267      (dont-check
 268       (nnheader-report 'nnshimbun "Group %s selected" group)
 269       t)
 270      (t
 271       (let (beg end lines)
 272         (save-excursion
 273           (set-buffer (nnshimbun-open-nov group))
 274           (goto-char (point-min))
 275           (setq beg (ignore-errors (read (current-buffer))))
 276           (goto-char (point-max))
 277           (forward-line -1)
 278           (setq end (ignore-errors (read (current-buffer)))
 279                 lines (count-lines (point-min) (point-max))))
 280         (nnheader-report 'nnshimbunw "Selected group %s" group)
 281         (nnheader-insert "211 %d %d %d %s\n"
 282                          lines (or beg 0) (or end 0) group))))))
 283
 284 (deffoo nnshimbun-request-scan (&optional group server)
 285   (nnshimbun-possibly-change-group group server)
 286   (nnshimbun-generate-nov-database group))
 287
 288 (deffoo nnshimbun-close-group (group &optional server)
 289   (nnshimbun-write-nov group)
 290   t)
 291
 292 (deffoo nnshimbun-request-list (&optional server)
 293   (with-current-buffer nntp-server-buffer
 294     (delete-region (point-min) (point-max))
 295     (dolist (group (shimbun-groups nnshimbun-shimbun))
 296       (when (nnshimbun-possibly-change-group group server)
 297         (let (beg end)
 298           (with-current-buffer (nnshimbun-open-nov group)
 299             (goto-char (point-min))
 300             (setq beg (ignore-errors (read (current-buffer))))
 301             (goto-char (point-max))
 302             (forward-line -1)
 303             (setq end (ignore-errors (read (current-buffer)))))
 304           (insert (format "%s %d %d n\n" group (or end 0) (or beg 0)))))))
 305   t) ; return value
 306
 307 (deffoo nnshimbun-retrieve-headers (articles &optional group server fetch-old)
 308   (when (nnshimbun-possibly-change-group group server)
 309     (if (nnshimbun-retrieve-headers-with-nov articles fetch-old)
 310         'nov
 311       (with-current-buffer nntp-server-buffer
 312         (delete-region (point-min) (point-max))
 313         (let (header)
 314           (dolist (art articles)
 315             (if (stringp art)
 316                 (setq art (nnshimbun-search-id group art)))
 317             (if (integerp art)
 318                 (when (setq header
 319                             (with-current-buffer (nnshimbun-open-nov group)
 320                               (and (nnheader-find-nov-line art)
 321                                    (nnheader-parse-nov))))
 322                   (insert (format "220 %d Article retrieved.\n" art))
 323                   (shimbun-header-insert
 324                    nnshimbun-shimbun
 325                    (nnshimbun-make-shimbun-header header))
 326                   (insert ".\n")
 327                   (delete-region (point) (point-max))))))
 328         'header))))
 329
 330 (defun nnshimbun-retrieve-headers-with-nov (articles &optional fetch-old)
 331   (if (or gnus-nov-is-evil nnshimbun-nov-is-evil)
 332       nil
 333     (let ((nov (expand-file-name nnshimbun-nov-file-name nnshimbun-current-directory)))
 334       (when (file-exists-p nov)
 335         (save-excursion
 336           (set-buffer nntp-server-buffer)
 337           (erase-buffer)
 338           (nnheader-insert-file-contents nov)
 339           (if (and fetch-old (not (numberp fetch-old)))
 340               t                         ; Don't remove anything.
 341             (nnheader-nov-delete-outside-range
 342              (if fetch-old (max 1 (- (car articles) fetch-old))
 343                (car articles))
 344              (and articles (nth (1- (length articles)) articles)))
 345             t))))))
 346
 347
 348
 349 ;;; Nov Database Operations
 350
 351 (defun nnshimbun-generate-nov-database (group)
 352   (nnshimbun-possibly-change-group group)
 353   (let (i)
 354   (with-current-buffer (nnshimbun-open-nov group)
 355     (goto-char (point-max))
 356     (forward-line -1)
 357     (setq i (or (ignore-errors (read (current-buffer))) 0))
 358     (dolist (header (shimbun-headers nnshimbun-shimbun))
 359       (unless (nnshimbun-search-id group (shimbun-header-id header))
 360         (goto-char (point-max))
 361         (nnheader-insert-nov
 362          (make-full-mail-header (setq i (1+ i))
 363                                 (shimbun-header-subject header)
 364                                 (shimbun-header-from header)
 365                                 (shimbun-header-date header)
 366                                 (shimbun-header-id header)
 367                                 (shimbun-header-references header)
 368                                 (shimbun-header-chars header)
 369                                 (shimbun-header-lines header)
 370                                 (shimbun-header-xref header)))
 371         (if nnshimbun-pre-fetch-article
 372             (nnshimbun-request-article-1 i group nil nnshimbun-buffer)))))
 373   (nnshimbun-write-nov group)))
 374
 375 (defun nnshimbun-search-id (group id &optional nov)
 376   (with-current-buffer (nnshimbun-open-nov group)
 377     (goto-char (point-min))
 378     (let (found)
 379       (while (and (not found)
 380                   (search-forward id nil t)) ; We find the ID.
 381         ;; And the id is in the fourth field.
 382         (if (not (and (search-backward "\t" nil t 4)
 383                       (not (search-backward "\t" (gnus-point-at-bol) t))))
 384             (forward-line 1)
 385           (forward-line 0)
 386           (setq found t)))
 387       (unless found
 388         (goto-char (point-min))
 389         (setq id (concat "X-Nnshimbun-Id: " id))
 390         (while (and (not found)
 391                     (search-forward id nil t))
 392           (if (not (search-backward "\t" (gnus-point-at-bol) t 8))
 393               (forward-line 1)
 394             (forward-line 0)
 395             (setq found t))))
 396       (if found
 397           (if nov
 398               (nnheader-parse-nov)
 399             ;; We return the article number.
 400             (ignore-errors (read (current-buffer))))))))
 401
 402 (defun nnshimbun-open-nov (group)
 403   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 404     (if (buffer-live-p buffer)
 405         buffer
 406       (setq buffer (gnus-get-buffer-create
 407                     (format " *nnshimbun overview %s %s*"
 408                             (nnoo-current-server 'nnshimbun) group)))
 409       (save-excursion
 410         (set-buffer buffer)
 411         (set (make-local-variable 'nnshimbun-nov-buffer-file-name)
 412              (expand-file-name
 413               nnshimbun-nov-file-name
 414               (nnmail-group-pathname group nnshimbun-server-directory)))
 415         (erase-buffer)
 416         (when (file-exists-p nnshimbun-nov-buffer-file-name)
 417           (nnheader-insert-file-contents nnshimbun-nov-buffer-file-name))
 418         (set-buffer-modified-p nil))
 419       (push (cons group buffer) nnshimbun-nov-buffer-alist)
 420       buffer)))
 421
 422 (defun nnshimbun-write-nov (group)
 423   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 424     (when (buffer-live-p buffer)
 425       (save-excursion
 426         (set-buffer buffer)
 427         (buffer-modified-p)
 428         (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 429                              nil 'nomesg)))))
 430
 431 (defun nnshimbun-save-nov ()
 432   (save-excursion
 433     (while nnshimbun-nov-buffer-alist
 434       (when (buffer-name (cdar nnshimbun-nov-buffer-alist))
 435         (set-buffer (cdar nnshimbun-nov-buffer-alist))
 436         (when (buffer-modified-p)
 437           (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 438                                nil 'nomesg))
 439         (set-buffer-modified-p nil)
 440         (kill-buffer (current-buffer)))
 441       (setq nnshimbun-nov-buffer-alist (cdr nnshimbun-nov-buffer-alist)))))
 442
 443
 444
 445 ;;; Server Initialize
 446
 447 (defun nnshimbun-possibly-change-group (group &optional server)
 448   (when server
 449     (unless (nnshimbun-server-opened server)
 450       (nnshimbun-open-server server)))
 451   (unless (gnus-buffer-live-p nnshimbun-buffer)
 452     (setq nnshimbun-buffer
 453           (save-excursion
 454             (nnheader-set-temp-buffer
 455              (format " *nnshimbun %s*" (nnoo-current-server 'nnshimbun))))))
 456   (if (not group)
 457       t
 458     (condition-case err
 459         (shimbun-open-group nnshimbun-shimbun group)
 460       (error (nnheader-report 'nnshimbun "%s" (error-message-string err))))
 461     (let ((pathname (nnmail-group-pathname group nnshimbun-server-directory))
 462           (file-name-coding-system nnmail-pathname-coding-system)
 463           (pathname-coding-system nnmail-pathname-coding-system))
 464       (unless (equal pathname nnshimbun-current-directory)
 465         (setq nnshimbun-current-directory pathname
 466               nnshimbun-current-group group))
 467       (unless (file-exists-p nnshimbun-current-directory)
 468         (ignore-errors (make-directory nnshimbun-current-directory t)))
 469       (cond
 470        ((not (file-exists-p nnshimbun-current-directory))
 471         (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-current-directory))
 472        ((not (file-directory-p (file-truename nnshimbun-current-directory)))
 473         (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-current-directory))
 474        (t t)))))
 475
 476
 477
 478 ;;; shimbun-gnus-mua
 479 (luna-define-class shimbun-gnus-mua (shimbun-mua) ())
 480
 481 (luna-define-method shimbun-mua-search-id ((mua shimbun-gnus-mua) id)
 482   (nnshimbun-search-id
 483    (shimbun-current-group-internal (shimbun-mua-shimbun-internal mua))
 484    id))
 485
 486 (luna-define-method shimbun-mua-use-entire-index ((mua shimbun-gnus-mua))
 487   nnshimbun-use-entire-index)
 488
 489
 490 (provide 'nnshimbun)
 491 ;;; nnshimbun.el ends here.