Commit | Line | Data |
---|---|---|
23f87bed | 1 | ;;; nnwfm.el --- interfacing with a web forum |
e84b4b86 | 2 | |
88e6695f | 3 | ;; Copyright (C) 2000, 2002, 2003, 2004, 2005, |
114f9c96 | 4 | ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. |
23f87bed MB |
5 | |
6 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | |
7 | ;; Keywords: news | |
8 | ||
9 | ;; This file is part of GNU Emacs. | |
10 | ||
5e809f55 | 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
23f87bed | 12 | ;; it under the terms of the GNU General Public License as published by |
5e809f55 GM |
13 | ;; the Free Software Foundation, either version 3 of the License, or |
14 | ;; (at your option) any later version. | |
23f87bed MB |
15 | |
16 | ;; GNU Emacs 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 | |
5e809f55 | 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
23f87bed MB |
23 | |
24 | ;;; Commentary: | |
25 | ||
26 | ;; Note: You need to have `url' and `w3' installed for this | |
27 | ;; backend to work. | |
28 | ||
29 | ;;; Code: | |
30 | ||
31 | (eval-when-compile (require 'cl)) | |
32 | ||
33 | (require 'nnoo) | |
34 | (require 'message) | |
35 | (require 'gnus-util) | |
36 | (require 'gnus) | |
37 | (require 'nnmail) | |
38 | (require 'mm-util) | |
39 | (require 'mm-url) | |
40 | (require 'nnweb) | |
41 | (autoload 'w3-parse-buffer "w3-parse") | |
42 | ||
43 | (nnoo-declare nnwfm) | |
44 | ||
45 | (defvoo nnwfm-directory (nnheader-concat gnus-directory "wfm/") | |
46 | "Where nnwfm will save its files.") | |
47 | ||
48 | (defvoo nnwfm-address "" | |
49 | "The address of the Ultimate bulletin board.") | |
50 | ||
51 | ;;; Internal variables | |
52 | ||
53 | (defvar nnwfm-groups-alist nil) | |
54 | (defvoo nnwfm-groups nil) | |
55 | (defvoo nnwfm-headers nil) | |
56 | (defvoo nnwfm-articles nil) | |
57 | (defvar nnwfm-table-regexp | |
58 | "postings.*editpost\\|forumdisplay\\|Forum[0-9]+/HTML\\|getbio") | |
59 | ||
60 | ;;; Interface functions | |
61 | ||
62 | (nnoo-define-basics nnwfm) | |
63 | ||
64 | (deffoo nnwfm-retrieve-headers (articles &optional group server fetch-old) | |
65 | (nnwfm-possibly-change-server group server) | |
66 | (unless gnus-nov-is-evil | |
67 | (let* ((last (car (last articles))) | |
68 | (did nil) | |
69 | (start 1) | |
70 | (entry (assoc group nnwfm-groups)) | |
71 | (sid (nth 2 entry)) | |
72 | (topics (nth 4 entry)) | |
73 | (mapping (nth 5 entry)) | |
74 | (old-total (or (nth 6 entry) 1)) | |
75 | (nnwfm-table-regexp "Thread.asp") | |
76 | headers article subject score from date lines parent point | |
77 | contents tinfo fetchers map elem a href garticles topic old-max | |
78 | inc datel table string current-page total-contents pages | |
79 | farticles forum-contents parse furl-fetched mmap farticle | |
80 | thread-id tables hstuff bstuff time) | |
81 | (setq map mapping) | |
82 | (while (and (setq article (car articles)) | |
83 | map) | |
84 | (while (and map | |
85 | (or (> article (caar map)) | |
86 | (< (cadar map) (caar map)))) | |
87 | (pop map)) | |
88 | (when (setq mmap (car map)) | |
89 | (setq farticle -1) | |
90 | (while (and article | |
91 | (<= article (nth 1 mmap))) | |
92 | ;; Do we already have a fetcher for this topic? | |
93 | (if (setq elem (assq (nth 2 mmap) fetchers)) | |
94 | ;; Yes, so we just add the spec to the end. | |
95 | (nconc elem (list (cons article | |
96 | (+ (nth 3 mmap) (incf farticle))))) | |
97 | ;; No, so we add a new one. | |
98 | (push (list (nth 2 mmap) | |
99 | (cons article | |
100 | (+ (nth 3 mmap) (incf farticle)))) | |
101 | fetchers)) | |
102 | (pop articles) | |
103 | (setq article (car articles))))) | |
104 | ;; Now we have the mapping from/to Gnus/nnwfm article numbers, | |
105 | ;; so we start fetching the topics that we need to satisfy the | |
106 | ;; request. | |
107 | (if (not fetchers) | |
108 | (save-excursion | |
109 | (set-buffer nntp-server-buffer) | |
110 | (erase-buffer)) | |
111 | (setq nnwfm-articles nil) | |
112 | (mm-with-unibyte-buffer | |
113 | (dolist (elem fetchers) | |
114 | (erase-buffer) | |
115 | (setq subject (nth 2 (assq (car elem) topics)) | |
116 | thread-id (nth 0 (assq (car elem) topics))) | |
117 | (mm-url-insert | |
118 | (concat nnwfm-address | |
119 | (format "Item.asp?GroupID=%d&ThreadID=%d" sid | |
120 | thread-id))) | |
121 | (goto-char (point-min)) | |
122 | (setq tables (caddar | |
123 | (caddar | |
124 | (cdr (caddar | |
125 | (caddar | |
126 | (ignore-errors | |
127 | (w3-parse-buffer (current-buffer))))))))) | |
128 | (setq tables (cdr (caddar (memq (assq 'div tables) tables)))) | |
129 | (setq contents nil) | |
130 | (dolist (table tables) | |
131 | (when (eq (car table) 'table) | |
132 | (setq table (caddar (caddar (caddr table))) | |
133 | hstuff (delete ":link" (nnweb-text (car table))) | |
134 | bstuff (car (caddar (cdr table))) | |
135 | from (car hstuff)) | |
136 | (when (nth 2 hstuff) | |
137 | (setq time (nnwfm-date-to-time (nth 2 hstuff))) | |
138 | (push (list from time bstuff) contents)))) | |
139 | (setq contents (nreverse contents)) | |
140 | (dolist (art (cdr elem)) | |
141 | (push (list (car art) | |
142 | (nth (1- (cdr art)) contents) | |
143 | subject) | |
144 | nnwfm-articles)))) | |
145 | (setq nnwfm-articles | |
146 | (sort nnwfm-articles 'car-less-than-car)) | |
147 | ;; Now we have all the articles, conveniently in an alist | |
148 | ;; where the key is the Gnus article number. | |
149 | (dolist (articlef nnwfm-articles) | |
150 | (setq article (nth 0 articlef) | |
151 | contents (nth 1 articlef) | |
152 | subject (nth 2 articlef)) | |
153 | (setq from (nth 0 contents) | |
154 | date (message-make-date (nth 1 contents))) | |
155 | (push | |
156 | (cons | |
157 | article | |
158 | (make-full-mail-header | |
159 | article subject | |
160 | from (or date "") | |
161 | (concat "<" (number-to-string sid) "%" | |
162 | (number-to-string article) | |
163 | "@wfm>") | |
164 | "" 0 | |
165 | (/ (length (mapconcat 'identity (nnweb-text (nth 2 contents)) "")) | |
166 | 70) | |
167 | nil nil)) | |
168 | headers)) | |
169 | (setq nnwfm-headers (sort headers 'car-less-than-car)) | |
170 | (save-excursion | |
171 | (set-buffer nntp-server-buffer) | |
172 | (mm-with-unibyte-current-buffer | |
173 | (erase-buffer) | |
174 | (dolist (header nnwfm-headers) | |
175 | (nnheader-insert-nov (cdr header)))))) | |
176 | 'nov))) | |
177 | ||
178 | (deffoo nnwfm-request-group (group &optional server dont-check) | |
179 | (nnwfm-possibly-change-server nil server) | |
180 | (when (not nnwfm-groups) | |
181 | (nnwfm-request-list)) | |
182 | (unless dont-check | |
183 | (nnwfm-create-mapping group)) | |
184 | (let ((elem (assoc group nnwfm-groups))) | |
185 | (cond | |
186 | ((not elem) | |
187 | (nnheader-report 'nnwfm "Group does not exist")) | |
188 | (t | |
189 | (nnheader-report 'nnwfm "Opened group %s" group) | |
190 | (nnheader-insert | |
191 | "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem) | |
192 | (prin1-to-string group)))))) | |
193 | ||
194 | (deffoo nnwfm-request-close () | |
195 | (setq nnwfm-groups-alist nil | |
196 | nnwfm-groups nil)) | |
197 | ||
198 | (deffoo nnwfm-request-article (article &optional group server buffer) | |
199 | (nnwfm-possibly-change-server group server) | |
200 | (let ((contents (cdr (assq article nnwfm-articles)))) | |
201 | (when (setq contents (nth 2 (car contents))) | |
202 | (save-excursion | |
203 | (set-buffer (or buffer nntp-server-buffer)) | |
204 | (erase-buffer) | |
205 | (nnweb-insert-html contents) | |
206 | (goto-char (point-min)) | |
207 | (insert "Content-Type: text/html\nMIME-Version: 1.0\n") | |
208 | (let ((header (cdr (assq article nnwfm-headers)))) | |
209 | (mm-with-unibyte-current-buffer | |
210 | (nnheader-insert-header header))) | |
211 | (nnheader-report 'nnwfm "Fetched article %s" article) | |
212 | (cons group article))))) | |
213 | ||
214 | (deffoo nnwfm-request-list (&optional server) | |
215 | (nnwfm-possibly-change-server nil server) | |
216 | (mm-with-unibyte-buffer | |
217 | (mm-url-insert | |
218 | (if (string-match "/$" nnwfm-address) | |
219 | (concat nnwfm-address "Group.asp") | |
220 | nnwfm-address)) | |
221 | (let* ((nnwfm-table-regexp "Thread.asp") | |
222 | (contents (w3-parse-buffer (current-buffer))) | |
223 | sid elem description articles a href group forum | |
224 | a1 a2) | |
225 | (dolist (row (cdr (nth 2 (car (nth 2 (nnwfm-find-forum-table | |
226 | contents)))))) | |
227 | (setq row (nth 2 row)) | |
228 | (when (setq a (nnweb-parse-find 'a row)) | |
229 | (setq group (car (last (nnweb-text a))) | |
230 | href (cdr (assq 'href (nth 1 a)))) | |
231 | (setq description (car (last (nnweb-text (nth 1 row))))) | |
232 | (setq articles | |
233 | (string-to-number | |
234 | (gnus-replace-in-string | |
235 | (car (last (nnweb-text (nth 3 row)))) "," ""))) | |
236 | (when (and href | |
237 | (string-match "GroupId=\\([0-9]+\\)" href)) | |
238 | (setq forum (string-to-number (match-string 1 href))) | |
239 | (if (setq elem (assoc group nnwfm-groups)) | |
240 | (setcar (cdr elem) articles) | |
241 | (push (list group articles forum description nil nil nil nil) | |
242 | nnwfm-groups)))))) | |
243 | (nnwfm-write-groups) | |
244 | (nnwfm-generate-active) | |
245 | t)) | |
246 | ||
247 | (deffoo nnwfm-request-newgroups (date &optional server) | |
248 | (nnwfm-possibly-change-server nil server) | |
249 | (nnwfm-generate-active) | |
250 | t) | |
251 | ||
252 | (nnoo-define-skeleton nnwfm) | |
253 | ||
254 | ;;; Internal functions | |
255 | ||
256 | (defun nnwfm-new-threads-p (group time) | |
257 | "See whether we want to fetch the threads for GROUP written before TIME." | |
258 | (let ((old-time (nth 7 (assoc group nnwfm-groups)))) | |
259 | (or (null old-time) | |
260 | (time-less-p old-time time)))) | |
261 | ||
262 | (defun nnwfm-create-mapping (group) | |
263 | (let* ((entry (assoc group nnwfm-groups)) | |
264 | (sid (nth 2 entry)) | |
265 | (topics (nth 4 entry)) | |
266 | (mapping (nth 5 entry)) | |
267 | (old-total (or (nth 6 entry) 1)) | |
268 | (current-time (current-time)) | |
269 | (nnwfm-table-regexp "Thread.asp") | |
270 | (furls (list (concat nnwfm-address | |
271 | (format "Thread.asp?GroupId=%d" sid)))) | |
272 | fetched-urls | |
273 | contents forum-contents a subject href | |
274 | garticles topic tinfo old-max inc parse elem date | |
275 | url time) | |
276 | (mm-with-unibyte-buffer | |
277 | (while furls | |
278 | (erase-buffer) | |
279 | (push (car furls) fetched-urls) | |
280 | (mm-url-insert (pop furls)) | |
281 | (goto-char (point-min)) | |
282 | (while (re-search-forward " wr(" nil t) | |
283 | (forward-char -1) | |
284 | (setq elem (message-tokenize-header | |
285 | (gnus-replace-in-string | |
286 | (buffer-substring | |
287 | (1+ (point)) | |
288 | (progn | |
289 | (forward-sexp 1) | |
290 | (1- (point)))) | |
291 | "\\\\[\"\\\\]" ""))) | |
292 | (push (list | |
293 | (string-to-number (nth 1 elem)) | |
294 | (gnus-replace-in-string (nth 2 elem) "\"" "") | |
295 | (string-to-number (nth 5 elem))) | |
296 | forum-contents)) | |
297 | (when (re-search-forward "href=\"\\(Thread.*DateLast=\\([^\"]+\\)\\)" | |
298 | nil t) | |
299 | (setq url (match-string 1) | |
300 | time (nnwfm-date-to-time (gnus-url-unhex-string | |
301 | (match-string 2)))) | |
302 | (when (and (nnwfm-new-threads-p group time) | |
303 | (not (member | |
304 | (setq url (concat | |
305 | nnwfm-address | |
306 | (mm-url-decode-entities-string url))) | |
307 | fetched-urls))) | |
308 | (push url furls)))) | |
309 | ;; The main idea here is to map Gnus article numbers to | |
310 | ;; nnwfm article numbers. Say there are three topics in | |
311 | ;; this forum, the first with 4 articles, the seconds with 2, | |
312 | ;; and the third with 1. Then this will translate into 7 Gnus | |
313 | ;; article numbers, where 1-4 comes from the first topic, 5-6 | |
314 | ;; from the second and 7 from the third. Now, then next time | |
315 | ;; the group is entered, there's 2 new articles in topic one | |
316 | ;; and 1 in topic three. Then Gnus article number 8-9 be 5-6 | |
317 | ;; in topic one and 10 will be the 2 in topic three. | |
318 | (dolist (elem (nreverse forum-contents)) | |
319 | (setq subject (nth 1 elem) | |
320 | topic (nth 0 elem) | |
321 | garticles (nth 2 elem)) | |
322 | (if (setq tinfo (assq topic topics)) | |
323 | (progn | |
324 | (setq old-max (cadr tinfo)) | |
325 | (setcar (cdr tinfo) garticles)) | |
326 | (setq old-max 0) | |
327 | (push (list topic garticles subject) topics) | |
328 | (setcar (nthcdr 4 entry) topics)) | |
329 | (when (not (= old-max garticles)) | |
330 | (setq inc (- garticles old-max)) | |
331 | (setq mapping (nconc mapping | |
332 | (list | |
333 | (list | |
334 | old-total (1- (incf old-total inc)) | |
335 | topic (1+ old-max))))) | |
336 | (incf old-max inc) | |
337 | (setcar (nthcdr 5 entry) mapping) | |
338 | (setcar (nthcdr 6 entry) old-total)))) | |
339 | (setcar (nthcdr 7 entry) current-time) | |
340 | (setcar (nthcdr 1 entry) (1- old-total)) | |
341 | (nnwfm-write-groups) | |
342 | mapping)) | |
343 | ||
344 | (defun nnwfm-possibly-change-server (&optional group server) | |
345 | (nnwfm-init server) | |
346 | (when (and server | |
347 | (not (nnwfm-server-opened server))) | |
348 | (nnwfm-open-server server)) | |
349 | (unless nnwfm-groups-alist | |
350 | (nnwfm-read-groups) | |
351 | (setq nnwfm-groups (cdr (assoc nnwfm-address | |
352 | nnwfm-groups-alist))))) | |
353 | ||
354 | (deffoo nnwfm-open-server (server &optional defs connectionless) | |
355 | (nnheader-init-server-buffer) | |
356 | (if (nnwfm-server-opened server) | |
357 | t | |
358 | (unless (assq 'nnwfm-address defs) | |
359 | (setq defs (append defs (list (list 'nnwfm-address server))))) | |
360 | (nnoo-change-server 'nnwfm server defs))) | |
361 | ||
362 | (defun nnwfm-read-groups () | |
363 | (setq nnwfm-groups-alist nil) | |
364 | (let ((file (expand-file-name "groups" nnwfm-directory))) | |
365 | (when (file-exists-p file) | |
366 | (mm-with-unibyte-buffer | |
367 | (insert-file-contents file) | |
368 | (goto-char (point-min)) | |
369 | (setq nnwfm-groups-alist (read (current-buffer))))))) | |
370 | ||
371 | (defun nnwfm-write-groups () | |
372 | (setq nnwfm-groups-alist | |
373 | (delq (assoc nnwfm-address nnwfm-groups-alist) | |
374 | nnwfm-groups-alist)) | |
375 | (push (cons nnwfm-address nnwfm-groups) | |
376 | nnwfm-groups-alist) | |
377 | (with-temp-file (expand-file-name "groups" nnwfm-directory) | |
378 | (prin1 nnwfm-groups-alist (current-buffer)))) | |
379 | ||
380 | (defun nnwfm-init (server) | |
381 | "Initialize buffers and such." | |
382 | (unless (file-exists-p nnwfm-directory) | |
383 | (gnus-make-directory nnwfm-directory))) | |
384 | ||
385 | (defun nnwfm-generate-active () | |
386 | (save-excursion | |
387 | (set-buffer nntp-server-buffer) | |
388 | (erase-buffer) | |
389 | (dolist (elem nnwfm-groups) | |
390 | (insert (prin1-to-string (car elem)) | |
391 | " " (number-to-string (cadr elem)) " 1 y\n")))) | |
392 | ||
393 | (defun nnwfm-find-forum-table (contents) | |
394 | (catch 'found | |
395 | (nnwfm-find-forum-table-1 contents))) | |
396 | ||
397 | (defun nnwfm-find-forum-table-1 (contents) | |
398 | (dolist (element contents) | |
399 | (unless (stringp element) | |
400 | (when (and (eq (car element) 'table) | |
401 | (nnwfm-forum-table-p element)) | |
402 | (throw 'found element)) | |
403 | (when (nth 2 element) | |
404 | (nnwfm-find-forum-table-1 (nth 2 element)))))) | |
405 | ||
406 | (defun nnwfm-forum-table-p (parse) | |
407 | (when (not (apply 'gnus-or | |
408 | (mapcar | |
409 | (lambda (p) | |
410 | (nnweb-parse-find 'table p)) | |
411 | (nth 2 parse)))) | |
412 | (let ((href (cdr (assq 'href (nth 1 (nnweb-parse-find 'a parse 20))))) | |
413 | case-fold-search) | |
414 | (when (and href (string-match nnwfm-table-regexp href)) | |
415 | t)))) | |
416 | ||
417 | (defun nnwfm-date-to-time (date) | |
418 | (let ((time (mapcar #'string-to-number (split-string date "[\\.\\+ :]")))) | |
419 | (encode-time 0 (nth 4 time) (nth 3 time) | |
420 | (nth 0 time) (nth 1 time) | |
421 | (if (< (nth 2 time) 70) | |
422 | (+ 2000 (nth 2 time)) | |
423 | (+ 1900 (nth 2 time)))))) | |
424 | ||
425 | (provide 'nnwfm) | |
426 | ||
427 | ;; Local Variables: | |
428 | ;; coding: iso-8859-1 | |
429 | ;; End: | |
430 | ||
cbee283d | 431 | ;; arch-tag: d813966a-4211-4557-ad11-d1ac2bc86536 |
23f87bed | 432 | ;;; nnwfm.el ends here |