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@pine.kuee.kyoto-u.ac.jp>
   4 ;;          Akihiro Arisawa    <ari@atesoft.advantest.co.jp>
   5 ;; Keywords: news
   6
   7 ;;; Copyright:
   8
   9 ;; This file is a part of Semi-Gnus.
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program; if not, you can either send email to this
  23 ;; program's maintainer or write to: The Free Software Foundation,
  24 ;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; Gnus backend to read newspapers on WEB.
  29
  30
  31 ;;; Defintinos:
  32
  33 (gnus-declare-backend "nnshimbun" 'address)
  34
  35 (eval-when-compile (require 'cl))
  36
  37 (require 'nnheader)
  38 (require 'nnmail)
  39 (require 'nnoo)
  40 (require 'gnus-bcklg)
  41 (eval-when-compile
  42   (ignore-errors
  43     (require 'nnweb)))
  44 ;; Report failure to find w3 at load time if appropriate.
  45 (eval '(require 'nnweb))
  46
  47
  48 (nnoo-declare nnshimbun)
  49
  50 (defvar nnshimbun-check-interval 300)
  51
  52 (defconst nnshimbun-mew-groups
  53   '(("meadow-develop" "meadow-develop" nil t)
  54     ("meadow-users-jp" "meadow-users-jp")
  55     ("mule-win32" "mule-win32")
  56     ("mew-win32" "mew-win32")
  57     ("mew-dist" "mew-dist/3300" t)
  58     ("mgp-users-jp" "mgp-users-jp/A" t t)))
  59
  60 (defvar nnshimbun-type-definition
  61   `(("asahi"
  62      (url . "http://spin.asahi.com/")
  63      (groups "national" "business" "politics" "international" "sports" "personal" "feneral")
  64      (coding-system  . ,(if (boundp 'MULE) '*sjis* 'shift_jis))
  65      (generate-nov   . nnshimbun-generate-nov-for-each-group)
  66      (get-headers    . nnshimbun-asahi-get-headers)
  67      (index-url      . (format "%sp%s.html" nnshimbun-url nnshimbun-current-group))
  68      (from-address   . "webmaster@www.asahi.com")
  69      (make-contents  . nnshimbun-make-text-or-html-contents)
  70      (contents-start . "\n<!-- Start of kiji -->\n")
  71      (contents-end   . "\n<!-- End of kiji -->\n"))
  72     ("sponichi"
  73      (url . "http://www.sponichi.co.jp/")
  74      (groups "baseball" "soccer" "usa" "others" "society" "entertainment" "horseracing")
  75      (coding-system  . ,(if (boundp 'MULE) '*sjis* 'shift_jis))
  76      (generate-nov   . nnshimbun-generate-nov-for-each-group)
  77      (get-headers    . nnshimbun-sponichi-get-headers)
  78      (index-url      . (format "%s%s/index.html" nnshimbun-url nnshimbun-current-group))
  79      (from-address   . "webmaster@www.sponichi.co.jp")
  80      (make-contents  . nnshimbun-make-text-or-html-contents)
  81      (contents-start . "\n<span class=\"text\">\e$B!!\e(B")
  82      (contents-end   . "\n"))
  83     ("cnet"
  84      (url . "http://cnet.sphere.ne.jp/")
  85      (groups "comp")
  86      (coding-system  . ,(if (boundp 'MULE) '*sjis* 'shift_jis))
  87      (generate-nov   . nnshimbun-generate-nov-for-each-group)
  88      (get-headers    . nnshimbun-cnet-get-headers)
  89      (index-url      . (format "%s/News/Oneweek/" nnshimbun-url))
  90      (from-address   . "cnet@sphere.ad.jp")
  91      (make-contents  . nnshimbun-make-html-contents)
  92      (contents-start . "\n<!--KIJI-->\n")
  93      (contents-end   . "\n<!--/KIJI-->\n"))
  94     ("wired"
  95      (url . "http://www.hotwired.co.jp/")
  96      (groups "business" "culture" "technology")
  97      (coding-system  . ,(if (boundp 'MULE) '*euc-japan* 'euc-jp))
  98      (generate-nov   . nnshimbun-generate-nov-for-all-groups)
  99      (get-headers    . nnshimbun-wired-get-all-headers)
 100      (index-url)
 101      (from-address   . "webmaster@www.hotwired.co.jp")
 102      (make-contents  . nnshimbun-make-html-contents)
 103      (contents-start . "\n<!-- START_OF_BODY -->\n")
 104      (contents-end   . "\n<!-- END_OF_BODY -->\n"))
 105     ("yomiuri"
 106      (url . "http://www.yomiuri.co.jp/")
 107      (groups "shakai" "sports" "seiji" "keizai" "kokusai" "fuho")
 108      (coding-system  . ,(if (boundp 'MULE) '*sjis* 'shift_jis))
 109      (generate-nov   . nnshimbun-generate-nov-for-all-groups)
 110      (get-headers    . nnshimbun-yomiuri-get-all-headers)
 111      (index-url      . (concat nnshimbun-url "main.htm"))
 112      (from-address   . "webmaster@www.yomiuri.co.jp")
 113      (make-contents  . nnshimbun-make-text-or-html-contents)
 114      (contents-start . "\n<!--  honbun start  -->\n")
 115      (contents-end   . "\n<!--  honbun end  -->\n"))
 116     ("zdnet"
 117      (url . "http://zdseek.pub.softbank.co.jp/news/")
 118      (groups "comp")
 119      (coding-system  . ,(if (boundp 'MULE) '*sjis* 'shift_jis))
 120      (generate-nov   . nnshimbun-generate-nov-for-each-group)
 121      (get-headers    . nnshimbun-zdnet-get-headers)
 122      (index-url      . nnshimbun-url)
 123      (from-address   . "zdnn@softbank.co.jp")
 124      (make-contents  . nnshimbun-make-html-contents)
 125      (contents-start . "\\(<!--BODY-->\\|[0-9]+\e$BG/\e(B[0-9]+\e$B7n\e(B[0-9]+\e$BF|\e(B[^<]*</font></td>[ \t\r\f\n]*</tr>[ \t\r\f\n]*</table>[ \t\r\f\n]*\\(</p>\\)?\\)")
 126      (contents-end   . "\\(<!--BODYEND-->\\|<div align=\"right\">\\|<\\(b\\|strong\\)>\\[</\\2>[^<]*<\\2>ZDNet/\\(JAPAN\\|USA\\)\\]\\(<[^>]+>\\)?</\\2>\\)"))
 127     ("mew"
 128      (url . "http://www.mew.org/archive/")
 129      (groups ,@(mapcar #'car nnshimbun-mew-groups))
 130      (coding-system . ,(if (boundp 'MULE) '*iso-2022-jp* 'iso-2022-jp))
 131      (generate-nov  . nnshimbun-generate-nov-for-each-group)
 132      (get-headers   . nnshimbun-mew-get-headers)
 133      (index-url     . (nnshimbun-mew-concat-url "index.html"))
 134      (make-contents . nnshimbun-make-mhonarc-contents))
 135     ("xemacs"
 136      (url . "http://www.xemacs.org/list-archives/")
 137      (groups "xemacs-announce" "xemacs-beta-ja" "xemacs-beta"
 138              "xemacs-build-reports" "xemacs-cvs" "xemacs-mule"
 139              "xemacs-nt" "xemacs-patches" "xemacs-users-ja" "xemacs")
 140      (coding-system . ,(if (boundp 'MULE) '*euc-japan* 'euc-jp))
 141      (generate-nov  . nnshimbun-generate-nov-for-each-group)
 142      (get-headers   . nnshimbun-xemacs-get-headers)
 143      (index-url     . (nnshimbun-xemacs-concat-url nil))
 144      (make-contents . nnshimbun-make-mhonarc-contents))
 145     ))
 146
 147 (defvar nnshimbun-x-face-alist
 148   '(("default" .
 149      (("default" .
 150        "X-Face: Ygq$6P.,%Xt$U)DS)cRY@k$VkW!7(X'X'?U{{osjjFG\"E]hND;SPJ-J?O?R|a?L
 151         g2$0rVng=O3Lt}?~IId8Jj&vP^3*o=LKUyk(`t%0c!;t6REk=JbpsEn9MrN7gZ%"))))
 152   "Alist of server vs. alist of group vs. X-Face field.  It looks like:
 153
 154 \((\"asahi\" . ((\"national\" . \"X-face: ***\")
 155              (\"business\" . \"X-Face: ***\")
 156                 ;;
 157                 ;;
 158              (\"default\" . \"X-face: ***\")))
 159  (\"sponichi\" . ((\"baseball\" . \"X-face: ***\")
 160                 (\"soccer\" . \"X-Face: ***\")
 161                 ;;
 162                 ;;
 163                 (\"default\" . \"X-face: ***\")))
 164                 ;;
 165  (\"default\" . ((\"default\" . \"X-face: ***\")))")
 166
 167 (defvoo nnshimbun-directory (nnheader-concat gnus-directory "shimbun/")
 168   "Where nnshimbun will save its files.")
 169
 170 (defvoo nnshimbun-nov-is-evil nil
 171   "*Non-nil means that nnshimbun will never retrieve NOV headers.")
 172
 173 (defvoo nnshimbun-nov-file-name ".overview")
 174
 175 (defvoo nnshimbun-pre-fetch-article nil
 176   "*Non nil means that nnshimbun fetch unread articles when scanning groups.")
 177
 178 ;; set by nnshimbun-possibly-change-group
 179 (defvoo nnshimbun-buffer nil)
 180 (defvoo nnshimbun-current-directory nil)
 181 (defvoo nnshimbun-current-group nil)
 182
 183 ;; set by nnshimbun-open-server
 184 (defvoo nnshimbun-url nil)
 185 (defvoo nnshimbun-coding-system nil)
 186 (defvoo nnshimbun-groups nil)
 187 (defvoo nnshimbun-generate-nov nil)
 188 (defvoo nnshimbun-get-headers nil)
 189 (defvoo nnshimbun-index-url nil)
 190 (defvoo nnshimbun-from-address nil)
 191 (defvoo nnshimbun-make-contents nil)
 192 (defvoo nnshimbun-contents-start nil)
 193 (defvoo nnshimbun-contents-end nil)
 194 (defvoo nnshimbun-server-directory nil)
 195
 196 (defvoo nnshimbun-status-string "")
 197 (defvoo nnshimbun-nov-last-check nil)
 198 (defvoo nnshimbun-nov-buffer-alist nil)
 199 (defvoo nnshimbun-nov-buffer-file-name nil)
 200
 201 (defvoo nnshimbun-keep-backlog 300)
 202 (defvoo nnshimbun-backlog-articles nil)
 203 (defvoo nnshimbun-backlog-hashtb nil)
 204
 205
 206
 207 ;;; backlog
 208 (defmacro nnshimbun-backlog (&rest form)
 209   `(let ((gnus-keep-backlog nnshimbun-keep-backlog)
 210          (gnus-backlog-buffer (format " *nnshimbun backlog %s*" (nnoo-current-server 'nnshimbun)))
 211          (gnus-backlog-articles nnshimbun-backlog-articles)
 212          (gnus-backlog-hashtb nnshimbun-backlog-hashtb))
 213      (unwind-protect
 214          (progn ,@form)
 215        (setq nnshimbun-backlog-articles gnus-backlog-articles
 216              nnshimbun-backlog-hashtb gnus-backlog-hashtb))))
 217 (put 'nnshimbun-backlog 'lisp-indent-function 0)
 218 (put 'nnshimbun-backlog 'edebug-form-spec '(form body))
 219
 220
 221
 222 ;;; Interface Functions
 223 (nnoo-define-basics nnshimbun)
 224
 225 (deffoo nnshimbun-open-server (server &optional defs)
 226   ;; Set default values.
 227   (dolist (default (cdr (assoc server nnshimbun-type-definition)))
 228     (let ((symbol (intern (concat "nnshimbun-" (symbol-name (car default))))))
 229       (unless (assq symbol defs)
 230         (push (list symbol (cdr default)) defs))))
 231   ;; Set directory for server working files.
 232   (push (list 'nnshimbun-server-directory
 233               (file-name-as-directory
 234                (expand-file-name server nnshimbun-directory)))
 235         defs)
 236   (nnoo-change-server 'nnshimbun server defs)
 237   (nnshimbun-possibly-change-group nil server)
 238   ;; Make directories.
 239   (unless (file-exists-p nnshimbun-directory)
 240     (ignore-errors (make-directory nnshimbun-directory t)))
 241   (cond
 242    ((not (file-exists-p nnshimbun-directory))
 243     (nnshimbun-close-server)
 244     (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-directory))
 245    ((not (file-directory-p (file-truename nnshimbun-directory)))
 246     (nnshimbun-close-server)
 247     (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-directory))
 248    (t
 249     (unless (file-exists-p nnshimbun-server-directory)
 250       (ignore-errors (make-directory nnshimbun-server-directory t)))
 251     (cond
 252      ((not (file-exists-p nnshimbun-server-directory))
 253       (nnshimbun-close-server)
 254       (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-server-directory))
 255      ((not (file-directory-p (file-truename nnshimbun-server-directory)))
 256       (nnshimbun-close-server)
 257       (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-server-directory))
 258      (t
 259       (nnheader-report 'nnshimbun "Opened server %s using directory %s"
 260                        server nnshimbun-server-directory)
 261       t)))))
 262
 263 (deffoo nnshimbun-close-server (&optional server)
 264   (and (nnshimbun-server-opened server)
 265        (gnus-buffer-live-p nnshimbun-buffer)
 266        (kill-buffer nnshimbun-buffer))
 267   (nnshimbun-backlog (gnus-backlog-shutdown))
 268   (nnshimbun-save-nov)
 269   (nnoo-close-server 'nnshimbun server)
 270   t)
 271
 272 (defun nnshimbun-retrieve-url (url &optional no-cache)
 273   "Rertrieve URL contents and insert to current buffer."
 274   (let ((coding-system-for-read 'binary)
 275         (coding-system-for-write 'binary))
 276     (set-buffer-multibyte nil)
 277     ;; Following code is imported from `url-insert-file-contents'.
 278     (save-excursion
 279       (let ((old-asynch (default-value 'url-be-asynchronous))
 280             (old-caching (default-value 'url-automatic-caching))
 281             (old-mode (default-value 'url-standalone-mode)))
 282         (unwind-protect
 283             (progn
 284               (setq-default url-be-asynchronous nil)
 285               (when no-cache
 286                 (setq-default url-automatic-caching nil)
 287                 (setq-default url-standalone-mode nil))
 288               (let ((buf (current-buffer))
 289                     (url-working-buffer (cdr (url-retrieve url no-cache))))
 290                 (set-buffer url-working-buffer)
 291                 (url-uncompress)
 292                 (set-buffer buf)
 293                 (insert-buffer url-working-buffer)
 294                 (save-excursion
 295                   (set-buffer url-working-buffer)
 296                   (set-buffer-modified-p nil))
 297                 (kill-buffer url-working-buffer)))
 298           (setq-default url-be-asynchronous old-asynch)
 299           (setq-default url-automatic-caching old-caching)
 300           (setq-default url-standalone-mode old-mode))))
 301     ;; Modify buffer coding system.
 302     (decode-coding-region (point-min) (point-max) nnshimbun-coding-system)
 303     (set-buffer-multibyte t)))
 304
 305 (deffoo nnshimbun-request-article (article &optional group server to-buffer)
 306   (when (nnshimbun-possibly-change-group group server)
 307     (if (stringp article)
 308         (setq article (nnshimbun-search-id group article)))
 309     (if (integerp article)
 310         (nnshimbun-request-article-1 article group server to-buffer)
 311       (nnheader-report 'nnml "Couldn't retrieve article: %s" (prin1-to-string article))
 312       nil)))
 313
 314 (defun nnshimbun-request-article-1 (article &optional group server to-buffer)
 315   (if (nnshimbun-backlog
 316         (gnus-backlog-request-article
 317          group article (or to-buffer nntp-server-buffer)))
 318       (cons group article)
 319     (let (header contents)
 320       (when (setq header (save-excursion
 321                            (set-buffer (nnshimbun-open-nov group))
 322                            (and (nnheader-find-nov-line article)
 323                                 (nnheader-parse-nov))))
 324         (let* ((xref (substring (mail-header-xref header) 6))
 325                (x-faces (cdr (or (assoc (or server
 326                                             (nnoo-current-server 'nnshimbun))
 327                                         nnshimbun-x-face-alist)
 328                                  (assoc "default" nnshimbun-x-face-alist))))
 329                (x-face (cdr (or (assoc group x-faces)
 330                                 (assoc "default" x-faces)))))
 331           (save-excursion
 332             (set-buffer nnshimbun-buffer)
 333             (erase-buffer)
 334             (nnshimbun-retrieve-url xref)
 335             (nnheader-message 6 "nnshimbun: Make contents...")
 336             (goto-char (point-min))
 337             (setq contents (funcall nnshimbun-make-contents header x-face))
 338             (nnheader-message 6 "nnshimbun: Make contents...done"))))
 339       (when contents
 340         (save-excursion
 341           (set-buffer (or to-buffer nntp-server-buffer))
 342           (erase-buffer)
 343           (insert contents)
 344           (nnshimbun-backlog
 345             (gnus-backlog-enter-article group article (current-buffer)))
 346           (nnheader-report 'nnshimbun "Article %s retrieved" (mail-header-id header))
 347           (cons group (mail-header-number header)))))))
 348
 349 (deffoo nnshimbun-request-group (group &optional server dont-check)
 350   (let ((pathname-coding-system 'binary))
 351     (cond
 352      ((not (nnshimbun-possibly-change-group group server))
 353       (nnheader-report 'nnshimbun "Invalid group (no such directory)"))
 354      ((not (file-exists-p nnshimbun-current-directory))
 355       (nnheader-report 'nnshimbun "Directory %s does not exist"
 356                        nnshimbun-current-directory))
 357      ((not (file-directory-p nnshimbun-current-directory))
 358       (nnheader-report 'nnshimbun "%s is not a directory" nnshimbun-current-directory))
 359      (dont-check
 360       (nnheader-report 'nnshimbun "Group %s selected" group)
 361       t)
 362      (t
 363       (let (beg end lines)
 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                 lines (count-lines (point-min) (point-max))))
 372         (nnheader-report 'nnshimbunw "Selected group %s" group)
 373         (nnheader-insert "211 %d %d %d %s\n"
 374                          lines (or beg 0) (or end 0) group))))))
 375
 376 (deffoo nnshimbun-request-scan (&optional group server)
 377   (nnshimbun-possibly-change-group group server)
 378   (nnshimbun-generate-nov-database group))
 379
 380 (deffoo nnshimbun-close-group (group &optional server)
 381   (nnshimbun-write-nov group)
 382   t)
 383
 384 (deffoo nnshimbun-request-list (&optional server)
 385   (save-excursion
 386     (set-buffer nntp-server-buffer)
 387     (erase-buffer)
 388     (dolist (group nnshimbun-groups)
 389       (when (nnshimbun-possibly-change-group group server)
 390         (let (beg end)
 391           (save-excursion
 392             (set-buffer (nnshimbun-open-nov group))
 393             (goto-char (point-min))
 394             (setq beg (ignore-errors (read (current-buffer))))
 395             (goto-char (point-max))
 396             (forward-line -1)
 397             (setq end (ignore-errors (read (current-buffer)))))
 398           (insert (format "%s %d %d n\n" group (or end 0) (or beg 0)))))))
 399   t) ; return value
 400
 401 (eval-and-compile
 402   (if (fboundp 'mime-entity-fetch-field)
 403       ;; For Semi-Gnus.
 404       (defun nnshimbun-insert-header (header)
 405         (insert "Subject: " (or (mime-entity-fetch-field header 'Subject) "(none)") "\n"
 406                 "From: " (or (mime-entity-fetch-field header 'From) "(nobody)") "\n"
 407                 "Date: " (or (mail-header-date header) "") "\n"
 408                 "Message-ID: " (or (mail-header-id header) (nnmail-message-id)) "\n"
 409                 "References: " (or (mail-header-references header) "") "\n"
 410                 "Lines: ")
 411         (princ (or (mail-header-lines header) 0) (current-buffer))
 412         (insert "\n")
 413         (if (mail-header-xref header)
 414             (insert (mail-header-xref header) "\n")))
 415     ;; For pure Gnus.
 416     (defun nnshimbun-insert-header (header)
 417       (nnheader-insert-header header)
 418       (delete-char -1)
 419       (if (mail-header-xref header)
 420           (insert (mail-header-xref header) "\n")))))
 421
 422 (deffoo nnshimbun-retrieve-headers (articles &optional group server fetch-old)
 423   (when (nnshimbun-possibly-change-group group server)
 424     (if (nnshimbun-retrieve-headers-with-nov articles fetch-old)
 425         'nov
 426       (save-excursion
 427         (set-buffer nntp-server-buffer)
 428         (erase-buffer)
 429         (let (header)
 430           (dolist (art articles)
 431             (if (stringp art)
 432                 (setq art (nnshimbun-search-id group art)))
 433             (if (integerp art)
 434                 (when (setq header
 435                             (save-excursion
 436                               (set-buffer (nnshimbun-open-nov group))
 437                               (and (nnheader-find-nov-line art)
 438                                    (nnheader-parse-nov))))
 439                   (insert (format "220 %d Article retrieved.\n" art))
 440                   (nnshimbun-insert-header header)
 441                   (insert ".\n")
 442                   (delete-region (point) (point-max))))))
 443         'header))))
 444
 445 (defun nnshimbun-retrieve-headers-with-nov (articles &optional fetch-old)
 446   (if (or gnus-nov-is-evil nnshimbun-nov-is-evil)
 447       nil
 448     (let ((nov (expand-file-name nnshimbun-nov-file-name nnshimbun-current-directory)))
 449       (when (file-exists-p nov)
 450         (save-excursion
 451           (set-buffer nntp-server-buffer)
 452           (erase-buffer)
 453           (nnheader-insert-file-contents nov)
 454           (if (and fetch-old (not (numberp fetch-old)))
 455               t                         ; Don't remove anything.
 456             (nnheader-nov-delete-outside-range
 457              (if fetch-old (max 1 (- (car articles) fetch-old))
 458                (car articles))
 459              (car (last articles)))
 460             t))))))
 461
 462
 463
 464 ;;; Nov Database Operations
 465
 466 (defun nnshimbun-generate-nov-database (group)
 467   (prog1 (funcall nnshimbun-generate-nov group)
 468     (nnshimbun-write-nov group)))
 469
 470 (defun nnshimbun-generate-nov-for-each-group (group)
 471   (nnshimbun-possibly-change-group group)
 472   (save-excursion
 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 (save-excursion
 479                         (set-buffer nnshimbun-buffer)
 480                         (erase-buffer)
 481                         (nnshimbun-retrieve-url (eval nnshimbun-index-url) t)
 482                         (goto-char (point-min))
 483                         (funcall nnshimbun-get-headers)))
 484         (unless (nnshimbun-search-id group (mail-header-id header))
 485           (mail-header-set-number header (setq i (1+ i)))
 486           (goto-char (point-max))
 487           (nnheader-insert-nov header)
 488           (if nnshimbun-pre-fetch-article
 489               (nnshimbun-request-article-1 i group nil nnshimbun-buffer)))))))
 490
 491 (defun nnshimbun-generate-nov-for-all-groups (&rest args)
 492   (unless (and nnshimbun-nov-last-check
 493                (< (nnshimbun-lapse-seconds nnshimbun-nov-last-check)
 494                   nnshimbun-check-interval))
 495     (save-excursion
 496       (dolist (list (funcall nnshimbun-get-headers))
 497         (let ((group (car list)))
 498           (nnshimbun-possibly-change-group group)
 499           (when (cdr list)
 500             (set-buffer (nnshimbun-open-nov group))
 501             (let (i)
 502               (goto-char (point-max))
 503               (forward-line -1)
 504               (setq i (or (ignore-errors (read (current-buffer))) 0))
 505               (dolist (header (cdr list))
 506                 (unless (nnshimbun-search-id group (mail-header-id header))
 507                   (mail-header-set-number header (setq i (1+ i)))
 508                   (goto-char (point-max))
 509                   (nnheader-insert-nov header)
 510                   (if nnshimbun-pre-fetch-article
 511                       (nnshimbun-request-article-1 i group nil nnshimbun-buffer))))))))
 512       (nnshimbun-save-nov)
 513       (setq nnshimbun-nov-last-check (current-time)))))
 514
 515 (defun nnshimbun-search-id (group id &optional nov)
 516   (save-excursion
 517     (set-buffer (nnshimbun-open-nov group))
 518     (goto-char (point-min))
 519     (let (found)
 520       (while (and (not found)
 521                   (search-forward id nil t)) ; We find the ID.
 522         ;; And the id is in the fourth field.
 523         (if (not (and (search-backward "\t" nil t 4)
 524                       (not (search-backward "\t" (gnus-point-at-bol) t))))
 525             (forward-line 1)
 526           (forward-line 0)
 527           (setq found t)))
 528       (unless found
 529         (goto-char (point-min))
 530         (when (search-forward (concat "X-Nnshimbun-Original-Id: " id) nil t)
 531           (forward-line 0)
 532           (setq found t)))
 533       (if found
 534           (if nov
 535               (nnheader-parse-nov)
 536             ;; We return the article number.
 537             (ignore-errors (read (current-buffer))))))))
 538
 539 (defun nnshimbun-nov-fix-header (group header args)
 540   (save-excursion
 541     (set-buffer (nnshimbun-open-nov group))
 542     (when (nnheader-find-nov-line (mail-header-number header))
 543       (dolist (arg args)
 544         (if (eq (car arg) 'id)
 545             (let ((extra (mail-header-extra header)) x)
 546               (when (setq x (assq 'X-Nnshimbun-Original-Id extra))
 547                 (setq extra (delq x extra)))
 548               (mail-header-set-extra
 549                header
 550                (cons (cons 'X-Nnshimbun-Original-Id (cdr arg)) extra)))
 551           (let ((func (intern (concat "mail-header-set-" (symbol-name (car arg))))))
 552             (if (cdr arg) (eval (list func header (cdr arg)))))))
 553       (let ((xref (mail-header-xref header)))
 554         (when (string-match "^Xref: " xref)
 555           (mail-header-set-xref header (substring xref 6))))
 556       (delete-region (point) (progn (forward-line 1) (point)))
 557       (nnheader-insert-nov header))))
 558
 559 (defun nnshimbun-open-nov (group)
 560   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 561     (if (buffer-live-p buffer)
 562         buffer
 563       (setq buffer (gnus-get-buffer-create
 564                     (format " *nnshimbun overview %s %s*"
 565                             (nnoo-current-server 'nnshimbun) group)))
 566       (save-excursion
 567         (set-buffer buffer)
 568         (set (make-local-variable 'nnshimbun-nov-buffer-file-name)
 569              (expand-file-name
 570               nnshimbun-nov-file-name
 571               (nnmail-group-pathname group nnshimbun-server-directory)))
 572         (erase-buffer)
 573         (when (file-exists-p nnshimbun-nov-buffer-file-name)
 574           (nnheader-insert-file-contents nnshimbun-nov-buffer-file-name))
 575         (set-buffer-modified-p nil))
 576       (push (cons group buffer) nnshimbun-nov-buffer-alist)
 577       buffer)))
 578
 579 (defun nnshimbun-write-nov (group)
 580   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 581     (when (buffer-live-p buffer)
 582       (save-excursion
 583         (set-buffer buffer)
 584         (buffer-modified-p)
 585         (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 586                              nil 'nomesg)))))
 587
 588 (defun nnshimbun-save-nov ()
 589   (save-excursion
 590     (while nnshimbun-nov-buffer-alist
 591       (when (buffer-name (cdar nnshimbun-nov-buffer-alist))
 592         (set-buffer (cdar nnshimbun-nov-buffer-alist))
 593         (when (buffer-modified-p)
 594           (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 595                                nil 'nomesg))
 596         (set-buffer-modified-p nil)
 597         (kill-buffer (current-buffer)))
 598       (setq nnshimbun-nov-buffer-alist (cdr nnshimbun-nov-buffer-alist)))))
 599
 600
 601
 602 ;;; Server Initialize
 603 (defun nnshimbun-possibly-change-group (group &optional server)
 604   (when server
 605     (unless (nnshimbun-server-opened server)
 606       (nnshimbun-open-server server)))
 607   (unless (gnus-buffer-live-p nnshimbun-buffer)
 608     (setq nnshimbun-buffer
 609           (save-excursion
 610             (nnheader-set-temp-buffer
 611              (format " *nnshimbun %s*" (nnoo-current-server 'nnshimbun))))))
 612   (if (not group)
 613       t
 614     (let ((pathname (nnmail-group-pathname group nnshimbun-server-directory))
 615           (pathname-coding-system 'binary))
 616       (unless (equal pathname nnshimbun-current-directory)
 617         (setq nnshimbun-current-directory pathname
 618               nnshimbun-current-group group))
 619       (unless (file-exists-p nnshimbun-current-directory)
 620         (ignore-errors (make-directory nnshimbun-current-directory t)))
 621       (cond
 622        ((not (file-exists-p nnshimbun-current-directory))
 623         (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-current-directory))
 624        ((not (file-directory-p (file-truename nnshimbun-current-directory)))
 625         (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-current-directory))
 626        (t t)))))
 627
 628
 629
 630 ;;; Misc Functions
 631
 632 (eval-and-compile
 633   (if (fboundp 'eword-encode-string)
 634       ;; For Semi-Gnus.
 635       (defun nnshimbun-mime-encode-string (string)
 636         (mapconcat
 637          #'identity
 638          (split-string (eword-encode-string (nnweb-decode-entities-string string)) "\n")
 639          ""))
 640     ;; For pure Gnus.
 641     (defun nnshimbun-mime-encode-string (string)
 642       (mapconcat
 643        #'identity
 644        (split-string
 645         (with-temp-buffer
 646           (insert (nnweb-decode-entities-string string))
 647           (rfc2047-encode-region (point-min) (point-max))
 648           (buffer-substring (point-min) (point-max)))
 649         "\n")
 650        ""))))
 651
 652 (defun nnshimbun-lapse-seconds (time)
 653   (let ((now (current-time)))
 654     (+ (* (- (car now) (car time)) 65536)
 655        (- (nth 1 now) (nth 1 time)))))
 656
 657 (defun nnshimbun-make-date-string (year month day &optional time)
 658   (format "%02d %s %04d %s +0900"
 659           day
 660           (aref [nil "Jan" "Feb" "Mar" "Apr" "May" "Jun"
 661                      "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"]
 662                 month)
 663           (cond ((< year 69)
 664                  (+ year 2000))
 665                 ((< year 100)
 666                  (+ year 1900))
 667                 ((< year 1000)  ; possible 3-digit years.
 668                  (+ year 1900))
 669                 (t year))
 670           (or time "00:00")))
 671
 672 (if (fboundp 'regexp-opt)
 673     (defalias 'nnshimbun-regexp-opt 'regexp-opt)
 674   (defun nnshimbun-regexp-opt (strings &optional paren)
 675     "Return a regexp to match a string in STRINGS.
 676 Each string should be unique in STRINGS and should not contain any regexps,
 677 quoted or not.  If optional PAREN is non-nil, ensure that the returned regexp
 678 is enclosed by at least one regexp grouping construct."
 679     (let ((open-paren (if paren "\\(" "")) (close-paren (if paren "\\)" "")))
 680       (concat open-paren (mapconcat 'regexp-quote strings "\\|") close-paren))))
 681
 682
 683 ;; Fast fill-region function
 684
 685 (defvar nnshimbun-fill-column (min 80 (- (frame-width) 4)))
 686
 687 (defconst nnshimbun-kinsoku-bol-list
 688   (funcall
 689    (if (fboundp 'string-to-char-list)
 690        'string-to-char-list
 691      'string-to-list) "\
 692 !)-_~}]:;',.?\e$B!"!#!$!%!&!'!(!)!*!+!,!-!.!/!0!1!2!3!4!5!6!7!8!9!:!;!<!=!>!?!@!A\e(B\
 693 \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"))
 694
 695 (defconst nnshimbun-kinsoku-eol-list
 696   (funcall
 697    (if (fboundp 'string-to-char-list)
 698        'string-to-char-list
 699      'string-to-list)
 700    "({[`\e$B!F!H!J!L!N!P!R!T!V!X!Z!k!l!m!x\e(B"))
 701
 702 (defun nnshimbun-fill-line ()
 703   (forward-line 0)
 704   (let ((top (point)) chr)
 705     (while (if (>= (move-to-column nnshimbun-fill-column)
 706                    nnshimbun-fill-column)
 707                (not (progn
 708                       (if (memq (preceding-char) nnshimbun-kinsoku-eol-list)
 709                           (progn
 710                             (backward-char)
 711                             (while (memq (preceding-char) nnshimbun-kinsoku-eol-list)
 712                               (backward-char))
 713                             (insert "\n"))
 714                         (while (memq (setq chr (following-char)) nnshimbun-kinsoku-bol-list)
 715                           (forward-char))
 716                         (if (looking-at "\\s-+")
 717                             (or (eolp) (delete-region (point) (match-end 0)))
 718                           (or (> (char-width chr) 1)
 719                               (re-search-backward "\\<" top t)
 720                               (end-of-line)))
 721                         (or (eolp) (insert "\n"))))))
 722       (setq top (point))))
 723   (forward-line 1)
 724   (not (eobp)))
 725
 726 (defsubst nnshimbun-shallow-rendering ()
 727   (goto-char (point-min))
 728   (while (search-forward "<p>" nil t)
 729     (insert "\n\n"))
 730   (goto-char (point-min))
 731   (while (search-forward "<br>" nil t)
 732     (insert "\n"))
 733   (nnweb-remove-markup)
 734   (nnweb-decode-entities)
 735   (goto-char (point-min))
 736   (while (nnshimbun-fill-line))
 737   (goto-char (point-min))
 738   (when (skip-chars-forward "\n")
 739     (delete-region (point-min) (point)))
 740   (while (search-forward "\n\n" nil t)
 741     (let ((p (point)))
 742       (when (skip-chars-forward "\n")
 743         (delete-region p (point)))))
 744   (goto-char (point-max))
 745   (when (skip-chars-backward "\n")
 746     (delete-region (point) (point-max)))
 747   (insert "\n"))
 748
 749 (defun nnshimbun-make-text-or-html-contents (header &optional x-face)
 750   (let ((case-fold-search t) (html t) (start))
 751     (when (and (re-search-forward nnshimbun-contents-start nil t)
 752                (setq start (point))
 753                (re-search-forward nnshimbun-contents-end nil t))
 754       (delete-region (match-beginning 0) (point-max))
 755       (delete-region (point-min) start)
 756       (nnshimbun-shallow-rendering)
 757       (setq html nil))
 758     (goto-char (point-min))
 759     (nnshimbun-insert-header header)
 760     (insert "Content-Type: " (if html "text/html" "text/plain")
 761             "; charset=ISO-2022-JP\nMIME-Version: 1.0\n")
 762     (when x-face
 763       (insert x-face)
 764       (unless (bolp)
 765         (insert "\n")))
 766     (insert "\n")
 767     (encode-coding-string (buffer-string)
 768                           (mime-charset-to-coding-system "ISO-2022-JP"))))
 769
 770 (defun nnshimbun-make-html-contents (header &optional x-face)
 771   (let (start)
 772     (when (and (re-search-forward nnshimbun-contents-start nil t)
 773                (setq start (point))
 774                (re-search-forward nnshimbun-contents-end nil t))
 775       (delete-region (match-beginning 0) (point-max))
 776       (delete-region (point-min) start))
 777     (goto-char (point-min))
 778     (nnshimbun-insert-header header)
 779     (insert "Content-Type: text/html; charset=ISO-2022-JP\n"
 780             "MIME-Version: 1.0\n")
 781     (when x-face
 782       (insert x-face)
 783       (unless (bolp)
 784         (insert "\n")))
 785     (insert "\n")
 786     (encode-coding-string (buffer-string)
 787                           (mime-charset-to-coding-system "ISO-2022-JP"))))
 788
 789 (defun nnshimbun-make-mhonarc-contents (header &rest args)
 790   (require 'mml)
 791   (if (search-forward "<!--X-Head-End-->" nil t)
 792       (progn
 793         (forward-line 0)
 794         ;; Processing headers.
 795         (save-restriction
 796           (narrow-to-region (point-min) (point))
 797           (nnweb-decode-entities)
 798           (goto-char (point-min))
 799           (while (search-forward "<!--X-" nil t)
 800             (replace-match ""))
 801           (goto-char (point-min))
 802           (while (search-forward " -->" nil t)
 803             (replace-match ""))
 804           (goto-char (point-min))
 805           (let (refs id)
 806             (while (not (eobp))
 807               (cond
 808                ((looking-at "<!--")
 809                 (delete-region (point) (progn (forward-line 1) (point))))
 810                ((looking-at "Message-Id: ")
 811                 (setq id (concat "<" (nnheader-header-value) ">"))
 812                 (forward-line 1))
 813                ((looking-at "Reference: ")
 814                 (push (concat "<" (nnheader-header-value) ">") refs)
 815                 (delete-region (point) (progn (forward-line 1) (point))))
 816                ((looking-at "Content-Type: ")
 817                 (unless (search-forward "charset" (gnus-point-at-eol) t)
 818                   (end-of-line)
 819                   (insert "; charset=ISO-2022-JP"))
 820                 (forward-line 1))
 821                (t (forward-line 1))))
 822             (let (buf)
 823               (dolist (ref refs)
 824                 (and
 825                  (setq ref (nnshimbun-search-id nnshimbun-current-group ref 'nov))
 826                  (push (mail-header-id ref) buf)))
 827               (setq refs buf))
 828             (insert "References: "
 829                     (setq refs (mapconcat #'identity refs " "))
 830                     "\nMIME-Version: 1.0\n")
 831             (nnshimbun-nov-fix-header nnshimbun-current-group
 832                                       header
 833                                       `((id . ,id)
 834                                         (references . ,refs))))
 835           (goto-char (point-max)))
 836         ;; Processing body.
 837         (save-restriction
 838           (narrow-to-region (point) (point-max))
 839           (delete-region
 840            (point)
 841            (progn
 842              (search-forward "\n<!--X-Body-of-Message-->\n" nil t)
 843              (point)))
 844           (when (search-forward "\n<!--X-Body-of-Message-End-->\n" nil t)
 845             (forward-line -1)
 846             (delete-region (point) (point-max)))
 847           (nnweb-remove-markup)
 848           (nnweb-decode-entities)))
 849     (goto-char (point-min))
 850     (nnshimbun-insert-header header)
 851     (insert "Content-Type: text/html; charset=ISO-2022-JP\nMIME-Version: 1.0\n\n"))
 852   (encode-coding-string (buffer-string)
 853                         (mime-charset-to-coding-system "ISO-2022-JP")))
 854
 855
 856 ;;; www.asahi.com
 857
 858 (defun nnshimbun-asahi-get-headers ()
 859   (when (search-forward "\n<!-- Start of past -->\n" nil t)
 860     (delete-region (point-min) (point))
 861     (when (search-forward "\n<!-- End of past -->\n" nil t)
 862       (forward-line -1)
 863       (delete-region (point) (point-max))
 864       (goto-char (point-min))
 865       (let (headers)
 866         (while (re-search-forward
 867                 "^\e$B"#\e(B<a href=\"\\(\\([0-9][0-9][0-9][0-9]\\)/past/\\([A-z]*[0-9]*\\)\\.html\\)\"> *"
 868                 nil t)
 869           (let ((id (format "<%s%s%%%s>"
 870                             (match-string 2)
 871                             (match-string 3)
 872                             nnshimbun-current-group))
 873                 (url (match-string 1)))
 874             (push (make-full-mail-header
 875                    0
 876                    (nnshimbun-mime-encode-string
 877                     (mapconcat 'identity
 878                                (split-string
 879                                 (buffer-substring
 880                                  (match-end 0)
 881                                  (progn (search-forward "<br>" nil t) (point)))
 882                                 "\\(<[^>]+>\\|\r\\)")
 883                                ""))
 884                    nnshimbun-from-address
 885                    "" id "" 0 0 (concat nnshimbun-url url))
 886                   headers)))
 887         (setq headers (nreverse headers))
 888         (let ((i 0))
 889           (while (and (nth i headers)
 890                       (re-search-forward
 891                        "^\\[\\([0-9][0-9]\\)/\\([0-9][0-9]\\) \\([0-9][0-9]:[0-9][0-9]\\)\\]"
 892                        nil t))
 893             (let ((month (string-to-number (match-string 1)))
 894                   (date (decode-time (current-time))))
 895               (mail-header-set-date
 896                (nth i headers)
 897                (nnshimbun-make-date-string
 898                 (if (and (eq 12 month) (eq 1 (nth 4 date)))
 899                     (1- (nth 5 date))
 900                   (nth 5 date))
 901                 month
 902                 (string-to-number (match-string 2))
 903                 (match-string 3))))
 904             (setq i (1+ i))))
 905         (nreverse headers)))))
 906
 907
 908
 909 ;;; www.sponichi.co.jp
 910
 911 (defun nnshimbun-sponichi-get-headers ()
 912   (when (search-forward "\e$B%K%e!<%9%$%s%G%C%/%9\e(B" nil t)
 913     (delete-region (point-min) (point))
 914     (when (search-forward "\e$B%"%I%?%0\e(B" nil t)
 915       (forward-line 2)
 916       (delete-region (point) (point-max))
 917       (goto-char (point-min))
 918       (let ((case-fold-search t) headers)
 919         (while (re-search-forward
 920                 "^<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\\)\">"
 921                 nil t)
 922           (let ((url (match-string 1))
 923                 (id (format "<%s%s%s%s%%%s>"
 924                             (match-string 3)
 925                             (match-string 4)
 926                             (match-string 5)
 927                             (match-string 6)
 928                             nnshimbun-current-group))
 929                 (date (nnshimbun-make-date-string
 930                        (string-to-number (match-string 3))
 931                        (string-to-number (match-string 4))
 932                        (string-to-number (match-string 5)))))
 933             (push (make-full-mail-header
 934                    0
 935                    (nnshimbun-mime-encode-string
 936                     (mapconcat 'identity
 937                                (split-string
 938                                 (buffer-substring
 939                                  (match-end 0)
 940                                  (progn (search-forward "<br>" nil t) (point)))
 941                                 "<[^>]+>")
 942                                ""))
 943                    nnshimbun-from-address
 944                    date id "" 0 0 (concat nnshimbun-url url))
 945                   headers)))
 946         headers))))
 947
 948
 949
 950 ;;; CNET Japan
 951
 952 (defun nnshimbun-cnet-get-headers ()
 953   (let ((case-fold-search t) headers)
 954     (while (search-forward "\n<!--*****\e$B8+=P$7\e(B*****-->\n" nil t)
 955       (let ((subject (buffer-substring (point) (gnus-point-at-eol)))
 956             (point (point)))
 957         (forward-line -2)
 958         (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\\)\">")
 959           (let ((url (match-string 1))
 960                 (id  (format "<%s%s%%%s>"
 961                              (match-string 2)
 962                              (match-string 3)
 963                              nnshimbun-current-group))
 964                 (date (nnshimbun-make-date-string
 965                        (string-to-number (match-string 2))
 966                        (string-to-number (match-string 4))
 967                        (string-to-number (match-string 5)))))
 968             (push (make-full-mail-header
 969                    0
 970                    (nnshimbun-mime-encode-string subject)
 971                    nnshimbun-from-address
 972                    date id "" 0 0 (concat nnshimbun-url url))
 973                   headers)))
 974         (goto-char point)))
 975     headers))
 976
 977
 978
 979 ;;; Wired
 980
 981 (defun nnshimbun-wired-get-all-headers ()
 982   (save-excursion
 983     (set-buffer nnshimbun-buffer)
 984     (let ((group-header-alist (mapcar (lambda (g) (cons g nil)) nnshimbun-groups))
 985           (case-fold-search t)
 986           (regexp (format
 987                    "<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>"
 988                    (regexp-quote nnshimbun-url)
 989                    (nnshimbun-regexp-opt nnshimbun-groups))))
 990       (dolist (xover (list (concat nnshimbun-url "news/news/index.html")
 991                            (concat nnshimbun-url "news/news/last_seven.html")))
 992         (erase-buffer)
 993         (nnshimbun-retrieve-url xover t)
 994         (goto-char (point-min))
 995         (while (re-search-forward regexp nil t)
 996           (let* ((url   (concat nnshimbun-url (match-string 2)))
 997                  (group (downcase (match-string 3)))
 998                  (id    (format "<%s%%%s>" (match-string 4) group))
 999                  (date  (nnshimbun-make-date-string
1000                          (string-to-number (match-string 5))
1001                          (string-to-number (match-string 6))
1002                          (string-to-number (match-string 7))))
1003                  (header (make-full-mail-header
1004                           0
1005                           (nnshimbun-mime-encode-string
1006                            (mapconcat 'identity
1007                                       (split-string
1008                                        (buffer-substring
1009                                         (match-end 0)
1010                                         (progn (search-forward "</b>" nil t) (point)))
1011                                        "<[^>]+>")
1012                                       ""))
1013                           nnshimbun-from-address
1014                           date id "" 0 0 url))
1015                  (x (assoc group group-header-alist)))
1016             (setcdr x (cons header (cdr x))))))
1017       group-header-alist)))
1018
1019
1020
1021 ;;; www.yomiuri.co.jp
1022
1023 (defun nnshimbun-yomiuri-get-all-headers ()
1024   (save-excursion
1025     (set-buffer nnshimbun-buffer)
1026     (erase-buffer)
1027     (nnshimbun-retrieve-url (eval nnshimbun-index-url) t)
1028     (let ((case-fold-search t)
1029           (group-header-alist (mapcar (lambda (g) (cons g nil)) nnshimbun-groups)))
1030       (dolist (group nnshimbun-groups)
1031         (let (start)
1032           (goto-char (point-min))
1033           (when (and (search-forward (format "\n<!-- /news/%s=start -->\n" group) nil t)
1034                      (setq start (point))
1035                      (search-forward (format "\n<!-- /news/%s=end -->\n" group) nil t))
1036             (forward-line -1)
1037             (save-restriction
1038               (narrow-to-region start (point))
1039               (goto-char start)
1040               (while (re-search-forward
1041                       "<a href=\"/\\([0-9]+\\)/\\(\\(\\([0-9][0-9][0-9][0-9]\\)\\([0-9][0-9]\\)\\([0-9][0-9]\\)[A-z0-9]+\\)\\.htm\\)\"[^>]*>"
1042                       nil t)
1043                 (let ((url   (concat (match-string 1) "a/" (match-string 2)))
1044                       (id    (format "<%s%s%%%s>"
1045                                      (match-string 1)
1046                                      (match-string 3)
1047                                      group))
1048                       (year  (string-to-number (match-string 4)))
1049                       (month (string-to-number (match-string 5)))
1050                       (day   (string-to-number (match-string 6)))
1051                       (subject (mapconcat
1052                                 'identity
1053                                 (split-string
1054                                  (buffer-substring
1055                                   (match-end 0)
1056                                   (progn (search-forward "<br>" nil t) (point)))
1057                                  "<[^>]+>")
1058                                 ""))
1059                       date x)
1060                   (when (string-match "^\e$B"!\e(B" subject)
1061                     (setq subject (substring subject (match-end 0))))
1062                   (if (string-match "(\\([0-9][0-9]:[0-9][0-9]\\))$" subject)
1063                       (setq date (nnshimbun-make-date-string
1064                                   year month day (match-string 1 subject))
1065                             subject (substring subject 0 (match-beginning 0)))
1066                     (setq date (nnshimbun-make-date-string year month day)))
1067                   (setcdr (setq x (assoc group group-header-alist))
1068                           (cons (make-full-mail-header
1069                                  0
1070                                  (nnshimbun-mime-encode-string subject)
1071                                  nnshimbun-from-address
1072                                  date id "" 0 0 (concat nnshimbun-url url))
1073                                 (cdr x)))))))))
1074       group-header-alist)))
1075
1076
1077
1078 ;;; Zdnet Japan
1079
1080 (defun nnshimbun-zdnet-get-headers ()
1081   (let ((case-fold-search t) headers)
1082     (goto-char (point-min))
1083     (let (start)
1084       (while (and (search-forward "<!--" nil t)
1085                   (setq start (- (point) 4))
1086                   (search-forward "-->" nil t))
1087         (delete-region start (point))))
1088     (goto-char (point-min))
1089     (while (re-search-forward
1090             "<a href=\"\\(\\([0-9][0-9]\\)\\([0-9][0-9]\\)/\\([0-9][0-9]\\)/\\([^\\.]+\\).html\\)\"><font size=\"4\"><strong>"
1091             nil t)
1092       (let ((year  (+ 2000 (string-to-number (match-string 2))))
1093             (month (string-to-number (match-string 3)))
1094             (day   (string-to-number (match-string 4)))
1095             (id    (format "<%s%s%s%s%%%s>"
1096                            (match-string 2)
1097                            (match-string 3)
1098                            (match-string 4)
1099                            (match-string 5)
1100                            nnshimbun-current-group))
1101             (url (match-string 1)))
1102         (push (make-full-mail-header
1103                0
1104                (nnshimbun-mime-encode-string
1105                 (mapconcat 'identity
1106                            (split-string
1107                             (buffer-substring
1108                              (match-end 0)
1109                              (progn (search-forward "</a>" nil t) (point)))
1110                             "<[^>]+>")
1111                            ""))
1112                nnshimbun-from-address
1113                (nnshimbun-make-date-string year month day)
1114                id  "" 0 0 (concat nnshimbun-url url))
1115               headers)))
1116     (nreverse headers)))
1117
1118 ;;; MLs on www.mew.org
1119
1120 (defmacro nnshimbun-mew-concat-url (url)
1121   `(concat nnshimbun-url
1122            (nth 1 (assoc nnshimbun-current-group nnshimbun-mew-groups))
1123            "/"
1124            ,url))
1125
1126 (defmacro nnshimbun-mew-reverse-order-p ()
1127   `(nth 2 (assoc nnshimbun-current-group nnshimbun-mew-groups)))
1128
1129 (defmacro nnshimbun-mew-spew-p ()
1130   `(nth 3 (assoc nnshimbun-current-group nnshimbun-mew-groups)))
1131
1132 (defsubst nnshimbun-mew-retrieve-xover (aux)
1133   (erase-buffer)
1134   (nnshimbun-retrieve-url
1135    (nnshimbun-mew-concat-url (if (= aux 1) "index.html" (format "mail%d.html" aux)))
1136    t))
1137
1138 (defconst nnshimbun-mew-regexp "<A[^>]*HREF=\"\\(msg\\([0-9]+\\).html\\)\">\\([^<]+\\)<")
1139
1140 (defmacro nnshimbun-mew-extract-header-values ()
1141   `(progn
1142      (setq url (nnshimbun-mew-concat-url (match-string 1))
1143            id (format "<%05d%%%s>"
1144                       (1- (string-to-number (match-string 2)))
1145                       nnshimbun-current-group)
1146            subject (match-string 3))
1147      (forward-line 1)
1148      (if (nnshimbun-search-id nnshimbun-current-group id)
1149          (throw 'stop headers)
1150        (push (make-full-mail-header
1151               0
1152               (nnshimbun-mime-encode-string subject)
1153               (if (looking-at "<EM>\\([^<]+\\)<")
1154                   (nnshimbun-mime-encode-string (match-string 1))
1155                 "")
1156               "" id "" 0 0 url)
1157              headers))))
1158
1159 (eval-and-compile
1160   (if (fboundp 'mime-entity-fetch-field)
1161       ;; For Semi-Gnus.
1162       (defmacro nnshimbun-mew-mail-header-subject (header)
1163         `(mime-entity-fetch-field ,header 'Subject))
1164     ;; For pure Gnus.
1165     (defalias 'nnshimbun-mew-mail-header-subject 'mail-header-subject)))
1166
1167 (defun nnshimbun-mew-get-headers ()
1168   (if (nnshimbun-mew-spew-p)
1169       (let ((headers (nnshimbun-mew-get-headers-1)))
1170         (erase-buffer)
1171         (insert-buffer-substring (nnshimbun-open-nov nnshimbun-current-group))
1172         (delq nil
1173               (mapcar
1174                (lambda (header)
1175                  (goto-char (point-min))
1176                  (let ((subject (nnshimbun-mew-mail-header-subject header))
1177                        (found))
1178                    (while (and (not found)
1179                                (search-forward subject nil t))
1180                      (if (not (and (search-backward "\t" nil t)
1181                                    (not (search-backward "\t" (gnus-point-at-bol) t))))
1182                          (forward-line 1)
1183                        (setq found t)))
1184                    (if found
1185                        nil
1186                      (goto-char (point-max))
1187                      (nnheader-insert-nov header)
1188                      header)))
1189                headers)))
1190     (nnshimbun-mew-get-headers-1)))
1191
1192 (defun nnshimbun-mew-get-headers-1 ()
1193   (let (headers)
1194     (when (re-search-forward
1195            "<A[^>]*HREF=\"mail\\([0-9]+\\)\\.html\">\\[?Last Page\\]?</A>" nil t)
1196       (let ((limit (string-to-number (match-string 1))))
1197         (catch 'stop
1198           (if (nnshimbun-mew-reverse-order-p)
1199               (let ((aux 1))
1200                 (while (let (id url subject)
1201                          (while (re-search-forward nnshimbun-mew-regexp nil t)
1202                            (nnshimbun-mew-extract-header-values))
1203                          (< aux limit))
1204                   (nnshimbun-mew-retrieve-xover (setq aux (1+ aux)))))
1205             (while (> limit 0)
1206               (nnshimbun-mew-retrieve-xover limit)
1207               (setq limit (1- limit))
1208               (let (id url subject)
1209                 (goto-char (point-max))
1210                 (while (re-search-backward nnshimbun-mew-regexp nil t)
1211                   (nnshimbun-mew-extract-header-values)
1212                   (forward-line -2)))))
1213           headers)))))
1214
1215 ;;; MLs on www.xemacs.org
1216
1217 (defmacro nnshimbun-xemacs-concat-url (url)
1218   `(concat nnshimbun-url nnshimbun-current-group "/" ,url))
1219
1220 (defun nnshimbun-xemacs-get-headers ()
1221   (let (headers auxs aux)
1222     (catch 'stop
1223       (while (re-search-forward
1224               (concat "<A HREF=\"/list-archives/" nnshimbun-current-group
1225                       "/\\([12][0-9][0-9][0-9][0-1][0-9]\\)/\">\\[Index\\]")
1226               nil t)
1227         (setq auxs (append auxs (list (match-string 1)))))
1228       (while auxs
1229         (erase-buffer)
1230         (nnshimbun-retrieve-url
1231          (nnshimbun-xemacs-concat-url (concat (setq aux (car auxs)) "/")))
1232         (let (id url subject)
1233           (goto-char (point-max))
1234           (while (re-search-backward
1235                   "<A[^>]*HREF=\"\\(msg\\([0-9]+\\).html\\)\">\\([^<]+\\)<"
1236                   nil t)
1237             (setq url (nnshimbun-xemacs-concat-url
1238                        (concat aux "/" (match-string 1)))
1239                   id (format "<%s%05d%%%s>"
1240                              aux
1241                              (string-to-number (match-string 2))
1242                              nnshimbun-current-group)
1243                   subject (match-string 3))
1244             (forward-line 1)
1245             (if (nnshimbun-search-id nnshimbun-current-group id)
1246                 (throw 'stop headers)
1247               (push (make-full-mail-header
1248                      0
1249                      (nnshimbun-mime-encode-string subject)
1250                      (if (looking-at "<td><em>\\([^<]+\\)<")
1251                          (match-string 1)
1252                        "")
1253                      "" id "" 0 0 url)
1254                     headers))
1255             (message "%s" id)
1256             (forward-line -2)))
1257         (setq auxs (cdr auxs))))
1258     headers))
1259
1260
1261 (provide 'nnshimbun)
1262 ;;; nnshimbun.el ends here.