Change README.md
[navi2ch.git] / navi2ch-megabbs.el
blob0fb62a6115914c85fbd4cc43d0175b6669bd10aa
1 ;;; navi2ch-megabbs.el --- View megabbs.net module for Navi2ch. -*- coding: iso-2022-7bit; -*-
3 ;; Copyright (C) 2002, 2004, 2006 by Navi2ch Project
5 ;; Author:
6 ;; Part5 \e$B%9%l$N\e(B 509 \e$B$NL>L5$7$5$s\e(B
7 ;; <http://pc.2ch.net/test/read.cgi/unix/1013457056/509>
9 ;; Keywords: 2ch, network
11 ;; This file 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.
16 ;; This file 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.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to
23 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
26 ;;; Commentary:
29 ;;; ----------\e$BNc\e(B----------
30 ;;; \e$BIaDL$K1\Mw$7$?$H$-\e(B
31 ;;; http://www.megabbs.com/egame/index.html
32 ;;;
33 ;;; \e$B%9%l0lMw$NA4$F\e(B (\e$B2a5n%m%0%a%K%e!<\e(B)
34 ;;; http://www.megabbs.com/cgi-bin/readtitle.cgi?bo=egame&br=off
35 ;;; html \e$B$GMn$A$F$/$k!%\e(B`br' \e$B$O\e(B <br> \e$B$NM-L5\e(B[on|off]\e$B!%\e(B
36 ;;;
37 ;;; http://www.megabbs.com/egame/egame_newb.txt
38 ;;; text \e$B$GMn$A$F$/$k!%\e(B1 \e$B9TL\$H:G8e$N9T$OITMW!%\e(B
39 ;;;
40 ;;; \e$B%9%l\e(B (\e$B%l%9$rA4It8+$k\e(B)
41 ;;; http://www.megabbs.com/cgi-bin/readres.cgi?bo=egame&vi=1080276946
42 ;;; html \e$B$GMn$A$F$/$k!%\e(B
43 ;;;
44 ;;; \e$B%9%l\e(B (\e$B:G?7\e(B 100 \e$B7o\e(B)
45 ;;; http://www.megabbs.com/cgi-bin/readres.cgi?bo=egame&vi=1080276946&rm=100
46 ;;; html \e$B$GMn$A$F$/$k!%\e(B
47 ;;;
48 ;;; readres.cgi \e$B$K$F!$\e(B>>1\e$B$r=|5n\e(B
49 ;;; fi=no
50 ;;;
51 ;;; readres.cgi \e$B$K$F!$\e(B>>30\e$B$N$_\e(B
52 ;;; res=30
54 ;;; Code:
55 (provide 'navi2ch-megabbs)
56 (defconst navi2ch-megabbs-ident
57 "$Id$")
59 (eval-when-compile
60 (require 'cl-lib)
61 (require 'navi2ch-decls)
62 (require 'navi2ch-inline))
63 (require 'navi2ch-vars)
65 (defvar navi2ch-megabbs-func-alist
66 '((bbs-p . navi2ch-megabbs-p)
67 (subject-callback . navi2ch-megabbs-subject-callback)
68 (article-update . navi2ch-megabbs-article-update)
69 (article-to-url . navi2ch-megabbs-article-to-url)
70 (url-to-board . navi2ch-megabbs-url-to-board)
71 (url-to-article . navi2ch-megabbs-url-to-article)
72 (send-message . navi2ch-megabbs-send-message)
73 (send-success-p . navi2ch-megabbs-send-message-success-p)
74 ; (error-string . navi2ch-megabbs-send-message-error-string)
75 (board-update . navi2ch-megabbs-board-update)
76 (board-get-file-name . navi2ch-megabbs-board-get-file-name)))
78 (defvar navi2ch-megabbs-variable-alist
79 (list (cons 'coding-system navi2ch-coding-system)))
81 (navi2ch-multibbs-regist 'megabbs
82 navi2ch-megabbs-func-alist
83 navi2ch-megabbs-variable-alist)
85 (defgroup navi2ch-megabbs nil
86 "*Navi2ch, megabbs."
87 :prefix "navi2ch-megabbs-"
88 :group 'navi2ch)
90 (defcustom navi2ch-megabbs-max-articles 300
91 "\e$B%9%l0lMw$N:GBgCM!%\e(B"
92 :type '(choice (const :tag "\e$BL5@)8B\e(B" 0)
93 (integer :tag "\e$B@)8BCM\e(B"))
94 :group 'navi2ch-megabbs)
96 ;;-------------
98 (defun navi2ch-megabbs-p (uri)
99 "URI \e$B$,\e(B megabbs.net \e$B$J$i\e(B non-nil\e$B$rJV$9!#\e(B"
100 (string-match "^http://www.megabbs.com/" uri))
102 (navi2ch-multibbs-defcallback navi2ch-megabbs-subject-callback (megabbs)
103 "subject.txt \e$B$r<hF@$9$k$H$-\e(B navi2ch-net-update-file
104 \e$B$G;H$o$l$k%3!<%k%P%C%/4X?t\e(B"
105 (progn (re-search-forward "[^\n]*\n" nil t) (replace-match ""))
106 (if (= navi2ch-megabbs-max-articles 0)
107 (while (navi2ch-megabbs-subject-callback-sub))
108 (let ((n navi2ch-megabbs-max-articles))
109 (while (and (not (zerop n))
110 (navi2ch-megabbs-subject-callback-sub))
111 (setq n (1- n)))))
112 (delete-region (point) (point-max)))
114 (defun navi2ch-megabbs-subject-callback-sub ()
115 (when (re-search-forward "\\([0-9]+\\)<>\\(.*\\)<>\\(.*\\)\n" nil t)
116 (replace-match "\\1.dat,\\2(\\3)\n" t)
119 (defun navi2ch-megabbs-article-update (board article start)
120 "BOARD ARTICLE \e$B$N5-;v$r99?7$9$k!#\e(B
121 START \e$B$,\e(B non-nil \e$B$J$i$P%l%9HV9f\e(B START \e$B$+$i$N:9J,$r<hF@$9$k!#\e(B
122 \e$BJV$jCM$O\e(B HEADER\e$B!#\e(B"
123 (let ((file (navi2ch-article-get-file-name board article))
124 (time (cdr (assq 'time article)))
125 (url (navi2ch-megabbs-article-to-url board article start nil start))
126 (func (if start 'navi2ch-megabbs-article-callback-diff
127 'navi2ch-megabbs-article-callback)))
128 (navi2ch-net-update-file url file time func nil start)))
130 (defmacro navi2ch-megabbs-with-board (uri id board &rest body)
131 (let ((alist (make-symbol "alist")))
132 `(let* ((,alist (navi2ch-megabbs-url-to-board
133 (cdr (assq 'uri ,board))))
134 (,uri (cdr (assq 'uri ,alist)))
135 ,@(if id
136 `((,id (cdr (assq 'id ,alist))))))
137 ,@body)))
139 (defun navi2ch-megabbs-article-to-url (board article &optional start end nofirst)
140 "BOARD, ARTICLE \e$B$+$i\e(B url \e$B$KJQ49!#\e(B
141 START, END, NOFIRST \e$B$GHO0O$r;XDj$9$k\e(B"
142 (navi2ch-megabbs-with-board
143 uri id board
144 (let ((artid (cdr (assq 'artid article))))
145 (concat
146 (progn (string-match "\\(http://[^/]+\\)/" uri)
147 (format "%s/cgi-bin/readres.cgi?bo=%s&vi=%s"
148 (match-string 1 uri) id artid))
149 (cond ((and (stringp start))
150 (string-match "l\\([0-9]+\\)" start)
151 (format "&rm=%s" (match-string 1 start)))
152 ((and start end (= (- end start) 1))
153 (format "&res=%d" start))
154 (t (concat
155 (and start (format "&rs=%d" start))
156 (and end (format "&re=%d" end)))))
157 (and nofirst
158 (not (eq start 1))
159 "&fi=no")))))
161 (defun navi2ch-megabbs-url-to-board (url)
162 "url \e$B$+$i\e(B BOARD \e$B$KJQ49!#\e(B"
163 (cond
164 ;; http://www.megabbs.com/cgi-bin/readtitle.cgi?bo=hoge&br=off
165 ((string-match
166 "http://\\([^/]+\\)/cgi-bin/[^?]*\\?.*bo=\\([^&]*\\)"
167 url)
168 (list (cons 'uri (format "http://%s/%s/"
169 (match-string 1 url)
170 (match-string 2 url)))
171 (cons 'id (match-string 2 url))))
172 ;; http://www.megabbs.com/egame/index.html
173 ((string-match
174 "http://\\([^/]+\\)/\\([^/]+\\)"
175 url)
176 (list (cons 'uri (format "http://%s/%s/"
177 (match-string 1 url)
178 (match-string 2 url)))
179 (cons 'id (match-string 2 url))))))
181 (defun navi2ch-megabbs-url-to-article (url)
182 (cond ((string-match
183 "http://.+/cgi-bin/readres\\.cgi.*vi=\\([0-9]+\\)"
184 url)
185 (list (cons 'artid (match-string 1 url))))))
188 ;------------------------------
190 (defconst navi2ch-megabbs-url-regexp
191 ;; prefix \e$B%+%F%4%j\e(B BBS\e$BHV9f\e(B
192 "\\`\\(.+\\)/\\([^/]+\\)/\\([^/]+\\)/\\'")
194 (defun navi2ch-megabbs-get-writecgi-url (board)
195 "write.cgi \e$B$N\e(B url \e$B$rJV$9!#\e(B"
196 (let* ((alist (navi2ch-megabbs-url-to-board (cdr (assq 'uri board))))
197 (uri (cdr (assq 'uri alist))))
198 (string-match "\\(http://[^/]*/\\)" uri)
199 (format "%s/cgi-bin/megabbs.cgi"
200 (match-string 1 uri))))
202 ;;; (defun navi2ch-megabbs-get-writecgi-url (board)
203 ;;; "write.cgi \e$B$N\e(B url \e$B$rJV$9!#\e(B"
204 ;;; (let ((uri (navi2ch-board-get-uri board)))
205 ;;; (and (string-match navi2ch-megabbs-url-regexp uri)
206 ;;; (format "%s/%s/bbs/write.cgi"
207 ;;; (match-string 1 uri)
208 ;;; (match-string 2 uri)))))
210 (defun navi2ch-megabbs-send-message
211 (from mail message subject bbs key time board article)
212 (let ((url (navi2ch-megabbs-get-writecgi-url board))
213 (referer (navi2ch-board-get-uri board))
214 (param-alist (list
215 (cons "submit" "\e$B=q$-9~$`\e(B")
216 (cons "mode" "res")
217 (cons "pre" "")
218 (cons "touhaba" "")
219 (cons "name" (or from ""))
220 (cons "email" (or mail ""))
221 (cons "com" message)
222 (cons "cook" "on")
223 (cons "board" bbs)
224 (cons "res" key))))
225 (navi2ch-net-send-request
226 url "POST"
227 (list (cons "Content-Type" "application/x-www-form-urlencoded")
228 (cons "Cookie" (concat "NAME=" from "; MAIL=" mail))
229 (cons "Referer" referer))
230 (navi2ch-net-get-param-string param-alist))))
232 (defun navi2ch-megabbs-send-message-success-p (proc)
233 (string-match "302 Found" (navi2ch-net-get-content proc)))
235 ;;-------------
237 (defvar navi2ch-megabbs-parse-regexp
238 ;; 1. num
239 ;; 2. (mail? + name?)
240 ;; 3. date
241 ;; 4. (id + contents)
242 "<dt><a href[^>]*>\\([0-9]+\\)</a>[^<]*<b>\\(.*\\)</b>[ \e$B!!\e(B]*\
243 \\([^<]*\\).*\n<dd>\\(.*\\)<hr[^>]*>$"
246 (defvar navi2ch-megabbs-parse-subject-regexp "<title>\\(.*\\)</title>")
248 (defun navi2ch-megabbs-parse-subject ()
249 (let ((case-fold-search t))
250 (re-search-forward navi2ch-megabbs-parse-subject-regexp nil t)
251 (match-string 1)))
253 (defun navi2ch-megabbs-parse ()
254 (let ((case-fold-search t))
255 (re-search-forward navi2ch-megabbs-parse-regexp nil t)))
257 (defun navi2ch-megabbs-make-article (&optional subject)
258 (let* ((mail+name (match-string 2))
259 (date (match-string 3))
260 (contents-with-id (match-string 4))
261 mail name id)
262 (progn
263 (setq mail+name (navi2ch-replace-string
264 "<font[^>]*>\\|</font>\\|</a>\\|<b>\\|</b>"
265 "" mail+name t))
266 (string-match "\\(<a href=\"mailto:\\([^\"]*\\)[ ]*\">\\(.*\\)\\|\\(.*\\)\\)"
267 mail+name)
268 (setq mail (match-string 2 mail+name))
269 (setq name (match-string (if mail 3 4) mail+name)))
270 (let ((m (string-match "^<!-- para=\\([^>]*\\)-->" contents-with-id)))
271 (setq id (and m (match-string 1 contents-with-id))))
272 (format "%s<>%s<>%s<>%s<>%s\n"
273 name (or mail "")
274 (concat date (and id " ID:") (or id ""))
275 contents-with-id (or subject ""))))
277 (navi2ch-multibbs-defcallback navi2ch-megabbs-article-callback
278 (megabbs &optional diff)
279 (let ((beg (point))
280 (max-num 0)
281 subject alist num min-num)
282 (unless diff
283 (setq subject (navi2ch-megabbs-parse-subject)))
284 (while (navi2ch-megabbs-parse)
285 (setq num (string-to-number (match-string 1))
286 min-num (or min-num num)
287 max-num (max max-num num)
288 alist (cons (cons (string-to-number (match-string 1))
289 (navi2ch-megabbs-make-article subject))
290 alist)
291 subject nil))
292 (delete-region beg (point-max))
293 (when (and min-num max-num)
294 (let ((i min-num))
295 (while (<= i max-num)
296 (insert (or (cdr (assoc i alist))
297 "\e$B$"$\!<$s\e(B<>\e$B$"$\!<$s\e(B<>\e$B$"$\!<$s\e(B<>\e$B$"$\!<$s\e(B<>\n"))
298 (setq i (1+ i)))))))
300 (defun navi2ch-megabbs-article-callback-diff ()
301 (navi2ch-megabbs-article-callback t))
303 ;------------------------------
305 (defun navi2ch-megabbs-board-update (board)
306 (let ((url (navi2ch-megabbs-util-article-list-url board))
307 (file (navi2ch-megabbs-board-get-file-name board))
308 (time (cdr (assq 'time board)))
309 (func (navi2ch-multibbs-subject-callback board)))
310 (navi2ch-net-update-file url file time func)))
312 (defun navi2ch-megabbs-util-article-list-url (board)
313 (navi2ch-megabbs-with-board
314 url id board
315 (concat url id "_newb.txt")))
317 (defun navi2ch-megabbs-board-get-file-name (board &optional file-name)
318 (navi2ch-megabbs-with-board
319 uri nil board
320 (string-match "http://\\(.+\\)" uri)
321 (navi2ch-expand-file-name
322 (concat (match-string 1 uri)
323 (or file-name navi2ch-board-subject-file-name)))))
325 ;;; navi2ch-megabbs.el ends here