HCoop / bpt / emacs.git / blame
| Commit | Line | Data |
|---|---|---|
| c113de23 GM |
1 | ;;; nnslashdot.el --- interfacing with Slashdot |
| 2 | ;; Copyright (C) 1999, 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 | (eval-when-compile | |
| 40 | (ignore-errors | |
| 41 | (require 'nnweb))) | |
| 42 | ;; Report failure to find w3 at load time if appropriate. | |
| 43 | (eval '(require 'nnweb)) | |
| 44 | ||
| 45 | (nnoo-declare nnslashdot) | |
| 46 | ||
| 47 | (defvoo nnslashdot-directory (nnheader-concat gnus-directory "slashdot/") | |
| 48 | "Where nnslashdot will save its files.") | |
| 49 | ||
| 50 | (defvoo nnslashdot-active-url "http://slashdot.org/search.pl?section=&min=%d" | |
| 51 | "Where nnslashdot will fetch the active file from.") | |
| 52 | ||
| 53 | (defvoo nnslashdot-comments-url "http://slashdot.org/comments.pl?sid=%s&threshold=%d&commentsort=%d&mode=flat&startat=%d" | |
| 54 | "Where nnslashdot will fetch comments from.") | |
| 55 | ||
| 56 | (defvoo nnslashdot-article-url | |
| 57 | "http://slashdot.org/article.pl?sid=%s&mode=nocomment" | |
| 58 | "Where nnslashdot will fetch the article from.") | |
| 59 | ||
| 60 | (defvoo nnslashdot-threshold -1 | |
| 61 | "The article threshold.") | |
| 62 | ||
| 63 | (defvoo nnslashdot-threaded t | |
| 64 | "Whether the nnslashdot groups should be threaded or not.") | |
| 65 | ||
| 66 | (defvoo nnslashdot-group-number 0 | |
| 67 | "The number of non-fresh groups to keep updated.") | |
| 68 | ||
| 69 | (defvoo nnslashdot-login-name "" | |
| 70 | "The login name to use when posting.") | |
| 71 | ||
| 72 | (defvoo nnslashdot-password "" | |
| 73 | "The password to use when posting.") | |
| 74 | ||
| 75 | ;;; Internal variables | |
| 76 | ||
| 77 | (defvar nnslashdot-groups nil) | |
| 78 | (defvar nnslashdot-buffer nil) | |
| 79 | (defvar nnslashdot-headers nil) | |
| 80 | ||
| 81 | ;;; Interface functions | |
| 82 | ||
| 83 | (nnoo-define-basics nnslashdot) | |
| 84 | ||
| 85 | (deffoo nnslashdot-retrieve-headers (articles &optional group server fetch-old) | |
| 86 | (nnslashdot-possibly-change-server group server) | |
| 87 | (condition-case why | |
| 88 | (unless gnus-nov-is-evil | |
| 89 | (if nnslashdot-threaded | |
| 90 | (nnslashdot-threaded-retrieve-headers articles group) | |
| 91 | (nnslashdot-sane-retrieve-headers articles group))) | |
| 92 | (search-failed (nnslashdot-lose why)))) | |
| 93 | ||
| 94 | (deffoo nnslashdot-threaded-retrieve-headers (articles group) | |
| 95 | (let ((last (car (last articles))) | |
| 96 | (did nil) | |
| 97 | (start 1) | |
| 98 | (sid (caddr (assoc group nnslashdot-groups))) | |
| 99 | (first-comments t) | |
| 100 | (startats '(1)) | |
| 101 | headers article subject score from date lines parent point s) | |
| 102 | (save-excursion | |
| 103 | (set-buffer nnslashdot-buffer) | |
| 104 | (let ((case-fold-search t)) | |
| 105 | (erase-buffer) | |
| 106 | (when (= start 1) | |
| 107 | (nnweb-insert (format nnslashdot-article-url | |
| 108 | (nnslashdot-sid-strip sid)) t) | |
| 109 | (goto-char (point-min)) | |
| 110 | (search-forward "Posted by ") | |
| 111 | (when (looking-at "<a[^>]+>\\([^<]+\\)") | |
| 112 | (setq from (nnweb-decode-entities-string (match-string 1)))) | |
| 113 | (search-forward " on ") | |
| 114 | (setq date (nnslashdot-date-to-date | |
| 115 | (buffer-substring (point) (1- (search-forward "<"))))) | |
| 116 | (setq lines (/ (- (point) | |
| 117 | (progn (forward-line 1) (point))) | |
| 118 | 60)) | |
| 119 | (push | |
| 120 | (cons | |
| 121 | 1 | |
| 122 | (make-full-mail-header | |
| 123 | 1 group from date | |
| 124 | (concat "<" (nnslashdot-sid-strip sid) "%1@slashdot>") | |
| 125 | "" 0 lines nil nil)) | |
| 126 | headers)) | |
| 127 | (while (and (setq start (pop startats)) | |
| 128 | (< start last)) | |
| 129 | (setq point (goto-char (point-max))) | |
| 130 | (nnweb-insert | |
| 131 | (format nnslashdot-comments-url | |
| 132 | (nnslashdot-sid-strip sid) | |
| 133 | nnslashdot-threshold 0 start) | |
| 134 | t) | |
| 135 | (when first-comments | |
| 136 | (setq first-comments nil) | |
| 137 | (goto-char (point-max)) | |
| 138 | (while (re-search-backward "startat=\\([0-9]+\\)" nil t) | |
| 139 | (setq s (string-to-number (match-string 1))) | |
| 140 | (unless (memq s startats) | |
| 141 | (push s startats))) | |
| 142 | (setq startats (sort startats '<))) | |
| 143 | (goto-char point) | |
| 144 | (while (re-search-forward | |
| 145 | "<a name=\"\\([0-9]+\\)\"><\\(b\\|H4\\)>\\([^<]+\\)</\\(b\\|H4\\)>.*score:\\([^)]+\\))" | |
| 146 | nil t) | |
| 147 | (setq article (string-to-number (match-string 1)) | |
| 148 | subject (match-string 3) | |
| 149 | score (match-string 5)) | |
| 150 | (when (string-match "^Re: *" subject) | |
| 151 | (setq subject (concat "Re: " (substring subject (match-end 0))))) | |
| 152 | (setq subject (nnweb-decode-entities-string subject)) | |
| 153 | (forward-line 1) | |
| 154 | (if (looking-at | |
| 155 | "by <a[^>]+>\\([^<]+\\)</a>[ \t\n]*.*(\\([^)]+\\))") | |
| 156 | (progn | |
| 157 | (goto-char (- (match-end 0) 5)) | |
| 158 | (setq from (concat | |
| 159 | (nnweb-decode-entities-string (match-string 1)) | |
| 160 | " <" (match-string 2) ">"))) | |
| 161 | (setq from "") | |
| 162 | (when (looking-at "by \\(.+\\) on ") | |
| 163 | (goto-char (- (match-end 0) 5)) | |
| 164 | (setq from (nnweb-decode-entities-string (match-string 1))))) | |
| 165 | (search-forward " on ") | |
| 166 | (setq date | |
| 167 | (nnslashdot-date-to-date | |
| 168 | (buffer-substring (point) (progn (end-of-line) (point))))) | |
| 169 | (setq lines (/ (abs (- (search-forward "<td ") | |
| 170 | (search-forward "</td>"))) | |
| 171 | 70)) | |
| 172 | (forward-line 4) | |
| 173 | (setq parent | |
| 174 | (if (looking-at ".*cid=\\([0-9]+\\)") | |
| 175 | (match-string 1) | |
| 176 | nil)) | |
| 177 | (setq did t) | |
| 178 | (push | |
| 179 | (cons | |
| 180 | (1+ article) | |
| 181 | (make-full-mail-header | |
| 182 | (1+ article) | |
| 183 | (concat subject " (" score ")") | |
| 184 | from date | |
| 185 | (concat "<" (nnslashdot-sid-strip sid) "%" | |
| 186 | (number-to-string (1+ article)) | |
| 187 | "@slashdot>") | |
| 188 | (if parent | |
| 189 | (concat "<" (nnslashdot-sid-strip sid) "%" | |
| 190 | (number-to-string (1+ (string-to-number parent))) | |
| 191 | "@slashdot>") | |
| 192 | "") | |
| 193 | 0 lines nil nil)) | |
| 194 | headers))))) | |
| 195 | (setq nnslashdot-headers (sort headers 'car-less-than-car)) | |
| 196 | (save-excursion | |
| 197 | (set-buffer nntp-server-buffer) | |
| 198 | (erase-buffer) | |
| 199 | (mm-with-unibyte-current-buffer | |
| 200 | (dolist (header nnslashdot-headers) | |
| 201 | (nnheader-insert-nov (cdr header))))) | |
| 202 | 'nov)) | |
| 203 | ||
| 204 | (deffoo nnslashdot-sane-retrieve-headers (articles group) | |
| 205 | (let ((last (car (last articles))) | |
| 206 | (did nil) | |
| 207 | (start (max (1- (car articles)) 1)) | |
| 208 | (sid (caddr (assoc group nnslashdot-groups))) | |
| 209 | headers article subject score from date lines parent point) | |
| 210 | (save-excursion | |
| 211 | (set-buffer nnslashdot-buffer) | |
| 212 | (erase-buffer) | |
| 213 | (when (= start 1) | |
| 214 | (nnweb-insert (format nnslashdot-article-url | |
| 215 | (nnslashdot-sid-strip sid)) t) | |
| 216 | (goto-char (point-min)) | |
| 217 | (search-forward "Posted by ") | |
| 218 | (when (looking-at "<a[^>]+>\\([^<]+\\)") | |
| 219 | (setq from (nnweb-decode-entities-string (match-string 1)))) | |
| 220 | (search-forward " on ") | |
| 221 | (setq date (nnslashdot-date-to-date | |
| 222 | (buffer-substring (point) (1- (search-forward "<"))))) | |
| 223 | (forward-line 2) | |
| 224 | (setq lines (count-lines (point) | |
| 225 | (re-search-forward | |
| 226 | "A href=\"\\(http://slashdot.org\\)?/article"))) | |
| 227 | (push | |
| 228 | (cons | |
| 229 | 1 | |
| 230 | (make-full-mail-header | |
| 231 | 1 group from date (concat "<" (nnslashdot-sid-strip sid) | |
| 232 | "%1@slashdot>") | |
| 233 | "" 0 lines nil nil)) | |
| 234 | headers)) | |
| 235 | (while (or (not article) | |
| 236 | (and did | |
| 237 | (< article last))) | |
| 238 | (when article | |
| 239 | (setq start (1+ article))) | |
| 240 | (setq point (goto-char (point-max))) | |
| 241 | (nnweb-insert | |
| 242 | (format nnslashdot-comments-url (nnslashdot-sid-strip sid) | |
| 243 | nnslashdot-threshold 4 start) | |
| 244 | t) | |
| 245 | (goto-char point) | |
| 246 | (while (re-search-forward | |
| 247 | "<a name=\"\\([0-9]+\\)\"><\\(b\\|H4\\)>\\([^<]+\\)</\\(b\\|H4\\)>.*score:\\([^)]+\\))" | |
| 248 | nil t) | |
| 249 | (setq article (string-to-number (match-string 1)) | |
| 250 | subject (match-string 3) | |
| 251 | score (match-string 5)) | |
| 252 | (when (string-match "^Re: *" subject) | |
| 253 | (setq subject (concat "Re: " (substring subject (match-end 0))))) | |
| 254 | (setq subject (nnweb-decode-entities-string subject)) | |
| 255 | (forward-line 1) | |
| 256 | (if (looking-at | |
| 257 | "by <a[^>]+>\\([^<]+\\)</a>[ \t\n]*.*(\\([^)]+\\))") | |
| 258 | (progn | |
| 259 | (goto-char (- (match-end 0) 5)) | |
| 260 | (setq from (concat | |
| 261 | (nnweb-decode-entities-string (match-string 1)) | |
| 262 | " <" (match-string 2) ">"))) | |
| 263 | (setq from "") | |
| 264 | (when (looking-at "by \\(.+\\) on ") | |
| 265 | (goto-char (- (match-end 0) 5)) | |
| 266 | (setq from (nnweb-decode-entities-string (match-string 1))))) | |
| 267 | (search-forward " on ") | |
| 268 | (setq date | |
| 269 | (nnslashdot-date-to-date | |
| 270 | (buffer-substring (point) (progn (end-of-line) (point))))) | |
| 271 | (setq lines (/ (abs (- (search-forward "<td ") | |
| 272 | (search-forward "</td>"))) | |
| 273 | 70)) | |
| 274 | (forward-line 2) | |
| 275 | (setq parent | |
| 276 | (if (looking-at ".*cid=\\([0-9]+\\)") | |
| 277 | (match-string 1) | |
| 278 | nil)) | |
| 279 | (setq did t) | |
| 280 | (push | |
| 281 | (cons | |
| 282 | (1+ article) | |
| 283 | (make-full-mail-header | |
| 284 | (1+ article) (concat subject " (" score ")") | |
| 285 | from date | |
| 286 | (concat "<" (nnslashdot-sid-strip sid) "%" | |
| 287 | (number-to-string (1+ article)) | |
| 288 | "@slashdot>") | |
| 289 | (if parent | |
| 290 | (concat "<" (nnslashdot-sid-strip sid) "%" | |
| 291 | (number-to-string (1+ (string-to-number parent))) | |
| 292 | "@slashdot>") | |
| 293 | "") | |
| 294 | 0 lines nil nil)) | |
| 295 | headers)))) | |
| 296 | (setq nnslashdot-headers | |
| 297 | (sort headers (lambda (s1 s2) (< (car s1) (car s2))))) | |
| 298 | (save-excursion | |
| 299 | (set-buffer nntp-server-buffer) | |
| 300 | (erase-buffer) | |
| 301 | (mm-with-unibyte-current-buffer | |
| 302 | (dolist (header nnslashdot-headers) | |
| 303 | (nnheader-insert-nov (cdr header))))) | |
| 304 | 'nov)) | |
| 305 | ||
| 306 | (deffoo nnslashdot-request-group (group &optional server dont-check) | |
| 307 | (nnslashdot-possibly-change-server nil server) | |
| 308 | (let ((elem (assoc group nnslashdot-groups))) | |
| 309 | (cond | |
| 310 | ((not elem) | |
| 311 | (nnheader-report 'nnslashdot "Group does not exist")) | |
| 312 | (t | |
| 313 | (nnheader-report 'nnslashdot "Opened group %s" group) | |
| 314 | (nnheader-insert | |
| 315 | "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem) | |
| 316 | (prin1-to-string group)))))) | |
| 317 | ||
| 318 | (deffoo nnslashdot-close-group (group &optional server) | |
| 319 | (nnslashdot-possibly-change-server group server) | |
| 320 | (when (gnus-buffer-live-p nnslashdot-buffer) | |
| 321 | (save-excursion | |
| 322 | (set-buffer nnslashdot-buffer) | |
| 323 | (kill-buffer nnslashdot-buffer))) | |
| 324 | t) | |
| 325 | ||
| 326 | (deffoo nnslashdot-request-article (article &optional group server buffer) | |
| 327 | (nnslashdot-possibly-change-server group server) | |
| 328 | (let (contents) | |
| 329 | (condition-case why | |
| 330 | (save-excursion | |
| 331 | (set-buffer nnslashdot-buffer) | |
| 332 | (let ((case-fold-search t)) | |
| 333 | (goto-char (point-min)) | |
| 334 | (when (and (stringp article) | |
| 335 | (string-match "%\\([0-9]+\\)@" article)) | |
| 336 | (setq article (string-to-number (match-string 1 article)))) | |
| 337 | (when (numberp article) | |
| 338 | (if (= article 1) | |
| 339 | (progn | |
| 340 | (re-search-forward "Posted by *<[^>]+>[^>]*<[^>]+> *on ") | |
| 341 | (search-forward "<BR>") | |
| 342 | (setq contents | |
| 343 | (buffer-substring | |
| 344 | (point) | |
| 345 | (progn | |
| 346 | (re-search-forward | |
| 347 | "<p>.*A href=\"\\(http://slashdot.org\\)?/article") | |
| 348 | (match-beginning 0))))) | |
| 349 | (search-forward (format "<a name=\"%d\">" (1- article))) | |
| 350 | (setq contents | |
| 351 | (buffer-substring | |
| 352 | (re-search-forward "<td[^>]+>") | |
| 353 | (search-forward "</td>"))))))) | |
| 354 | (search-failed (nnslashdot-lose why))) | |
| 355 | ||
| 356 | (when contents | |
| 357 | (save-excursion | |
| 358 | (set-buffer (or buffer nntp-server-buffer)) | |
| 359 | (erase-buffer) | |
| 360 | (mm-with-unibyte-current-buffer | |
| 361 | (insert contents) | |
| 362 | (goto-char (point-min)) | |
| 363 | (while (re-search-forward "\\(<br>\r?\\)+" nil t) | |
| 364 | (replace-match "<p>" t t)) | |
| 365 | (goto-char (point-min)) | |
| 366 | (insert "Content-Type: text/html\nMIME-Version: 1.0\n") | |
| 367 | (insert "Newsgroups: " (caddr (assoc group nnslashdot-groups)) | |
| 368 | "\n") | |
| 369 | (let ((header (cdr (assq article nnslashdot-headers)))) | |
| 370 | (nnheader-insert-header header)) | |
| 371 | (nnheader-report 'nnslashdot "Fetched article %s" article)) | |
| 372 | (cons group article))))) | |
| 373 | ||
| 374 | (deffoo nnslashdot-close-server (&optional server) | |
| 375 | (when (and (nnslashdot-server-opened server) | |
| 376 | (gnus-buffer-live-p nnslashdot-buffer)) | |
| 377 | (save-excursion | |
| 378 | (set-buffer nnslashdot-buffer) | |
| 379 | (kill-buffer nnslashdot-buffer))) | |
| 380 | (nnoo-close-server 'nnslashdot server)) | |
| 381 | ||
| 382 | (deffoo nnslashdot-request-list (&optional server) | |
| 383 | (nnslashdot-possibly-change-server nil server) | |
| 384 | (let ((number 0) | |
| 385 | sid elem description articles gname) | |
| 386 | (condition-case why | |
| 387 | ;; First we do the Ultramode to get info on all the latest groups. | |
| 388 | (progn | |
| 389 | (mm-with-unibyte-buffer | |
| 390 | (nnweb-insert "http://slashdot.org/slashdot.xml" t) | |
| 391 | (goto-char (point-min)) | |
| 392 | (while (search-forward "<story>" nil t) | |
| 393 | (narrow-to-region (point) (search-forward "</story>")) | |
| 394 | (goto-char (point-min)) | |
| 395 | (re-search-forward "<title>\\([^<]+\\)</title>") | |
| 396 | (setq description | |
| 397 | (nnweb-decode-entities-string (match-string 1))) | |
| 398 | (re-search-forward "<url>\\([^<]+\\)</url>") | |
| 399 | (setq sid (match-string 1)) | |
| 400 | (string-match "/\\([0-9/]+\\)\\(.shtml\\|$\\)" sid) | |
| 401 | (setq sid (concat "00/" (match-string 1 sid))) | |
| 402 | (re-search-forward "<comments>\\([^<]+\\)</comments>") | |
| 403 | (setq articles (string-to-number (match-string 1))) | |
| 404 | (setq gname (concat description " (" sid ")")) | |
| 405 | (if (setq elem (assoc gname nnslashdot-groups)) | |
| 406 | (setcar (cdr elem) articles) | |
| 407 | (push (list gname articles sid) nnslashdot-groups)) | |
| 408 | (goto-char (point-max)) | |
| 409 | (widen))) | |
| 410 | ;; Then do the older groups. | |
| 411 | (while (> (- nnslashdot-group-number number) 0) | |
| 412 | (mm-with-unibyte-buffer | |
| 413 | (let ((case-fold-search t)) | |
| 414 | (nnweb-insert (format nnslashdot-active-url number) t) | |
| 415 | (goto-char (point-min)) | |
| 416 | (while (re-search-forward | |
| 417 | "article.pl\\?sid=\\([^&]+\\).*<b>\\([^<]+\\)</b>" | |
| 418 | nil t) | |
| 419 | (setq sid (match-string 1) | |
| 420 | description | |
| 421 | (nnweb-decode-entities-string (match-string 2))) | |
| 422 | (forward-line 1) | |
| 423 | (when (re-search-forward "<b>\\([0-9]+\\)</b>" nil t) | |
| 424 | (setq articles (string-to-number (match-string 1)))) | |
| 425 | (setq gname (concat description " (" sid ")")) | |
| 426 | (if (setq elem (assoc gname nnslashdot-groups)) | |
| 427 | (setcar (cdr elem) articles) | |
| 428 | (push (list gname articles sid) nnslashdot-groups))))) | |
| 429 | (incf number 30))) | |
| 430 | (search-failed (nnslashdot-lose why))) | |
| 431 | (nnslashdot-write-groups) | |
| 432 | (nnslashdot-generate-active) | |
| 433 | t)) | |
| 434 | ||
| 435 | (deffoo nnslashdot-request-newgroups (date &optional server) | |
| 436 | (nnslashdot-possibly-change-server nil server) | |
| 437 | (nnslashdot-generate-active) | |
| 438 | t) | |
| 439 | ||
| 440 | (deffoo nnslashdot-request-post (&optional server) | |
| 441 | (nnslashdot-possibly-change-server nil server) | |
| 442 | (let ((sid (nnslashdot-sid-strip (message-fetch-field "newsgroups"))) | |
| 443 | (subject (message-fetch-field "subject")) | |
| 444 | (references (car (last (split-string | |
| 445 | (message-fetch-field "references"))))) | |
| 446 | body quoted pid) | |
| 447 | (string-match "%\\([0-9]+\\)@slashdot" references) | |
| 448 | (setq pid (match-string 1 references)) | |
| 449 | (message-goto-body) | |
| 450 | (narrow-to-region (point) (progn (message-goto-signature) (point))) | |
| 451 | (goto-char (point-min)) | |
| 452 | (while (not (eobp)) | |
| 453 | (if (looking-at "> ") | |
| 454 | (progn | |
| 455 | (delete-region (point) (+ (point) 2)) | |
| 456 | (unless quoted | |
| 457 | (insert "<blockquote>\n")) | |
| 458 | (setq quoted t)) | |
| 459 | (when quoted | |
| 460 | (insert "</blockquote>\n") | |
| 461 | (setq quoted nil))) | |
| 462 | (forward-line 1)) | |
| 463 | (goto-char (point-min)) | |
| 464 | (while (re-search-forward "^ *\n" nil t) | |
| 465 | (replace-match "<p>\n")) | |
| 466 | (widen) | |
| 467 | (when (message-goto-signature) | |
| 468 | (forward-line -1) | |
| 469 | (insert "<p>\n") | |
| 470 | (while (not (eobp)) | |
| 471 | (end-of-line) | |
| 472 | (insert "<br>") | |
| 473 | (forward-line 1))) | |
| 474 | (message-goto-body) | |
| 475 | (setq body (buffer-substring (point) (point-max))) | |
| 476 | (erase-buffer) | |
| 477 | (nnweb-fetch-form | |
| 478 | "http://slashdot.org/comments.pl" | |
| 479 | `(("sid" . ,sid) | |
| 480 | ("pid" . ,pid) | |
| 481 | ("rlogin" . "userlogin") | |
| 482 | ("unickname" . ,nnslashdot-login-name) | |
| 483 | ("upasswd" . ,nnslashdot-password) | |
| 484 | ("postersubj" . ,subject) | |
| 485 | ("op" . "Submit") | |
| 486 | ("postercomment" . ,body) | |
| 487 | ("posttype" . "html"))))) | |
| 488 | ||
| 489 | (deffoo nnslashdot-request-delete-group (group &optional force server) | |
| 490 | (nnslashdot-possibly-change-server group server) | |
| 491 | (setq nnslashdot-groups (delq (assoc group nnslashdot-groups) | |
| 492 | nnslashdot-groups)) | |
| 493 | (nnslashdot-write-groups)) | |
| 494 | ||
| 495 | (deffoo nnslashdot-request-close () | |
| 496 | (setq nnslashdot-headers nil | |
| 497 | nnslashdot-groups nil)) | |
| 498 | ||
| 499 | (nnoo-define-skeleton nnslashdot) | |
| 500 | ||
| 501 | ;;; Internal functions | |
| 502 | ||
| 503 | (defun nnslashdot-possibly-change-server (&optional group server) | |
| 504 | (nnslashdot-init server) | |
| 505 | (when (and server | |
| 506 | (not (nnslashdot-server-opened server))) | |
| 507 | (nnslashdot-open-server server)) | |
| 508 | (unless nnslashdot-groups | |
| 509 | (nnslashdot-read-groups))) | |
| 510 | ||
| 511 | (defun nnslashdot-read-groups () | |
| 512 | (let ((file (expand-file-name "groups" nnslashdot-directory))) | |
| 513 | (when (file-exists-p file) | |
| 514 | (mm-with-unibyte-buffer | |
| 515 | (insert-file-contents file) | |
| 516 | (goto-char (point-min)) | |
| 517 | (setq nnslashdot-groups (read (current-buffer))))))) | |
| 518 | ||
| 519 | (defun nnslashdot-write-groups () | |
| 520 | (with-temp-file (expand-file-name "groups" nnslashdot-directory) | |
| 521 | (prin1 nnslashdot-groups (current-buffer)))) | |
| 522 | ||
| 523 | (defun nnslashdot-init (server) | |
| 524 | "Initialize buffers and such." | |
| 525 | (unless (file-exists-p nnslashdot-directory) | |
| 526 | (gnus-make-directory nnslashdot-directory)) | |
| 527 | (unless (gnus-buffer-live-p nnslashdot-buffer) | |
| 528 | (setq nnslashdot-buffer | |
| 529 | (save-excursion | |
| 530 | (nnheader-set-temp-buffer | |
| 531 | (format " *nnslashdot %s*" server)))))) | |
| 532 | ||
| 533 | (defun nnslashdot-date-to-date (sdate) | |
| 534 | (condition-case err | |
| 535 | (let ((elem (delete "" (split-string sdate)))) | |
| 536 | (concat (substring (nth 0 elem) 0 3) " " | |
| 537 | (substring (nth 1 elem) 0 3) " " | |
| 538 | (substring (nth 2 elem) 0 2) " " | |
| 539 | (substring (nth 3 elem) 1 6) " " | |
| 540 | (format-time-string "%Y") " " | |
| 541 | (nth 4 elem))) | |
| 542 | (error ""))) | |
| 543 | ||
| 544 | (defun nnslashdot-generate-active () | |
| 545 | (save-excursion | |
| 546 | (set-buffer nntp-server-buffer) | |
| 547 | (erase-buffer) | |
| 548 | (dolist (elem nnslashdot-groups) | |
| 549 | (insert (prin1-to-string (car elem)) | |
| 550 | " " (number-to-string (cadr elem)) " 1 y\n")))) | |
| 551 | ||
| 552 | (defun nnslashdot-lose (why) | |
| 553 | (error "Slashdot HTML has changed; please get a new version of nnslashdot")) | |
| 554 | ||
| 555 | ;(defun nnslashdot-sid-strip (sid) | |
| 556 | ; (if (string-match "^00/" sid) | |
| 557 | ; (substring sid (match-end 0)) | |
| 558 | ; sid)) | |
| 559 | ||
| 560 | (defalias 'nnslashdot-sid-strip 'identity) | |
| 561 | ||
| 562 | (provide 'nnslashdot) | |
| 563 | ||
| 564 | ;;; nnslashdot.el ends here |