/[emacs]/emacs/lisp/gnus/nnwfm.el
ViewVC logotype

Diff of /emacs/lisp/gnus/nnwfm.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by schwab, Thu Jul 22 16:45:51 2004 UTC revision 1.2 by miles, Sat Sep 4 13:13:43 2004 UTC
# Line 0  Line 1 
1    ;;; nnwfm.el --- interfacing with a web forum
2    ;; Copyright (C) 2000 Free Software Foundation, Inc.
3    
4    ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5    ;; Keywords: news
6    
7    ;; This file is part of GNU Emacs.
8    
9    ;; GNU Emacs is free software; you can redistribute it and/or modify
10    ;; it under the terms of the GNU General Public License as published by
11    ;; the Free Software Foundation; either version 2, or (at your option)
12    ;; any later version.
13    
14    ;; GNU Emacs is distributed in the hope that it will be useful,
15    ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16    ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17    ;; GNU General Public License for more details.
18    
19    ;; You should have received a copy of the GNU General Public License
20    ;; along with GNU Emacs; see the file COPYING.  If not, write to the
21    ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22    ;; Boston, MA 02111-1307, USA.
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    
431    ;;; arch-tag: d813966a-4211-4557-ad11-d1ac2bc86536
432    ;;; nnwfm.el ends here

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26