Mercurial > emacs

comparison lisp/gnus/nnslashdot.el @ 88155:d7ddb3e565de

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
sync with trunk
author Henrik Enberg <henrik.enberg@telia.com>
date Mon, 16 Jan 2006 00:03:54 +0000
parents 0d8b17d428b5
children
comparison
equal deleted inserted replaced
88154:8ce476d3ba36 88155:d7ddb3e565de
1 ;;; nnslashdot.el --- interfacing with Slashdot 1 ;;; nnslashdot.el --- interfacing with Slashdot
2 ;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. 2
3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005 Free Software Foundation, Inc.
3 5
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5 ;; Keywords: news 7 ;; Keywords: news
6 8
7 ;; This file is part of GNU Emacs. 9 ;; This file is part of GNU Emacs.
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details. 19 ;; GNU General Public License for more details.
18 20
19 ;; You should have received a copy of the GNU General Public License 21 ;; 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 22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
22 ;; Boston, MA 02111-1307, USA. 24 ;; Boston, MA 02110-1301, USA.
23 25
24 ;;; Commentary: 26 ;;; Commentary:
25
26 ;; Note: You need to have `url' and `w3' installed for this
27 ;; backend to work.
28 27
29 ;;; Code: 28 ;;; Code:
30 29
31 (eval-when-compile (require 'cl)) 30 (eval-when-compile (require 'cl))
32 31
34 (require 'message) 33 (require 'message)
35 (require 'gnus-util) 34 (require 'gnus-util)
36 (require 'gnus) 35 (require 'gnus)
37 (require 'nnmail) 36 (require 'nnmail)
38 (require 'mm-util) 37 (require 'mm-util)
39 (eval-when-compile 38 (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 39
45 (nnoo-declare nnslashdot) 40 (nnoo-declare nnslashdot)
46 41
47 (defvoo nnslashdot-directory (nnheader-concat gnus-directory "slashdot/") 42 (defvoo nnslashdot-directory (nnheader-concat gnus-directory "slashdot/")
48 "Where nnslashdot will save its files.") 43 "Where nnslashdot will save its files.")
57 "http://slashdot.org/article.pl?sid=%s&mode=nocomment" 52 "http://slashdot.org/article.pl?sid=%s&mode=nocomment"
58 "Where nnslashdot will fetch the article from.") 53 "Where nnslashdot will fetch the article from.")
59 54
60 (defvoo nnslashdot-backslash-url "http://slashdot.org/slashdot.xml" 55 (defvoo nnslashdot-backslash-url "http://slashdot.org/slashdot.xml"
61 "Where nnslashdot will fetch the stories from.") 56 "Where nnslashdot will fetch the stories from.")
57
58 (defvoo nnslashdot-use-front-page nil
59 "Use the front page in addition to the backslash page.")
62 60
63 (defvoo nnslashdot-threshold -1 61 (defvoo nnslashdot-threshold -1
64 "The article threshold.") 62 "The article threshold.")
65 63
66 (defvoo nnslashdot-threaded t 64 (defvoo nnslashdot-threaded t
87 85
88 (deffoo nnslashdot-retrieve-headers (articles &optional group server fetch-old) 86 (deffoo nnslashdot-retrieve-headers (articles &optional group server fetch-old)
89 (nnslashdot-possibly-change-server group server) 87 (nnslashdot-possibly-change-server group server)
90 (condition-case why 88 (condition-case why
91 (unless gnus-nov-is-evil 89 (unless gnus-nov-is-evil
92 (nnslashdot-retrieve-headers-1 articles group)) 90 (nnslashdot-retrieve-headers-1 articles group))
93 (search-failed (nnslashdot-lose why)))) 91 (search-failed (nnslashdot-lose why))))
94 92
95 (deffoo nnslashdot-retrieve-headers-1 (articles group) 93 (deffoo nnslashdot-retrieve-headers-1 (articles group)
96 (let* ((last (car (last articles))) 94 (let* ((last (car (last articles)))
97 (start (if nnslashdot-threaded 1 (pop articles))) 95 (start (if nnslashdot-threaded 1 (pop articles)))
103 (save-excursion 101 (save-excursion
104 (set-buffer nnslashdot-buffer) 102 (set-buffer nnslashdot-buffer)
105 (let ((case-fold-search t)) 103 (let ((case-fold-search t))
106 (erase-buffer) 104 (erase-buffer)
107 (when (= start 1) 105 (when (= start 1)
108 (nnweb-insert (format nnslashdot-article-url 106 (mm-url-insert (format nnslashdot-article-url sid) t)
109 (nnslashdot-sid-strip sid)) t)
110 (goto-char (point-min)) 107 (goto-char (point-min))
108 (if (eobp)
109 (error "Couldn't open connection to slashdot"))
111 (re-search-forward "Posted by[ \t\r\n]+") 110 (re-search-forward "Posted by[ \t\r\n]+")
112 (when (looking-at "\\(<a[^>]+>\\)?[ \t\r\n]*\\([^<\r\n]+\\)") 111 (when (looking-at "\\(<a[^>]+>\\)?[ \t\r\n]*\\([^<\r\n]+\\)")
113 (setq from (nnweb-decode-entities-string (match-string 2)))) 112 (setq from (mm-url-decode-entities-string (match-string 2))))
114 (search-forward "on ") 113 (search-forward "on ")
115 (setq date (nnslashdot-date-to-date 114 (setq date (nnslashdot-date-to-date
116 (buffer-substring (point) (1- (search-forward "<"))))) 115 (buffer-substring (point) (1- (search-forward "<")))))
117 (setq lines (/ (- (point) 116 (setq lines (/ (- (point)
118 (progn (forward-line 1) (point))) 117 (progn (forward-line 1) (point)))
120 (push 119 (push
121 (cons 120 (cons
122 1 121 1
123 (make-full-mail-header 122 (make-full-mail-header
124 1 group from date 123 1 group from date
125 (concat "<" (nnslashdot-sid-strip sid) "%1@slashdot>") 124 (concat "<" sid "%1@slashdot>")
126 "" 0 lines nil nil)) 125 "" 0 lines nil nil))
127 headers) 126 headers)
128 (setq start (if nnslashdot-threaded 2 (pop articles)))) 127 (setq start (if nnslashdot-threaded 2 (pop articles))))
129 (while (and start (<= start last)) 128 (while (and start (<= start last))
130 (setq point (goto-char (point-max))) 129 (setq point (goto-char (point-max)))
131 (nnweb-insert 130 (mm-url-insert
132 (format nnslashdot-comments-url 131 (format nnslashdot-comments-url sid
133 (nnslashdot-sid-strip sid)
134 nnslashdot-threshold 0 (- start 2)) 132 nnslashdot-threshold 0 (- start 2))
135 t) 133 t)
136 (when (and nnslashdot-threaded first-comments) 134 (when (and nnslashdot-threaded first-comments)
137 (setq first-comments nil) 135 (setq first-comments nil)
138 (goto-char (point-max)) 136 (goto-char (point-max))
142 (push s startats))) 140 (push s startats)))
143 (setq startats (sort startats '<))) 141 (setq startats (sort startats '<)))
144 (setq article (if (and article (< start article)) article start)) 142 (setq article (if (and article (< start article)) article start))
145 (goto-char point) 143 (goto-char point)
146 (while (re-search-forward 144 (while (re-search-forward
147 "<a name=\"\\([0-9]+\\)\"><\\(b\\|H4\\)>\\([^<]+\\)</\\(b\\|H4\\)>.*score:\\([^)]+\\))" 145 "<a name=\"\\([0-9]+\\)\">\\([^<]+\\)</a>.*\n.*score:\\([^)]+\\))"
148 nil t) 146 nil t)
149 (setq cid (match-string 1) 147 (setq cid (match-string 1)
150 subject (match-string 3) 148 subject (match-string 2)
151 score (match-string 5)) 149 score (match-string 3))
152 (unless (assq article (nth 4 entry)) 150 (unless (assq article (nth 4 entry))
153 (setcar (nthcdr 4 entry) (cons (cons article cid) (nth 4 entry))) 151 (setcar (nthcdr 4 entry) (cons (cons article cid) (nth 4 entry)))
154 (setq changed t)) 152 (setq changed t))
155 (when (string-match "^Re: *" subject) 153 (when (string-match "^Re: *" subject)
156 (setq subject (concat "Re: " (substring subject (match-end 0))))) 154 (setq subject (concat "Re: " (substring subject (match-end 0)))))
157 (setq subject (nnweb-decode-entities-string subject)) 155 (setq subject (mm-url-decode-entities-string subject)
158 (search-forward "<BR>") 156 from "")
159 (if (looking-at 157 (when (re-search-forward "by[ \t\n]+<[^>]+>\\([^<(]+\\)" nil t)
160 "by[ \t\n]+<a[^>]+>\\([^<]+\\)</a>[ \t\n]*(\\(<[^>]+>\\)*\\([^<>)]+\\))") 158 (setq from
161 (progn 159 (concat
162 (goto-char (- (match-end 0) 5)) 160 (mm-url-decode-entities-string (match-string 1))
163 (setq from (concat 161 " <nobody@slashdot.org>")))
164 (nnweb-decode-entities-string (match-string 1)) 162 (search-forward "on ")
165 " <" (match-string 3) ">")))
166 (setq from "")
167 (when (looking-at "by \\([^<>]*\\) on ")
168 (goto-char (- (match-end 0) 5))
169 (setq from (nnweb-decode-entities-string (match-string 1)))))
170 (search-forward " on ")
171 (setq date 163 (setq date
172 (nnslashdot-date-to-date 164 (nnslashdot-date-to-date
173 (buffer-substring (point) (progn (skip-chars-forward "^()<>\n\r") (point))))) 165 (buffer-substring
174 (setq lines (/ (abs (- (search-forward "<td") 166 (point) (progn (skip-chars-forward "^()<>\n\r") (point)))))
175 (search-forward "</td>"))) 167 (setq lines (/ (abs (- (search-forward "<div")
168 (search-forward "</div>")))
176 70)) 169 70))
177 (if (not 170 (if (not
178 (re-search-forward ".*cid=\\([0-9]+\\)\">Parent</A>" nil t)) 171 (re-search-forward ".*cid=\\([0-9]+\\)\">Parent</A>" nil t))
179 (setq parent nil) 172 (setq parent nil)
180 (setq parent (match-string 1)) 173 (setq parent (match-string 1))
185 article 178 article
186 (make-full-mail-header 179 (make-full-mail-header
187 article 180 article
188 (concat subject " (" score ")") 181 (concat subject " (" score ")")
189 from date 182 from date
190 (concat "<" (nnslashdot-sid-strip sid) "%" cid "@slashdot>") 183 (concat "<" sid "%" cid "@slashdot>")
191 (if parent 184 (if parent
192 (concat "<" (nnslashdot-sid-strip sid) "%" 185 (concat "<" sid "%" parent "@slashdot>")
193 parent "@slashdot>")
194 "") 186 "")
195 0 lines nil nil)) 187 0 lines nil nil))
196 headers) 188 headers)
197 (while (and articles (<= (car articles) article)) 189 (while (and articles (<= (car articles) article))
198 (pop articles)) 190 (pop articles))
250 map nil) 242 map nil)
251 (setq map (cdr map)))))) 243 (setq map (cdr map))))))
252 (when (numberp article) 244 (when (numberp article)
253 (if (= article 1) 245 (if (= article 1)
254 (progn 246 (progn
255 (re-search-forward 247 (search-forward "Posted by")
256 "Posted by") 248 (search-forward "<div class=\"intro\">")
257 (search-forward "<BR>")
258 (setq contents 249 (setq contents
259 (buffer-substring 250 (buffer-substring
260 (point) 251 (point)
261 (progn 252 (progn
262 (re-search-forward 253 (search-forward "commentwrap")
263 "&lt;&nbsp;[ \t\r\n]*<A HREF=\"\\(\\(http:\\)?//slashdot\\.org\\)?/article")
264 (match-beginning 0))))) 254 (match-beginning 0)))))
265 (setq cid (cdr (assq article 255 (setq cid (cdr (assq article
266 (nth 4 (assoc group nnslashdot-groups))))) 256 (nth 4 (assoc group nnslashdot-groups)))))
267 (search-forward (format "<a name=\"%s\">" cid)) 257 (search-forward (format "<a name=\"%s\">" cid))
268 (setq contents 258 (setq contents
269 (buffer-substring 259 (buffer-substring
270 (re-search-forward "<td[^>]*>") 260 (search-forward "<div class=\"commentBody\">")
271 (search-forward "</td>"))))))) 261 (search-forward "</div>")))))))
272 (search-failed (nnslashdot-lose why))) 262 (search-failed (nnslashdot-lose why)))
273 263
274 (when contents 264 (when contents
275 (save-excursion 265 (save-excursion
276 (set-buffer (or buffer nntp-server-buffer)) 266 (set-buffer (or buffer nntp-server-buffer))
298 (nnoo-close-server 'nnslashdot server)) 288 (nnoo-close-server 'nnslashdot server))
299 289
300 (deffoo nnslashdot-request-list (&optional server) 290 (deffoo nnslashdot-request-list (&optional server)
301 (nnslashdot-possibly-change-server nil server) 291 (nnslashdot-possibly-change-server nil server)
302 (let ((number 0) 292 (let ((number 0)
293 (first nnslashdot-use-front-page)
303 sid elem description articles gname) 294 sid elem description articles gname)
304 (condition-case why 295 (condition-case why
305 ;; First we do the Ultramode to get info on all the latest groups. 296 ;; First we do the Ultramode to get info on all the latest groups.
306 (progn 297 (progn
307 (mm-with-unibyte-buffer 298 (mm-with-unibyte-buffer
308 (nnweb-insert nnslashdot-backslash-url t) 299 (mm-url-insert nnslashdot-backslash-url t)
309 (goto-char (point-min)) 300 (goto-char (point-min))
301 (if (eobp)
302 (error "Couldn't open connection to slashdot"))
310 (while (search-forward "<story>" nil t) 303 (while (search-forward "<story>" nil t)
311 (narrow-to-region (point) (search-forward "</story>")) 304 (narrow-to-region (point) (search-forward "</story>"))
312 (goto-char (point-min)) 305 (goto-char (point-min))
313 (re-search-forward "<title>\\([^<]+\\)</title>") 306 (re-search-forward "<title>\\([^<]+\\)</title>")
314 (setq description 307 (setq description
315 (nnweb-decode-entities-string (match-string 1))) 308 (mm-url-decode-entities-string (match-string 1)))
316 (re-search-forward "<url>\\([^<]+\\)</url>") 309 (re-search-forward "<url>\\([^<]+\\)</url>")
317 (setq sid (match-string 1)) 310 (setq sid (match-string 1))
318 (string-match "sid=\\([0-9/]+\\)\\(.shtml\\|$\\)" sid) 311 (string-match "sid=\\([0-9/]+\\)\\(.shtml\\|$\\)" sid)
319 (setq sid (match-string 1 sid)) 312 (setq sid (match-string 1 sid))
320 (re-search-forward "<comments>\\([^<]+\\)</comments>") 313 (re-search-forward "<comments>\\([^<]+\\)</comments>")
325 (push (list gname articles sid (current-time) nil) 318 (push (list gname articles sid (current-time) nil)
326 nnslashdot-groups)) 319 nnslashdot-groups))
327 (goto-char (point-max)) 320 (goto-char (point-max))
328 (widen))) 321 (widen)))
329 ;; Then do the older groups. 322 ;; Then do the older groups.
330 (while (> (- nnslashdot-group-number number) 0) 323 (while (or first
324 (> (- nnslashdot-group-number number) 0))
325 (setq first nil)
331 (mm-with-unibyte-buffer 326 (mm-with-unibyte-buffer
332 (let ((case-fold-search t)) 327 (let ((case-fold-search t))
333 (nnweb-insert (format nnslashdot-active-url number) t) 328 (mm-url-insert (format nnslashdot-active-url number) t)
334 (goto-char (point-min)) 329 (goto-char (point-min))
335 (while (re-search-forward 330 (while (re-search-forward
336 "article.pl\\?sid=\\([^&]+\\).*<b>\\([^<]+\\)</b>" 331 "article.pl\\?sid=\\([^&]+\\).*>\\([^<]+\\)</a>"
337 nil t) 332 nil t)
338 (setq sid (match-string 1) 333 (setq sid (match-string 1)
339 description 334 description
340 (nnweb-decode-entities-string (match-string 2))) 335 (mm-url-decode-entities-string (match-string 2)))
341 (forward-line 1) 336 (forward-line 1)
342 (when (re-search-forward "<b>\\([0-9]+\\)</b>" nil t) 337 (when (re-search-forward "with \\([0-9]+\\) comment" nil t)
343 (setq articles (string-to-number (match-string 1)))) 338 (setq articles (1+ (string-to-number (match-string 1)))))
344 (setq gname (concat description " (" sid ")")) 339 (setq gname (concat description " (" sid ")"))
345 (if (setq elem (assoc gname nnslashdot-groups)) 340 (if (setq elem (assoc gname nnslashdot-groups))
346 (setcar (cdr elem) articles) 341 (setcar (cdr elem) articles)
347 (push (list gname articles sid (current-time) nil) 342 (push (list gname articles sid (current-time) nil)
348 nnslashdot-groups))))) 343 nnslashdot-groups)))))
357 (nnslashdot-generate-active) 352 (nnslashdot-generate-active)
358 t) 353 t)
359 354
360 (deffoo nnslashdot-request-post (&optional server) 355 (deffoo nnslashdot-request-post (&optional server)
361 (nnslashdot-possibly-change-server nil server) 356 (nnslashdot-possibly-change-server nil server)
362 (let ((sid (nnslashdot-sid-strip (message-fetch-field "newsgroups"))) 357 (let ((sid (message-fetch-field "newsgroups"))
363 (subject (message-fetch-field "subject")) 358 (subject (message-fetch-field "subject"))
364 (references (car (last (split-string 359 (references (car (last (split-string
365 (message-fetch-field "references"))))) 360 (message-fetch-field "references")))))
366 body quoted pid) 361 body quoted pid)
367 (string-match "%\\([0-9]+\\)@slashdot" references) 362 (string-match "%\\([0-9]+\\)@slashdot" references)
392 (insert "<br>") 387 (insert "<br>")
393 (forward-line 1))) 388 (forward-line 1)))
394 (message-goto-body) 389 (message-goto-body)
395 (setq body (buffer-substring (point) (point-max))) 390 (setq body (buffer-substring (point) (point-max)))
396 (erase-buffer) 391 (erase-buffer)
397 (nnweb-fetch-form 392 (mm-url-fetch-form
398 "http://slashdot.org/comments.pl" 393 "http://slashdot.org/comments.pl"
399 `(("sid" . ,sid) 394 `(("sid" . ,sid)
400 ("pid" . ,pid) 395 ("pid" . ,pid)
401 ("rlogin" . "userlogin") 396 ("rlogin" . "userlogin")
402 ("unickname" . ,nnslashdot-login-name) 397 ("unickname" . ,nnslashdot-login-name)
497 (defun nnslashdot-generate-active () 492 (defun nnslashdot-generate-active ()
498 (save-excursion 493 (save-excursion
499 (set-buffer nntp-server-buffer) 494 (set-buffer nntp-server-buffer)
500 (erase-buffer) 495 (erase-buffer)
501 (dolist (elem nnslashdot-groups) 496 (dolist (elem nnslashdot-groups)
502 (insert (prin1-to-string (car elem)) 497 (when (numberp (cadr elem))
503 " " (number-to-string (cadr elem)) " 1 y\n")))) 498 (insert (prin1-to-string (car elem))
499 " " (number-to-string (cadr elem)) " 1 y\n")))))
504 500
505 (defun nnslashdot-lose (why) 501 (defun nnslashdot-lose (why)
506 (error "Slashdot HTML has changed; please get a new version of nnslashdot")) 502 (error "Slashdot HTML has changed; please get a new version of nnslashdot"))
507 503
508 (defalias 'nnslashdot-sid-strip 'identity)
509
510 (provide 'nnslashdot) 504 (provide 'nnslashdot)
511 505
506 ;;; arch-tag: aa73df7a-f7e6-4eef-bdea-5ce2f8c691b3
512 ;;; nnslashdot.el ends here 507 ;;; nnslashdot.el ends here