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