1;;; sb-cgi-board.el --- Shimbun backend for CGI_Board bulletin board systems
2
3;; Copyright (C) 2004, 2006, 2009, 2019
4;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
5
6;; Author: TSUCHIYA Masatoshi <tsuchiya@namazu.org>
7;; Keywords: shimbun
8
9;; This file is a part of shimbun.
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; see the file COPYING.  If not, write to
23;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24;; Boston, MA 02110-1301, USA.
25
26;;; Commentary:
27
28;; This is a shimbun backend to browse CGI_Board bulletin board
29;; systems, developed by KUROKI Gen <kuroki@math.tohoku.ac.jp>.
30
31;;; Code:
32
33(require 'cl-lib) ;; cl-incf, cl-multiple-value-bind, cl-values-list
34
35(require 'shimbun)
36
37(defcustom shimbun-cgi-board-group-alist
38  '(("support" .
39     "http://www.math.tohoku.ac.jp/~kuroki/support/BBS.cgi?b=cgi_board")
40    ("kuroki.a" .
41     "http://www.math.tohoku.ac.jp/~kuroki/keijiban/BBS.cgi?b=a")
42    ("kuroki.b" .
43     "http://www.math.tohoku.ac.jp/~kuroki/keijiban/BBS.cgi?b=b")
44    ("kuroki.c" .
45     "http://www.math.tohoku.ac.jp/~kuroki/keijiban/BBS.cgi?b=c")
46    ("kuroki.e" .
47     "http://www.math.tohoku.ac.jp/~kuroki/keijiban/BBS.cgi?b=e")
48    ("nojiri" .
49     "http://njb.virtualave.net/BBS.cgi?b=nmain")
50    ("yamagata" .
51     "http://ruitomo.com/~hiroo/bbs/BBS.cgi?b=kohobu"))
52  "An alist of CGI_Board bulletin board systems and their URLs."
53  :group 'shimbun
54  :type '(repeat
55	  (cons :format "%v" :indent 4
56		(string :tag "Name")
57		(string :tag "      URL"))))
58
59(luna-define-class shimbun-cgi-board (shimbun) ())
60
61(luna-define-method shimbun-groups ((shimbun shimbun-cgi-board))
62  (mapcar 'car shimbun-cgi-board-group-alist))
63
64(defsubst shimbun-cgi-board-base-url (shimbun)
65  (cdr (assoc (shimbun-current-group-internal shimbun)
66	      shimbun-cgi-board-group-alist)))
67
68(luna-define-method shimbun-index-url ((shimbun shimbun-cgi-board))
69  (concat (shimbun-cgi-board-base-url shimbun) "&old"))
70
71(luna-define-method shimbun-x-face ((shimbun shimbun-cgi-board))
72  nil)
73
74(luna-define-method shimbun-get-headers ((shimbun shimbun-cgi-board)
75					 &optional range)
76  (catch 'found
77    (let ((base (shimbun-cgi-board-base-url shimbun))
78	  (no-cache t)
79	  (headers))
80      (dolist (page (shimbun-cgi-board-get-pages range))
81	(let (buffer header)
82	  (unwind-protect
83	      (with-temp-buffer
84		(when (shimbun-fetch-url shimbun
85					 (shimbun-expand-url page base)
86					 no-cache)
87		  (goto-char (point-min))
88		  (while (re-search-forward
89			  "\n<!--\\([^: \t\r\f\n]+\\):--><hr noshade>\n" nil t)
90		    (let* ((fragment (match-string 1))
91			   (id (shimbun-cgi-board-make-message-id base
92								  fragment)))
93		      (when (shimbun-search-id shimbun id)
94			(throw 'found headers))
95		      (unless buffer
96			(with-current-buffer
97			    (setq buffer (generate-new-buffer " *temp*"))
98			  (shimbun-fetch-url shimbun
99					     (concat base "&thread&_f=" page))))
100		      (when (setq header
101				  (with-current-buffer buffer
102				    (shimbun-cgi-board-extract-header base
103								      fragment)))
104			(push header headers))))))
105	    (when buffer
106	      (kill-buffer buffer))))
107	(setq no-cache nil))
108      headers)))
109
110(defconst shimbun-cgi-board-thread-regexp "\\( *\\)\\[\\([^]]+\\)\\] *\
111<a name=\"\\([^\"]+\\)\" href=\"\\([^\"]+\\)\" target=\"article\">\\([^<]*\\)\
112</a> *<small>(\\(.+\\))</small>")
113
114(defun shimbun-cgi-board-extract-header (base fragment)
115  (let (header)
116    (goto-char (point-min))
117    (while (and (not header) (search-forward fragment nil t))
118      (forward-line 0)
119      (if (and (looking-at shimbun-cgi-board-thread-regexp)
120	       (equal fragment (match-string 3)))
121	  (let ((level (length (match-string 1)))
122		(url (shimbun-expand-url (match-string 4) base)))
123	    (setq header
124		  (shimbun-create-header
125		   0
126		   (let ((subject (match-string 5)))
127		     (if (equal subject fragment) "" subject))
128		   (match-string 2)
129		   (shimbun-cgi-board-make-date-string (match-string 6))
130		   (shimbun-cgi-board-make-message-id base (match-string 3))
131		   nil nil nil url))
132	    (when (> level 0)
133	      ;; Search a parent article.
134	      (while (and (not (shimbun-header-references header))
135			  (zerop (forward-line 1))
136			  (not (looking-at "^$")))
137		(when (and (looking-at shimbun-cgi-board-thread-regexp)
138			   (< (length (match-string 1)) level))
139		  (shimbun-header-set-references
140		   header
141		   (shimbun-cgi-board-make-message-id base
142						      (match-string 3)))))))
143	(forward-line 1)))
144    header))
145
146(defun shimbun-cgi-board-make-date-string (string)
147  (save-match-data
148    (if (string-match
149	 "\\`\\([0-9]+\\)/\\([0-9]+\\)/\\([0-9]+\\) \\([0-9:]+\\)\\'" string)
150	(shimbun-make-date-string (string-to-number (match-string 1 string))
151				  (string-to-number (match-string 2 string))
152				  (string-to-number (match-string 3 string))
153				  (match-string 4 string))
154      (cl-multiple-value-bind (sec min hour day month year dow dst zone)
155	  (cl-values-list (decode-time (shimbun-time-parse-string string)))
156	(setq zone (/ zone 60))
157	(shimbun-make-date-string year month day
158				  (format "%02d:%02d" hour min)
159				  (format "%s%02d%02d"
160					  (if (>= zone 0) "+" "-")
161					  (/ zone 60)
162					  (% zone 60)))))))
163
164(defun shimbun-cgi-board-get-pages (&optional range)
165  "Return a list of splited index pages."
166  (let ((pages)
167	(count 0)
168	(limit (shimbun-header-index-pages range)))
169    (goto-char (point-min))
170    (while (and (or (not limit) (<= (cl-incf count) limit))
171		(re-search-forward
172		 "<a href=\"\\./\\([^.]+\\.html\\)\" target=\"article\">"
173		 nil t))
174      (push (match-string 1) pages))
175    (nreverse pages)))
176
177(defun shimbun-cgi-board-make-message-id (url &optional fragment)
178  (save-match-data
179    (format "<%s@%s>"
180	    (or fragment
181		(progn
182		  (string-match "\\`[^#]*#" url)
183		  (substring url (match-end 0))))
184	    (progn
185	      (string-match "\\`[^:/#?]+://\\([^/#?]+\\)/" url)
186	      (match-string 1 url)))))
187
188(luna-define-method shimbun-clear-contents ((shimbun shimbun-cgi-board) header)
189  (let ((id (shimbun-header-id header)))
190    (when (string-match "\\`<\\([^@]+\\)@" id)
191      (goto-char (point-min))
192      (let (start)
193	(when (and (search-forward
194		    (concat "\n<!--" (match-string 1 id) ":-->") nil t)
195		   (setq start (match-end 0))
196		   (re-search-forward "<!--[^-]*-->\n" nil t))
197	  (delete-region (match-beginning 0) (point-max))
198	  (delete-region (point-min) start)
199	  (goto-char (point-min))
200	  (when (looking-at "<hr[^>]*>")
201	    (delete-region (match-beginning 0) (match-end 0)))
202	  t)))))
203
204(provide 'sb-cgi-board)
205
206;;; sb-cgi-board.el ends here
207