1;;; nnwfm.el --- interfacing with a web forum 2 3;; Copyright (C) 2000, 2002, 2003, 2004, 2005, 4;; 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 7;; Keywords: news 8 9;; This file is part of GNU Emacs. 10 11;; GNU Emacs is free software; you can redistribute it and/or modify 12;; it under the terms of the GNU General Public License as published by 13;; the Free Software Foundation; either version 2, or (at your option) 14;; any later version. 15 16;; GNU Emacs is distributed in the hope that it will be useful, 17;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19;; GNU General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, USA. 25 26;;; Commentary: 27 28;; Note: You need to have `url' and `w3' installed for this 29;; backend to work. 30 31;;; Code: 32 33(eval-when-compile (require 'cl)) 34 35(require 'nnoo) 36(require 'message) 37(require 'gnus-util) 38(require 'gnus) 39(require 'nnmail) 40(require 'mm-util) 41(require 'mm-url) 42(require 'nnweb) 43(autoload 'w3-parse-buffer "w3-parse") 44 45(nnoo-declare nnwfm) 46 47(defvoo nnwfm-directory (nnheader-concat gnus-directory "wfm/") 48 "Where nnwfm will save its files.") 49 50(defvoo nnwfm-address "" 51 "The address of the Ultimate bulletin board.") 52 53;;; Internal variables 54 55(defvar nnwfm-groups-alist nil) 56(defvoo nnwfm-groups nil) 57(defvoo nnwfm-headers nil) 58(defvoo nnwfm-articles nil) 59(defvar nnwfm-table-regexp 60 "postings.*editpost\\|forumdisplay\\|Forum[0-9]+/HTML\\|getbio") 61 62;;; Interface functions 63 64(nnoo-define-basics nnwfm) 65 66(deffoo nnwfm-retrieve-headers (articles &optional group server fetch-old) 67 (nnwfm-possibly-change-server group server) 68 (unless gnus-nov-is-evil 69 (let* ((last (car (last articles))) 70 (did nil) 71 (start 1) 72 (entry (assoc group nnwfm-groups)) 73 (sid (nth 2 entry)) 74 (topics (nth 4 entry)) 75 (mapping (nth 5 entry)) 76 (old-total (or (nth 6 entry) 1)) 77 (nnwfm-table-regexp "Thread.asp") 78 headers article subject score from date lines parent point 79 contents tinfo fetchers map elem a href garticles topic old-max 80 inc datel table string current-page total-contents pages 81 farticles forum-contents parse furl-fetched mmap farticle 82 thread-id tables hstuff bstuff time) 83 (setq map mapping) 84 (while (and (setq article (car articles)) 85 map) 86 (while (and map 87 (or (> article (caar map)) 88 (< (cadar map) (caar map)))) 89 (pop map)) 90 (when (setq mmap (car map)) 91 (setq farticle -1) 92 (while (and article 93 (<= article (nth 1 mmap))) 94 ;; Do we already have a fetcher for this topic? 95 (if (setq elem (assq (nth 2 mmap) fetchers)) 96 ;; Yes, so we just add the spec to the end. 97 (nconc elem (list (cons article 98 (+ (nth 3 mmap) (incf farticle))))) 99 ;; No, so we add a new one. 100 (push (list (nth 2 mmap) 101 (cons article 102 (+ (nth 3 mmap) (incf farticle)))) 103 fetchers)) 104 (pop articles) 105 (setq article (car articles))))) 106 ;; Now we have the mapping from/to Gnus/nnwfm article numbers, 107 ;; so we start fetching the topics that we need to satisfy the 108 ;; request. 109 (if (not fetchers) 110 (save-excursion 111 (set-buffer nntp-server-buffer) 112 (erase-buffer)) 113 (setq nnwfm-articles nil) 114 (mm-with-unibyte-buffer 115 (dolist (elem fetchers) 116 (erase-buffer) 117 (setq subject (nth 2 (assq (car elem) topics)) 118 thread-id (nth 0 (assq (car elem) topics))) 119 (mm-url-insert 120 (concat nnwfm-address 121 (format "Item.asp?GroupID=%d&ThreadID=%d" sid 122 thread-id))) 123 (goto-char (point-min)) 124 (setq tables (caddar 125 (caddar 126 (cdr (caddar 127 (caddar 128 (ignore-errors 129 (w3-parse-buffer (current-buffer))))))))) 130 (setq tables (cdr (caddar (memq (assq 'div tables) tables)))) 131 (setq contents nil) 132 (dolist (table tables) 133 (when (eq (car table) 'table) 134 (setq table (caddar (caddar (caddr table))) 135 hstuff (delete ":link" (nnweb-text (car table))) 136 bstuff (car (caddar (cdr table))) 137 from (car hstuff)) 138 (when (nth 2 hstuff) 139 (setq time (nnwfm-date-to-time (nth 2 hstuff))) 140 (push (list from time bstuff) contents)))) 141 (setq contents (nreverse contents)) 142 (dolist (art (cdr elem)) 143 (push (list (car art) 144 (nth (1- (cdr art)) contents) 145 subject) 146 nnwfm-articles)))) 147 (setq nnwfm-articles 148 (sort nnwfm-articles 'car-less-than-car)) 149 ;; Now we have all the articles, conveniently in an alist 150 ;; where the key is the Gnus article number. 151 (dolist (articlef nnwfm-articles) 152 (setq article (nth 0 articlef) 153 contents (nth 1 articlef) 154 subject (nth 2 articlef)) 155 (setq from (nth 0 contents) 156 date (message-make-date (nth 1 contents))) 157 (push 158 (cons 159 article 160 (make-full-mail-header 161 article subject 162 from (or date "") 163 (concat "<" (number-to-string sid) "%" 164 (number-to-string article) 165 "@wfm>") 166 "" 0 167 (/ (length (mapconcat 'identity (nnweb-text (nth 2 contents)) "")) 168 70) 169 nil nil)) 170 headers)) 171 (setq nnwfm-headers (sort headers 'car-less-than-car)) 172 (save-excursion 173 (set-buffer nntp-server-buffer) 174 (mm-with-unibyte-current-buffer 175 (erase-buffer) 176 (dolist (header nnwfm-headers) 177 (nnheader-insert-nov (cdr header)))))) 178 'nov))) 179 180(deffoo nnwfm-request-group (group &optional server dont-check) 181 (nnwfm-possibly-change-server nil server) 182 (when (not nnwfm-groups) 183 (nnwfm-request-list)) 184 (unless dont-check 185 (nnwfm-create-mapping group)) 186 (let ((elem (assoc group nnwfm-groups))) 187 (cond 188 ((not elem) 189 (nnheader-report 'nnwfm "Group does not exist")) 190 (t 191 (nnheader-report 'nnwfm "Opened group %s" group) 192 (nnheader-insert 193 "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem) 194 (prin1-to-string group)))))) 195 196(deffoo nnwfm-request-close () 197 (setq nnwfm-groups-alist nil 198 nnwfm-groups nil)) 199 200(deffoo nnwfm-request-article (article &optional group server buffer) 201 (nnwfm-possibly-change-server group server) 202 (let ((contents (cdr (assq article nnwfm-articles)))) 203 (when (setq contents (nth 2 (car contents))) 204 (save-excursion 205 (set-buffer (or buffer nntp-server-buffer)) 206 (erase-buffer) 207 (nnweb-insert-html contents) 208 (goto-char (point-min)) 209 (insert "Content-Type: text/html\nMIME-Version: 1.0\n") 210 (let ((header (cdr (assq article nnwfm-headers)))) 211 (mm-with-unibyte-current-buffer 212 (nnheader-insert-header header))) 213 (nnheader-report 'nnwfm "Fetched article %s" article) 214 (cons group article))))) 215 216(deffoo nnwfm-request-list (&optional server) 217 (nnwfm-possibly-change-server nil server) 218 (mm-with-unibyte-buffer 219 (mm-url-insert 220 (if (string-match "/$" nnwfm-address) 221 (concat nnwfm-address "Group.asp") 222 nnwfm-address)) 223 (let* ((nnwfm-table-regexp "Thread.asp") 224 (contents (w3-parse-buffer (current-buffer))) 225 sid elem description articles a href group forum 226 a1 a2) 227 (dolist (row (cdr (nth 2 (car (nth 2 (nnwfm-find-forum-table 228 contents)))))) 229 (setq row (nth 2 row)) 230 (when (setq a (nnweb-parse-find 'a row)) 231 (setq group (car (last (nnweb-text a))) 232 href (cdr (assq 'href (nth 1 a)))) 233 (setq description (car (last (nnweb-text (nth 1 row))))) 234 (setq articles 235 (string-to-number 236 (gnus-replace-in-string 237 (car (last (nnweb-text (nth 3 row)))) "," ""))) 238 (when (and href 239 (string-match "GroupId=\\([0-9]+\\)" href)) 240 (setq forum (string-to-number (match-string 1 href))) 241 (if (setq elem (assoc group nnwfm-groups)) 242 (setcar (cdr elem) articles) 243 (push (list group articles forum description nil nil nil nil) 244 nnwfm-groups)))))) 245 (nnwfm-write-groups) 246 (nnwfm-generate-active) 247 t)) 248 249(deffoo nnwfm-request-newgroups (date &optional server) 250 (nnwfm-possibly-change-server nil server) 251 (nnwfm-generate-active) 252 t) 253 254(nnoo-define-skeleton nnwfm) 255 256;;; Internal functions 257 258(defun nnwfm-new-threads-p (group time) 259 "See whether we want to fetch the threads for GROUP written before TIME." 260 (let ((old-time (nth 7 (assoc group nnwfm-groups)))) 261 (or (null old-time) 262 (time-less-p old-time time)))) 263 264(defun nnwfm-create-mapping (group) 265 (let* ((entry (assoc group nnwfm-groups)) 266 (sid (nth 2 entry)) 267 (topics (nth 4 entry)) 268 (mapping (nth 5 entry)) 269 (old-total (or (nth 6 entry) 1)) 270 (current-time (current-time)) 271 (nnwfm-table-regexp "Thread.asp") 272 (furls (list (concat nnwfm-address 273 (format "Thread.asp?GroupId=%d" sid)))) 274 fetched-urls 275 contents forum-contents a subject href 276 garticles topic tinfo old-max inc parse elem date 277 url time) 278 (mm-with-unibyte-buffer 279 (while furls 280 (erase-buffer) 281 (push (car furls) fetched-urls) 282 (mm-url-insert (pop furls)) 283 (goto-char (point-min)) 284 (while (re-search-forward " wr(" nil t) 285 (forward-char -1) 286 (setq elem (message-tokenize-header 287 (gnus-replace-in-string 288 (buffer-substring 289 (1+ (point)) 290 (progn 291 (forward-sexp 1) 292 (1- (point)))) 293 "\\\\[\"\\\\]" ""))) 294 (push (list 295 (string-to-number (nth 1 elem)) 296 (gnus-replace-in-string (nth 2 elem) "\"" "") 297 (string-to-number (nth 5 elem))) 298 forum-contents)) 299 (when (re-search-forward "href=\"\\(Thread.*DateLast=\\([^\"]+\\)\\)" 300 nil t) 301 (setq url (match-string 1) 302 time (nnwfm-date-to-time (gnus-url-unhex-string 303 (match-string 2)))) 304 (when (and (nnwfm-new-threads-p group time) 305 (not (member 306 (setq url (concat 307 nnwfm-address 308 (mm-url-decode-entities-string url))) 309 fetched-urls))) 310 (push url furls)))) 311 ;; The main idea here is to map Gnus article numbers to 312 ;; nnwfm article numbers. Say there are three topics in 313 ;; this forum, the first with 4 articles, the seconds with 2, 314 ;; and the third with 1. Then this will translate into 7 Gnus 315 ;; article numbers, where 1-4 comes from the first topic, 5-6 316 ;; from the second and 7 from the third. Now, then next time 317 ;; the group is entered, there's 2 new articles in topic one 318 ;; and 1 in topic three. Then Gnus article number 8-9 be 5-6 319 ;; in topic one and 10 will be the 2 in topic three. 320 (dolist (elem (nreverse forum-contents)) 321 (setq subject (nth 1 elem) 322 topic (nth 0 elem) 323 garticles (nth 2 elem)) 324 (if (setq tinfo (assq topic topics)) 325 (progn 326 (setq old-max (cadr tinfo)) 327 (setcar (cdr tinfo) garticles)) 328 (setq old-max 0) 329 (push (list topic garticles subject) topics) 330 (setcar (nthcdr 4 entry) topics)) 331 (when (not (= old-max garticles)) 332 (setq inc (- garticles old-max)) 333 (setq mapping (nconc mapping 334 (list 335 (list 336 old-total (1- (incf old-total inc)) 337 topic (1+ old-max))))) 338 (incf old-max inc) 339 (setcar (nthcdr 5 entry) mapping) 340 (setcar (nthcdr 6 entry) old-total)))) 341 (setcar (nthcdr 7 entry) current-time) 342 (setcar (nthcdr 1 entry) (1- old-total)) 343 (nnwfm-write-groups) 344 mapping)) 345 346(defun nnwfm-possibly-change-server (&optional group server) 347 (nnwfm-init server) 348 (when (and server 349 (not (nnwfm-server-opened server))) 350 (nnwfm-open-server server)) 351 (unless nnwfm-groups-alist 352 (nnwfm-read-groups) 353 (setq nnwfm-groups (cdr (assoc nnwfm-address 354 nnwfm-groups-alist))))) 355 356(deffoo nnwfm-open-server (server &optional defs connectionless) 357 (nnheader-init-server-buffer) 358 (if (nnwfm-server-opened server) 359 t 360 (unless (assq 'nnwfm-address defs) 361 (setq defs (append defs (list (list 'nnwfm-address server))))) 362 (nnoo-change-server 'nnwfm server defs))) 363 364(defun nnwfm-read-groups () 365 (setq nnwfm-groups-alist nil) 366 (let ((file (expand-file-name "groups" nnwfm-directory))) 367 (when (file-exists-p file) 368 (mm-with-unibyte-buffer 369 (insert-file-contents file) 370 (goto-char (point-min)) 371 (setq nnwfm-groups-alist (read (current-buffer))))))) 372 373(defun nnwfm-write-groups () 374 (setq nnwfm-groups-alist 375 (delq (assoc nnwfm-address nnwfm-groups-alist) 376 nnwfm-groups-alist)) 377 (push (cons nnwfm-address nnwfm-groups) 378 nnwfm-groups-alist) 379 (with-temp-file (expand-file-name "groups" nnwfm-directory) 380 (prin1 nnwfm-groups-alist (current-buffer)))) 381 382(defun nnwfm-init (server) 383 "Initialize buffers and such." 384 (unless (file-exists-p nnwfm-directory) 385 (gnus-make-directory nnwfm-directory))) 386 387(defun nnwfm-generate-active () 388 (save-excursion 389 (set-buffer nntp-server-buffer) 390 (erase-buffer) 391 (dolist (elem nnwfm-groups) 392 (insert (prin1-to-string (car elem)) 393 " " (number-to-string (cadr elem)) " 1 y\n")))) 394 395(defun nnwfm-find-forum-table (contents) 396 (catch 'found 397 (nnwfm-find-forum-table-1 contents))) 398 399(defun nnwfm-find-forum-table-1 (contents) 400 (dolist (element contents) 401 (unless (stringp element) 402 (when (and (eq (car element) 'table) 403 (nnwfm-forum-table-p element)) 404 (throw 'found element)) 405 (when (nth 2 element) 406 (nnwfm-find-forum-table-1 (nth 2 element)))))) 407 408(defun nnwfm-forum-table-p (parse) 409 (when (not (apply 'gnus-or 410 (mapcar 411 (lambda (p) 412 (nnweb-parse-find 'table p)) 413 (nth 2 parse)))) 414 (let ((href (cdr (assq 'href (nth 1 (nnweb-parse-find 'a parse 20))))) 415 case-fold-search) 416 (when (and href (string-match nnwfm-table-regexp href)) 417 t)))) 418 419(defun nnwfm-date-to-time (date) 420 (let ((time (mapcar #'string-to-number (split-string date "[\\.\\+ :]")))) 421 (encode-time 0 (nth 4 time) (nth 3 time) 422 (nth 0 time) (nth 1 time) 423 (if (< (nth 2 time) 70) 424 (+ 2000 (nth 2 time)) 425 (+ 1900 (nth 2 time)))))) 426 427(provide 'nnwfm) 428 429;; Local Variables: 430;; coding: iso-8859-1 431;; End: 432 433;;; arch-tag: d813966a-4211-4557-ad11-d1ac2bc86536 434;;; nnwfm.el ends here 435