Mercurial > emacs
comparison lisp/gnus/nnslashdot.el @ 82951:0fde48feb604
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 "< [ \t\r\n]*<A HREF=\"\\(\\(http:\\)?//slashdot\\.org\\)?/article") | 264 "<IFRAME\\|<SCRIPT LANGUAGE=\"JAVASCRIPT\">\\|<!-- no ad 6 -->\\|< [ \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 |