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

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