1 ;;; -*- mode: Emacs-Lisp; coding: junet -*-
3 ;;; Author: TSUCHIYA Masatoshi <tsuchiya@pine.kuee.kyoto-u.ac.jp>
8 ;; This file is a part of Semi-Gnus.
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)
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.
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.
27 ;; Gnus backend to read newspapers on WEB.
32 (gnus-declare-backend "nnshimbun" 'address)
34 (eval-when-compile (require 'cl))
43 ;; Report failure to find w3 at load time if appropriate.
44 (eval '(require 'nnweb))
47 (nnoo-declare nnshimbun)
49 (defvar nnshimbun-check-interval 300)
51 (defvar nnshimbun-type-definition
53 (url . "http://spin.asahi.com/")
54 (groups "national" "business" "politics" "international" "sports" "personal" "feneral")
55 (coding-system . ,(if (boundp 'MULE) '*sjis* 'shift_jis))
56 (generate-nov . nnshimbun-generate-nov-for-each-group)
57 (get-headers . nnshimbun-asahi-get-headers)
58 (index-url . (format "%sp%s.html" nnshimbun-url nnshimbun-current-group))
59 (from-address . "webmaster@www.asahi.com")
60 (make-contents . nnshimbun-make-text-or-html-contents)
61 (contents-start . "\n<!-- Start of kiji -->\n")
62 (contents-end . "\n<!-- End of kiji -->\n"))
64 (url . "http://www.sponichi.co.jp/")
65 (groups "baseball" "soccer" "usa" "others" "society" "entertainment" "horseracing")
66 (coding-system . ,(if (boundp 'MULE) '*sjis* 'shift_jis))
67 (generate-nov . nnshimbun-generate-nov-for-each-group)
68 (get-headers . nnshimbun-sponichi-get-headers)
69 (index-url . (format "%s%s/index.html" nnshimbun-url nnshimbun-current-group))
70 (from-address . "webmaster@www.sponichi.co.jp")
71 (make-contents . nnshimbun-make-text-or-html-contents)
72 (contents-start . "\n<span class=\"text\">
\e$B!!
\e(B")
73 (contents-end . "\n"))
75 (url . "http://cnet.sphere.ne.jp/")
77 (coding-system . ,(if (boundp 'MULE) '*sjis* 'shift_jis))
78 (generate-nov . nnshimbun-generate-nov-for-each-group)
79 (get-headers . nnshimbun-cnet-get-headers)
80 (index-url . (format "%s/News/Oneweek/" nnshimbun-url))
81 (from-address . "cnet@sphere.ad.jp")
82 (make-contents . nnshimbun-make-html-contents)
83 (contents-start . "\n<!--KIJI-->\n")
84 (contents-end . "\n<!--/KIJI-->\n"))
86 (url . "http://www.hotwired.co.jp/")
87 (groups "business" "culture" "technology")
88 (coding-system . ,(if (boundp 'MULE) '*euc-japan* 'euc-jp))
89 (generate-nov . nnshimbun-generate-nov-for-all-groups)
90 (get-headers . nnshimbun-wired-get-all-headers)
92 (from-address . "webmaster@www.hotwired.co.jp")
93 (make-contents . nnshimbun-make-html-contents)
94 (contents-start . "\n<!-- START_OF_BODY -->\n")
95 (contents-end . "\n<!-- END_OF_BODY -->\n"))
97 (url . "http://www.yomiuri.co.jp/")
98 (groups "shakai" "sports" "seiji" "keizai" "kokusai" "fuho")
99 (coding-system . ,(if (boundp 'MULE) '*sjis* 'shift_jis))
100 (generate-nov . nnshimbun-generate-nov-for-all-groups)
101 (get-headers . nnshimbun-yomiuri-get-all-headers)
102 (index-url . (concat nnshimbun-url "main.htm"))
103 (from-address . "webmaster@www.yomiuri.co.jp")
104 (make-contents . nnshimbun-make-text-or-html-contents)
105 (contents-start . "\n<!-- honbun start -->\n")
106 (contents-end . "\n<!-- honbun end -->\n"))
108 (url . "http://zdseek.pub.softbank.co.jp/news/")
110 (coding-system . ,(if (boundp 'MULE) '*sjis* 'shift_jis))
111 (generate-nov . nnshimbun-generate-nov-for-each-group)
112 (get-headers . nnshimbun-zdnet-get-headers)
113 (index-url . nnshimbun-url)
114 (from-address . "zdnn@softbank.co.jp")
115 (make-contents . nnshimbun-make-html-contents)
116 (contents-start . "<!--BODY-->")
117 (contents-end . "<!--BODYEND-->"))
120 (defvar nnshimbun-x-face-alist
123 "X-Face: Ygq$6P.,%Xt$U)DS)cRY@k$VkW!7(X'X'?U{{osjjFG\"E]hND;SPJ-J?O?R|a?L
124 g2$0rVng=O3Lt}?~IId8Jj&vP^3*o=LKUyk(`t%0c!;t6REk=JbpsEn9MrN7gZ%"))))
125 "Alist of server vs. alist of group vs. X-Face field. It looks like:
127 \((\"asahi\" . ((\"national\" . \"X-face: ***\")
128 (\"business\" . \"X-Face: ***\")
131 (\"default\" . \"X-face: ***\")))
132 (\"sponichi\" . ((\"baseball\" . \"X-face: ***\")
133 (\"soccer\" . \"X-Face: ***\")
136 (\"default\" . \"X-face: ***\")))
138 (\"default\" . ((\"default\" . \"X-face: ***\")))")
140 (defvoo nnshimbun-directory (nnheader-concat gnus-directory "shimbun/")
141 "Where nnshimbun will save its files.")
143 (defvoo nnshimbun-nov-is-evil nil
144 "*Non-nil means that nnshimbun will never retrieve NOV headers.")
146 (defvoo nnshimbun-nov-file-name ".overview")
148 (defvoo nnshimbun-pre-fetch-article nil
149 "*Non nil means that nnshimbun fetch unread articles when scanning groups.")
151 ;; set by nnshimbun-possibly-change-group
152 (defvoo nnshimbun-buffer nil)
153 (defvoo nnshimbun-current-directory nil)
154 (defvoo nnshimbun-current-group nil)
156 ;; set by nnshimbun-open-server
157 (defvoo nnshimbun-url nil)
158 (defvoo nnshimbun-coding-system nil)
159 (defvoo nnshimbun-groups nil)
160 (defvoo nnshimbun-generate-nov nil)
161 (defvoo nnshimbun-get-headers nil)
162 (defvoo nnshimbun-index-url nil)
163 (defvoo nnshimbun-from-address nil)
164 (defvoo nnshimbun-make-contents nil)
165 (defvoo nnshimbun-contents-start nil)
166 (defvoo nnshimbun-contents-end nil)
167 (defvoo nnshimbun-server-directory nil)
169 (defvoo nnshimbun-status-string "")
170 (defvoo nnshimbun-nov-last-check nil)
171 (defvoo nnshimbun-nov-buffer-alist nil)
172 (defvoo nnshimbun-nov-buffer-file-name nil)
174 (defvoo nnshimbun-keep-backlog 300)
175 (defvoo nnshimbun-backlog-articles nil)
176 (defvoo nnshimbun-backlog-hashtb nil)
181 (defmacro nnshimbun-backlog (&rest form)
182 `(let ((gnus-keep-backlog nnshimbun-keep-backlog)
183 (gnus-backlog-buffer (format " *nnshimbun backlog %s*" (nnoo-current-server 'nnshimbun)))
184 (gnus-backlog-articles nnshimbun-backlog-articles)
185 (gnus-backlog-hashtb nnshimbun-backlog-hashtb))
188 (setq nnshimbun-backlog-articles gnus-backlog-articles
189 nnshimbun-backlog-hashtb gnus-backlog-hashtb))))
190 (put 'nnshimbun-backlog 'lisp-indent-function 0)
191 (put 'nnshimbun-backlog 'edebug-form-spec '(form body))
195 ;;; Interface Functions
196 (nnoo-define-basics nnshimbun)
198 (deffoo nnshimbun-open-server (server &optional defs)
199 ;; Set default values.
200 (dolist (default (cdr (assoc server nnshimbun-type-definition)))
201 (let ((symbol (intern (concat "nnshimbun-" (symbol-name (car default))))))
202 (unless (assq symbol defs)
203 (push (list symbol (cdr default)) defs))))
204 ;; Set directory for server working files.
205 (push (list 'nnshimbun-server-directory
206 (file-name-as-directory
207 (expand-file-name server nnshimbun-directory)))
209 (nnoo-change-server 'nnshimbun server defs)
210 (nnshimbun-possibly-change-group nil server)
212 (unless (file-exists-p nnshimbun-directory)
213 (ignore-errors (make-directory nnshimbun-directory t)))
215 ((not (file-exists-p nnshimbun-directory))
216 (nnshimbun-close-server)
217 (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-directory))
218 ((not (file-directory-p (file-truename nnshimbun-directory)))
219 (nnshimbun-close-server)
220 (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-directory))
222 (unless (file-exists-p nnshimbun-server-directory)
223 (ignore-errors (make-directory nnshimbun-server-directory t)))
225 ((not (file-exists-p nnshimbun-server-directory))
226 (nnshimbun-close-server)
227 (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-server-directory))
228 ((not (file-directory-p (file-truename nnshimbun-server-directory)))
229 (nnshimbun-close-server)
230 (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-server-directory))
232 (nnheader-report 'nnshimbun "Opened server %s using directory %s"
233 server nnshimbun-server-directory)
236 (deffoo nnshimbun-close-server (&optional server)
237 (and (nnshimbun-server-opened server)
238 (gnus-buffer-live-p nnshimbun-buffer)
239 (kill-buffer nnshimbun-buffer))
240 (nnshimbun-backlog (gnus-backlog-shutdown))
242 (nnoo-close-server 'nnshimbun server)
245 (defun nnshimbun-retrieve-url (url &optional no-cache)
246 "Rertrieve URL contents and insert to current buffer."
247 (let ((coding-system-for-read 'binary)
248 (coding-system-for-write 'binary))
249 (set-buffer-multibyte nil)
250 ;; Following code is imported from `url-insert-file-contents'.
252 (let ((old-asynch (default-value 'url-be-asynchronous))
253 (old-caching (default-value 'url-automatic-caching))
254 (old-mode (default-value 'url-standalone-mode)))
257 (setq-default url-be-asynchronous nil)
259 (setq-default url-automatic-caching nil)
260 (setq-default url-standalone-mode nil))
261 (let ((buf (current-buffer))
262 (url-working-buffer (cdr (url-retrieve url no-cache))))
263 (set-buffer url-working-buffer)
266 (insert-buffer url-working-buffer)
268 (set-buffer url-working-buffer)
269 (set-buffer-modified-p nil))
270 (kill-buffer url-working-buffer)))
271 (setq-default url-be-asynchronous old-asynch)
272 (setq-default url-automatic-caching old-caching)
273 (setq-default url-standalone-mode old-mode))))
274 ;; Modify buffer coding system.
275 (decode-coding-region (point-min) (point-max) nnshimbun-coding-system)
276 (set-buffer-multibyte t)))
278 (deffoo nnshimbun-request-article (article &optional group server to-buffer)
279 (when (nnshimbun-possibly-change-group group server)
280 (if (stringp article)
281 (setq article (nnshimbun-search-id group article)))
282 (if (integerp article)
283 (nnshimbun-request-article-1 article group server to-buffer)
284 (nnheader-report 'nnml "Couldn't retrieve article: %s" (prin1-to-string article))
287 (defun nnshimbun-request-article-1 (article &optional group server to-buffer)
288 (if (nnshimbun-backlog
289 (gnus-backlog-request-article
290 group article (or to-buffer nntp-server-buffer)))
292 (let (header contents)
293 (when (setq header (save-excursion
294 (set-buffer (nnshimbun-open-nov group))
295 (and (nnheader-find-nov-line article)
296 (nnheader-parse-nov))))
297 (let* ((xref (substring (mail-header-xref header) 6))
298 (x-faces (cdr (or (assoc (or server
299 (nnoo-current-server 'nnshimbun))
300 nnshimbun-x-face-alist)
301 (assoc "default" nnshimbun-x-face-alist))))
302 (x-face (cdr (or (assoc group x-faces)
303 (assoc "default" x-faces)))))
305 (set-buffer nnshimbun-buffer)
307 (nnshimbun-retrieve-url xref)
308 (nnheader-message 6 "nnshimbun: Make contents...")
309 (goto-char (point-min))
310 (setq contents (funcall nnshimbun-make-contents header x-face))
311 (nnheader-message 6 "nnshimbun: Make contents...done"))))
314 (set-buffer (or to-buffer nntp-server-buffer))
318 (gnus-backlog-enter-article group article (current-buffer)))
319 (nnheader-report 'nnshimbun "Article %s retrieved" (mail-header-id header))
320 (cons group (mail-header-number header)))))))
322 (deffoo nnshimbun-request-group (group &optional server dont-check)
323 (let ((pathname-coding-system 'binary))
325 ((not (nnshimbun-possibly-change-group group server))
326 (nnheader-report 'nnshimbun "Invalid group (no such directory)"))
327 ((not (file-exists-p nnshimbun-current-directory))
328 (nnheader-report 'nnshimbun "Directory %s does not exist"
329 nnshimbun-current-directory))
330 ((not (file-directory-p nnshimbun-current-directory))
331 (nnheader-report 'nnshimbun "%s is not a directory" nnshimbun-current-directory))
333 (nnheader-report 'nnshimbun "Group %s selected" group)
338 (set-buffer (nnshimbun-open-nov group))
339 (goto-char (point-min))
340 (setq beg (ignore-errors (read (current-buffer))))
341 (goto-char (point-max))
343 (setq end (ignore-errors (read (current-buffer)))
344 lines (count-lines (point-min) (point-max))))
345 (nnheader-report 'nnshimbunw "Selected group %s" group)
346 (nnheader-insert "211 %d %d %d %s\n"
347 lines (or beg 0) (or end 0) group))))))
349 (deffoo nnshimbun-request-scan (&optional group server)
350 (nnshimbun-possibly-change-group group server)
351 (nnshimbun-generate-nov-database group))
353 (deffoo nnshimbun-close-group (group &optional server)
354 (nnshimbun-write-nov group)
357 (deffoo nnshimbun-request-list (&optional server)
359 (set-buffer nntp-server-buffer)
361 (dolist (group nnshimbun-groups)
362 (when (nnshimbun-possibly-change-group group server)
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))
370 (setq end (ignore-errors (read (current-buffer)))))
371 (insert (format "%s %d %d n\n" group (or end 0) (or beg 0)))))))
375 (if (fboundp 'mime-entity-fetch-field)
377 (defun nnshimbun-insert-header (header)
378 (insert "Subject: " (or (mime-entity-fetch-field header 'Subject) "(none)") "\n"
379 "From: " (or (mime-entity-fetch-field header 'From) "(nobody)") "\n"
380 "Date: " (or (mail-header-date header) "") "\n"
381 "Message-ID: " (or (mail-header-id header) (nnmail-message-id)) "\n"
382 "References: " (or (mail-header-references header) "") "\n"
384 (princ (or (mail-header-lines header) 0) (current-buffer))
386 (if (mail-header-xref header)
387 (insert (mail-header-xref header) "\n")))
389 (defun nnshimbun-insert-header (header)
390 (nnheader-insert-header header)
392 (if (mail-header-xref header)
393 (insert (mail-header-xref header) "\n")))))
395 (deffoo nnshimbun-retrieve-headers (articles &optional group server fetch-old)
396 (when (nnshimbun-possibly-change-group group server)
397 (if (nnshimbun-retrieve-headers-with-nov articles fetch-old)
400 (set-buffer nntp-server-buffer)
403 (dolist (art articles)
405 (setq art (nnshimbun-search-id group art)))
409 (set-buffer (nnshimbun-open-nov group))
410 (and (nnheader-find-nov-line art)
411 (nnheader-parse-nov))))
412 (insert (format "220 %d Article retrieved.\n" art))
413 (nnshimbun-insert-header header)
415 (delete-region (point) (point-max))))))
418 (defun nnshimbun-retrieve-headers-with-nov (articles &optional fetch-old)
419 (if (or gnus-nov-is-evil nnshimbun-nov-is-evil)
421 (let ((nov (expand-file-name nnshimbun-nov-file-name nnshimbun-current-directory)))
422 (when (file-exists-p nov)
424 (set-buffer nntp-server-buffer)
426 (nnheader-insert-file-contents nov)
427 (if (and fetch-old (not (numberp fetch-old)))
428 t ; Don't remove anything.
429 (nnheader-nov-delete-outside-range
430 (if fetch-old (max 1 (- (car articles) fetch-old))
432 (car (last articles)))
437 ;;; Nov Database Operations
439 (defun nnshimbun-generate-nov-database (group)
440 (prog1 (funcall nnshimbun-generate-nov group)
441 (nnshimbun-write-nov group)))
443 (defun nnshimbun-generate-nov-for-each-group (group)
444 (nnshimbun-possibly-change-group group)
446 (set-buffer (nnshimbun-open-nov group))
448 (goto-char (point-max))
450 (setq i (or (ignore-errors (read (current-buffer))) 0))
451 (dolist (header (save-excursion
452 (set-buffer nnshimbun-buffer)
454 (nnshimbun-retrieve-url (eval nnshimbun-index-url) t)
455 (goto-char (point-min))
456 (funcall nnshimbun-get-headers)))
457 (unless (nnshimbun-search-id group (mail-header-id header))
458 (mail-header-set-number header (setq i (1+ i)))
459 (goto-char (point-max))
460 (nnheader-insert-nov header)
461 (if nnshimbun-pre-fetch-article
462 (nnshimbun-request-article-1 i group nil nnshimbun-buffer)))))))
464 (defun nnshimbun-generate-nov-for-all-groups (&rest args)
465 (unless (and nnshimbun-nov-last-check
466 (< (nnshimbun-lapse-seconds nnshimbun-nov-last-check)
467 nnshimbun-check-interval))
469 (dolist (list (funcall nnshimbun-get-headers))
470 (let ((group (car list)))
471 (nnshimbun-possibly-change-group group)
473 (set-buffer (nnshimbun-open-nov group))
475 (goto-char (point-max))
477 (setq i (or (ignore-errors (read (current-buffer))) 0))
478 (dolist (header (cdr list))
479 (unless (nnshimbun-search-id group (mail-header-id header))
480 (mail-header-set-number header (setq i (1+ i)))
481 (goto-char (point-max))
482 (nnheader-insert-nov header)
483 (if nnshimbun-pre-fetch-article
484 (nnshimbun-request-article-1 i group nil nnshimbun-buffer))))))))
486 (setq nnshimbun-nov-last-check (current-time)))))
488 (defun nnshimbun-search-id (group id &optional nov)
490 (set-buffer (nnshimbun-open-nov group))
491 (goto-char (point-min))
493 (while (and (not found)
494 (search-forward id nil t)) ; We find the ID.
495 ;; And the id is in the fourth field.
496 (if (not (and (search-backward "\t" nil t 4)
497 (not (search-backward "\t" (gnus-point-at-bol) t))))
502 (goto-char (point-min))
503 (when (search-forward (concat "X-Nnshimbun-Original-Id: " id) nil t)
509 ;; We return the article number.
510 (ignore-errors (read (current-buffer))))))))
512 (defun nnshimbun-nov-fix-header (group header args)
514 (set-buffer (nnshimbun-open-nov group))
515 (when (nnheader-find-nov-line (mail-header-number header))
517 (if (eq (car arg) 'id)
518 (let ((extra (mail-header-extra header)) x)
519 (when (setq x (assq 'X-Nnshimbun-Original-Id extra))
520 (setq extra (delq x extra)))
521 (mail-header-set-extra
523 (cons (cons 'X-Nnshimbun-Original-Id (cdr arg)) extra)))
524 (let ((func (intern (concat "mail-header-set-" (symbol-name (car arg))))))
525 (if (cdr arg) (eval (list func header (cdr arg)))))))
526 (let ((xref (mail-header-xref header)))
527 (when (string-match "^Xref: " xref)
528 (mail-header-set-xref header (substring xref 6))))
529 (delete-region (point) (progn (forward-line 1) (point)))
530 (nnheader-insert-nov header))))
532 (defun nnshimbun-open-nov (group)
533 (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
534 (if (buffer-live-p buffer)
536 (setq buffer (gnus-get-buffer-create
537 (format " *nnshimbun overview %s %s*"
538 (nnoo-current-server 'nnshimbun) group)))
541 (set (make-local-variable 'nnshimbun-nov-buffer-file-name)
543 nnshimbun-nov-file-name
544 (nnmail-group-pathname group nnshimbun-server-directory)))
546 (when (file-exists-p nnshimbun-nov-buffer-file-name)
547 (nnheader-insert-file-contents nnshimbun-nov-buffer-file-name))
548 (set-buffer-modified-p nil))
549 (push (cons group buffer) nnshimbun-nov-buffer-alist)
552 (defun nnshimbun-write-nov (group)
553 (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
554 (when (buffer-live-p buffer)
558 (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
561 (defun nnshimbun-save-nov ()
563 (while nnshimbun-nov-buffer-alist
564 (when (buffer-name (cdar nnshimbun-nov-buffer-alist))
565 (set-buffer (cdar nnshimbun-nov-buffer-alist))
566 (when (buffer-modified-p)
567 (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
569 (set-buffer-modified-p nil)
570 (kill-buffer (current-buffer)))
571 (setq nnshimbun-nov-buffer-alist (cdr nnshimbun-nov-buffer-alist)))))
575 ;;; Server Initialize
576 (defun nnshimbun-possibly-change-group (group &optional server)
578 (unless (nnshimbun-server-opened server)
579 (nnshimbun-open-server server)))
580 (unless (gnus-buffer-live-p nnshimbun-buffer)
581 (setq nnshimbun-buffer
583 (nnheader-set-temp-buffer
584 (format " *nnshimbun %s*" (nnoo-current-server 'nnshimbun))))))
587 (let ((pathname (nnmail-group-pathname group nnshimbun-server-directory))
588 (pathname-coding-system 'binary))
589 (unless (equal pathname nnshimbun-current-directory)
590 (setq nnshimbun-current-directory pathname
591 nnshimbun-current-group group))
592 (unless (file-exists-p nnshimbun-current-directory)
593 (ignore-errors (make-directory nnshimbun-current-directory t)))
595 ((not (file-exists-p nnshimbun-current-directory))
596 (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-current-directory))
597 ((not (file-directory-p (file-truename nnshimbun-current-directory)))
598 (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-current-directory))
606 (if (fboundp 'eword-encode-string)
608 (defun nnshimbun-mime-encode-string (string)
611 (split-string (eword-encode-string (nnweb-decode-entities-string string)) "\n")
614 (defun nnshimbun-mime-encode-string (string)
619 (insert (nnweb-decode-entities-string string))
620 (rfc2047-encode-region (point-min) (point-max))
621 (buffer-substring (point-min) (point-max)))
625 (defun nnshimbun-lapse-seconds (time)
626 (let ((now (current-time)))
627 (+ (* (- (car now) (car time)) 65536)
628 (- (nth 1 now) (nth 1 time)))))
630 (defun nnshimbun-make-date-string (year month day &optional time)
631 (format "%02d %s %04d %s +0900"
633 (aref [nil "Jan" "Feb" "Mar" "Apr" "May" "Jun"
634 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"]
640 ((< year 1000) ; possible 3-digit years.
645 (if (fboundp 'regexp-opt)
646 (defalias 'nnshimbun-regexp-opt 'regexp-opt)
647 (defun nnshimbun-regexp-opt (strings &optional paren)
648 "Return a regexp to match a string in STRINGS.
649 Each string should be unique in STRINGS and should not contain any regexps,
650 quoted or not. If optional PAREN is non-nil, ensure that the returned regexp
651 is enclosed by at least one regexp grouping construct."
652 (let ((open-paren (if paren "\\(" "")) (close-paren (if paren "\\)" "")))
653 (concat open-paren (mapconcat 'regexp-quote strings "\\|") close-paren))))
656 ;; Fast fill-region function
658 (defvar nnshimbun-fill-column (min 80 (- (frame-width) 4)))
660 (defconst nnshimbun-kinsoku-bol-list
662 (if (fboundp 'string-to-char-list)
665 !)-_~}]:;',.?
\e$B!"!#!$!%!&!'!(!)!*!+!,!-!.!/!0!1!2!3!4!5!6!7!8!9!:!;!<!=!>!?!@!A
\e(B\
666 \e$B!B!C!D!E!G!I!K!M!O!Q!S!U!W!Y![!k!l!m!n$!$#$%$'$)$C$c$e$g$n%!%#%%%'%)%C%c%e%g%n%u%v
\e(B"))
668 (defconst nnshimbun-kinsoku-eol-list
670 (if (fboundp 'string-to-char-list)
673 "({[`
\e$B!F!H!J!L!N!P!R!T!V!X!Z!k!l!m!x
\e(B"))
675 (defun nnshimbun-fill-line ()
677 (let ((top (point)) chr)
678 (while (if (>= (move-to-column nnshimbun-fill-column)
679 nnshimbun-fill-column)
681 (if (memq (preceding-char) nnshimbun-kinsoku-eol-list)
684 (while (memq (preceding-char) nnshimbun-kinsoku-eol-list)
687 (while (memq (setq chr (following-char)) nnshimbun-kinsoku-bol-list)
689 (if (looking-at "\\s-+")
690 (or (eolp) (delete-region (point) (match-end 0)))
691 (or (> (char-width chr) 1)
692 (re-search-backward "\\<" top t)
694 (or (eolp) (insert "\n"))))))
699 (defsubst nnshimbun-shallow-rendering ()
700 (goto-char (point-min))
701 (while (search-forward "<p>" nil t)
703 (goto-char (point-min))
704 (while (search-forward "<br>" nil t)
706 (nnweb-remove-markup)
707 (nnweb-decode-entities)
708 (goto-char (point-min))
709 (while (nnshimbun-fill-line))
710 (goto-char (point-min))
711 (when (skip-chars-forward "\n")
712 (delete-region (point-min) (point)))
713 (while (search-forward "\n\n" nil t)
715 (when (skip-chars-forward "\n")
716 (delete-region p (point)))))
717 (goto-char (point-max))
718 (when (skip-chars-backward "\n")
719 (delete-region (point) (point-max)))
722 (defun nnshimbun-make-text-or-html-contents (header &optional x-face)
723 (let ((case-fold-search t) (html t) (start))
724 (when (and (search-forward nnshimbun-contents-start nil t)
726 (search-forward nnshimbun-contents-end nil t))
727 (delete-region (point-min) start)
728 (delete-region (- (point) (length nnshimbun-contents-end)) (point-max))
729 (nnshimbun-shallow-rendering)
731 (goto-char (point-min))
732 (nnshimbun-insert-header header)
733 (insert "Content-Type: " (if html "text/html" "text/plain")
734 "; charset=ISO-2022-JP\nMIME-Version: 1.0\n")
740 (encode-coding-string (buffer-string)
741 (mime-charset-to-coding-system "ISO-2022-JP"))))
743 (defun nnshimbun-make-html-contents (header &optional x-face)
745 (when (and (search-forward nnshimbun-contents-start nil t)
747 (search-forward nnshimbun-contents-end nil t))
748 (delete-region (point-min) start)
749 (delete-region (- (point) (length nnshimbun-contents-end)) (point-max)))
750 (goto-char (point-min))
751 (nnshimbun-insert-header header)
752 (insert "Content-Type: text/html; charset=ISO-2022-JP\n"
753 "MIME-Version: 1.0\n")
759 (encode-coding-string (buffer-string)
760 (mime-charset-to-coding-system "ISO-2022-JP"))))
766 (defun nnshimbun-asahi-get-headers ()
767 (when (search-forward "\n<!-- Start of past -->\n" nil t)
768 (delete-region (point-min) (point))
769 (when (search-forward "\n<!-- End of past -->\n" nil t)
771 (delete-region (point) (point-max))
772 (goto-char (point-min))
774 (while (re-search-forward
775 "^
\e$B"#
\e(B<a href=\"\\(\\([0-9][0-9][0-9][0-9]\\)/past/\\([A-z]*[0-9]*\\)\\.html\\)\"> *"
777 (let ((id (format "<%s%s%%%s>"
780 nnshimbun-current-group))
781 (url (match-string 1)))
782 (push (make-full-mail-header
784 (nnshimbun-mime-encode-string
789 (progn (search-forward "<br>" nil t) (point)))
790 "\\(<[^>]+>\\|\r\\)")
792 nnshimbun-from-address
793 "" id "" 0 0 (concat nnshimbun-url url))
795 (setq headers (nreverse headers))
797 (while (and (nth i headers)
799 "^\\[\\([0-9][0-9]\\)/\\([0-9][0-9]\\) \\([0-9][0-9]:[0-9][0-9]\\)\\]"
801 (let ((month (string-to-number (match-string 1)))
802 (date (decode-time (current-time))))
803 (mail-header-set-date
805 (nnshimbun-make-date-string
806 (if (and (eq 12 month) (eq 1 (nth 4 date)))
810 (string-to-number (match-string 2))
813 (nreverse headers)))))
817 ;;; www.sponichi.co.jp
819 (defun nnshimbun-sponichi-get-headers ()
820 (when (search-forward "
\e$B%K%e!<%9%$%s%G%C%/%9
\e(B" nil t)
821 (delete-region (point-min) (point))
822 (when (search-forward "
\e$B%"%I%?%0
\e(B" nil t)
824 (delete-region (point) (point-max))
825 (goto-char (point-min))
826 (let ((case-fold-search t) headers)
827 (while (re-search-forward
828 "^<a href=\"/\\(\\([A-z]*\\)/kiji/\\([0-9][0-9][0-9][0-9]\\)/\\([0-9][0-9]\\)/\\([0-9][0-9]\\)/\\([0-9][0-9]\\)\\.html\\)\">"
830 (let ((url (match-string 1))
831 (id (format "<%s%s%s%s%%%s>"
836 nnshimbun-current-group))
837 (date (nnshimbun-make-date-string
838 (string-to-number (match-string 3))
839 (string-to-number (match-string 4))
840 (string-to-number (match-string 5)))))
841 (push (make-full-mail-header
843 (nnshimbun-mime-encode-string
848 (progn (search-forward "<br>" nil t) (point)))
851 nnshimbun-from-address
852 date id "" 0 0 (concat nnshimbun-url url))
860 (defun nnshimbun-cnet-get-headers ()
861 (let ((case-fold-search t) headers)
862 (while (search-forward "\n<!--*****
\e$B8+=P$7
\e(B*****-->\n" nil t)
863 (let ((subject (buffer-substring (point) (gnus-point-at-eol)))
866 (when (looking-at "<a href=\"/\\(News/\\([0-9][0-9][0-9][0-9]\\)/Item/\\([0-9][0-9]\\([0-9][0-9]\\)\\([0-9][0-9]\\)-[0-9]+\\).html\\)\">")
867 (let ((url (match-string 1))
868 (id (format "<%s%s%%%s>"
871 nnshimbun-current-group))
872 (date (nnshimbun-make-date-string
873 (string-to-number (match-string 2))
874 (string-to-number (match-string 4))
875 (string-to-number (match-string 5)))))
876 (push (make-full-mail-header
878 (nnshimbun-mime-encode-string subject)
879 nnshimbun-from-address
880 date id "" 0 0 (concat nnshimbun-url url))
889 (defun nnshimbun-wired-get-all-headers ()
891 (set-buffer nnshimbun-buffer)
892 (let ((group-header-alist (mapcar (lambda (g) (cons g nil)) nnshimbun-groups))
895 "<a href=\"\\(%s\\|/\\)\\(news/news/\\(%s\\)/story/\\(\\([0-9][0-9][0-9][0-9]\\)\\([0-9][0-9]\\)\\([0-9][0-9]\\)[0-9]+\\)\\.html\\)\"><b>"
896 (regexp-quote nnshimbun-url)
897 (nnshimbun-regexp-opt nnshimbun-groups))))
898 (dolist (xover (list (concat nnshimbun-url "news/news/index.html")
899 (concat nnshimbun-url "news/news/last_seven.html")))
901 (nnshimbun-retrieve-url xover t)
902 (goto-char (point-min))
903 (while (re-search-forward regexp nil t)
904 (let* ((url (concat nnshimbun-url (match-string 2)))
905 (group (downcase (match-string 3)))
906 (id (format "<%s%%%s>" (match-string 4) group))
907 (date (nnshimbun-make-date-string
908 (string-to-number (match-string 5))
909 (string-to-number (match-string 6))
910 (string-to-number (match-string 7))))
911 (header (make-full-mail-header
913 (nnshimbun-mime-encode-string
918 (progn (search-forward "</b>" nil t) (point)))
921 nnshimbun-from-address
923 (x (assoc group group-header-alist)))
924 (setcdr x (cons header (cdr x))))))
925 group-header-alist)))
929 ;;; www.yomiuri.co.jp
931 (defun nnshimbun-yomiuri-get-all-headers ()
933 (set-buffer nnshimbun-buffer)
935 (nnshimbun-retrieve-url (eval nnshimbun-index-url) t)
936 (let ((case-fold-search t)
937 (group-header-alist (mapcar (lambda (g) (cons g nil)) nnshimbun-groups)))
938 (dolist (group nnshimbun-groups)
940 (goto-char (point-min))
941 (when (and (search-forward (format "\n<!-- /news/%s=start -->\n" group) nil t)
943 (search-forward (format "\n<!-- /news/%s=end -->\n" group) nil t))
946 (narrow-to-region start (point))
948 (while (re-search-forward
949 "<a href=\"/\\([0-9]+\\)/\\(\\(\\([0-9][0-9][0-9][0-9]\\)\\([0-9][0-9]\\)\\([0-9][0-9]\\)[A-z0-9]+\\)\\.htm\\)\"[^>]*>"
951 (let ((url (concat (match-string 1) "a/" (match-string 2)))
952 (id (format "<%s%s%%%s>"
956 (year (string-to-number (match-string 4)))
957 (month (string-to-number (match-string 5)))
958 (day (string-to-number (match-string 6)))
964 (progn (search-forward "<br>" nil t) (point)))
968 (when (string-match "^
\e$B"!
\e(B" subject)
969 (setq subject (substring subject (match-end 0))))
970 (if (string-match "(\\([0-9][0-9]:[0-9][0-9]\\))$" subject)
971 (setq date (nnshimbun-make-date-string
972 year month day (match-string 1 subject))
973 subject (substring subject 0 (match-beginning 0)))
974 (setq date (nnshimbun-make-date-string year month day)))
975 (setcdr (setq x (assoc group group-header-alist))
976 (cons (make-full-mail-header
978 (nnshimbun-mime-encode-string subject)
979 nnshimbun-from-address
980 date id "" 0 0 (concat nnshimbun-url url))
982 group-header-alist)))
988 (defun nnshimbun-zdnet-get-headers ()
989 (let ((case-fold-search t) headers)
990 (goto-char (point-min))
992 (while (and (search-forward "<!--" nil t)
993 (setq start (- (point) 4))
994 (search-forward "-->" nil t))
995 (delete-region start (point))))
996 (goto-char (point-min))
997 (while (re-search-forward
998 "<a href=\"\\(\\([0-9][0-9]\\)\\([0-9][0-9]\\)/\\([0-9][0-9]\\)/\\([^\\.]+\\).html\\)\"><font size=\"4\"><strong>"
1000 (let ((year (+ 2000 (string-to-number (match-string 2))))
1001 (month (string-to-number (match-string 3)))
1002 (day (string-to-number (match-string 4)))
1003 (id (format "<%s%s%s%s%%%s>"
1008 nnshimbun-current-group))
1009 (url (match-string 1)))
1010 (push (make-full-mail-header
1012 (nnshimbun-mime-encode-string
1013 (mapconcat 'identity
1017 (progn (search-forward "</a>" nil t) (point)))
1020 nnshimbun-from-address
1021 (nnshimbun-make-date-string year month day)
1022 id "" 0 0 (concat nnshimbun-url url))
1024 (nreverse headers)))
1028 (provide 'nnshimbun)
1029 ;;; nnshimbun.el ends here.