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