cgit.sxemacs.org Git - gnus/blob - lisp/nnultimate.el

   1 ;;; nnultimate.el --- interfacing with the Ultimate Bulletin Board
   2 ;; Copyright (C) 1999 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 (require 'nnweb)
  40 (eval-when-compile
  41   (ignore-errors
  42     (require 'w3)
  43     (require 'url)
  44     (require 'w3-forms)))
  45 ;; Report failure to find w3 at load time if appropriate.
  46 (eval '(progn
  47          (require 'w3)
  48          (require 'url)
  49          (require 'w3-forms)))
  50
  51 (nnoo-declare nnultimate)
  52
  53 (defvoo nnultimate-directory (nnheader-concat gnus-directory "ultimate/")
  54   "Where nnultimate will save its files.")
  55
  56 (defvoo nnultimate-address-1 "http://debet.solbors.no/cgi-bin/billboard/"
  57   "The address of the Ultimate bulletin board.")
  58
  59 ;;; Internal variables
  60
  61 (defvar nnultimate-groups nil)
  62 (defvar nnultimate-buffer nil)
  63 (defvar nnultimate-headers nil)
  64 (defvar nnultimate-articles nil)
  65
  66 ;;; Interface functions
  67
  68 (nnoo-define-basics nnultimate)
  69
  70 (deffoo nnultimate-retrieve-headers (articles &optional group server fetch-old)
  71   (nnultimate-possibly-change-server group server)
  72   (let* ((last (car (last articles)))
  73          (did nil)
  74          (start 1)
  75          (entry (gnus-copy-sequence (assoc group nnultimate-groups)))
  76          (sid (nth 2 entry))
  77          (topics (nth 4 entry))
  78          (mapping (nth 5 entry))
  79          (old-total (or (nth 6 entry) 0))
  80          (furl "forumdisplay.cgi?action=topics&number=%d&DaysPrune=1000")
  81          (turl "http://debet.solbors.no/billboard/Forum%d/HTML/%06d.html")
  82          headers article subject score from date lines parent point
  83          contents tinfo fetchers map elem)
  84     (save-excursion
  85       (set-buffer nnultimate-buffer)
  86       (erase-buffer)
  87       (url-insert-file-contents
  88        (concat nnultimate-address-1 (format furl sid)))
  89       (setq buffer-file-name nil)
  90       (goto-char (point-min))
  91       (setq contents (nth 2 (car (nth 2
  92                                       (nnultimate-find-forum-table
  93                                        (w3-parse-buffer (current-buffer)))))))
  94       ;; The main idea here is to map Gnus article numbers to
  95       ;; nnultimate article numbers.  Say there are three topics in
  96       ;; this forum, the first with 4 articles, the seconds with 2,
  97       ;; and the third with 1.  Then this will translate into 7 Gnus
  98       ;; article numbers, where 1-4 comes from the first topic, 5-6
  99       ;; from the second and 7 from the third.  Now, then next time
 100       ;; the group is entered, there's 2 new articles in topic one and
 101       ;; 1 in topic three.  Then Gnus article number 8-9 be 5-6 in
 102       ;; topic one and 10 will be the 2 in topic three.
 103       (dolist (row (cdr contents))
 104         (setq row (nth 2 row))
 105         (when (setq a (nnultimate-descend 'a (nth 2 row)))
 106           (setq subject (car (last (nnultimate-text a)))
 107                 href (cdr (assq 'href (nth 1 a))))
 108           (setq garticles (1+ (string-to-number (car (last (nnultimate-text
 109                                                             (nth 4 row)))))))
 110           (string-match "/\\([0-9]+\\).html" href)
 111           (setq topic (string-to-number (match-string 1 href)))
 112           (if (setq tinfo (assq topic topics))
 113               (progn
 114                 (setq old-max (cadr tinfo))
 115                 (setcar (cdr tinfo) garticles))
 116             (setq old-max 0)
 117             (push (list topic garticles subject) topics)
 118             (setcar (nthcdr 4 entry) topics))
 119           (when (not (= old-max garticles))
 120             (setq inc (- garticles old-max))
 121             (setq mapping (nconc mapping
 122                                  (list
 123                                   (list
 124                                    (setq old-total (+ old-total inc))
 125                                    topic (1+ old-max)))))
 126             (incf old-max inc)
 127             (setcar (nthcdr 5 entry) mapping))))
 128       (setq map mapping)
 129       (while (and (setq article (car articles))
 130                   map)
 131         (while (and map
 132                     (> article (caar map)))
 133           (pop map))
 134         (while (and article
 135                     map
 136                     (<= article (caar map)))
 137           (if (setq elem (assq (cadar map) fetchers))
 138               (nconc elem (list (cons article
 139                                       (+ (caddar map)
 140                                          (- (caar map) article)))))
 141             (push (list (cadar map) (cons article
 142                                           (+ (caddar map)
 143                                              (- (caar map) article))))
 144                   fetchers))
 145           (setq article (car (setq articles (cdr articles))))))
 146       ;; Now we have the mapping from/to Gnus/nnultimate article numbers,
 147       ;; so we start fetching the topics that we need to satisfy the
 148       ;; request.
 149       (if (not fetchers)
 150           (save-excursion
 151             (set-buffer nntp-server-buffer)
 152             (erase-buffer))
 153         (setq nnultimate-articles nil)
 154         (with-temp-buffer
 155           (dolist (elem fetchers)
 156             (erase-buffer)
 157             (setq subject (nth 2 (assq (car elem) topics)))
 158             (url-insert-file-contents (format turl sid (car elem)))
 159             (setq buffer-file-name nil)
 160             (goto-char (point-min))
 161             (setq contents
 162                   (cdr
 163                    (nth 2 (car (nth 2
 164                                     (nnultimate-find-forum-table
 165                                      (w3-parse-buffer (current-buffer))))))))
 166             (dolist (art (cdr elem))
 167               (push (list (car art)
 168                           (nth (1- (cdr art)) contents)
 169                           subject)
 170                     nnultimate-articles))))
 171         (setq nnultimate-articles
 172               (sort nnultimate-articles 'car-less-than-car))
 173         ;; Now we have all the articles, conveniently in an alist
 174         ;; where the key is the Gnus article number.
 175         (dolist (articlef nnultimate-articles)
 176           (setq article (nth 0 articlef)
 177                 contents (nth 1 articlef)
 178                 subject (nth 2 articlef))
 179           (setq from (mapconcat 'identity
 180                                 (nnultimate-text (car (nth 2 contents)))
 181                                 " ")
 182                 datel (nnultimate-text (nth 2 (car (cdr (nth 2 contents))))))
 183           (while datel
 184             (when (string-match "Posted" (car datel))
 185               (setq date (substring (car datel) (match-end 0))
 186                     datel nil))
 187             (pop datel))
 188           (setq date (delete "" (split-string date "[- \n\t\r    ]")))
 189           (setq date (format "%s %s %s %s"
 190                              (car (rassq (string-to-number (nth 1 date))
 191                                          parse-time-months))
 192                              (nth 0 date) (nth 2 date) (nth 3 date)))
 193           (push
 194            (cons
 195             article
 196             (make-full-mail-header
 197              article subject
 198              from (or date "")
 199              (concat "<" (number-to-string sid) "%"
 200                      (number-to-string article)
 201                      "@ultimate>")
 202              "" 0 0 nil nil))
 203            headers))
 204         (setq nnultimate-headers (sort headers 'car-less-than-car))
 205         (save-excursion
 206           (set-buffer nntp-server-buffer)
 207           (erase-buffer)
 208           (dolist (header nnultimate-headers)
 209             (nnheader-insert-nov (cdr header))))))
 210     'nov))
 211
 212 (deffoo nnultimate-request-group (group &optional server dont-check)
 213   (nnultimate-possibly-change-server nil server)
 214   (let ((elem (assoc group nnultimate-groups)))
 215     (cond
 216      ((not elem)
 217       (nnheader-report 'nnultimate "Group does not exist"))
 218      (t
 219       (nnheader-report 'nnultimate "Opened group %s" group)
 220       (nnheader-insert
 221        "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem)
 222        (prin1-to-string group))))))
 223
 224 (deffoo nnultimate-close-group (group &optional server)
 225   (nnultimate-possibly-change-server group server)
 226   (when (gnus-buffer-live-p nnultimate-buffer)
 227     (save-excursion
 228       (set-buffer nnultimate-buffer)
 229       (kill-buffer nnultimate-buffer)))
 230   t)
 231
 232 (deffoo nnultimate-request-article (article &optional group server buffer)
 233   (nnultimate-possibly-change-server group server)
 234   (let ((contents (cdr (assq article nnultimate-articles))))
 235     (setq contents (cdr (nth 2 (nth 1 (nth 2 (car contents))))))
 236     (when contents
 237       (save-excursion
 238         (set-buffer (or buffer nntp-server-buffer))
 239         (erase-buffer)
 240         (apply 'insert (nnultimate-text contents))
 241         (goto-char (point-min))
 242         (insert "Content-Type: text/html\nMIME-Version: 1.0\n")
 243         (let ((header (cdr (assq article nnultimate-headers))))
 244           (nnheader-insert-header header))
 245         (nnheader-report 'nnultimate "Fetched article %s" article)
 246         (cons group article)))))
 247
 248 (deffoo nnultimate-close-server (&optional server)
 249   (when (and (nnultimate-server-opened server)
 250              (gnus-buffer-live-p nnultimate-buffer))
 251     (save-excursion
 252       (set-buffer nnultimate-buffer)
 253       (kill-buffer nnultimate-buffer)))
 254   (nnoo-close-server 'nnultimate server))
 255
 256 (deffoo nnultimate-request-list (&optional server)
 257   (nnultimate-possibly-change-server nil server)
 258   (with-temp-buffer
 259     (url-insert-file-contents (concat nnultimate-address-1 "Ultimate.cgi"))
 260     (setq buffer-file-name nil)
 261     (let ((contents (nth 2 (car (nth 2
 262                                      (nnultimate-find-forum-table
 263                                       (w3-parse-buffer (current-buffer)))))))
 264           sid elem description articles a href group)
 265       (dolist (row contents)
 266         (setq row (nth 2 row))
 267         (when (setq a (nnultimate-descend 'a row))
 268           (setq group (car (last (nnultimate-text a)))
 269                 href (cdr (assq 'href (nth 1 a))))
 270           (setq description (car (last (nnultimate-text (nth 1 row)))))
 271           (setq articles (string-to-number (car (last (nnultimate-text
 272                                                        (nth 2 row))))))
 273           (when href
 274             (string-match "number=\\([0-9]+\\)" href)
 275             (setq forum (string-to-number (match-string 1 href)))
 276             (if (setq elem (assoc group nnultimate-groups))
 277                 (setcar (cdr elem) articles)
 278               (push (list group articles forum description nil nil nil)
 279                     nnultimate-groups))))))
 280     (nnultimate-write-groups)
 281     (nnultimate-generate-active)
 282     t))
 283
 284 (deffoo nnultimate-request-newgroups (date &optional server)
 285   (nnultimate-possibly-change-server nil server)
 286   (nnultimate-generate-active)
 287   t)
 288
 289 (deffoo nnultimate-asynchronous-p ()
 290   nil)
 291
 292 (nnoo-define-skeleton nnultimate)
 293
 294 ;;; Internal functions
 295
 296 (defun nnultimate-possibly-change-server (&optional group server)
 297   (nnultimate-init server)
 298   (when (and server
 299              (not (nnultimate-server-opened server)))
 300     (nnultimate-open-server server))
 301   (unless nnultimate-groups
 302     (nnultimate-read-groups)))
 303
 304 (defun nnultimate-read-groups ()
 305   (let ((file (expand-file-name "groups" nnultimate-directory)))
 306     (when (file-exists-p file)
 307       (with-temp-buffer
 308         (insert-file-contents file)
 309         (goto-char (point-min))
 310         (setq nnultimate-groups (read (current-buffer)))))))
 311
 312 (defun nnultimate-write-groups ()
 313   (with-temp-file (expand-file-name "groups" nnultimate-directory)
 314     (prin1 nnultimate-groups (current-buffer))))
 315
 316 (defun nnultimate-init (server)
 317   "Initialize buffers and such."
 318   (unless (file-exists-p nnultimate-directory)
 319     (gnus-make-directory nnultimate-directory))
 320   (unless (gnus-buffer-live-p nnultimate-buffer)
 321     (setq nnultimate-buffer
 322           (save-excursion
 323             (nnheader-set-temp-buffer
 324              (format " *nnultimate %s*" server))))))
 325
 326 (defun nnultimate-encode-www-form-urlencoded (pairs)
 327   "Return PAIRS encoded for forms."
 328   (mapconcat
 329    (function
 330     (lambda (data)
 331       (concat (w3-form-encode-xwfu (car data)) "="
 332               (w3-form-encode-xwfu (cdr data)))))
 333    pairs "&"))
 334
 335 (defun nnultimate-fetch-form (url pairs)
 336   (let ((url-request-data (nnultimate-encode-www-form-urlencoded pairs))
 337         (url-request-method "POST")
 338         (url-request-extra-headers
 339          '(("Content-type" . "application/x-www-form-urlencoded"))))
 340     (url-insert-file-contents url)
 341     (setq buffer-file-name nil))
 342   t)
 343
 344 (defun nnultimate-decode-entities ()
 345   (goto-char (point-min))
 346   (while (re-search-forward "&\\([a-z]+\\);" nil t)
 347     (replace-match (char-to-string (or (cdr (assq (intern (match-string 1))
 348                                                   w3-html-entities))
 349                                        ?#))
 350                    t t)))
 351
 352 (defun nnultimate-remove-markup ()
 353   (goto-char (point-min))
 354   (while (search-forward "<!--" nil t)
 355     (delete-region (match-beginning 0)
 356                    (or (search-forward "-->" nil t)
 357                        (point-max))))
 358   (goto-char (point-min))
 359   (while (re-search-forward "<[^>]+>" nil t)
 360     (replace-match "" t t)))
 361
 362 (defun nnultimate-date-to-date (sdate)
 363   (let ((elem (split-string sdate)))
 364     (concat (substring (nth 0 elem) 0 3) " "
 365             (substring (nth 1 elem) 0 3) " "
 366             (substring (nth 2 elem) 0 2) " "
 367             (substring (nth 3 elem) 1 6) " "
 368             (format-time-string "%Y") " "
 369             (nth 4 elem))))
 370
 371 (defun nnultimate-generate-active ()
 372   (save-excursion
 373     (set-buffer nntp-server-buffer)
 374     (erase-buffer)
 375     (dolist (elem nnultimate-groups)
 376       (insert (prin1-to-string (car elem))
 377               " " (number-to-string (cadr elem)) " 1 y\n"))))
 378
 379 (defun nnultimate-find-forum-table (contents)
 380   (catch 'found
 381     (nnultimate-find-forum-table-1 contents)))
 382
 383 (defun nnultimate-find-forum-table-1 (contents)
 384   (dolist (element contents)
 385     (unless (stringp element)
 386       (when (and (eq (car element) 'table)
 387                  (equalp (cdr (assq 'width (cadr element))) "100%"))
 388         (throw 'found element))
 389       (when (nth 2 element)
 390         (nnultimate-find-forum-table-1 (nth 2 element))))))
 391
 392 (defun nnultimate-descend (type contents)
 393   (catch 'found
 394     (nnultimate-descend-1 type contents)))
 395
 396 (defun nnultimate-descend-1 (type contents)
 397   (when (consp contents)
 398     (when (eq (car contents) type)
 399       (throw 'found contents))
 400     (when (listp (cdr contents))
 401       (dolist (element contents)
 402         (when (consp element)
 403           (nnultimate-descend-1 type element))))))
 404
 405 (defvar nnultimate-text)
 406 (defun nnultimate-text (contents)
 407   (let ((nnultimate-text nil))
 408     (nnultimate-text-1 contents)
 409     (nreverse nnultimate-text)))
 410
 411 (defun nnultimate-text-1 (contents)
 412   (when (consp (car contents))
 413     (dolist (element contents)
 414       (if (stringp element)
 415           (push element nnultimate-text)
 416         (when (consp element)
 417           (nnultimate-text-1 (nth 2 element)))))))
 418
 419
 420 (defun nnultimate-text-1 (contents)
 421   (dolist (element contents)
 422     (if (stringp element)
 423         (push element nnultimate-text)
 424       (when (and (consp element)
 425                  (listp (cdr element)))
 426         (nnultimate-text-1 element)))))
 427
 428 (provide 'nnultimate)
 429
 430 ;;; nnultimate.el ends here