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 nil
 278           (setq xmlform (xml-parse-region (point-min) (point-max)))
 279         (error
 280          (condition-case err
 281              (setq htmlform (caddar (w3-parse-buffer
 282                                      (current-buffer))))
 283            (error
 284             (message "nnrss: %s: Not valid XML and w3-parse doesn't work: %s"
 285                      url err)))))
 286       (if htmlform
 287           htmlform
 288         xmlform))))
 289
 290 (defun nnrss-possibly-change-group (&optional group server)
 291   (when (and server
 292              (not (nnrss-server-opened server)))
 293     (nnrss-open-server server))
 294   (when (and group (not (equal group nnrss-group)))
 295     (nnrss-read-group-data group server)
 296     (setq nnrss-group group)))
 297
 298 (defvar nnrss-extra-categories '(nnrss-snarf-moreover-categories))
 299
 300 (defun nnrss-generate-active ()
 301   (when (y-or-n-p "Fetch extra categories? ")
 302     (mapc 'funcall nnrss-extra-categories))
 303   (save-excursion
 304     (set-buffer nntp-server-buffer)
 305     (erase-buffer)
 306     (dolist (elem nnrss-group-alist)
 307       (insert (prin1-to-string (car elem)) " 0 1 y\n"))
 308     (dolist (elem nnrss-server-data)
 309       (unless (assoc (car elem) nnrss-group-alist)
 310         (insert (prin1-to-string (car elem)) " 0 1 y\n")))))
 311
 312 ;;; data functions
 313
 314 (defun nnrss-read-server-data (server)
 315   (setq nnrss-server-data nil)
 316   (let ((file (nnrss-make-filename "nnrss" server)))
 317     (when (file-exists-p file)
 318       (let ((coding-system-for-read 'binary))
 319         (load file nil nil t)))))
 320
 321 (defun nnrss-save-server-data (server)
 322   (gnus-make-directory nnrss-directory)
 323   (let ((coding-system-for-write 'binary))
 324     (with-temp-file (nnrss-make-filename "nnrss" server)
 325       (gnus-prin1 `(setq nnrss-group-alist ',nnrss-group-alist))
 326       (gnus-prin1 `(setq nnrss-server-data ',nnrss-server-data)))))
 327
 328 (defun nnrss-read-group-data (group server)
 329   (setq nnrss-group-data nil)
 330   (if (hash-table-p nnrss-group-hashtb)
 331       (clrhash nnrss-group-hashtb)
 332     (setq nnrss-group-hashtb (make-hash-table :test 'equal)))
 333   (let ((pair (assoc group nnrss-server-data)))
 334     (setq nnrss-group-max (or (cadr pair) 0))
 335     (setq nnrss-group-min (+ nnrss-group-max 1)))
 336   (let ((file (nnrss-make-filename group server)))
 337     (when (file-exists-p file)
 338       (let ((coding-system-for-read 'binary))
 339         (load file nil t t))
 340       (dolist (e nnrss-group-data)
 341         (puthash (or (nth 2 e) (nth 6 e)) t nnrss-group-hashtb)
 342         (when (and (car e) (> nnrss-group-min (car e)))
 343           (setq nnrss-group-min (car e)))
 344         (when (and (car e) (< nnrss-group-max (car e)))
 345           (setq nnrss-group-max (car e)))))))
 346
 347 (defun nnrss-save-group-data (group server)
 348   (gnus-make-directory nnrss-directory)
 349   (let ((coding-system-for-write 'binary))
 350     (with-temp-file (nnrss-make-filename group server)
 351       (gnus-prin1 `(setq nnrss-group-data ',nnrss-group-data)))))
 352
 353 (defun nnrss-make-filename (name server)
 354   (expand-file-name
 355    (nnrss-translate-file-chars
 356     (concat name
 357             (and server
 358                  (not (equal server ""))
 359                  "-")
 360             server
 361             ".el"))
 362    nnrss-directory))
 363
 364 (gnus-add-shutdown 'nnrss-close 'gnus)
 365
 366 (defun nnrss-close ()
 367   "Clear internal nnrss variables."
 368   (setq nnrss-group-data nil
 369         nnrss-server-data nil
 370         nnrss-group-hashtb nil
 371         nnrss-group-alist nil))
 372
 373 ;;; URL interface
 374
 375 (defun nnrss-no-cache (url)
 376   "")
 377
 378 (defun nnrss-insert-w3 (url)
 379   (mm-with-unibyte-current-buffer
 380     (mm-url-insert url)))
 381
 382 (defun nnrss-decode-entities-unibyte-string (string)
 383   (if string
 384       (mm-with-unibyte-buffer
 385         (insert string)
 386         (mm-url-decode-entities-nbsp)
 387         (buffer-string))))
 388
 389 (defalias 'nnrss-insert 'nnrss-insert-w3)
 390
 391 ;;; Snarf functions
 392
 393 (defun nnrss-check-group (group server)
 394   (let (file xml subject url extra changed author
 395              date rss-ns rdf-ns content-ns dc-ns)
 396     (if (and nnrss-use-local
 397              (file-exists-p (setq file (expand-file-name
 398                                         (nnrss-translate-file-chars
 399                                          (concat group ".xml"))
 400                                         nnrss-directory))))
 401         (setq xml (nnrss-fetch file t))
 402       (setq url (or (nth 2 (assoc group nnrss-server-data))
 403                     (second (assoc group nnrss-group-alist))))
 404       (unless url
 405         (setq url
 406              (cdr
 407               (assoc 'href
 408                      (nnrss-discover-feed
 409                       (read-string
 410                        (format "URL to search for %s: " group) "http://")))))
 411         (let ((pair (assoc group nnrss-server-data)))
 412           (if pair
 413               (setcdr (cdr pair) (list url))
 414             (push (list group nnrss-group-max url) nnrss-server-data)))
 415         (setq changed t))
 416       (setq xml (nnrss-fetch url)))
 417     ;; See
 418     ;; http://feeds.archive.org/validator/docs/howto/declare_namespaces.html
 419     ;; for more RSS namespaces.
 420     (setq dc-ns (nnrss-get-namespace-prefix xml "http://purl.org/dc/elements/1.1/")
 421           rdf-ns (nnrss-get-namespace-prefix xml "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
 422           rss-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/")
 423           content-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/modules/content/"))
 424     (dolist (item (nreverse (nnrss-find-el (intern (concat rss-ns "item")) xml)))
 425       (when (and (listp item)
 426                  (string= (concat rss-ns "item") (car item))
 427                  (if (setq url (nnrss-decode-entities-unibyte-string
 428                                 (nnrss-node-text rss-ns 'link (cddr item))))
 429                      (not (gethash url nnrss-group-hashtb))
 430                    (setq extra (or (nnrss-node-text content-ns 'encoded item)
 431                                    (nnrss-node-text rss-ns 'description item)))
 432                    (not (gethash extra nnrss-group-hashtb))))
 433         (setq subject (nnrss-node-text rss-ns 'title item))
 434         (setq extra (or extra
 435                         (nnrss-node-text content-ns 'encoded item)
 436                         (nnrss-node-text rss-ns 'description item)))
 437         (setq author (or (nnrss-node-text rss-ns 'author item)
 438                          (nnrss-node-text dc-ns 'creator item)
 439                          (nnrss-node-text dc-ns 'contributor item)))
 440         (setq date (or (nnrss-node-text dc-ns 'date item)
 441                        (nnrss-node-text rss-ns 'pubDate item)
 442                        (message-make-date)))
 443         (push
 444          (list
 445           (incf nnrss-group-max)
 446           (current-time)
 447           url
 448           (and subject (nnrss-decode-entities-unibyte-string subject))
 449           (and author (nnrss-decode-entities-unibyte-string author))
 450           date
 451           (and extra (nnrss-decode-entities-unibyte-string extra)))
 452          nnrss-group-data)
 453         (puthash (or url extra) t nnrss-group-hashtb)
 454         (setq changed t))
 455         (setq extra nil))
 456     (when changed
 457       (nnrss-save-group-data group server)
 458       (let ((pair (assoc group nnrss-server-data)))
 459         (if pair
 460             (setcar (cdr pair) nnrss-group-max)
 461           (push (list group nnrss-group-max) nnrss-server-data)))
 462       (nnrss-save-server-data server))))
 463
 464 (defun nnrss-opml-import (opml-file)
 465   "OPML subscriptions import.
 466 Read the file and attempt to subscribe to each Feed in the file."
 467   (interactive "fImport file: ")
 468   (mapcar
 469    (lambda (node) (gnus-group-make-rss-group
 470                    (cdr (assq 'xmlUrl (cadr node)))))
 471    (nnrss-find-el 'outline
 472                   (progn
 473                     (find-file opml-file)
 474                     (xml-parse-region (point-min)
 475                                       (point-max))))))
 476
 477 (defun nnrss-opml-export ()
 478   "OPML subscription export.
 479 Export subscriptions to a buffer in OPML Format."
 480   (interactive)
 481   (with-current-buffer (get-buffer-create "*OPML Export*")
 482     (mm-set-buffer-file-coding-system 'utf-8)
 483     (insert (concat
 484              "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"
 485              "<!-- OPML generated by Emacs Gnus' nnrss.el -->\n"
 486              "<opml version=\"1.1\">\n"
 487              "  <head>\n"
 488              "    <title>mySubscriptions</title>\n"
 489              "    <dateCreated>" (format-time-string "%a, %d %b %Y %T %z")
 490              "</dateCreated>\n"
 491              "    <ownerEmail>" user-mail-address "</ownerEmail>\n"
 492              "    <ownerName>" (user-full-name) "</ownerName>\n"
 493              "  </head>\n"
 494              "  <body>\n"))
 495     (mapc (lambda (sub)
 496             (insert (concat
 497                      "    <outline text=\"" (car sub) "\" xmlUrl=\""
 498                      (cadr sub) "\"/>\n")))
 499           nnrss-group-alist)
 500     (insert (concat
 501              "  </body>\n"
 502            "</opml>\n")))
 503   (pop-to-buffer "*OPML Export*")
 504   (when (fboundp 'sgml-mode)
 505     (sgml-mode)))
 506
 507 (defun nnrss-generate-download-script ()
 508   "Generate a download script in the current buffer.
 509 It is useful when `(setq nnrss-use-local t)'."
 510   (interactive)
 511   (insert "#!/bin/sh\n")
 512   (insert "WGET=wget\n")
 513   (insert "RSSDIR='" (expand-file-name nnrss-directory) "'\n")
 514   (dolist (elem nnrss-server-data)
 515     (let ((url (or (nth 2 elem)
 516                    (second (assoc (car elem) nnrss-group-alist)))))
 517       (insert "$WGET -q -O \"$RSSDIR\"/'"
 518               (nnrss-translate-file-chars (concat (car elem) ".xml"))
 519               "' '" url "'\n"))))
 520
 521 (defun nnrss-translate-file-chars (name)
 522   (let ((nnheader-file-name-translation-alist
 523          (append nnheader-file-name-translation-alist '((?' . ?_)))))
 524     (nnheader-translate-file-chars name)))
 525
 526 (defvar nnrss-moreover-url
 527   "http://w.moreover.com/categories/category_list_rss.html"
 528   "The url of moreover.com categories.")
 529
 530 (defun nnrss-snarf-moreover-categories ()
 531   "Snarf RSS links from moreover.com."
 532   (interactive)
 533   (let (category name url changed)
 534     (with-temp-buffer
 535       (nnrss-insert nnrss-moreover-url)
 536       (goto-char (point-min))
 537       (while (re-search-forward
 538               "<a name=\"\\([^\"]+\\)\">\\|<a href=\"\\(http://[^\"]*moreover\\.com[^\"]+page\\?c=\\([^\"&]+\\)&o=rss\\)" nil t)
 539         (if (match-string 1)
 540             (setq category (match-string 1))
 541           (setq url (match-string 2)
 542                 name (mm-url-decode-entities-string
 543                       (rfc2231-decode-encoded-string
 544                        (match-string 3))))
 545           (if category
 546               (setq name (concat category "." name)))
 547           (unless (assoc name nnrss-server-data)
 548             (setq changed t)
 549             (push (list name 0 url) nnrss-server-data)))))
 550     (if changed
 551         (nnrss-save-server-data ""))))
 552
 553 (defun nnrss-format-string (string)
 554   (gnus-replace-in-string (nnrss-string-as-multibyte string) " *\n *" " "))
 555
 556 (defun nnrss-node-text (namespace local-name element)
 557   (let* ((node (assq (intern (concat namespace (symbol-name local-name)))
 558                      element))
 559          (text (if (and node (listp node))
 560                    (nnrss-node-just-text node)
 561                  node))
 562          (cleaned-text (if text (gnus-replace-in-string
 563                                  text "^[\000-\037\177]+\\|^ +\\| +$" ""))))
 564     (if (string-equal "" cleaned-text)
 565         nil
 566       cleaned-text)))
 567
 568 (defun nnrss-node-just-text (node)
 569   (if (and node (listp node))
 570       (mapconcat 'nnrss-node-just-text (cddr node) " ")
 571     node))
 572
 573 (defun nnrss-find-el (tag data &optional found-list)
 574   "Find the all matching elements in the data.
 575 Careful with this on large documents!"
 576   (when (listp data)
 577     (mapc (lambda (bit)
 578             (when (car-safe bit)
 579               (when (equal tag (car bit))
 580                 (setq found-list
 581                       (append found-list
 582                               (list bit))))
 583               (if (and (listp (car-safe (caddr bit)))
 584                        (not (stringp (caddr bit))))
 585                   (setq found-list
 586                         (append found-list
 587                                 (nnrss-find-el
 588                                  tag (caddr bit))))
 589                 (setq found-list
 590                       (append found-list
 591                               (nnrss-find-el
 592                                tag (cddr bit)))))))
 593           data))
 594   found-list)
 595
 596 (defun nnrss-rsslink-p (el)
 597   "Test if the element we are handed is an RSS autodiscovery link."
 598   (and (eq (car-safe el) 'link)
 599        (string-equal (cdr (assoc 'rel (cadr el))) "alternate")
 600        (or (string-equal (cdr (assoc 'type (cadr el)))
 601                          "application/rss+xml")
 602            (string-equal (cdr (assoc 'type (cadr el))) "text/xml"))))
 603
 604 (defun nnrss-get-rsslinks (data)
 605   "Extract the <link> elements that are links to RSS from the parsed data."
 606   (delq nil (mapcar
 607              (lambda (el)
 608                (if (nnrss-rsslink-p el) el))
 609              (nnrss-find-el 'link data))))
 610
 611 (defun nnrss-extract-hrefs (data)
 612   "Recursively extract hrefs from a page's source.
 613 DATA should be the output of `xml-parse-region' or
 614 `w3-parse-buffer'."
 615   (mapcar (lambda (ahref)
 616             (cdr (assoc 'href (cadr ahref))))
 617           (nnrss-find-el 'a data)))
 618
 619 (defmacro nnrss-match-macro (base-uri item
 620                                            onsite-list offsite-list)
 621   `(cond ((or (string-match (concat "^" ,base-uri) ,item)
 622                (not (string-match "://" ,item)))
 623            (setq ,onsite-list (append ,onsite-list (list ,item))))
 624           (t (setq ,offsite-list (append ,offsite-list (list ,item))))))
 625
 626 (defun nnrss-order-hrefs (base-uri hrefs)
 627   "Given a list of hrefs, sort them using the following priorities:
 628   1. links ending in .rss
 629   2. links ending in .rdf
 630   3. links ending in .xml
 631   4. links containing the above
 632   5. offsite links
 633
 634 BASE-URI is used to determine the location of the links and
 635 whether they are `offsite' or `onsite'."
 636   (let (rss-onsite-end  rdf-onsite-end  xml-onsite-end
 637         rss-onsite-in   rdf-onsite-in   xml-onsite-in
 638         rss-offsite-end rdf-offsite-end xml-offsite-end
 639         rss-offsite-in rdf-offsite-in xml-offsite-in)
 640     (mapc (lambda (href)
 641             (if (not (null href))
 642                 (cond ((string-match "\\.rss$" href)
 643                        (nnrss-match-macro
 644                         base-uri href rss-onsite-end rss-offsite-end))
 645                       ((string-match "\\.rdf$" href)
 646                        (nnrss-match-macro
 647                         base-uri href rdf-onsite-end rdf-offsite-end))
 648                       ((string-match "\\.xml$" href)
 649                        (nnrss-match-macro
 650                         base-uri href xml-onsite-end xml-offsite-end))
 651                       ((string-match "rss" href)
 652                        (nnrss-match-macro
 653                         base-uri href rss-onsite-in rss-offsite-in))
 654                       ((string-match "rdf" href)
 655                        (nnrss-match-macro
 656                         base-uri href rdf-onsite-in rdf-offsite-in))
 657                       ((string-match "xml" href)
 658                        (nnrss-match-macro
 659                         base-uri href xml-onsite-in xml-offsite-in)))))
 660           hrefs)
 661     (append
 662      rss-onsite-end  rdf-onsite-end  xml-onsite-end
 663      rss-onsite-in   rdf-onsite-in   xml-onsite-in
 664      rss-offsite-end rdf-offsite-end xml-offsite-end
 665      rss-offsite-in rdf-offsite-in xml-offsite-in)))
 666
 667 (defun nnrss-discover-feed (url)
 668   "Given a page, find an RSS feed using Mark Pilgrim's
 669 `ultra-liberal rss locator' (http://diveintomark.org/2002/08/15.html)."
 670
 671   (let ((parsed-page (nnrss-fetch url)))
 672
 673 ;;    1. if this url is the rss, use it.
 674     (if (nnrss-rss-p parsed-page)
 675         (let ((rss-ns (nnrss-get-namespace-prefix parsed-page "http://purl.org/rss/1.0/")))
 676           (nnrss-rss-title-description rss-ns parsed-page url))
 677
 678 ;;    2. look for the <link rel="alternate"
 679 ;;    type="application/rss+xml" and use that if it is there.
 680       (let ((links (nnrss-get-rsslinks parsed-page)))
 681         (if links
 682             (let* ((xml (nnrss-fetch
 683                          (cdr (assoc 'href (cadar links)))))
 684                    (rss-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/")))
 685               (nnrss-rss-title-description rss-ns xml (cdr (assoc 'href (cadar links)))))
 686
 687 ;;    3. look for links on the site in the following order:
 688 ;;       - onsite links ending in .rss, .rdf, or .xml
 689 ;;       - onsite links containing any of the above
 690 ;;       - offsite links ending in .rss, .rdf, or .xml
 691 ;;       - offsite links containing any of the above
 692           (let* ((base-uri (progn (string-match ".*://[^/]+/?" url)
 693                                   (match-string 0 url)))
 694                  (hrefs (nnrss-order-hrefs
 695                          base-uri (nnrss-extract-hrefs parsed-page)))
 696                  (rss-link nil))
 697           (while (and (eq rss-link nil) (not (eq hrefs nil)))
 698             (let ((href-data (nnrss-fetch (car hrefs))))
 699               (if (nnrss-rss-p href-data)
 700                   (let* ((rss-ns (nnrss-get-namespace-prefix href-data "http://purl.org/rss/1.0/")))
 701                     (setq rss-link (nnrss-rss-title-description
 702                                     rss-ns href-data (car hrefs))))
 703                 (setq hrefs (cdr hrefs)))))
 704           (if rss-link rss-link
 705
 706 ;;    4. check syndic8
 707             (nnrss-find-rss-via-syndic8 url))))))))
 708
 709 (defun nnrss-find-rss-via-syndic8 (url)
 710   "Query syndic8 for the rss feeds it has for URL."
 711   (if (not (locate-library "xml-rpc"))
 712       (progn
 713         (message "XML-RPC is not available... not checking Syndic8.")
 714         nil)
 715     (require 'xml-rpc)
 716     (let ((feedid (xml-rpc-method-call
 717                    "http://www.syndic8.com/xmlrpc.php"
 718                    'syndic8.FindSites
 719                    url)))
 720       (when feedid
 721         (let* ((feedinfo (xml-rpc-method-call
 722                           "http://www.syndic8.com/xmlrpc.php"
 723                           'syndic8.GetFeedInfo
 724                           feedid))
 725                (urllist
 726                 (delq nil
 727                       (mapcar
 728                        (lambda (listinfo)
 729                          (if (string-equal
 730                               (cdr (assoc "status" listinfo))
 731                               "Syndicated")
 732                              (cons
 733                               (cdr (assoc "sitename" listinfo))
 734                               (list
 735                                (cons 'title
 736                                      (cdr (assoc
 737                                            "sitename" listinfo)))
 738                                (cons 'href
 739                                      (cdr (assoc
 740                                            "dataurl" listinfo)))))))
 741                        feedinfo))))
 742           (if (not (> (length urllist) 1))
 743               (cdar urllist)
 744             (let ((completion-ignore-case t)
 745                   (selection
 746                    (mapcar (lambda (listinfo)
 747                              (cons (cdr (assoc "sitename" listinfo))
 748                                    (string-to-int
 749                                     (cdr (assoc "feedid" listinfo)))))
 750                            feedinfo)))
 751               (cdr (assoc
 752                     (completing-read
 753                      "Multiple feeds found.  Select one: "
 754                      selection nil t) urllist)))))))))
 755
 756 (defun nnrss-rss-p (data)
 757   "Test if DATA is an RSS feed.
 758 Simply ensures that the first element is rss or rdf."
 759   (or (eq (caar data) 'rss)
 760       (eq (caar data) 'rdf:RDF)))
 761
 762 (defun nnrss-rss-title-description (rss-namespace data url)
 763   "Return the title of an RSS feed."
 764   (if (nnrss-rss-p data)
 765       (let ((description (intern (concat rss-namespace "description")))
 766             (title (intern (concat rss-namespace "title")))
 767             (channel (nnrss-find-el (intern (concat rss-namespace "channel"))
 768                                     data)))
 769         (list
 770          (cons 'description (caddr (nth 0 (nnrss-find-el description channel))))
 771          (cons 'title (caddr (nth 0 (nnrss-find-el title channel))))
 772          (cons 'href url)))))
 773
 774 (defun nnrss-get-namespace-prefix (el uri)
 775   "Given EL (containing a parsed element) and URI (containing a string
 776 that gives the URI for which you want to retrieve the namespace
 777 prefix), return the prefix."
 778   (let* ((prefix (car (rassoc uri (cadar el))))
 779          (nslist (if prefix
 780                      (split-string (symbol-name prefix) ":")))
 781          (ns (cond ((eq (length nslist) 1) ; no prefix given
 782                     "")
 783                    ((eq (length nslist) 2) ; extract prefix
 784                     (cadr nslist)))))
 785     (if (and ns (not (string= ns "")))
 786         (concat ns ":")
 787       ns)))
 788
 789 (provide 'nnrss)
 790
 791
 792 ;;; nnrss.el ends here
 793
 794 ;;; arch-tag: 12910c07-0cdf-44fb-8d2c-416ded64c267