150 lines
5.9 KiB
EmacsLisp
150 lines
5.9 KiB
EmacsLisp
;;; sb-wired-jp.el --- shimbun backend for Hotwired Japan -*- coding: iso-2022-7bit; -*-
|
||
|
||
;; Copyright (C) 2005, 2006 TSUCHIYA Masatoshi <tsuchiya@namazu.org>
|
||
|
||
;; Author: TSUCHIYA Masatoshi <tsuchiya@namazu.org>
|
||
;; Keywords: news
|
||
|
||
;; This file is a part of shimbun.
|
||
|
||
;; This program is free software; you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation; either version 2, or (at your option)
|
||
;; any later version.
|
||
|
||
;; This program is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this program; see the file COPYING. If not, write to
|
||
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||
;; Boston, MA 02110-1301, USA.
|
||
|
||
;;; Code:
|
||
|
||
(require 'shimbun)
|
||
(require 'sb-rss)
|
||
|
||
(luna-define-class shimbun-wired-jp (shimbun-rss shimbun) ())
|
||
|
||
(defvar shimbun-wired-jp-group-table
|
||
'(("news" "http://hotwired.goo.ne.jp/news/index.rdf" nil
|
||
"<!-- articles -->" "<!-- /articles -->")
|
||
("business" nil "http://hotwired.goo.ne.jp/news/business/"
|
||
"<!-- articles -->" "<!-- /articles -->")
|
||
("culture" nil "http://hotwired.goo.ne.jp/news/culture/"
|
||
"<!-- articles -->" "<!-- /articles -->")
|
||
("technology" nil "http://hotwired.goo.ne.jp/news/technology/"
|
||
"<!-- articles -->" "<!-- /articles -->")
|
||
("blog.takahashi" "http://blog.goo.ne.jp/hwj-takahashi/index.rdf" nil
|
||
"<div class=\"content3\">" "<!-- COMMENT MODULE -->")
|
||
("blog.sasaki" "http://blog.goo.ne.jp/hwj-sasaki/index.rdf" nil
|
||
"<div class=\"content3\">" "<!-- COMMENT MODULE -->")
|
||
("blog.ogura" "http://blog.goo.ne.jp/hwj-ogura/index.rdf" nil
|
||
"<div class=\"content3\">" "<!-- COMMENT MODULE -->")))
|
||
|
||
(defvar shimbun-wired-jp-server-name "Hotwired Japan")
|
||
(defvar shimbun-wired-jp-x-face-alist
|
||
'(("default" . "\
|
||
Face: iVBORw0KGgoAAAANSUhEUgAAADAAAAAQBAMAAACigOGCAAAABGdBTUEAALGPC/xhBQAAADB
|
||
QTFRFAAAAAgIBBgcFCgsJDA0MDhANEhYOHDALK0kQOGEUSn8aYaYies4piugulfkymf8zRL4klQA
|
||
AAC90RVh0U29mdHdhcmUAWFYgVmVyc2lvbiAzLjEwYStGTG1hc2sgIFJldjogMTIvMjkvOTQbx6p
|
||
8AAABfUlEQVR42h3MTyiDcRzH8e+ImT3KckBRNmGHPRfPRdpt5sBNe3bgynJRi5Q1jfL/T1moqSm
|
||
i/Nth6jkMI8lh2pJQ6/c8K26PUTju+Un7+T5+h1effu9+P/D5fN6tbnRwQVec9+o3c17A3VucE0W
|
||
x53Mc7c0NoQM5ETwed4hJLsE9wiSP4AmxTZfQtVachf7hsfiL2pkc22GqEBGu2W3nBSqBM7h3FdB
|
||
4NnpyedZO2tNB1ZFrllefwTm5l2lW+N++8+iJjbS8HxUch22aXQV+e18+TNbnbWQ5ZiVtNEsdCTu
|
||
VCPBf+/l00kJqyFLMQmrpIm34qKPZO+C/NzAAKc1HYkAqaOCHk016aLxcl88wlJAD1EhTlJup0L+
|
||
qioYVmwIESCINpJymNO7IqLW+QdXK7lWHhiGZk/GdIhe43/L3oArmCX/8XoUUxFkBfWBP5ozhlT2
|
||
CoRpC7AasMIVaMJ8adHcBj7k4jTawMDryv0NFvx7KjqtR40UTalL0XSnDH6TavYxiVdRgAAAAB3R
|
||
JTUUH1AoWBQgh+MK8xgAAAABJRU5ErkJggg==")))
|
||
|
||
(luna-define-method shimbun-groups ((shimbun shimbun-wired-jp))
|
||
(mapcar 'car shimbun-wired-jp-group-table))
|
||
|
||
(luna-define-method shimbun-index-url ((shimbun shimbun-wired-jp))
|
||
(let ((elem (assoc (shimbun-current-group shimbun)
|
||
shimbun-wired-jp-group-table)))
|
||
(or (nth 1 elem) (nth 2 elem))))
|
||
|
||
(luna-define-method shimbun-headers :around ((shimbun shimbun-wired-jp)
|
||
&optional range)
|
||
(if (nth 1 (assoc (shimbun-current-group shimbun)
|
||
shimbun-wired-jp-group-table))
|
||
(luna-call-next-method)
|
||
(with-temp-buffer
|
||
(shimbun-fetch-url shimbun (shimbun-index-url shimbun) t)
|
||
(shimbun-wired-jp-get-headers shimbun))))
|
||
|
||
(defun shimbun-wired-jp-get-headers (shimbun)
|
||
(let ((headers)
|
||
(base (shimbun-index-url shimbun))
|
||
(regexp (format "<a href=\"\\(/news/%s/story/[0-9]+\\.html\\)\">"
|
||
(shimbun-current-group shimbun))))
|
||
(goto-char (point-min))
|
||
(while (re-search-forward regexp nil t)
|
||
(let ((url (shimbun-expand-url (match-string 1) base)))
|
||
(push (shimbun-create-header
|
||
0
|
||
(buffer-substring (point)
|
||
(if (search-forward "</a>" nil t)
|
||
(match-beginning 0)
|
||
(point-at-eol)))
|
||
(format "%s (%s)"
|
||
(shimbun-server-name shimbun)
|
||
(shimbun-current-group shimbun))
|
||
""
|
||
(shimbun-rss-build-message-id shimbun url)
|
||
"" 0 0 url)
|
||
headers)))
|
||
headers))
|
||
|
||
(luna-define-method shimbun-article-url ((shimbun shimbun-wired-jp) header)
|
||
(let ((url (shimbun-article-base-url shimbun header)))
|
||
(if (string-match "/news/[a-z]+/story/\\([0-9]+\\.html\\)\\'" url)
|
||
(shimbun-expand-url (concat "/news/print/" (match-string 1 url)) url)
|
||
url)))
|
||
|
||
(luna-define-method shimbun-clear-contents ((shimbun shimbun-wired-jp) header)
|
||
(let ((case-fold-search t)
|
||
(start)
|
||
(elem (assoc (shimbun-current-group shimbun)
|
||
shimbun-wired-jp-group-table)))
|
||
(when (string-match "/news/print/[0-9]+\\.html\\'"
|
||
(shimbun-article-url shimbun header))
|
||
(goto-char (point-min))
|
||
(when (re-search-forward "<font[^>]*>\\([0-9]+\\)$BG/(B\\([0-9]+\\)$B7n(B\
|
||
\\([0-9]+\\)$BF|(B +\\([0-9]+\\):\\([0-9]+\\)\\([ap]m\\) +\\([A-Z]+\\)</font>"
|
||
nil t)
|
||
(setq start (match-end 0))
|
||
(shimbun-header-set-date header
|
||
(shimbun-make-date-string
|
||
(string-to-number (match-string 1))
|
||
(string-to-number (match-string 2))
|
||
(string-to-number (match-string 3))
|
||
(format
|
||
"%2d:%s"
|
||
(+ (string-to-number (match-string 4))
|
||
(if (string= "pm" (match-string 6))
|
||
12 0))
|
||
(match-string 5))
|
||
(cdr (assoc (match-string 7)
|
||
'(("JT" . "+0900")
|
||
("PT" . "-0700"))))))
|
||
(forward-line -1)
|
||
(when (looking-at "<b><font[^>]+>\\([^<>]+\\)</font></b><br>")
|
||
(shimbun-header-set-from header (match-string 1)))))
|
||
(goto-char (point-min))
|
||
(when (and (or start
|
||
(when (re-search-forward (nth 3 elem) nil t)
|
||
(setq start (point))))
|
||
(re-search-forward (nth 4 elem) nil t))
|
||
(delete-region (match-beginning 0) (point-max))
|
||
(delete-region (point-min) start)
|
||
t)))
|
||
|
||
(provide 'sb-wired-jp)
|
||
|
||
;;; sb-wired-jp.el ends here
|