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 (eval-and-compile
 162   (let ((Gnus-p
 163          (eval-when-compile
 164            (let ((gnus (locate-library "gnus"))
 165                  ;; Gnus has mailcap.el in the same directory of gnus.el.
 166                  (mailcap (locate-library "mailcap")))
 167              (and gnus mailcap
 168                   (string-equal (file-name-directory gnus)
 169                                 (file-name-directory mailcap)))))))
 170     (if Gnus-p
 171         (progn
 172           (defmacro nnshimbun-mail-header-subject (header)
 173             `(mail-header-subject ,header))
 174           (defmacro nnshimbun-mail-header-from (header)
 175             `(mail-header-from ,header)))
 176       (defmacro nnshimbun-mail-header-subject (header)
 177         `(mime-entity-fetch-field ,header 'Subject))
 178       (defmacro nnshimbun-mail-header-from (header)
 179         `(mime-entity-fetch-field ,header 'From)))))
 180
 181 (defun nnshimbun-make-shimbun-header (header)
 182   (shimbun-make-header
 183    (mail-header-number header)
 184    (nnshimbun-mail-header-subject header)
 185    (nnshimbun-mail-header-from header)
 186    (mail-header-date header)
 187    (or (cdr (assq 'X-Nnshimbun-Id (mail-header-extra header)))
 188        (mail-header-id header))
 189    (mail-header-references header)
 190    (mail-header-chars header)
 191    (mail-header-lines header)
 192    (let ((xref (mail-header-xref header)))
 193      (if (and xref (string-match "^Xref: " xref))
 194          (substring xref 6)
 195        xref))))
 196
 197 (defun nnshimbun-request-article-1 (article &optional group server to-buffer)
 198   (if (nnshimbun-backlog
 199         (gnus-backlog-request-article
 200          group article (or to-buffer nntp-server-buffer)))
 201       (cons group article)
 202     (let* ((header (with-current-buffer (nnshimbun-open-nov group)
 203                      (and (nnheader-find-nov-line article)
 204                           (nnshimbun-make-shimbun-header
 205                            (nnheader-parse-nov)))))
 206            (original-id (shimbun-header-id header)))
 207       (when header
 208         (with-current-buffer (or to-buffer nntp-server-buffer)
 209           (delete-region (point-min) (point-max))
 210           (shimbun-article nnshimbun-shimbun header)
 211           (when (> (buffer-size) 0)
 212             (nnshimbun-replace-nov-entry group article header original-id)
 213             (nnshimbun-backlog
 214               (gnus-backlog-enter-article group article (current-buffer)))
 215             (nnheader-report 'nnshimbun "Article %s retrieved"
 216                              (shimbun-header-id header))
 217             (cons group article)))))))
 218
 219 (deffoo nnshimbun-request-article (article &optional group server to-buffer)
 220   (when (nnshimbun-possibly-change-group group server)
 221     (when (stringp article)
 222       (setq article (nnshimbun-search-id group article)))
 223     (if (integerp article)
 224         (nnshimbun-request-article-1 article group server to-buffer)
 225       (nnheader-report 'nnshimbun "Couldn't retrieve article: %s"
 226                        (prin1-to-string article))
 227       nil)))
 228
 229 (deffoo nnshimbun-request-group (group &optional server dont-check)
 230   (let ((file-name-coding-system nnmail-pathname-coding-system)
 231         (pathname-coding-system nnmail-pathname-coding-system))
 232     (cond
 233      ((not (nnshimbun-possibly-change-group group server))
 234       (nnheader-report 'nnshimbun "Invalid group (no such directory)"))
 235      ((not (file-exists-p nnshimbun-current-directory))
 236       (nnheader-report 'nnshimbun "Directory %s does not exist"
 237                        nnshimbun-current-directory))
 238      ((not (file-directory-p nnshimbun-current-directory))
 239       (nnheader-report 'nnshimbun "%s is not a directory" nnshimbun-current-directory))
 240      (dont-check
 241       (nnheader-report 'nnshimbun "Group %s selected" group)
 242       t)
 243      (t
 244       (let (beg end lines)
 245         (with-current-buffer (nnshimbun-open-nov group)
 246           (goto-char (point-min))
 247           (setq beg (ignore-errors (read (current-buffer))))
 248           (goto-char (point-max))
 249           (forward-line -1)
 250           (setq end (ignore-errors (read (current-buffer)))
 251                 lines (count-lines (point-min) (point-max))))
 252         (nnheader-report 'nnshimbunw "Selected group %s" group)
 253         (nnheader-insert "211 %d %d %d %s\n"
 254                          lines (or beg 0) (or end 0) group))))))
 255
 256 (deffoo nnshimbun-request-scan (&optional group server)
 257   (nnshimbun-possibly-change-group group server)
 258   (nnshimbun-generate-nov-database group))
 259
 260 (deffoo nnshimbun-close-group (group &optional server)
 261   (nnshimbun-write-nov group)
 262   t)
 263
 264 (deffoo nnshimbun-request-list (&optional server)
 265   (with-current-buffer nntp-server-buffer
 266     (delete-region (point-min) (point-max))
 267     (dolist (group (shimbun-groups nnshimbun-shimbun))
 268       (when (nnshimbun-possibly-change-group group server)
 269         (let (beg end)
 270           (with-current-buffer (nnshimbun-open-nov group)
 271             (goto-char (point-min))
 272             (setq beg (ignore-errors (read (current-buffer))))
 273             (goto-char (point-max))
 274             (forward-line -1)
 275             (setq end (ignore-errors (read (current-buffer)))))
 276           (insert (format "%s %d %d n\n" group (or end 0) (or beg 0)))))))
 277   t) ; return value
 278
 279 (deffoo nnshimbun-retrieve-headers (articles &optional group server fetch-old)
 280   (when (nnshimbun-possibly-change-group group server)
 281     (if (nnshimbun-retrieve-headers-with-nov articles fetch-old)
 282         'nov
 283       (with-current-buffer nntp-server-buffer
 284         (delete-region (point-min) (point-max))
 285         (let (header)
 286           (dolist (art articles)
 287             (if (stringp art)
 288                 (setq art (nnshimbun-search-id group art)))
 289             (if (integerp art)
 290                 (when (setq header
 291                             (with-current-buffer (nnshimbun-open-nov group)
 292                               (and (nnheader-find-nov-line art)
 293                                    (nnheader-parse-nov))))
 294                   (insert (format "220 %d Article retrieved.\n" art))
 295                   (shimbun-header-insert
 296                    nnshimbun-shimbun
 297                    (nnshimbun-make-shimbun-header header))
 298                   (insert ".\n")
 299                   (delete-region (point) (point-max))))))
 300         'header))))
 301
 302 (defun nnshimbun-retrieve-headers-with-nov (articles &optional fetch-old)
 303   (if (or gnus-nov-is-evil nnshimbun-nov-is-evil)
 304       nil
 305     (let ((nov (expand-file-name nnshimbun-nov-file-name nnshimbun-current-directory)))
 306       (when (file-exists-p nov)
 307         (save-excursion
 308           (set-buffer nntp-server-buffer)
 309           (erase-buffer)
 310           (nnheader-insert-file-contents nov)
 311           (if (and fetch-old (not (numberp fetch-old)))
 312               t                         ; Don't remove anything.
 313             (nnheader-nov-delete-outside-range
 314              (if fetch-old (max 1 (- (car articles) fetch-old))
 315                (car articles))
 316              (and articles (nth (1- (length articles)) articles)))
 317             t))))))
 318
 319
 320
 321 ;;; Nov Database Operations
 322
 323 (defsubst nnshimbun-insert-nov (number header &optional id)
 324   (unless (and (stringp id)
 325                (not (string= id (shimbun-header-id header))))
 326     (setq id nil))
 327   (princ number (current-buffer))
 328   (let ((p (point)))
 329     (insert
 330      "\t"
 331      (or (shimbun-header-subject header) "(none)") "\t"
 332      (or (shimbun-header-from header) "(nobody)") "\t"
 333      (or (shimbun-header-date header) "") "\t"
 334      (or (shimbun-header-id header) (nnmail-message-id)) "\t"
 335      (or (shimbun-header-references header) "") "\t")
 336     (princ (or (shimbun-header-chars header) 0) (current-buffer))
 337     (insert "\t")
 338     (princ (or (shimbun-header-lines header) 0) (current-buffer))
 339     (insert "\t")
 340     (when (shimbun-header-xref header)
 341       (insert "Xref: " (shimbun-header-xref header)))
 342     (when (or (shimbun-header-xref header) id)
 343       (insert "\t"))
 344     (when id
 345       (insert "X-Nnshimbun-Id: " id "\t"))
 346     (insert "\n")
 347     (backward-char 1)
 348     (while (search-backward "\n" p t)
 349       (delete-char 1))
 350     (forward-line 1)))
 351
 352 (defun nnshimbun-generate-nov-database (group)
 353   (nnshimbun-possibly-change-group group)
 354   (with-current-buffer (nnshimbun-open-nov group)
 355     (goto-char (point-max))
 356     (forward-line -1)
 357     (let ((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           (nnshimbun-insert-nov (setq i (1+ i)) header)
 362           (when nnshimbun-pre-fetch-article
 363             (nnshimbun-request-article-1 i group nil nnshimbun-buffer)))))
 364   (nnshimbun-write-nov group)))
 365
 366 (defun nnshimbun-replace-nov-entry (group article header &optional id)
 367   (with-current-buffer (nnshimbun-open-nov group)
 368     (when (nnheader-find-nov-line article)
 369       (delete-region (point) (progn (forward-line 1) (point)))
 370       (nnshimbun-insert-nov article header id))))
 371
 372 (defun nnshimbun-search-id (group id &optional nov)
 373   (with-current-buffer (nnshimbun-open-nov group)
 374     (goto-char (point-min))
 375     (let (found)
 376       (while (and (not found)
 377                   (search-forward id nil t)) ; We find the ID.
 378         ;; And the id is in the fourth field.
 379         (if (not (and (search-backward "\t" nil t 4)
 380                       (not (search-backward "\t" (gnus-point-at-bol) t))))
 381             (forward-line 1)
 382           (forward-line 0)
 383           (setq found t)))
 384       (unless found
 385         (goto-char (point-min))
 386         (setq id (concat "X-Nnshimbun-Id: " id))
 387         (while (and (not found)
 388                     (search-forward id nil t))
 389           (if (not (search-backward "\t" (gnus-point-at-bol) t 8))
 390               (forward-line 1)
 391             (forward-line 0)
 392             (setq found t))))
 393       (if found
 394           (if nov
 395               (nnheader-parse-nov)
 396             ;; We return the article number.
 397             (ignore-errors (read (current-buffer))))))))
 398
 399 (defun nnshimbun-open-nov (group)
 400   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 401     (if (buffer-live-p buffer)
 402         buffer
 403       (setq buffer (gnus-get-buffer-create
 404                     (format " *nnshimbun overview %s %s*"
 405                             (nnoo-current-server 'nnshimbun) group)))
 406       (save-excursion
 407         (set-buffer buffer)
 408         (set (make-local-variable 'nnshimbun-nov-buffer-file-name)
 409              (expand-file-name
 410               nnshimbun-nov-file-name
 411               (nnmail-group-pathname group nnshimbun-server-directory)))
 412         (erase-buffer)
 413         (when (file-exists-p nnshimbun-nov-buffer-file-name)
 414           (nnheader-insert-file-contents nnshimbun-nov-buffer-file-name))
 415         (set-buffer-modified-p nil))
 416       (push (cons group buffer) nnshimbun-nov-buffer-alist)
 417       buffer)))
 418
 419 (defun nnshimbun-write-nov (group)
 420   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 421     (when (buffer-live-p buffer)
 422       (save-excursion
 423         (set-buffer buffer)
 424         (buffer-modified-p)
 425         (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 426                              nil 'nomesg)))))
 427
 428 (defun nnshimbun-save-nov ()
 429   (save-excursion
 430     (while nnshimbun-nov-buffer-alist
 431       (when (buffer-name (cdar nnshimbun-nov-buffer-alist))
 432         (set-buffer (cdar nnshimbun-nov-buffer-alist))
 433         (when (buffer-modified-p)
 434           (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 435                                nil 'nomesg))
 436         (set-buffer-modified-p nil)
 437         (kill-buffer (current-buffer)))
 438       (setq nnshimbun-nov-buffer-alist (cdr nnshimbun-nov-buffer-alist)))))
 439
 440
 441
 442 ;;; Server Initialize
 443
 444 (defun nnshimbun-possibly-change-group (group &optional server)
 445   (when server
 446     (unless (nnshimbun-server-opened server)
 447       (nnshimbun-open-server server)))
 448   (unless (gnus-buffer-live-p nnshimbun-buffer)
 449     (setq nnshimbun-buffer
 450           (save-excursion
 451             (nnheader-set-temp-buffer
 452              (format " *nnshimbun %s*" (nnoo-current-server 'nnshimbun))))))
 453   (if (not group)
 454       t
 455     (condition-case err
 456         (shimbun-open-group nnshimbun-shimbun group)
 457       (error (nnheader-report 'nnshimbun "%s" (error-message-string err))))
 458     (let ((pathname (nnmail-group-pathname group nnshimbun-server-directory))
 459           (file-name-coding-system nnmail-pathname-coding-system)
 460           (pathname-coding-system nnmail-pathname-coding-system))
 461       (unless (equal pathname nnshimbun-current-directory)
 462         (setq nnshimbun-current-directory pathname
 463               nnshimbun-current-group group))
 464       (unless (file-exists-p nnshimbun-current-directory)
 465         (ignore-errors (make-directory nnshimbun-current-directory t)))
 466       (cond
 467        ((not (file-exists-p nnshimbun-current-directory))
 468         (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-current-directory))
 469        ((not (file-directory-p (file-truename nnshimbun-current-directory)))
 470         (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-current-directory))
 471        (t t)))))
 472
 473
 474
 475 ;;; shimbun-gnus-mua
 476 (luna-define-class shimbun-gnus-mua (shimbun-mua) ())
 477
 478 (luna-define-method shimbun-mua-search-id ((mua shimbun-gnus-mua) id)
 479   (nnshimbun-search-id
 480    (shimbun-current-group-internal (shimbun-mua-shimbun-internal mua))
 481    id))
 482
 483 (luna-define-method shimbun-mua-use-entire-index ((mua shimbun-gnus-mua))
 484   nnshimbun-use-entire-index)
 485
 486
 487 (provide 'nnshimbun)
 488 ;;; nnshimbun.el ends here.