Mercurial > emacs

comparison lisp/gnus/nnslashdot.el @ 82951:0fde48feb604

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
author Andreas Schwab <schwab@suse.de>
date Thu, 22 Jul 2004 16:45:51 +0000
parents 695cf19ef79e
children 18a818a2ee7c cce1c0ee76ee
comparison
equal deleted inserted replaced
56503:8bbd2323fbf2 82951:0fde48feb604
1 ;;; nnslashdot.el --- interfacing with Slashdot 1 ;;; nnslashdot.el --- interfacing with Slashdot
2 ;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. 2 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
3 3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5 ;; Keywords: news 5 ;; Keywords: news
6 6
7 ;; This file is part of GNU Emacs. 7 ;; This file is part of GNU Emacs.
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the 20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA. 22 ;; Boston, MA 02111-1307, USA.
23 23
24 ;;; Commentary: 24 ;;; Commentary:
25
26 ;; Note: You need to have `url' and `w3' installed for this
27 ;; backend to work.
28 25
29 ;;; Code: 26 ;;; Code:
30 27
31 (eval-when-compile (require 'cl)) 28 (eval-when-compile (require 'cl))
32 29
34 (require 'message) 31 (require 'message)
35 (require 'gnus-util) 32 (require 'gnus-util)
36 (require 'gnus) 33 (require 'gnus)
37 (require 'nnmail) 34 (require 'nnmail)
38 (require 'mm-util) 35 (require 'mm-util)
39 (eval-when-compile 36 (require 'mm-url)
40 (ignore-errors
41 (require 'nnweb)))
42 ;; Report failure to find w3 at load time if appropriate.
43 (eval '(require 'nnweb))
44 37
45 (nnoo-declare nnslashdot) 38 (nnoo-declare nnslashdot)
46 39
47 (defvoo nnslashdot-directory (nnheader-concat gnus-directory "slashdot/") 40 (defvoo nnslashdot-directory (nnheader-concat gnus-directory "slashdot/")
48 "Where nnslashdot will save its files.") 41 "Where nnslashdot will save its files.")
57 "http://slashdot.org/article.pl?sid=%s&mode=nocomment" 50 "http://slashdot.org/article.pl?sid=%s&mode=nocomment"
58 "Where nnslashdot will fetch the article from.") 51 "Where nnslashdot will fetch the article from.")
59 52
60 (defvoo nnslashdot-backslash-url "http://slashdot.org/slashdot.xml" 53 (defvoo nnslashdot-backslash-url "http://slashdot.org/slashdot.xml"
61 "Where nnslashdot will fetch the stories from.") 54 "Where nnslashdot will fetch the stories from.")
55
56 (defvoo nnslashdot-use-front-page nil
57 "Use the front page in addition to the backslash page.")
62 58
63 (defvoo nnslashdot-threshold -1 59 (defvoo nnslashdot-threshold -1
64 "The article threshold.") 60 "The article threshold.")
65 61
66 (defvoo nnslashdot-threaded t 62 (defvoo nnslashdot-threaded t
103 (save-excursion 99 (save-excursion
104 (set-buffer nnslashdot-buffer) 100 (set-buffer nnslashdot-buffer)
105 (let ((case-fold-search t)) 101 (let ((case-fold-search t))
106 (erase-buffer) 102 (erase-buffer)
107 (when (= start 1) 103 (when (= start 1)
108 (nnweb-insert (format nnslashdot-article-url 104 (mm-url-insert (format nnslashdot-article-url sid) t)
109 (nnslashdot-sid-strip sid)) t)
110 (goto-char (point-min)) 105 (goto-char (point-min))
106 (if (eobp)
107 (error "Couldn't open connection to slashdot"))
111 (re-search-forward "Posted by[ \t\r\n]+") 108 (re-search-forward "Posted by[ \t\r\n]+")
112 (when (looking-at "\\(<a[^>]+>\\)?[ \t\r\n]*\\([^<\r\n]+\\)") 109 (when (looking-at "\\(<a[^>]+>\\)?[ \t\r\n]*\\([^<\r\n]+\\)")
113 (setq from (nnweb-decode-entities-string (match-string 2)))) 110 (setq from (mm-url-decode-entities-string (match-string 2))))
114 (search-forward "on ") 111 (search-forward "on ")
115 (setq date (nnslashdot-date-to-date 112 (setq date (nnslashdot-date-to-date
116 (buffer-substring (point) (1- (search-forward "<"))))) 113 (buffer-substring (point) (1- (search-forward "<")))))
117 (setq lines (/ (- (point) 114 (setq lines (/ (- (point)
118 (progn (forward-line 1) (point))) 115 (progn (forward-line 1) (point)))
120 (push 117 (push
121 (cons 118 (cons
122 1 119 1
123 (make-full-mail-header 120 (make-full-mail-header
124 1 group from date 121 1 group from date
125 (concat "<" (nnslashdot-sid-strip sid) "%1@slashdot>") 122 (concat "<" sid "%1@slashdot>")
126 "" 0 lines nil nil)) 123 "" 0 lines nil nil))
127 headers) 124 headers)
128 (setq start (if nnslashdot-threaded 2 (pop articles)))) 125 (setq start (if nnslashdot-threaded 2 (pop articles))))
129 (while (and start (<= start last)) 126 (while (and start (<= start last))
130 (setq point (goto-char (point-max))) 127 (setq point (goto-char (point-max)))
131 (nnweb-insert 128 (mm-url-insert
132 (format nnslashdot-comments-url 129 (format nnslashdot-comments-url sid
133 (nnslashdot-sid-strip sid)
134 nnslashdot-threshold 0 (- start 2)) 130 nnslashdot-threshold 0 (- start 2))
135 t) 131 t)
136 (when (and nnslashdot-threaded first-comments) 132 (when (and nnslashdot-threaded first-comments)
137 (setq first-comments nil) 133 (setq first-comments nil)
138 (goto-char (point-max)) 134 (goto-char (point-max))
152 (unless (assq article (nth 4 entry)) 148 (unless (assq article (nth 4 entry))
153 (setcar (nthcdr 4 entry) (cons (cons article cid) (nth 4 entry))) 149 (setcar (nthcdr 4 entry) (cons (cons article cid) (nth 4 entry)))
154 (setq changed t)) 150 (setq changed t))
155 (when (string-match "^Re: *" subject) 151 (when (string-match "^Re: *" subject)
156 (setq subject (concat "Re: " (substring subject (match-end 0))))) 152 (setq subject (concat "Re: " (substring subject (match-end 0)))))
157 (setq subject (nnweb-decode-entities-string subject)) 153 (setq subject (mm-url-decode-entities-string subject))
158 (search-forward "<BR>") 154 (search-forward "<BR>")
159 (if (looking-at 155 (cond
160 "by[ \t\n]+<a[^>]+>\\([^<]+\\)</a>[ \t\n]*(\\(<[^>]+>\\)*\\([^<>)]+\\))") 156 ((looking-at
161 (progn 157 "by[ \t\n]+<a[^>]+>\\([^<]+\\)</a>[ \t\n]*(\\(<[^>]+>\\)*\\([^<>)]+\\))")
162 (goto-char (- (match-end 0) 5)) 158 (goto-char (- (match-end 0) 5))
163 (setq from (concat 159 (setq from (concat
164 (nnweb-decode-entities-string (match-string 1)) 160 (mm-url-decode-entities-string (match-string 1))
165 " <" (match-string 3) ">"))) 161 " <" (match-string 3) ">")))
166 (setq from "") 162 ((looking-at "by[ \t\n]+<a[^>]+>\\([^<(]+\\) (\\([0-9]+\\))</a>")
167 (when (looking-at "by \\([^<>]*\\) on ") 163 (goto-char (- (match-end 0) 5))
168 (goto-char (- (match-end 0) 5)) 164 (setq from (concat
169 (setq from (nnweb-decode-entities-string (match-string 1))))) 165 (mm-url-decode-entities-string (match-string 1))
170 (search-forward " on ") 166 " <" (match-string 2) ">")))
167 ((looking-at "by \\([^<>]*\\)[\t\n\r ]+on ")
168 (goto-char (- (match-end 0) 5))
169 (setq from (mm-url-decode-entities-string (match-string 1))))
170 (t
171 (setq from "")))
172 (search-forward "on ")
171 (setq date 173 (setq date
172 (nnslashdot-date-to-date 174 (nnslashdot-date-to-date
173 (buffer-substring (point) (progn (skip-chars-forward "^()<>\n\r") (point))))) 175 (buffer-substring (point) (progn (skip-chars-forward "^()<>\n\r") (point)))))
174 (setq lines (/ (abs (- (search-forward "<td") 176 (setq lines (/ (abs (- (search-forward "<td")
175 (search-forward "</td>"))) 177 (search-forward "</td>")))
185 article 187 article
186 (make-full-mail-header 188 (make-full-mail-header
187 article 189 article
188 (concat subject " (" score ")") 190 (concat subject " (" score ")")
189 from date 191 from date
190 (concat "<" (nnslashdot-sid-strip sid) "%" cid "@slashdot>") 192 (concat "<" sid "%" cid "@slashdot>")
191 (if parent 193 (if parent
192 (concat "<" (nnslashdot-sid-strip sid) "%" 194 (concat "<" sid "%" parent "@slashdot>")
193 parent "@slashdot>")
194 "") 195 "")
195 0 lines nil nil)) 196 0 lines nil nil))
196 headers) 197 headers)
197 (while (and articles (<= (car articles) article)) 198 (while (and articles (<= (car articles) article))
198 (pop articles)) 199 (pop articles))
258 (setq contents 259 (setq contents
259 (buffer-substring 260 (buffer-substring
260 (point) 261 (point)
261 (progn 262 (progn
262 (re-search-forward 263 (re-search-forward
263 "&lt;&nbsp;[ \t\r\n]*<A HREF=\"\\(\\(http:\\)?//slashdot\\.org\\)?/article") 264 "<IFRAME\\|<SCRIPT LANGUAGE=\"JAVASCRIPT\">\\|<!-- no ad 6 -->\\|&lt;&nbsp;[ \t\r\n]*<A HREF=\"\\(\\(http:\\)?//slashdot\\.org\\)?/article")
264 (match-beginning 0))))) 265 (match-beginning 0)))))
265 (setq cid (cdr (assq article 266 (setq cid (cdr (assq article
266 (nth 4 (assoc group nnslashdot-groups))))) 267 (nth 4 (assoc group nnslashdot-groups)))))
267 (search-forward (format "<a name=\"%s\">" cid)) 268 (search-forward (format "<a name=\"%s\">" cid))
268 (setq contents 269 (setq contents
298 (nnoo-close-server 'nnslashdot server)) 299 (nnoo-close-server 'nnslashdot server))
299 300
300 (deffoo nnslashdot-request-list (&optional server) 301 (deffoo nnslashdot-request-list (&optional server)
301 (nnslashdot-possibly-change-server nil server) 302 (nnslashdot-possibly-change-server nil server)
302 (let ((number 0) 303 (let ((number 0)
304 (first nnslashdot-use-front-page)
303 sid elem description articles gname) 305 sid elem description articles gname)
304 (condition-case why 306 (condition-case why
305 ;; First we do the Ultramode to get info on all the latest groups. 307 ;; First we do the Ultramode to get info on all the latest groups.
306 (progn 308 (progn
307 (mm-with-unibyte-buffer 309 (mm-with-unibyte-buffer
308 (nnweb-insert nnslashdot-backslash-url t) 310 (mm-url-insert nnslashdot-backslash-url t)
309 (goto-char (point-min)) 311 (goto-char (point-min))
312 (if (eobp)
313 (error "Couldn't open connection to slashdot"))
310 (while (search-forward "<story>" nil t) 314 (while (search-forward "<story>" nil t)
311 (narrow-to-region (point) (search-forward "</story>")) 315 (narrow-to-region (point) (search-forward "</story>"))
312 (goto-char (point-min)) 316 (goto-char (point-min))
313 (re-search-forward "<title>\\([^<]+\\)</title>") 317 (re-search-forward "<title>\\([^<]+\\)</title>")
314 (setq description 318 (setq description
315 (nnweb-decode-entities-string (match-string 1))) 319 (mm-url-decode-entities-string (match-string 1)))
316 (re-search-forward "<url>\\([^<]+\\)</url>") 320 (re-search-forward "<url>\\([^<]+\\)</url>")
317 (setq sid (match-string 1)) 321 (setq sid (match-string 1))
318 (string-match "sid=\\([0-9/]+\\)\\(.shtml\\|$\\)" sid) 322 (string-match "sid=\\([0-9/]+\\)\\(.shtml\\|$\\)" sid)
319 (setq sid (match-string 1 sid)) 323 (setq sid (match-string 1 sid))
320 (re-search-forward "<comments>\\([^<]+\\)</comments>") 324 (re-search-forward "<comments>\\([^<]+\\)</comments>")
325 (push (list gname articles sid (current-time) nil) 329 (push (list gname articles sid (current-time) nil)
326 nnslashdot-groups)) 330 nnslashdot-groups))
327 (goto-char (point-max)) 331 (goto-char (point-max))
328 (widen))) 332 (widen)))
329 ;; Then do the older groups. 333 ;; Then do the older groups.
330 (while (> (- nnslashdot-group-number number) 0) 334 (while (or first
335 (> (- nnslashdot-group-number number) 0))
336 (setq first nil)
331 (mm-with-unibyte-buffer 337 (mm-with-unibyte-buffer
332 (let ((case-fold-search t)) 338 (let ((case-fold-search t))
333 (nnweb-insert (format nnslashdot-active-url number) t) 339 (mm-url-insert (format nnslashdot-active-url number) t)
334 (goto-char (point-min)) 340 (goto-char (point-min))
335 (while (re-search-forward 341 (while (re-search-forward
336 "article.pl\\?sid=\\([^&]+\\).*<b>\\([^<]+\\)</b>" 342 "article.pl\\?sid=\\([^&]+\\).*>\\([^<]+\\)</a>"
337 nil t) 343 nil t)
338 (setq sid (match-string 1) 344 (setq sid (match-string 1)
339 description 345 description
340 (nnweb-decode-entities-string (match-string 2))) 346 (mm-url-decode-entities-string (match-string 2)))
341 (forward-line 1) 347 (forward-line 1)
342 (when (re-search-forward "<b>\\([0-9]+\\)</b>" nil t) 348 (when (re-search-forward "with \\([0-9]+\\) comment" nil t)
343 (setq articles (string-to-number (match-string 1)))) 349 (setq articles (1+ (string-to-number (match-string 1)))))
344 (setq gname (concat description " (" sid ")")) 350 (setq gname (concat description " (" sid ")"))
345 (if (setq elem (assoc gname nnslashdot-groups)) 351 (if (setq elem (assoc gname nnslashdot-groups))
346 (setcar (cdr elem) articles) 352 (setcar (cdr elem) articles)
347 (push (list gname articles sid (current-time) nil) 353 (push (list gname articles sid (current-time) nil)
348 nnslashdot-groups))))) 354 nnslashdot-groups)))))
357 (nnslashdot-generate-active) 363 (nnslashdot-generate-active)
358 t) 364 t)
359 365
360 (deffoo nnslashdot-request-post (&optional server) 366 (deffoo nnslashdot-request-post (&optional server)
361 (nnslashdot-possibly-change-server nil server) 367 (nnslashdot-possibly-change-server nil server)
362 (let ((sid (nnslashdot-sid-strip (message-fetch-field "newsgroups"))) 368 (let ((sid (message-fetch-field "newsgroups"))
363 (subject (message-fetch-field "subject")) 369 (subject (message-fetch-field "subject"))
364 (references (car (last (split-string 370 (references (car (last (split-string
365 (message-fetch-field "references"))))) 371 (message-fetch-field "references")))))
366 body quoted pid) 372 body quoted pid)
367 (string-match "%\\([0-9]+\\)@slashdot" references) 373 (string-match "%\\([0-9]+\\)@slashdot" references)
392 (insert "<br>") 398 (insert "<br>")
393 (forward-line 1))) 399 (forward-line 1)))
394 (message-goto-body) 400 (message-goto-body)
395 (setq body (buffer-substring (point) (point-max))) 401 (setq body (buffer-substring (point) (point-max)))
396 (erase-buffer) 402 (erase-buffer)
397 (nnweb-fetch-form 403 (mm-url-fetch-form
398 "http://slashdot.org/comments.pl" 404 "http://slashdot.org/comments.pl"
399 `(("sid" . ,sid) 405 `(("sid" . ,sid)
400 ("pid" . ,pid) 406 ("pid" . ,pid)
401 ("rlogin" . "userlogin") 407 ("rlogin" . "userlogin")
402 ("unickname" . ,nnslashdot-login-name) 408 ("unickname" . ,nnslashdot-login-name)
497 (defun nnslashdot-generate-active () 503 (defun nnslashdot-generate-active ()
498 (save-excursion 504 (save-excursion
499 (set-buffer nntp-server-buffer) 505 (set-buffer nntp-server-buffer)
500 (erase-buffer) 506 (erase-buffer)
501 (dolist (elem nnslashdot-groups) 507 (dolist (elem nnslashdot-groups)
502 (insert (prin1-to-string (car elem)) 508 (when (numberp (cadr elem))
503 " " (number-to-string (cadr elem)) " 1 y\n")))) 509 (insert (prin1-to-string (car elem))
510 " " (number-to-string (cadr elem)) " 1 y\n")))))
504 511
505 (defun nnslashdot-lose (why) 512 (defun nnslashdot-lose (why)
506 (error "Slashdot HTML has changed; please get a new version of nnslashdot")) 513 (error "Slashdot HTML has changed; please get a new version of nnslashdot"))
507 514
508 (defalias 'nnslashdot-sid-strip 'identity)
509
510 (provide 'nnslashdot) 515 (provide 'nnslashdot)
511 516
512 ;;; arch-tag: aa73df7a-f7e6-4eef-bdea-5ce2f8c691b3 517 ;;; arch-tag: aa73df7a-f7e6-4eef-bdea-5ce2f8c691b3
513 ;;; nnslashdot.el ends here 518 ;;; nnslashdot.el ends here