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

   1 ;;; -*- mode: Emacs-Lisp; coding: junet -*-
   2
   3 ;;; Author: TSUCHIYA Masatoshi <tsuchiya@pine.kuee.kyoto-u.ac.jp>
   4 ;;; Keywords: news
   5
   6 ;;; Copyright:
   7
   8 ;; This file is a part of Semi-Gnus.
   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 this program; if not, you can either send email to this
  22 ;; program's maintainer or write to: The Free Software Foundation,
  23 ;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Gnus backend to read newspapers on WEB.
  28
  29
  30 ;;; Defintinos:
  31
  32 (gnus-declare-backend "nnshimbun" 'address)
  33
  34 (eval-when-compile (require 'cl))
  35
  36 (require 'nnheader)
  37 (require 'nnmail)
  38 (require 'nnoo)
  39 (require 'gnus-bcklg)
  40 (eval-when-compile
  41   (ignore-errors
  42     (require 'nnweb)))
  43 ;; Report failure to find w3 at load time if appropriate.
  44 (eval '(require 'nnweb))
  45
  46
  47 (nnoo-declare nnshimbun)
  48
  49 (defvar nnshimbun-check-interval 300)
  50
  51 (defvar nnshimbun-type-definition
  52   `(("asahi"
  53      (url . "http://spin.asahi.com/")
  54      (groups "national" "business" "politics" "international" "sports" "personal" "feneral")
  55      (coding-system  . ,(if (boundp 'MULE) '*sjis* 'shift_jis))
  56      (generate-nov   . nnshimbun-generate-nov-for-each-group)
  57      (get-headers    . nnshimbun-asahi-get-headers)
  58      (index-url      . (format "%sp%s.html" nnshimbun-url nnshimbun-current-group))
  59      (from-address   . "webmaster@www.asahi.com")
  60      (make-contents  . nnshimbun-make-text-or-html-contents)
  61      (contents-start . "\n<!-- Start of kiji -->\n")
  62      (contents-end   . "\n<!-- End of kiji -->\n"))
  63     ("sponichi"
  64      (url . "http://www.sponichi.co.jp/")
  65      (groups "baseball" "soccer" "usa" "others" "society" "entertainment" "horseracing")
  66      (coding-system  . ,(if (boundp 'MULE) '*sjis* 'shift_jis))
  67      (generate-nov   . nnshimbun-generate-nov-for-each-group)
  68      (get-headers    . nnshimbun-sponichi-get-headers)
  69      (index-url      . (format "%s%s/index.html" nnshimbun-url nnshimbun-current-group))
  70      (from-address   . "webmaster@www.sponichi.co.jp")
  71      (make-contents  . nnshimbun-make-text-or-html-contents)
  72      (contents-start . "\n<span class=\"text\">\e$B!!\e(B")
  73      (contents-end   . "\n"))
  74     ("cnet"
  75      (url . "http://cnet.sphere.ne.jp/")
  76      (groups "comp")
  77      (coding-system  . ,(if (boundp 'MULE) '*sjis* 'shift_jis))
  78      (generate-nov   . nnshimbun-generate-nov-for-each-group)
  79      (get-headers    . nnshimbun-cnet-get-headers)
  80      (index-url      . (format "%s/News/Oneweek/" nnshimbun-url))
  81      (from-address   . "cnet@sphere.ad.jp")
  82      (make-contents  . nnshimbun-make-html-contents)
  83      (contents-start . "\n<!--KIJI-->\n")
  84      (contents-end   . "\n<!--/KIJI-->\n"))
  85     ("wired"
  86      (url . "http://www.hotwired.co.jp/")
  87      (groups "business" "culture" "technology")
  88      (coding-system  . ,(if (boundp 'MULE) '*euc-japan* 'euc-jp))
  89      (generate-nov   . nnshimbun-generate-nov-for-all-groups)
  90      (get-headers    . nnshimbun-wired-get-all-headers)
  91      (index-url)
  92      (from-address   . "webmaster@www.hotwired.co.jp")
  93      (make-contents  . nnshimbun-make-html-contents)
  94      (contents-start . "\n<!-- START_OF_BODY -->\n")
  95      (contents-end   . "\n<!-- END_OF_BODY -->\n"))
  96     ("yomiuri"
  97      (url . "http://www.yomiuri.co.jp/")
  98      (groups "shakai" "sports" "seiji" "keizai" "kokusai" "fuho")
  99      (coding-system  . ,(if (boundp 'MULE) '*sjis* 'shift_jis))
 100      (generate-nov   . nnshimbun-generate-nov-for-all-groups)
 101      (get-headers    . nnshimbun-yomiuri-get-all-headers)
 102      (index-url      . (concat nnshimbun-url "main.htm"))
 103      (from-address   . "webmaster@www.yomiuri.co.jp")
 104      (make-contents  . nnshimbun-make-text-or-html-contents)
 105      (contents-start . "\n<!--  honbun start  -->\n")
 106      (contents-end   . "\n<!--  honbun end  -->\n"))
 107     ("zdnet"
 108      (url . "http://zdseek.pub.softbank.co.jp/news/")
 109      (groups "comp")
 110      (coding-system  . ,(if (boundp 'MULE) '*sjis* 'shift_jis))
 111      (generate-nov   . nnshimbun-generate-nov-for-each-group)
 112      (get-headers    . nnshimbun-zdnet-get-headers)
 113      (index-url      . nnshimbun-url)
 114      (from-address   . "zdnn@softbank.co.jp")
 115      (make-contents  . nnshimbun-make-html-contents)
 116      (contents-start . "<!--BODY-->")
 117      (contents-end   . "<!--BODYEND-->"))
 118     ))
 119
 120 (defvoo nnshimbun-directory (nnheader-concat gnus-directory "shimbun/")
 121   "Where nnshimbun will save its files.")
 122
 123 (defvoo nnshimbun-nov-is-evil nil
 124   "*Non-nil means that nnshimbun will never retrieve NOV headers.")
 125
 126 (defvoo nnshimbun-nov-file-name ".overview")
 127
 128 (defvoo nnshimbun-pre-fetch-article nil
 129   "*Non nil means that nnshimbun fetch unread articles when scanning groups.")
 130
 131 ;; set by nnshimbun-possibly-change-server
 132 (defvoo nnshimbun-buffer nil)
 133 (defvoo nnshimbun-current-directory nil)
 134 (defvoo nnshimbun-current-group nil)
 135
 136 ;; set by nnshimbun-open-server
 137 (defvoo nnshimbun-url nil)
 138 (defvoo nnshimbun-coding-system nil)
 139 (defvoo nnshimbun-groups nil)
 140 (defvoo nnshimbun-generate-nov nil)
 141 (defvoo nnshimbun-get-headers nil)
 142 (defvoo nnshimbun-index-url nil)
 143 (defvoo nnshimbun-from-address nil)
 144 (defvoo nnshimbun-make-contents nil)
 145 (defvoo nnshimbun-contents-start nil)
 146 (defvoo nnshimbun-contents-end nil)
 147 (defvoo nnshimbun-server-directory nil)
 148
 149 (defvoo nnshimbun-status-string "")
 150 (defvoo nnshimbun-nov-last-check nil)
 151 (defvoo nnshimbun-nov-buffer-alist nil)
 152 (defvoo nnshimbun-nov-buffer-file-name nil)
 153
 154 (defvoo nnshimbun-keep-backlog 300)
 155 (defvoo nnshimbun-backlog-articles nil)
 156 (defvoo nnshimbun-backlog-hashtb nil)
 157
 158
 159
 160 ;;; backlog
 161 (defmacro nnshimbun-backlog (&rest form)
 162   `(let ((gnus-keep-backlog nnshimbun-keep-backlog)
 163          (gnus-backlog-buffer (format " *nnshimbun backlog %s*" (nnoo-current-server 'nnshimbun)))
 164          (gnus-backlog-articles nnshimbun-backlog-articles)
 165          (gnus-backlog-hashtb nnshimbun-backlog-hashtb))
 166      (unwind-protect
 167          (progn ,@form)
 168        (setq nnshimbun-backlog-articles gnus-backlog-articles
 169              nnshimbun-backlog-hashtb gnus-backlog-hashtb))))
 170 (put 'nnshimbun-backlog 'lisp-indent-function 0)
 171 (put 'nnshimbun-backlog 'edebug-form-spec '(form body))
 172
 173
 174
 175 ;;; Interface Functions
 176 (nnoo-define-basics nnshimbun)
 177
 178 (deffoo nnshimbun-open-server (server &optional defs)
 179   ;; Set default values.
 180   (dolist (default (cdr (assoc server nnshimbun-type-definition)))
 181     (let ((symbol (intern (concat "nnshimbun-" (symbol-name (car default))))))
 182       (unless (assq symbol defs)
 183         (push (list symbol (cdr default)) defs))))
 184   ;; Set directory for server working files.
 185   (push (list 'nnshimbun-server-directory
 186               (file-name-as-directory
 187                (expand-file-name server nnshimbun-directory)))
 188         defs)
 189   (nnoo-change-server 'nnshimbun server defs)
 190   (nnshimbun-possibly-change-group nil server)
 191   ;; Make directories.
 192   (unless (file-exists-p nnshimbun-directory)
 193     (ignore-errors (make-directory nnshimbun-directory t)))
 194   (cond
 195    ((not (file-exists-p nnshimbun-directory))
 196     (nnshimbun-close-server)
 197     (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-directory))
 198    ((not (file-directory-p (file-truename nnshimbun-directory)))
 199     (nnshimbun-close-server)
 200     (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-directory))
 201    (t
 202     (unless (file-exists-p nnshimbun-server-directory)
 203       (ignore-errors (make-directory nnshimbun-server-directory t)))
 204     (cond
 205      ((not (file-exists-p nnshimbun-server-directory))
 206       (nnshimbun-close-server)
 207       (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-server-directory))
 208      ((not (file-directory-p (file-truename nnshimbun-server-directory)))
 209       (nnshimbun-close-server)
 210       (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-server-directory))
 211      (t
 212       (nnheader-report 'nnshimbun "Opened server %s using directory %s"
 213                        server nnshimbun-server-directory)
 214       t)))))
 215
 216 (deffoo nnshimbun-close-server (&optional server)
 217   (and (nnshimbun-server-opened server)
 218        (gnus-buffer-live-p nnshimbun-buffer)
 219        (kill-buffer nnshimbun-buffer))
 220   (nnshimbun-backlog (gnus-backlog-shutdown))
 221   (nnshimbun-save-nov)
 222   (nnoo-close-server 'nnshimbun server)
 223   t)
 224
 225 (defun nnshimbun-retrieve-url (url &optional no-cache)
 226   "Rertrieve URL contents and insert to current buffer."
 227   (let ((coding-system-for-read 'binary)
 228         (coding-system-for-write 'binary))
 229     ;; XXX: Ad hok.
 230     (when (or no-cache
 231               (not (file-exists-p
 232                     (url-cache-create-filename url))))
 233       (set-buffer-multibyte nil))
 234     ;; Following code is imported from `url-insert-file-contents'.
 235     (save-excursion
 236       (let ((old-asynch (default-value 'url-be-asynchronous))
 237             (old-caching (default-value 'url-automatic-caching))
 238             (old-mode (default-value 'url-standalone-mode)))
 239         (unwind-protect
 240             (progn
 241               (setq-default url-be-asynchronous nil)
 242               (when no-cache
 243                 (setq-default url-automatic-caching nil)
 244                 (setq-default url-standalone-mode nil))
 245               (let ((buf (current-buffer))
 246                     (url-working-buffer (cdr (url-retrieve url no-cache))))
 247                 (set-buffer url-working-buffer)
 248                 (url-uncompress)
 249                 (set-buffer buf)
 250                 (insert-buffer url-working-buffer)
 251                 (save-excursion
 252                   (set-buffer url-working-buffer)
 253                   (set-buffer-modified-p nil))
 254                 (kill-buffer url-working-buffer)))
 255           (setq-default url-be-asynchronous old-asynch)
 256           (setq-default url-automatic-caching old-caching)
 257           (setq-default url-standalone-mode old-mode))))
 258     ;; Modify buffer coding system.
 259     (decode-coding-region (point-min) (point-max) nnshimbun-coding-system)
 260     (set-buffer-multibyte t)))
 261
 262 (deffoo nnshimbun-request-article (article &optional group server to-buffer)
 263   (when (nnshimbun-possibly-change-group group server)
 264     (if (stringp article)
 265         (setq article (nnshimbun-search-id group article)))
 266     (if (integerp article)
 267         (nnshimbun-request-article-1 article group server to-buffer)
 268       (nnheader-report 'nnml "Couldn't retrieve article: %s" (prin1-to-string article))
 269       nil)))
 270
 271 (defun nnshimbun-request-article-1 (article &optional group server to-buffer)
 272   (if (nnshimbun-backlog
 273         (gnus-backlog-request-article
 274          group article (or to-buffer nntp-server-buffer)))
 275       (cons group article)
 276     (let (header contents)
 277       (when (setq header (save-excursion
 278                            (set-buffer (nnshimbun-open-nov group))
 279                            (and (nnheader-find-nov-line article)
 280                                 (nnheader-parse-nov))))
 281         (let ((xref (substring (mail-header-xref header) 6)))
 282           (save-excursion
 283             (set-buffer nnshimbun-buffer)
 284             (erase-buffer)
 285             (nnshimbun-retrieve-url xref)
 286             (nnheader-message 6 "nnshimbun: Make contents...")
 287             (goto-char (point-min))
 288             (setq contents (funcall nnshimbun-make-contents header))
 289             (nnheader-message 6 "nnshimbun: Make contents...done"))))
 290       (when contents
 291         (save-excursion
 292           (set-buffer (or to-buffer nntp-server-buffer))
 293           (erase-buffer)
 294           (insert contents)
 295           (nnshimbun-backlog
 296             (gnus-backlog-enter-article group article (current-buffer)))
 297           (nnheader-report 'nnshimbun "Article %s retrieved" (mail-header-id header))
 298           (cons group (mail-header-number header)))))))
 299
 300 (deffoo nnshimbun-request-group (group &optional server dont-check)
 301   (let ((pathname-coding-system 'binary))
 302     (cond
 303      ((not (nnshimbun-possibly-change-group group server))
 304       (nnheader-report 'nnshimbun "Invalid group (no such directory)"))
 305      ((not (file-exists-p nnshimbun-current-directory))
 306       (nnheader-report 'nnshimbun "Directory %s does not exist"
 307                        nnshimbun-current-directory))
 308      ((not (file-directory-p nnshimbun-current-directory))
 309       (nnheader-report 'nnshimbun "%s is not a directory" nnshimbun-current-directory))
 310      (dont-check
 311       (nnheader-report 'nnshimbun "Group %s selected" group)
 312       t)
 313      (t
 314       (let (beg end lines)
 315         (save-excursion
 316           (set-buffer (nnshimbun-open-nov group))
 317           (goto-char (point-min))
 318           (setq beg (ignore-errors (read (current-buffer))))
 319           (goto-char (point-max))
 320           (forward-line -1)
 321           (setq end (ignore-errors (read (current-buffer)))
 322                 lines (count-lines (point-min) (point-max))))
 323         (nnheader-report 'nnshimbunw "Selected group %s" group)
 324         (nnheader-insert "211 %d %d %d %s\n"
 325                          lines (or beg 0) (or end 0) group))))))
 326
 327 (deffoo nnshimbun-request-scan (&optional group server)
 328   (nnshimbun-possibly-change-group group server)
 329   (nnshimbun-generate-nov-database group))
 330
 331 (deffoo nnshimbun-close-group (group &optional server)
 332   t)
 333
 334 (deffoo nnshimbun-request-list (&optional server)
 335   (save-excursion
 336     (set-buffer nntp-server-buffer)
 337     (erase-buffer)
 338     (dolist (group nnshimbun-groups)
 339       (when (nnshimbun-possibly-change-group group server)
 340         (let (beg end)
 341           (save-excursion
 342             (set-buffer (nnshimbun-open-nov group))
 343             (goto-char (point-min))
 344             (setq beg (ignore-errors (read (current-buffer))))
 345             (goto-char (point-max))
 346             (forward-line -1)
 347             (setq end (ignore-errors (read (current-buffer)))))
 348           (insert (format "%s %d %d n\n" group (or end 0) (or beg 0)))))))
 349   t) ; return value
 350
 351 (eval-and-compile
 352   (if (fboundp 'mime-entity-fetch-field)
 353       ;; For Semi-Gnus.
 354       (defun nnshimbun-insert-header (header)
 355         (insert "Subject: " (or (mime-entity-fetch-field header 'Subject) "(none)") "\n"
 356                 "From: " (or (mime-entity-fetch-field header 'From) "(nobody)") "\n"
 357                 "Date: " (or (mail-header-date header) "") "\n"
 358                 "Message-ID: " (or (mail-header-id header) (nnmail-message-id)) "\n"
 359                 "References: " (or (mail-header-references header) "") "\n"
 360                 "Lines: ")
 361         (princ (or (mail-header-lines header) 0) (current-buffer))
 362         (insert "\n")
 363         (if (mail-header-xref header)
 364             (insert (mail-header-xref header) "\n")))
 365     ;; For pure Gnus.
 366     (defun nnshimbun-insert-header (header)
 367       (nnheader-insert-header header)
 368       (delete-char -1)
 369       (if (mail-header-xref header)
 370           (insert (mail-header-xref header) "\n")))))
 371
 372 (deffoo nnshimbun-retrieve-headers (articles &optional group server fetch-old)
 373   (when (nnshimbun-possibly-change-group group server)
 374     (if (nnshimbun-retrieve-headers-with-nov articles fetch-old)
 375         'nov
 376       (save-excursion
 377         (set-buffer nntp-server-buffer)
 378         (erase-buffer)
 379         (let (header)
 380           (dolist (art articles)
 381             (if (stringp art)
 382                 (setq art (nnshimbun-search-id group art)))
 383             (if (integerp art)
 384                 (when (setq header
 385                             (save-excursion
 386                               (set-buffer (nnshimbun-open-nov group))
 387                               (and (nnheader-find-nov-line art)
 388                                    (nnheader-parse-nov))))
 389                   (insert (format "220 %d Article retrieved.\n" art))
 390                   (nnshimbun-insert-header header)
 391                   (insert ".\n")
 392                   (delete-region (point) (point-max))))))
 393         'header))))
 394
 395 (defun nnshimbun-retrieve-headers-with-nov (articles &optional fetch-old)
 396   (if (or gnus-nov-is-evil nnshimbun-nov-is-evil)
 397       nil
 398     (let ((nov (expand-file-name nnshimbun-nov-file-name nnshimbun-current-directory)))
 399       (when (file-exists-p nov)
 400         (save-excursion
 401           (set-buffer nntp-server-buffer)
 402           (erase-buffer)
 403           (nnheader-insert-file-contents nov)
 404           (if (and fetch-old (not (numberp fetch-old)))
 405               t                         ; Don't remove anything.
 406             (nnheader-nov-delete-outside-range
 407              (if fetch-old (max 1 (- (car articles) fetch-old))
 408                (car articles))
 409              (car (last articles)))
 410             t))))))
 411
 412
 413
 414 ;;; Nov Database Operations
 415
 416 (defun nnshimbun-generate-nov-database (group)
 417   (prog1 (funcall nnshimbun-generate-nov group)
 418     (save-excursion
 419       (set-buffer (nnshimbun-open-nov group))
 420       (when (buffer-modified-p)
 421         (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 422                              nil 'nomesg)))))
 423
 424 (defun nnshimbun-generate-nov-for-each-group (group)
 425   (nnshimbun-possibly-change-group group)
 426   (save-excursion
 427     (set-buffer (nnshimbun-open-nov group))
 428     (let (i)
 429       (goto-char (point-max))
 430       (forward-line -1)
 431       (setq i (or (ignore-errors (read (current-buffer))) 0))
 432       (goto-char (point-max))
 433       (dolist (header (save-excursion
 434                         (set-buffer nnshimbun-buffer)
 435                         (erase-buffer)
 436                         (nnshimbun-retrieve-url (eval nnshimbun-index-url) t)
 437                         (goto-char (point-min))
 438                         (funcall nnshimbun-get-headers)))
 439         (unless (nnshimbun-search-id group (mail-header-id header))
 440           (mail-header-set-number header (setq i (1+ i)))
 441           (nnheader-insert-nov header)
 442           (if nnshimbun-pre-fetch-article
 443               (nnshimbun-request-article-1 i group nil nnshimbun-buffer)))))))
 444
 445 (defun nnshimbun-generate-nov-for-all-groups (&rest args)
 446   (unless (and nnshimbun-nov-last-check
 447                (< (nnshimbun-lapse-seconds nnshimbun-nov-last-check)
 448                   nnshimbun-check-interval))
 449     (save-excursion
 450       (dolist (list (funcall nnshimbun-get-headers))
 451         (let ((group (car list)))
 452           (nnshimbun-possibly-change-group group)
 453           (when (cdr list)
 454             (set-buffer (nnshimbun-open-nov group))
 455             (let (i)
 456               (goto-char (point-max))
 457               (forward-line -1)
 458               (setq i (or (ignore-errors (read (current-buffer))) 0))
 459               (goto-char (point-max))
 460               (dolist (header (cdr list))
 461                 (unless (nnshimbun-search-id group (mail-header-id header))
 462                   (mail-header-set-number header (setq i (1+ i)))
 463                   (nnheader-insert-nov header)
 464                   (if nnshimbun-pre-fetch-article
 465                       (nnshimbun-request-article-1 i group nil nnshimbun-buffer))))))))
 466       (nnshimbun-save-nov)
 467       (setq nnshimbun-nov-last-check (current-time)))))
 468
 469 (defun nnshimbun-search-id (group id)
 470   (save-excursion
 471     (set-buffer (nnshimbun-open-nov group))
 472     (goto-char (point-min))
 473     (let (number found)
 474       (while (and (not found)
 475                   (search-forward id nil t)) ; We find the ID.
 476         ;; And the id is in the fourth field.
 477         (if (not (and (search-backward "\t" nil t 4)
 478                       (not (search-backward "\t" (gnus-point-at-bol) t))))
 479             (forward-line 1)
 480           (beginning-of-line)
 481           (setq found t)
 482           ;; We return the article number.
 483           (setq number (ignore-errors (read (current-buffer))))))
 484       number)))
 485
 486 (defun nnshimbun-open-nov (group)
 487   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 488     (if (buffer-live-p buffer)
 489         buffer
 490       (setq buffer (gnus-get-buffer-create
 491                     (format " *nnshimbun overview %s %s*"
 492                             (nnoo-current-server 'nnshimbun) group)))
 493       (save-excursion
 494         (set-buffer buffer)
 495         (set (make-local-variable 'nnshimbun-nov-buffer-file-name)
 496              (expand-file-name
 497               nnshimbun-nov-file-name
 498               (nnmail-group-pathname group nnshimbun-server-directory)))
 499         (erase-buffer)
 500         (when (file-exists-p nnshimbun-nov-buffer-file-name)
 501           (nnheader-insert-file-contents nnshimbun-nov-buffer-file-name))
 502         (set-buffer-modified-p nil))
 503       (push (cons group buffer) nnshimbun-nov-buffer-alist)
 504       buffer)))
 505
 506 (defun nnshimbun-save-nov ()
 507   (save-excursion
 508     (while nnshimbun-nov-buffer-alist
 509       (when (buffer-name (cdar nnshimbun-nov-buffer-alist))
 510         (set-buffer (cdar nnshimbun-nov-buffer-alist))
 511         (when (buffer-modified-p)
 512           (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 513                                nil 'nomesg))
 514         (set-buffer-modified-p nil)
 515         (kill-buffer (current-buffer)))
 516       (setq nnshimbun-nov-buffer-alist (cdr nnshimbun-nov-buffer-alist)))))
 517
 518
 519
 520 ;;; Server Initialize
 521 (defun nnshimbun-possibly-change-group (group &optional server)
 522   (when server
 523     (unless (nnshimbun-server-opened server)
 524       (nnshimbun-open-server server)))
 525   (unless (gnus-buffer-live-p nnshimbun-buffer)
 526     (setq nnshimbun-buffer
 527           (save-excursion
 528             (nnheader-set-temp-buffer
 529              (format " *nnshimbun %s*" (nnoo-current-server 'nnshimbun))))))
 530   (if (not group)
 531       t
 532     (let ((pathname (nnmail-group-pathname group nnshimbun-server-directory))
 533           (pathname-coding-system 'binary))
 534       (unless (equal pathname nnshimbun-current-directory)
 535         (setq nnshimbun-current-directory pathname
 536               nnshimbun-current-group group))
 537       (unless (file-exists-p nnshimbun-current-directory)
 538         (ignore-errors (make-directory nnshimbun-current-directory t)))
 539       (cond
 540        ((not (file-exists-p nnshimbun-current-directory))
 541         (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-current-directory))
 542        ((not (file-directory-p (file-truename nnshimbun-current-directory)))
 543         (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-current-directory))
 544        (t t)))))
 545
 546
 547
 548 ;;; Misc Functions
 549
 550 (eval-and-compile
 551   (if (fboundp 'eword-encode-string)
 552       ;; For Semi-Gnus.
 553       (defun nnshimbun-mime-encode-string (string)
 554         (if (zerop (length string))
 555             ""
 556           (mapconcat
 557            #'identity
 558            (split-string (eword-encode-string (nnweb-decode-entities-string string)) "\n")
 559            "")))
 560     ;; For pure Gnus.
 561     (defun nnshimbun-mime-encode-string (string)
 562       (mapconcat
 563        #'identity
 564        (split-string
 565         (with-temp-buffer
 566           (insert (nnweb-decode-entities-string string))
 567           (rfc2047-encode-region (point-min) (point-max))
 568           (buffer-substring (point-min) (point-max)))
 569         "\n")
 570        ""))))
 571
 572 (defun nnshimbun-lapse-seconds (time)
 573   (let ((now (current-time)))
 574     (+ (* (- (car now) (car time)) 65536)
 575        (- (nth 1 now) (nth 1 time)))))
 576
 577 (defun nnshimbun-make-date-string (year month day &optional time)
 578   (format "%02d %s %04d %s +0900"
 579           day
 580           (aref [nil "Jan" "Feb" "Mar" "Apr" "May" "Jun"
 581                      "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"]
 582                 month)
 583           year
 584           (or time "00:00")))
 585
 586 (if (fboundp 'regexp-opt)
 587     (defalias 'nnshimbun-regexp-opt 'regexp-opt)
 588   (defun nnshimbun-regexp-opt (strings &optional paren)
 589     "Return a regexp to match a string in STRINGS.
 590 Each string should be unique in STRINGS and should not contain any regexps,
 591 quoted or not.  If optional PAREN is non-nil, ensure that the returned regexp
 592 is enclosed by at least one regexp grouping construct."
 593     (let ((open-paren (if paren "\\(" "")) (close-paren (if paren "\\)" "")))
 594       (concat open-paren (mapconcat 'regexp-quote strings "\\|") close-paren))))
 595
 596
 597 ;; Fast fill-region function
 598
 599 (defvar nnshimbun-fill-column (min 80 (- (frame-width) 4)))
 600
 601 (defconst nnshimbun-kinsoku-bol-list
 602   (funcall
 603    (if (fboundp 'string-to-char-list)
 604        'string-to-char-list
 605      'string-to-list) "\
 606 !)-_~}]:;',.?\e$B!"!#!$!%!&!'!(!)!*!+!,!-!.!/!0!1!2!3!4!5!6!7!8!9!:!;!<!=!>!?!@!A\e(B\
 607 \e$B!B!C!D!E!G!I!K!M!O!Q!S!U!W!Y![!k!l!m!n$!$#$%$'$)$C$c$e$g$n%!%#%%%'%)%C%c%e%g%n%u%v\e(B"))
 608
 609 (defconst nnshimbun-kinsoku-eol-list
 610   (funcall
 611    (if (fboundp 'string-to-char-list)
 612        'string-to-char-list
 613      'string-to-list)
 614    "({[`\e$B!F!H!J!L!N!P!R!T!V!X!Z!k!l!m!x\e(B"))
 615
 616 (defun nnshimbun-fill-line ()
 617   (forward-line 0)
 618   (let ((top (point)) chr)
 619     (while (if (>= (move-to-column nnshimbun-fill-column)
 620                    nnshimbun-fill-column)
 621                (not (progn
 622                       (if (memq (preceding-char) nnshimbun-kinsoku-eol-list)
 623                           (progn
 624                             (backward-char)
 625                             (while (memq (preceding-char) nnshimbun-kinsoku-eol-list)
 626                               (backward-char))
 627                             (insert "\n"))
 628                         (while (memq (setq chr (following-char)) nnshimbun-kinsoku-bol-list)
 629                           (forward-char))
 630                         (if (looking-at "\\s-+")
 631                             (or (eolp) (delete-region (point) (match-end 0)))
 632                           (or (> (char-width chr) 1)
 633                               (re-search-backward "\\<" top t)
 634                               (end-of-line)))
 635                         (or (eolp) (insert "\n"))))))
 636       (setq top (point))))
 637   (forward-line 1)
 638   (not (eobp)))
 639
 640 (defsubst nnshimbun-shallow-rendering ()
 641   (goto-char (point-min))
 642   (while (search-forward "<p>" nil t)
 643     (insert "\n\n"))
 644   (goto-char (point-min))
 645   (while (search-forward "<br>" nil t)
 646     (insert "\n"))
 647   (nnweb-remove-markup)
 648   (nnweb-decode-entities)
 649   (goto-char (point-min))
 650   (while (nnshimbun-fill-line))
 651   (goto-char (point-min))
 652   (when (skip-chars-forward "\n")
 653     (delete-region (point-min) (point)))
 654   (while (search-forward "\n\n" nil t)
 655     (let ((p (point)))
 656       (when (skip-chars-forward "\n")
 657         (delete-region p (point)))))
 658   (goto-char (point-max))
 659   (when (skip-chars-backward "\n")
 660     (delete-region (point) (point-max)))
 661   (insert "\n"))
 662
 663 (defun nnshimbun-make-text-or-html-contents (header)
 664   (let ((case-fold-search t) (html t) (start))
 665     (when (and (search-forward nnshimbun-contents-start nil t)
 666                (setq start (point))
 667                (search-forward nnshimbun-contents-end nil t))
 668       (delete-region (point-min) start)
 669       (delete-region (- (point) (length nnshimbun-contents-end)) (point-max))
 670       (nnshimbun-shallow-rendering)
 671       (setq html nil))
 672     (goto-char (point-min))
 673     (nnshimbun-insert-header header)
 674     (insert "Content-Type: " (if html "text/html" "text/plain")
 675             "; charset=ISO-2022-JP\nMIME-Version: 1.0\n\n")
 676     (encode-coding-string (buffer-string)
 677                           (mime-charset-to-coding-system "ISO-2022-JP"))))
 678
 679 (defun nnshimbun-make-html-contents (header)
 680   (let (start)
 681     (when (and (search-forward nnshimbun-contents-start nil t)
 682                (setq start (point))
 683                (search-forward nnshimbun-contents-end nil t))
 684       (delete-region (point-min) start)
 685       (delete-region (- (point) (length nnshimbun-contents-end)) (point-max)))
 686     (goto-char (point-min))
 687     (nnshimbun-insert-header header)
 688     (insert "Content-Type: text/html; charset=ISO-2022-JP\nMIME-Version: 1.0\n\n")
 689     (encode-coding-string (buffer-string)
 690                           (mime-charset-to-coding-system "ISO-2022-JP"))))
 691
 692
 693
 694 ;;; www.asahi.com
 695
 696 (defun nnshimbun-asahi-get-headers ()
 697   (when (search-forward "\n<!-- Start of past -->\n" nil t)
 698     (delete-region (point-min) (point))
 699     (when (search-forward "\n<!-- End of past -->\n" nil t)
 700       (forward-line -1)
 701       (delete-region (point) (point-max))
 702       (goto-char (point-min))
 703       (let (headers)
 704         (while (re-search-forward
 705                 "^\e$B"#\e(B<a href=\"\\(\\([0-9][0-9][0-9][0-9]\\)/past/\\([A-z]*[0-9]*\\)\\.html\\)\"> *"
 706                 nil t)
 707           (let ((id (format "<%s%s%%%s>"
 708                             (match-string 2)
 709                             (match-string 3)
 710                             nnshimbun-current-group))
 711                 (url (match-string 1)))
 712             (push (make-full-mail-header
 713                    0
 714                    (nnshimbun-mime-encode-string
 715                     (mapconcat 'identity
 716                                (split-string
 717                                 (buffer-substring
 718                                  (match-end 0)
 719                                  (progn (search-forward "<br>" nil t) (point)))
 720                                 "<[^>]+>")
 721                                ""))
 722                    nnshimbun-from-address
 723                    "" id "" 0 0 (concat nnshimbun-url url))
 724                   headers)))
 725         (setq headers (nreverse headers))
 726         (let ((i 0))
 727           (while (and (nth i headers)
 728                       (re-search-forward
 729                        "^\\[\\([0-9][0-9]\\)/\\([0-9][0-9]\\) \\([0-9][0-9]:[0-9][0-9]\\)\\]"
 730                        nil t))
 731             (let ((month (string-to-number (match-string 1)))
 732                   (date (decode-time (current-time))))
 733               (mail-header-set-date
 734                (nth i headers)
 735                (nnshimbun-make-date-string
 736                 (if (and (eq 12 month) (eq 1 (nth 4 date)))
 737                     (1- (nth 5 date))
 738                   (nth 5 date))
 739                 month
 740                 (string-to-number (match-string 2))
 741                 (match-string 3))))
 742             (setq i (1+ i))))
 743         (nreverse headers)))))
 744
 745
 746
 747 ;;; www.sponichi.co.jp
 748
 749 (defun nnshimbun-sponichi-get-headers ()
 750   (when (search-forward "\e$B%K%e!<%9%$%s%G%C%/%9\e(B" nil t)
 751     (delete-region (point-min) (point))
 752     (when (search-forward "\e$B%"%I%?%0\e(B" nil t)
 753       (forward-line 2)
 754       (delete-region (point) (point-max))
 755       (goto-char (point-min))
 756       (let ((case-fold-search t) headers)
 757         (while (re-search-forward
 758                 "^<a href=\"/\\(\\([A-z]*\\)/kiji/\\([0-9][0-9][0-9][0-9]\\)/\\([0-9][0-9]\\)/\\([0-9][0-9]\\)/\\([0-9][0-9]\\)\\.html\\)\">"
 759                 nil t)
 760           (let ((url (match-string 1))
 761                 (id (format "<%s%s%s%s%%%s>"
 762                             (match-string 3)
 763                             (match-string 4)
 764                             (match-string 5)
 765                             (match-string 6)
 766                             nnshimbun-current-group))
 767                 (date (nnshimbun-make-date-string
 768                        (string-to-number (match-string 3))
 769                        (string-to-number (match-string 4))
 770                        (string-to-number (match-string 5)))))
 771             (push (make-full-mail-header
 772                    0
 773                    (nnshimbun-mime-encode-string
 774                     (mapconcat 'identity
 775                                (split-string
 776                                 (buffer-substring
 777                                  (match-end 0)
 778                                  (progn (search-forward "<br>" nil t) (point)))
 779                                 "<[^>]+>")
 780                                ""))
 781                    nnshimbun-from-address
 782                    date id "" 0 0 (concat nnshimbun-url url))
 783                   headers)))
 784         headers))))
 785
 786
 787
 788 ;;; CNET Japan
 789
 790 (defun nnshimbun-cnet-get-headers ()
 791   (let ((case-fold-search t) headers)
 792     (while (search-forward "\n<!--*****\e$B8+=P$7\e(B*****-->\n" nil t)
 793       (let ((subject (buffer-substring (point) (gnus-point-at-eol)))
 794             (point (point)))
 795         (forward-line -2)
 796         (when (looking-at "<a href=\"/\\(News/\\([0-9][0-9][0-9][0-9]\\)/Item/\\([0-9][0-9]\\([0-9][0-9]\\)\\([0-9][0-9]\\)-[0-9]+\\).html\\)\">")
 797           (let ((url (match-string 1))
 798                 (id  (format "<%s%s%%%s>"
 799                              (match-string 2)
 800                              (match-string 3)
 801                              nnshimbun-current-group))
 802                 (date (nnshimbun-make-date-string
 803                        (string-to-number (match-string 2))
 804                        (string-to-number (match-string 4))
 805                        (string-to-number (match-string 5)))))
 806             (push (make-full-mail-header
 807                    0
 808                    (nnshimbun-mime-encode-string subject)
 809                    nnshimbun-from-address
 810                    date id "" 0 0 (concat nnshimbun-url url))
 811                   headers)))
 812         (goto-char point)))
 813     headers))
 814
 815
 816
 817 ;;; Wired
 818
 819 (defun nnshimbun-wired-get-all-headers ()
 820   (save-excursion
 821     (set-buffer nnshimbun-buffer)
 822     (let ((group-header-alist (mapcar (lambda (g) (cons g nil)) nnshimbun-groups))
 823           (case-fold-search t)
 824           (regexp (format
 825                    "<a href=\"\\(%s\\|/\\)\\(news/news/\\(%s\\)/story/\\(\\([0-9][0-9][0-9][0-9]\\)\\([0-9][0-9]\\)\\([0-9][0-9]\\)[0-9]+\\)\\.html\\)\"><b>"
 826                    (regexp-quote nnshimbun-url)
 827                    (nnshimbun-regexp-opt nnshimbun-groups))))
 828       (dolist (xover (list (concat nnshimbun-url "news/news/index.html")
 829                            (concat nnshimbun-url "news/news/last_seven.html")))
 830         (erase-buffer)
 831         (nnshimbun-retrieve-url xover t)
 832         (goto-char (point-min))
 833         (while (re-search-forward regexp nil t)
 834           (let* ((url   (concat nnshimbun-url (match-string 2)))
 835                  (group (downcase (match-string 3)))
 836                  (id    (format "<%s%%%s>" (match-string 4) group))
 837                  (date  (nnshimbun-make-date-string
 838                          (string-to-number (match-string 5))
 839                          (string-to-number (match-string 6))
 840                          (string-to-number (match-string 7))))
 841                  (header (make-full-mail-header
 842                           0
 843                           (nnshimbun-mime-encode-string
 844                            (mapconcat 'identity
 845                                       (split-string
 846                                        (buffer-substring
 847                                         (match-end 0)
 848                                         (progn (search-forward "</b>" nil t) (point)))
 849                                        "<[^>]+>")
 850                                       ""))
 851                           nnshimbun-from-address
 852                           date id "" 0 0 url))
 853                  (x (assoc group group-header-alist)))
 854             (setcdr x (cons header (cdr x))))))
 855       group-header-alist)))
 856
 857
 858
 859 ;;; www.yomiuri.co.jp
 860
 861 (defun nnshimbun-yomiuri-get-all-headers ()
 862   (save-excursion
 863     (set-buffer nnshimbun-buffer)
 864     (erase-buffer)
 865     (nnshimbun-retrieve-url (eval nnshimbun-index-url) t)
 866     (let ((case-fold-search t)
 867           (group-header-alist (mapcar (lambda (g) (cons g nil)) nnshimbun-groups)))
 868       (dolist (group nnshimbun-groups)
 869         (let (start)
 870           (goto-char (point-min))
 871           (when (and (search-forward (format "\n<!-- /news/%s=start -->\n" group) nil t)
 872                      (setq start (point))
 873                      (search-forward (format "\n<!-- /news/%s=end -->\n" group) nil t))
 874             (forward-line -1)
 875             (save-restriction
 876               (narrow-to-region start (point))
 877               (goto-char start)
 878               (while (re-search-forward
 879                       "<a href=\"/\\([0-9]+\\)/\\(\\(\\([0-9][0-9][0-9][0-9]\\)\\([0-9][0-9]\\)\\([0-9][0-9]\\)[A-z0-9]+\\)\\.htm\\)\"[^>]*>"
 880                       nil t)
 881                 (let ((url   (concat (match-string 1) "a/" (match-string 2)))
 882                       (id    (format "<%s%s%%%s>"
 883                                      (match-string 1)
 884                                      (match-string 3)
 885                                      group))
 886                       (year  (string-to-number (match-string 4)))
 887                       (month (string-to-number (match-string 5)))
 888                       (day   (string-to-number (match-string 6)))
 889                       (subject (mapconcat
 890                                 'identity
 891                                 (split-string
 892                                  (buffer-substring
 893                                   (match-end 0)
 894                                   (progn (search-forward "<br>" nil t) (point)))
 895                                  "<[^>]+>")
 896                                 ""))
 897                       date x)
 898                   (when (string-match "^\e$B"!\e(B" subject)
 899                     (setq subject (substring subject (match-end 0))))
 900                   (if (string-match "(\\([0-9][0-9]:[0-9][0-9]\\))$" subject)
 901                       (setq date (nnshimbun-make-date-string
 902                                   year month day (match-string 1 subject))
 903                             subject (substring subject 0 (match-beginning 0)))
 904                     (setq date (nnshimbun-make-date-string year month day)))
 905                   (setcdr (setq x (assoc group group-header-alist))
 906                           (cons (make-full-mail-header
 907                                  0
 908                                  (nnshimbun-mime-encode-string subject)
 909                                  nnshimbun-from-address
 910                                  date id "" 0 0 (concat nnshimbun-url url))
 911                                 (cdr x)))))))))
 912       group-header-alist)))
 913
 914
 915
 916 ;;; Zdnet Japan
 917
 918 (defun nnshimbun-zdnet-get-headers ()
 919   (let ((case-fold-search t) headers)
 920     (goto-char (point-min))
 921     (let (start)
 922       (while (and (search-forward "<!--" nil t)
 923                   (setq start (- (point) 4))
 924                   (search-forward "-->" nil t))
 925         (delete-region start (point))))
 926     (goto-char (point-min))
 927     (while (re-search-forward
 928             "<a href=\"\\(\\([0-9][0-9]\\)\\([0-9][0-9]\\)/\\([0-9][0-9]\\)/\\([^\\.]+\\).html\\)\"><font size=\"4\"><strong>"
 929             nil t)
 930       (let ((year  (+ 2000 (string-to-number (match-string 2))))
 931             (month (string-to-number (match-string 3)))
 932             (day   (string-to-number (match-string 4)))
 933             (id    (format "<%s%s%s%s%%%s>"
 934                            (match-string 2)
 935                            (match-string 3)
 936                            (match-string 4)
 937                            (match-string 5)
 938                            nnshimbun-current-group))
 939             (url (match-string 1)))
 940         (push (make-full-mail-header
 941                0
 942                (nnshimbun-mime-encode-string
 943                 (mapconcat 'identity
 944                            (split-string
 945                             (buffer-substring
 946                              (match-end 0)
 947                              (progn (search-forward "</a>" nil t) (point)))
 948                             "<[^>]+>")
 949                            ""))
 950                nnshimbun-from-address
 951                (nnshimbun-make-date-string year month day)
 952                id  "" 0 0 (concat nnshimbun-url url))
 953               headers)))
 954     (nreverse headers)))
 955
 956
 957
 958 (provide 'nnshimbun)
 959 ;;; nnshimbun.el ends here.