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

   1 ;;; nnrss.el --- interfacing with RSS
   2 ;; Copyright (C) 2001, 2002, 2003, 2004  Free Software Foundation, Inc.
   3
   4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
   5 ;; Keywords: RSS
   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
  11 ;; by the Free Software Foundation; either version 2, or (at your
  12 ;; option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 ;; 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 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29
  30 (require 'gnus)
  31 (require 'nnoo)
  32 (require 'nnmail)
  33 (require 'message)
  34 (require 'mm-util)
  35 (require 'gnus-util)
  36 (require 'time-date)
  37 (require 'rfc2231)
  38 (require 'mm-url)
  39 (eval-when-compile
  40   (ignore-errors
  41     (require 'xml)))
  42 (eval '(require 'xml))
  43
  44 (nnoo-declare nnrss)
  45
  46 (defvoo nnrss-directory (nnheader-concat gnus-directory "rss/")
  47   "Where nnrss will save its files.")
  48
  49 ;; (group max rss-url)
  50 (defvoo nnrss-server-data nil)
  51
  52 ;; (num timestamp url subject author date extra)
  53 (defvoo nnrss-group-data nil)
  54 (defvoo nnrss-group-max 0)
  55 (defvoo nnrss-group-min 1)
  56 (defvoo nnrss-group nil)
  57 (defvoo nnrss-group-hashtb (make-hash-table :test 'equal))
  58 (defvoo nnrss-status-string "")
  59
  60 (defconst nnrss-version "nnrss 1.0")
  61
  62 (defvar nnrss-group-alist '()
  63   "List of RSS addresses.")
  64
  65 (defvar nnrss-use-local nil)
  66
  67 (defvar nnrss-description-field 'X-Gnus-Description
  68   "Field name used for DESCRIPTION.
  69 To use the description in headers, put this name into `nnmail-extra-headers'.")
  70
  71 (defvar nnrss-url-field 'X-Gnus-Url
  72   "Field name used for URL.
  73 To use the description in headers, put this name into `nnmail-extra-headers'.")
  74
  75 (defvar nnrss-content-function nil
  76   "A function which is called in `nnrss-request-article'.
  77 The arguments are (ENTRY GROUP ARTICLE).
  78 ENTRY is the record of the current headline.  GROUP is the group name.
  79 ARTICLE is the article number of the current headline.")
  80
  81 (nnoo-define-basics nnrss)
  82
  83 ;;; Interface functions
  84
  85 (eval-when-compile
  86   (defmacro nnrss-string-as-multibyte (string)
  87     (if (featurep 'xemacs)
  88         string
  89       `(string-as-multibyte ,string))))
  90
  91 (deffoo nnrss-retrieve-headers (articles &optional group server fetch-old)
  92   (nnrss-possibly-change-group group server)
  93   (let (e)
  94     (save-excursion
  95       (set-buffer nntp-server-buffer)
  96       (erase-buffer)
  97       (dolist (article articles)
  98         (if (setq e (assq article nnrss-group-data))
  99             (insert (number-to-string (car e)) "\t" ;; number
 100                     (if (nth 3 e)
 101                         (nnrss-format-string (nth 3 e)) "")
 102                     "\t" ;; subject
 103                     (if (nth 4 e)
 104                         (nnrss-format-string (nth 4 e))
 105                       "(nobody)")
 106                     "\t" ;;from
 107                     (or (nth 5 e) "")
 108                     "\t" ;; date
 109                     (format "<%d@%s.nnrss>" (car e) group)
 110                     "\t" ;; id
 111                     "\t" ;; refs
 112                     "-1" "\t" ;; chars
 113                     "-1" "\t" ;; lines
 114                     "" "\t" ;; Xref
 115                     (if (and (nth 6 e)
 116                              (memq nnrss-description-field
 117                                    nnmail-extra-headers))
 118                         (concat (symbol-name nnrss-description-field)
 119                                 ": "
 120                                 (nnrss-format-string (nth 6 e))
 121                                 "\t")
 122                       "")
 123                     (if (and (nth 2 e)
 124                              (memq nnrss-url-field
 125                                    nnmail-extra-headers))
 126                         (concat (symbol-name nnrss-url-field)
 127                                 ": "
 128                                 (nnrss-format-string (nth 2 e))
 129                                 "\t")
 130                       "")
 131                     "\n")))))
 132   'nov)
 133
 134 (deffoo nnrss-request-group (group &optional server dont-check)
 135   (nnrss-possibly-change-group group server)
 136   (if dont-check
 137       t
 138     (nnrss-check-group group server)
 139     (nnheader-report 'nnrss "Opened group %s" group)
 140     (nnheader-insert
 141      "211 %d %d %d %s\n" nnrss-group-max nnrss-group-min nnrss-group-max
 142      (prin1-to-string group)
 143      t)))
 144
 145 (deffoo nnrss-close-group (group &optional server)
 146   t)
 147
 148 (deffoo nnrss-request-article (article &optional group server buffer)
 149   (nnrss-possibly-change-group group server)
 150   (let ((e (assq article nnrss-group-data))
 151         (boundary "=-=-=-=-=-=-=-=-=-")
 152         (nntp-server-buffer (or buffer nntp-server-buffer))
 153         post err)
 154     (when e
 155       (catch 'error
 156         (with-current-buffer nntp-server-buffer
 157           (erase-buffer)
 158           (goto-char (point-min))
 159           (insert "Mime-Version: 1.0\nContent-Type: multipart/alternative; boundary=\"" boundary "\"\n")
 160           (if group
 161               (insert "Newsgroups: " group "\n"))
 162           (if (nth 3 e)
 163               (insert "Subject: " (nnrss-format-string (nth 3 e)) "\n"))
 164           (if (nth 4 e)
 165               (insert "From: " (nnrss-format-string (nth 4 e)) "\n"))
 166           (if (nth 5 e)
 167               (insert "Date: " (nnrss-format-string (nth 5 e)) "\n"))
 168           (insert "Message-ID: " (format "<%d@%s.nnrss>" (car e) group) "\n")
 169           (insert "\n")
 170           (let ((text (if (nth 6 e)
 171                           (nnrss-string-as-multibyte (nth 6 e))))
 172                 (link (if (nth 2 e)
 173                           (nth 2 e))))
 174             (insert "\n\n--" boundary "\nContent-Type: text/plain\n\n")
 175             (let ((point (point)))
 176               (when text
 177                 (insert text)
 178                 (goto-char point)
 179                 (while (search-forward "\n" nil t)
 180                   (replace-match " "))
 181                 (goto-char (point-max))
 182                 (insert "\n\n"))
 183               (when link
 184                 (insert link)))
 185             (insert "\n\n--" boundary "\nContent-Type: text/html\n\n")
 186             (let ((point (point)))
 187               (when text
 188                 (insert "<html><head></head><body>\n" text "\n</body></html>")
 189                 (goto-char point)
 190                 (while (search-forward "\n" nil t)
 191                   (replace-match " "))
 192                 (goto-char (point-max))
 193                 (insert "\n\n"))
 194               (when link
 195                 (insert "<p><a href=\"" link "\">link</a></p>\n"))))
 196           (when nnrss-content-function
 197             (funcall nnrss-content-function e group article)))))
 198     (cond
 199      (err
 200       (nnheader-report 'nnrss err))
 201      ((not e)
 202       (nnheader-report 'nnrss "no such id: %d" article))
 203      (t
 204       (nnheader-report 'nnrss "article %s retrieved" (car e))
 205       ;; we return the article number.
 206       (cons nnrss-group (car e))))))
 207
 208 (deffoo nnrss-request-list (&optional server)
 209   (nnrss-possibly-change-group nil server)
 210   (nnrss-generate-active)
 211   t)
 212
 213 (deffoo nnrss-open-server (server &optional defs connectionless)
 214   (nnrss-read-server-data server)
 215   (nnoo-change-server 'nnrss server defs)
 216   t)
 217
 218 (deffoo nnrss-request-expire-articles
 219     (articles group &optional server force)
 220   (nnrss-possibly-change-group group server)
 221   (let (e days not-expirable changed)
 222     (dolist (art articles)
 223       (if (and (setq e (assq art nnrss-group-data))
 224                (nnmail-expired-article-p
 225                 group
 226                 (if (listp (setq days (nth 1 e))) days
 227                   (days-to-time (- days (time-to-days '(0 0)))))
 228                 force))
 229           (setq nnrss-group-data (delq e nnrss-group-data)
 230                 changed t)
 231         (push art not-expirable)))
 232     (if changed
 233         (nnrss-save-group-data group server))
 234     not-expirable))
 235
 236 (deffoo nnrss-request-delete-group (group &optional force server)
 237   (nnrss-possibly-change-group group server)
 238   (setq nnrss-server-data
 239         (delq (assoc group nnrss-server-data) nnrss-server-data))
 240   (nnrss-save-server-data server)
 241   (ignore-errors
 242     (delete-file (nnrss-make-filename group server)))
 243   t)
 244
 245 (deffoo nnrss-request-list-newsgroups (&optional server)
 246   (nnrss-possibly-change-group nil server)
 247   (save-excursion
 248     (set-buffer nntp-server-buffer)
 249     (erase-buffer)
 250     (dolist (elem nnrss-group-alist)
 251       (if (third elem)
 252           (insert (car elem) "\t" (third elem) "\n"))))
 253   t)
 254
 255 (nnoo-define-skeleton nnrss)
 256
 257 ;;; Internal functions
 258 (eval-when-compile (defun xml-rpc-method-call (&rest args)))
 259 (defun nnrss-fetch (url &optional local)
 260   "Fetch URL and put it in a the expected Lisp structure."
 261   (with-temp-buffer
 262     ;;some CVS versions of url.el need this to close the connection quickly
 263     (let (xmlform htmlform)
 264       ;; bit o' work necessary for w3 pre-cvs and post-cvs
 265       (if local
 266           (let ((coding-system-for-read 'binary))
 267             (insert-file-contents url))
 268         (mm-url-insert url))
 269
 270       ;; Because xml-parse-region can't deal with anything that isn't
 271       ;; xml and w3-parse-buffer can't deal with some xml, we have to
 272       ;; parse with xml-parse-region first and, if that fails, parse
 273       ;; with w3-parse-buffer.  Yuck.  Eventually, someone should find out
 274       ;; why w3-parse-buffer fails to parse some well-formed xml and
 275       ;; fix it.
 276
 277       (condition-case err
 278           (setq xmlform (xml-parse-region (point-min) (point-max)))
 279         (error (if (fboundp 'w3-parse-buffer)
 280                    (setq htmlform (caddar (w3-parse-buffer
 281                                            (current-buffer))))
 282                  (message "nnrss: Not valid XML and w3 parse not available (%s)"
 283                           url))))
 284       (if htmlform
 285           htmlform
 286         xmlform))))
 287
 288 (defun nnrss-possibly-change-group (&optional group server)
 289   (when (and server
 290              (not (nnrss-server-opened server)))
 291     (nnrss-open-server server))
 292   (when (and group (not (equal group nnrss-group)))
 293     (nnrss-read-group-data group server)
 294     (setq nnrss-group group)))
 295
 296 (defvar nnrss-extra-categories '(nnrss-snarf-moreover-categories))
 297
 298 (defun nnrss-generate-active ()
 299   (when (y-or-n-p "Fetch extra categories? ")
 300     (mapc 'funcall nnrss-extra-categories))
 301   (save-excursion
 302     (set-buffer nntp-server-buffer)
 303     (erase-buffer)
 304     (dolist (elem nnrss-group-alist)
 305       (insert (prin1-to-string (car elem)) " 0 1 y\n"))
 306     (dolist (elem nnrss-server-data)
 307       (unless (assoc (car elem) nnrss-group-alist)
 308         (insert (prin1-to-string (car elem)) " 0 1 y\n")))))
 309
 310 ;;; data functions
 311
 312 (defun nnrss-read-server-data (server)
 313   (setq nnrss-server-data nil)
 314   (let ((file (nnrss-make-filename "nnrss" server)))
 315     (when (file-exists-p file)
 316       (let ((coding-system-for-read 'binary))
 317         (load file nil nil t)))))
 318
 319 (defun nnrss-save-server-data (server)
 320   (gnus-make-directory nnrss-directory)
 321   (let ((coding-system-for-write 'binary))
 322     (with-temp-file (nnrss-make-filename "nnrss" server)
 323       (gnus-prin1 `(setq nnrss-group-alist ',nnrss-group-alist))
 324       (gnus-prin1 `(setq nnrss-server-data ',nnrss-server-data)))))
 325
 326 (defun nnrss-read-group-data (group server)
 327   (setq nnrss-group-data nil)
 328   (if (hash-table-p nnrss-group-hashtb)
 329       (clrhash nnrss-group-hashtb)
 330     (setq nnrss-group-hashtb (make-hash-table :test 'equal)))
 331   (let ((pair (assoc group nnrss-server-data)))
 332     (setq nnrss-group-max (or (cadr pair) 0))
 333     (setq nnrss-group-min (+ nnrss-group-max 1)))
 334   (let ((file (nnrss-make-filename group server)))
 335     (when (file-exists-p file)
 336       (let ((coding-system-for-read 'binary))
 337         (load file nil t t))
 338       (dolist (e nnrss-group-data)
 339         (puthash (or (nth 2 e) (nth 6 e)) t nnrss-group-hashtb)
 340         (when (and (car e) (> nnrss-group-min (car e)))
 341           (setq nnrss-group-min (car e)))
 342         (when (and (car e) (< nnrss-group-max (car e)))
 343           (setq nnrss-group-max (car e)))))))
 344
 345 (defun nnrss-save-group-data (group server)
 346   (gnus-make-directory nnrss-directory)
 347   (let ((coding-system-for-write 'binary))
 348     (with-temp-file (nnrss-make-filename group server)
 349       (gnus-prin1 `(setq nnrss-group-data ',nnrss-group-data)))))
 350
 351 (defun nnrss-make-filename (name server)
 352   (expand-file-name
 353    (nnrss-translate-file-chars
 354     (concat name
 355             (and server
 356                  (not (equal server ""))
 357                  "-")
 358             server
 359             ".el"))
 360    nnrss-directory))
 361
 362 (gnus-add-shutdown 'nnrss-close 'gnus)
 363
 364 (defun nnrss-close ()
 365   "Clear internal nnrss variables."
 366   (setq nnrss-group-data nil
 367         nnrss-server-data nil
 368         nnrss-group-hashtb nil
 369         nnrss-group-alist nil))
 370
 371 ;;; URL interface
 372
 373 (defun nnrss-no-cache (url)
 374   "")
 375
 376 (defun nnrss-insert-w3 (url)
 377   (mm-with-unibyte-current-buffer
 378     (mm-url-insert url)))
 379
 380 (defun nnrss-decode-entities-unibyte-string (string)
 381   (if string
 382       (mm-with-unibyte-buffer
 383         (insert string)
 384         (mm-url-decode-entities-nbsp)
 385         (buffer-string))))
 386
 387 (defalias 'nnrss-insert 'nnrss-insert-w3)
 388
 389 ;;; Snarf functions
 390
 391 (defun nnrss-check-group (group server)
 392   (let (file xml subject url extra changed author
 393              date rss-ns rdf-ns content-ns dc-ns)
 394     (if (and nnrss-use-local
 395              (file-exists-p (setq file (expand-file-name
 396                                         (nnrss-translate-file-chars
 397                                          (concat group ".xml"))
 398                                         nnrss-directory))))
 399         (setq xml (nnrss-fetch file t))
 400       (setq url (or (nth 2 (assoc group nnrss-server-data))
 401                     (second (assoc group nnrss-group-alist))))
 402       (unless url
 403         (setq url
 404              (cdr
 405               (assoc 'href
 406                      (nnrss-discover-feed
 407                       (read-string
 408                        (format "URL to search for %s: " group) "http://")))))
 409         (let ((pair (assoc group nnrss-server-data)))
 410           (if pair
 411               (setcdr (cdr pair) (list url))
 412             (push (list group nnrss-group-max url) nnrss-server-data)))
 413         (setq changed t))
 414       (setq xml (nnrss-fetch url)))
 415     ;; See
 416     ;; http://feeds.archive.org/validator/docs/howto/declare_namespaces.html
 417     ;; for more RSS namespaces.
 418     (setq dc-ns (nnrss-get-namespace-prefix xml "http://purl.org/dc/elements/1.1/")
 419           rdf-ns (nnrss-get-namespace-prefix xml "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
 420           rss-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/")
 421           content-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/modules/content/"))
 422     (dolist (item (nreverse (nnrss-find-el (intern (concat rss-ns "item")) xml)))
 423       (when (and (listp item)
 424                  (string= (concat rss-ns "item") (car item))
 425                  (if (setq url (nnrss-decode-entities-unibyte-string
 426                                 (nnrss-node-text rss-ns 'link (cddr item))))
 427                      (not (gethash url nnrss-group-hashtb))
 428                    (setq extra (or (nnrss-node-text content-ns 'encoded item)
 429                                    (nnrss-node-text rss-ns 'description item)))
 430                    (not (gethash extra nnrss-group-hashtb))))
 431         (setq subject (nnrss-node-text rss-ns 'title item))
 432         (setq extra (or extra
 433                         (nnrss-node-text content-ns 'encoded item)
 434                         (nnrss-node-text rss-ns 'description item)))
 435         (setq author (or (nnrss-node-text rss-ns 'author item)
 436                          (nnrss-node-text dc-ns 'creator item)
 437                          (nnrss-node-text dc-ns 'contributor item)))
 438         (setq date (or (nnrss-node-text dc-ns 'date item)
 439                        (nnrss-node-text rss-ns 'pubDate item)
 440                        (message-make-date)))
 441         (push
 442          (list
 443           (incf nnrss-group-max)
 444           (current-time)
 445           url
 446           (and subject (nnrss-decode-entities-unibyte-string subject))
 447           (and author (nnrss-decode-entities-unibyte-string author))
 448           date
 449           (and extra (nnrss-decode-entities-unibyte-string extra)))
 450          nnrss-group-data)
 451         (puthash (or url extra) t nnrss-group-hashtb)
 452         (setq changed t))
 453         (setq extra nil))
 454     (when changed
 455       (nnrss-save-group-data group server)
 456       (let ((pair (assoc group nnrss-server-data)))
 457         (if pair
 458             (setcar (cdr pair) nnrss-group-max)
 459           (push (list group nnrss-group-max) nnrss-server-data)))
 460       (nnrss-save-server-data server))))
 461
 462 (defun nnrss-opml-import (opml-file)
 463   "OPML subscriptions import.
 464 Read the file and attempt to subscribe to each Feed in the file."
 465   (interactive "fImport file: ")
 466   (mapcar
 467    (lambda (node) (gnus-group-make-rss-group
 468                    (cdr (assq 'xmlUrl (cadr node)))))
 469    (nnrss-find-el 'outline
 470                   (progn
 471                     (find-file opml-file)
 472                     (xml-parse-region (point-min)
 473                                       (point-max))))))
 474
 475 (defun nnrss-opml-export ()
 476   "OPML subscription export.
 477 Export subscriptions to a buffer in OPML Format."
 478   (interactive)
 479   (with-current-buffer (get-buffer-create "*OPML Export*")
 480     (mm-set-buffer-file-coding-system 'utf-8)
 481     (insert (concat
 482              "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"
 483              "<!-- OPML generated by Emacs Gnus' nnrss.el -->\n"
 484              "<opml version=\"1.1\">\n"
 485              "  <head>\n"
 486              "    <title>mySubscriptions</title>\n"
 487              "    <dateCreated>" (format-time-string "%a, %d %b %Y %T %z")
 488              "</dateCreated>\n"
 489              "    <ownerEmail>" user-mail-address "</ownerEmail>\n"
 490              "    <ownerName>" (user-full-name) "</ownerName>\n"
 491              "  </head>\n"
 492              "  <body>\n"))
 493     (mapc (lambda (sub)
 494             (insert (concat
 495                      "    <outline text=\"" (car sub) "\" xmlUrl=\""
 496                      (cadr sub) "\"/>\n")))
 497           nnrss-group-alist)
 498     (insert (concat
 499              "  </body>\n"
 500            "</opml>\n")))
 501   (pop-to-buffer "*OPML Export*")
 502   (when (fboundp 'sgml-mode)
 503     (sgml-mode)))
 504
 505 (defun nnrss-generate-download-script ()
 506   "Generate a download script in the current buffer.
 507 It is useful when `(setq nnrss-use-local t)'."
 508   (interactive)
 509   (insert "#!/bin/sh\n")
 510   (insert "WGET=wget\n")
 511   (insert "RSSDIR='" (expand-file-name nnrss-directory) "'\n")
 512   (dolist (elem nnrss-server-data)
 513     (let ((url (or (nth 2 elem)
 514                    (second (assoc (car elem) nnrss-group-alist)))))
 515       (insert "$WGET -q -O \"$RSSDIR\"/'"
 516               (nnrss-translate-file-chars (concat (car elem) ".xml"))
 517               "' '" url "'\n"))))
 518
 519 (defun nnrss-translate-file-chars (name)
 520   (let ((nnheader-file-name-translation-alist
 521          (append nnheader-file-name-translation-alist '((?' . ?_)))))
 522     (nnheader-translate-file-chars name)))
 523
 524 (defvar nnrss-moreover-url
 525   "http://w.moreover.com/categories/category_list_rss.html"
 526   "The url of moreover.com categories.")
 527
 528 (defun nnrss-snarf-moreover-categories ()
 529   "Snarf RSS links from moreover.com."
 530   (interactive)
 531   (let (category name url changed)
 532     (with-temp-buffer
 533       (nnrss-insert nnrss-moreover-url)
 534       (goto-char (point-min))
 535       (while (re-search-forward
 536               "<a name=\"\\([^\"]+\\)\">\\|<a href=\"\\(http://[^\"]*moreover\\.com[^\"]+page\\?c=\\([^\"&]+\\)&o=rss\\)" nil t)
 537         (if (match-string 1)
 538             (setq category (match-string 1))
 539           (setq url (match-string 2)
 540                 name (mm-url-decode-entities-string
 541                       (rfc2231-decode-encoded-string
 542                        (match-string 3))))
 543           (if category
 544               (setq name (concat category "." name)))
 545           (unless (assoc name nnrss-server-data)
 546             (setq changed t)
 547             (push (list name 0 url) nnrss-server-data)))))
 548     (if changed
 549         (nnrss-save-server-data ""))))
 550
 551 (defun nnrss-format-string (string)
 552   (gnus-replace-in-string (nnrss-string-as-multibyte string) " *\n *" " "))
 553
 554 (defun nnrss-node-text (namespace local-name element)
 555   (let* ((node (assq (intern (concat namespace (symbol-name local-name)))
 556                      element))
 557          (text (if (and node (listp node))
 558                    (nnrss-node-just-text node)
 559                  node))
 560          (cleaned-text (if text (gnus-replace-in-string
 561                                  text "^[\000-\037\177]+\\|^ +\\| +$" ""))))
 562     (if (string-equal "" cleaned-text)
 563         nil
 564       cleaned-text)))
 565
 566 (defun nnrss-node-just-text (node)
 567   (if (and node (listp node))
 568       (mapconcat 'nnrss-node-just-text (cddr node) " ")
 569     node))
 570
 571 (defun nnrss-find-el (tag data &optional found-list)
 572   "Find the all matching elements in the data.
 573 Careful with this on large documents!"
 574   (when (listp data)
 575     (mapc (lambda (bit)
 576             (when (car-safe bit)
 577               (when (equal tag (car bit))
 578                 (setq found-list
 579                       (append found-list
 580                               (list bit))))
 581               (if (and (listp (car-safe (caddr bit)))
 582                        (not (stringp (caddr bit))))
 583                   (setq found-list
 584                         (append found-list
 585                                 (nnrss-find-el
 586                                  tag (caddr bit))))
 587                 (setq found-list
 588                       (append found-list
 589                               (nnrss-find-el
 590                                tag (cddr bit)))))))
 591           data))
 592   found-list)
 593
 594 (defun nnrss-rsslink-p (el)
 595   "Test if the element we are handed is an RSS autodiscovery link."
 596   (and (eq (car-safe el) 'link)
 597        (string-equal (cdr (assoc 'rel (cadr el))) "alternate")
 598        (or (string-equal (cdr (assoc 'type (cadr el)))
 599                          "application/rss+xml")
 600            (string-equal (cdr (assoc 'type (cadr el))) "text/xml"))))
 601
 602 (defun nnrss-get-rsslinks (data)
 603   "Extract the <link> elements that are links to RSS from the parsed data."
 604   (delq nil (mapcar
 605              (lambda (el)
 606                (if (nnrss-rsslink-p el) el))
 607              (nnrss-find-el 'link data))))
 608
 609 (defun nnrss-extract-hrefs (data)
 610   "Recursively extract hrefs from a page's source.
 611 DATA should be the output of `xml-parse-region' or
 612 `w3-parse-buffer'."
 613   (mapcar (lambda (ahref)
 614             (cdr (assoc 'href (cadr ahref))))
 615           (nnrss-find-el 'a data)))
 616
 617 (defmacro nnrss-match-macro (base-uri item
 618                                            onsite-list offsite-list)
 619   `(cond ((or (string-match (concat "^" ,base-uri) ,item)
 620                (not (string-match "://" ,item)))
 621            (setq ,onsite-list (append ,onsite-list (list ,item))))
 622           (t (setq ,offsite-list (append ,offsite-list (list ,item))))))
 623
 624 (defun nnrss-order-hrefs (base-uri hrefs)
 625   "Given a list of hrefs, sort them using the following priorities:
 626   1. links ending in .rss
 627   2. links ending in .rdf
 628   3. links ending in .xml
 629   4. links containing the above
 630   5. offsite links
 631
 632 BASE-URI is used to determine the location of the links and
 633 whether they are `offsite' or `onsite'."
 634   (let (rss-onsite-end  rdf-onsite-end  xml-onsite-end
 635         rss-onsite-in   rdf-onsite-in   xml-onsite-in
 636         rss-offsite-end rdf-offsite-end xml-offsite-end
 637         rss-offsite-in rdf-offsite-in xml-offsite-in)
 638     (mapc (lambda (href)
 639             (if (not (null href))
 640                 (cond ((string-match "\\.rss$" href)
 641                        (nnrss-match-macro
 642                         base-uri href rss-onsite-end rss-offsite-end))
 643                       ((string-match "\\.rdf$" href)
 644                        (nnrss-match-macro
 645                         base-uri href rdf-onsite-end rdf-offsite-end))
 646                       ((string-match "\\.xml$" href)
 647                        (nnrss-match-macro
 648                         base-uri href xml-onsite-end xml-offsite-end))
 649                       ((string-match "rss" href)
 650                        (nnrss-match-macro
 651                         base-uri href rss-onsite-in rss-offsite-in))
 652                       ((string-match "rdf" href)
 653                        (nnrss-match-macro
 654                         base-uri href rdf-onsite-in rdf-offsite-in))
 655                       ((string-match "xml" href)
 656                        (nnrss-match-macro
 657                         base-uri href xml-onsite-in xml-offsite-in)))))
 658           hrefs)
 659     (append
 660      rss-onsite-end  rdf-onsite-end  xml-onsite-end
 661      rss-onsite-in   rdf-onsite-in   xml-onsite-in
 662      rss-offsite-end rdf-offsite-end xml-offsite-end
 663      rss-offsite-in rdf-offsite-in xml-offsite-in)))
 664
 665 (defun nnrss-discover-feed (url)
 666   "Given a page, find an RSS feed using Mark Pilgrim's
 667 `ultra-liberal rss locator' (http://diveintomark.org/2002/08/15.html)."
 668
 669   (let ((parsed-page (nnrss-fetch url)))
 670
 671 ;;    1. if this url is the rss, use it.
 672     (if (nnrss-rss-p parsed-page)
 673         (let ((rss-ns (nnrss-get-namespace-prefix parsed-page "http://purl.org/rss/1.0/")))
 674           (nnrss-rss-title-description rss-ns parsed-page url))
 675
 676 ;;    2. look for the <link rel="alternate"
 677 ;;    type="application/rss+xml" and use that if it is there.
 678       (let ((links (nnrss-get-rsslinks parsed-page)))
 679         (if links
 680             (let* ((xml (nnrss-fetch
 681                          (cdr (assoc 'href (cadar links)))))
 682                    (rss-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/")))
 683               (nnrss-rss-title-description rss-ns xml (cdr (assoc 'href (cadar links)))))
 684
 685 ;;    3. look for links on the site in the following order:
 686 ;;       - onsite links ending in .rss, .rdf, or .xml
 687 ;;       - onsite links containing any of the above
 688 ;;       - offsite links ending in .rss, .rdf, or .xml
 689 ;;       - offsite links containing any of the above
 690           (let* ((base-uri (progn (string-match ".*://[^/]+/?" url)
 691                                   (match-string 0 url)))
 692                  (hrefs (nnrss-order-hrefs
 693                          base-uri (nnrss-extract-hrefs parsed-page)))
 694                  (rss-link nil))
 695           (while (and (eq rss-link nil) (not (eq hrefs nil)))
 696             (let ((href-data (nnrss-fetch (car hrefs))))
 697               (if (nnrss-rss-p href-data)
 698                   (let* ((rss-ns (nnrss-get-namespace-prefix href-data "http://purl.org/rss/1.0/")))
 699                     (setq rss-link (nnrss-rss-title-description
 700                                     rss-ns href-data (car hrefs))))
 701                 (setq hrefs (cdr hrefs)))))
 702           (if rss-link rss-link
 703
 704 ;;    4. check syndic8
 705             (nnrss-find-rss-via-syndic8 url))))))))
 706
 707 (defun nnrss-find-rss-via-syndic8 (url)
 708   "Query syndic8 for the rss feeds it has for URL."
 709   (if (not (locate-library "xml-rpc"))
 710       (progn
 711         (message "XML-RPC is not available... not checking Syndic8.")
 712         nil)
 713     (require 'xml-rpc)
 714     (let ((feedid (xml-rpc-method-call
 715                    "http://www.syndic8.com/xmlrpc.php"
 716                    'syndic8.FindSites
 717                    url)))
 718       (when feedid
 719         (let* ((feedinfo (xml-rpc-method-call
 720                           "http://www.syndic8.com/xmlrpc.php"
 721                           'syndic8.GetFeedInfo
 722                           feedid))
 723                (urllist
 724                 (delq nil
 725                       (mapcar
 726                        (lambda (listinfo)
 727                          (if (string-equal
 728                               (cdr (assoc "status" listinfo))
 729                               "Syndicated")
 730                              (cons
 731                               (cdr (assoc "sitename" listinfo))
 732                               (list
 733                                (cons 'title
 734                                      (cdr (assoc
 735                                            "sitename" listinfo)))
 736                                (cons 'href
 737                                      (cdr (assoc
 738                                            "dataurl" listinfo)))))))
 739                        feedinfo))))
 740           (if (not (> (length urllist) 1))
 741               (cdar urllist)
 742             (let ((completion-ignore-case t)
 743                   (selection
 744                    (mapcar (lambda (listinfo)
 745                              (cons (cdr (assoc "sitename" listinfo))
 746                                    (string-to-int
 747                                     (cdr (assoc "feedid" listinfo)))))
 748                            feedinfo)))
 749               (cdr (assoc
 750                     (completing-read
 751                      "Multiple feeds found.  Select one: "
 752                      selection nil t) urllist)))))))))
 753
 754 (defun nnrss-rss-p (data)
 755   "Test if DATA is an RSS feed.
 756 Simply ensures that the first element is rss or rdf."
 757   (or (eq (caar data) 'rss)
 758       (eq (caar data) 'rdf:RDF)))
 759
 760 (defun nnrss-rss-title-description (rss-namespace data url)
 761   "Return the title of an RSS feed."
 762   (if (nnrss-rss-p data)
 763       (let ((description (intern (concat rss-namespace "description")))
 764             (title (intern (concat rss-namespace "title")))
 765             (channel (nnrss-find-el (intern (concat rss-namespace "channel"))
 766                                     data)))
 767         (list
 768          (cons 'description (caddr (nth 0 (nnrss-find-el description channel))))
 769          (cons 'title (caddr (nth 0 (nnrss-find-el title channel))))
 770          (cons 'href url)))))
 771
 772 (defun nnrss-get-namespace-prefix (el uri)
 773   "Given EL (containing a parsed element) and URI (containing a string
 774 that gives the URI for which you want to retrieve the namespace
 775 prefix), return the prefix."
 776   (let* ((prefix (car (rassoc uri (cadar el))))
 777          (nslist (if prefix
 778                      (split-string (symbol-name prefix) ":")))
 779          (ns (cond ((eq (length nslist) 1) ; no prefix given
 780                     "")
 781                    ((eq (length nslist) 2) ; extract prefix
 782                     (cadr nslist)))))
 783     (if (and ns (not (string= ns "")))
 784         (concat ns ":")
 785       ns)))
 786
 787 (provide 'nnrss)
 788
 789
 790 ;;; nnrss.el ends here
 791
 792 ;;; arch-tag: 12910c07-0cdf-44fb-8d2c-416ded64c267