emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Emacs-diffs] Changes to emacs/lisp/gnus/nnrss.el [lexbind]


From: Miles Bader
Subject: [Emacs-diffs] Changes to emacs/lisp/gnus/nnrss.el [lexbind]
Date: Wed, 15 Sep 2004 20:34:52 -0400

Index: emacs/lisp/gnus/nnrss.el
diff -c /dev/null emacs/lisp/gnus/nnrss.el:1.2.4.1
*** /dev/null   Thu Sep 16 00:13:15 2004
--- emacs/lisp/gnus/nnrss.el    Thu Sep 16 00:12:15 2004
***************
*** 0 ****
--- 1,771 ----
+ ;;; nnrss.el --- interfacing with RSS
+ ;; Copyright (C) 2001, 2002, 2003  Free Software Foundation, Inc.
+ 
+ ;; Author: Shenghuo Zhu <address@hidden>
+ ;; Keywords: RSS
+ 
+ ;; This file is part of GNU Emacs.
+ 
+ ;; GNU Emacs is free software; you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published
+ ;; by the Free Software Foundation; either version 2, or (at your
+ ;; option) any later version.
+ 
+ ;; GNU Emacs is distributed in the hope that it will be useful, but
+ ;; WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ ;; General Public License for more details.
+ 
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs; see the file COPYING.  If not, write to the
+ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ ;; Boston, MA 02111-1307, USA.
+ 
+ ;;; Commentary:
+ 
+ ;;; Code:
+ 
+ (eval-when-compile (require 'cl))
+ 
+ (require 'gnus)
+ (require 'nnoo)
+ (require 'nnmail)
+ (require 'message)
+ (require 'mm-util)
+ (require 'gnus-util)
+ (require 'time-date)
+ (require 'rfc2231)
+ (require 'mm-url)
+ (eval-when-compile
+   (ignore-errors
+     (require 'xml)))
+ (eval '(require 'xml))
+ 
+ (nnoo-declare nnrss)
+ 
+ (defvoo nnrss-directory (nnheader-concat gnus-directory "rss/")
+   "Where nnrss will save its files.")
+ 
+ ;; (group max rss-url)
+ (defvoo nnrss-server-data nil)
+ 
+ ;; (num timestamp url subject author date extra)
+ (defvoo nnrss-group-data nil)
+ (defvoo nnrss-group-max 0)
+ (defvoo nnrss-group-min 1)
+ (defvoo nnrss-group nil)
+ (defvoo nnrss-group-hashtb nil)
+ (defvoo nnrss-status-string "")
+ 
+ (defconst nnrss-version "nnrss 1.0")
+ 
+ (defvar nnrss-group-alist '()
+   "List of RSS addresses.")
+ 
+ (defvar nnrss-use-local nil)
+ 
+ (defvar nnrss-description-field 'X-Gnus-Description
+   "Field name used for DESCRIPTION.
+ To use the description in headers, put this name into 
`nnmail-extra-headers'.")
+ 
+ (defvar nnrss-url-field 'X-Gnus-Url
+   "Field name used for URL.
+ To use the description in headers, put this name into 
`nnmail-extra-headers'.")
+ 
+ (defvar nnrss-content-function nil
+   "A function which is called in `nnrss-request-article'.
+ The arguments are (ENTRY GROUP ARTICLE).
+ ENTRY is the record of the current headline. GROUP is the group name.
+ ARTICLE is the article number of the current headline.")
+ 
+ (nnoo-define-basics nnrss)
+ 
+ ;;; Interface functions
+ 
+ (deffoo nnrss-retrieve-headers (articles &optional group server fetch-old)
+   (nnrss-possibly-change-group group server)
+   (let (e)
+     (save-excursion
+       (set-buffer nntp-server-buffer)
+       (erase-buffer)
+       (dolist (article articles)
+       (if (setq e (assq article nnrss-group-data))
+           (insert (number-to-string (car e)) "\t" ;; number
+                   (if (nth 3 e)
+                       (nnrss-format-string (nth 3 e)) "")
+                   "\t" ;; subject
+                   (if (nth 4 e)
+                       (nnrss-format-string (nth 4 e))
+                     "(nobody)")
+                   "\t" ;;from
+                   (or (nth 5 e) "")
+                   "\t" ;; date
+                   (format "<address@hidden>" (car e) group)
+                   "\t" ;; id
+                   "\t" ;; refs
+                   "-1" "\t" ;; chars
+                   "-1" "\t" ;; lines
+                   "" "\t" ;; Xref
+                   (if (and (nth 6 e)
+                            (memq nnrss-description-field
+                                  nnmail-extra-headers))
+                       (concat (symbol-name nnrss-description-field)
+                               ": "
+                               (nnrss-format-string (nth 6 e))
+                               "\t")
+                     "")
+                   (if (and (nth 2 e)
+                            (memq nnrss-url-field
+                                  nnmail-extra-headers))
+                       (concat (symbol-name nnrss-url-field)
+                               ": "
+                               (nnrss-format-string (nth 2 e))
+                               "\t")
+                     "")
+                   "\n")))))
+   'nov)
+ 
+ (deffoo nnrss-request-group (group &optional server dont-check)
+   (nnrss-possibly-change-group group server)
+   (if dont-check
+       t
+     (nnrss-check-group group server)
+     (nnheader-report 'nnrss "Opened group %s" group)
+     (nnheader-insert
+      "211 %d %d %d %s\n" nnrss-group-max nnrss-group-min nnrss-group-max
+      (prin1-to-string group)
+      t)))
+ 
+ (deffoo nnrss-close-group (group &optional server)
+   t)
+ 
+ (deffoo nnrss-request-article (article &optional group server buffer)
+   (nnrss-possibly-change-group group server)
+   (let ((e (assq article nnrss-group-data))
+       (boundary "=-=-=-=-=-=-=-=-=-")
+       (nntp-server-buffer (or buffer nntp-server-buffer))
+       post err)
+     (when e
+       (catch 'error
+       (with-current-buffer nntp-server-buffer
+         (erase-buffer)
+         (goto-char (point-min))
+         (insert "Mime-Version: 1.0\nContent-Type: multipart/alternative; 
boundary=\"" boundary "\"\n")
+         (if group
+             (insert "Newsgroups: " group "\n"))
+         (if (nth 3 e)
+             (insert "Subject: " (nnrss-format-string (nth 3 e)) "\n"))
+         (if (nth 4 e)
+             (insert "From: " (nnrss-format-string (nth 4 e)) "\n"))
+         (if (nth 5 e)
+             (insert "Date: " (nnrss-format-string (nth 5 e)) "\n"))
+         (insert "Message-ID: " (format "<address@hidden>" (car e) group) "\n")
+         (insert "\n")
+         (let ((text (if (nth 6 e)
+                         (nnrss-string-as-multibyte (nth 6 e))))
+               (link (if (nth 2 e)
+                         (nth 2 e))))
+           (insert "\n\n--" boundary "\nContent-Type: text/plain\n\n")
+           (let ((point (point)))
+             (if text
+                 (progn (insert text)
+                        (goto-char point)
+                        (while (re-search-forward "\n" nil t)
+                          (replace-match " "))
+                        (goto-char (point-max))
+                        (insert "\n\n")))
+             (if link
+                 (insert link)))
+           (insert "\n\n--" boundary "\nContent-Type: text/html\n\n")
+           (let ((point (point)))
+             (if text
+                 (progn (insert "<html><head></head><body>\n" text 
"\n</body></html>")
+                        (goto-char point)
+                        (while (re-search-forward "\n" nil t)
+                          (replace-match " "))
+                        (goto-char (point-max))
+                        (insert "\n\n")))
+             (if link
+                 (insert "<p><a href=\"" link "\">link</a></p>\n"))))
+         (if nnrss-content-function
+             (funcall nnrss-content-function e group article)))))
+     (cond
+      (err
+       (nnheader-report 'nnrss err))
+      ((not e)
+       (nnheader-report 'nnrss "no such id: %d" article))
+      (t
+       (nnheader-report 'nnrss "article %s retrieved" (car e))
+       ;; we return the article number.
+       (cons nnrss-group (car e))))))
+ 
+ (deffoo nnrss-request-list (&optional server)
+   (nnrss-possibly-change-group nil server)
+   (nnrss-generate-active)
+   t)
+ 
+ (deffoo nnrss-open-server (server &optional defs connectionless)
+   (nnrss-read-server-data server)
+   (nnoo-change-server 'nnrss server defs)
+   t)
+ 
+ (deffoo nnrss-request-expire-articles
+     (articles group &optional server force)
+   (nnrss-possibly-change-group group server)
+   (let (e days not-expirable changed)
+     (dolist (art articles)
+       (if (and (setq e (assq art nnrss-group-data))
+              (nnmail-expired-article-p
+               group
+               (if (listp (setq days (nth 1 e))) days
+                 (days-to-time (- days (time-to-days '(0 0)))))
+               force))
+         (setq nnrss-group-data (delq e nnrss-group-data)
+               changed t)
+       (push art not-expirable)))
+     (if changed
+       (nnrss-save-group-data group server))
+     not-expirable))
+ 
+ (deffoo nnrss-request-delete-group (group &optional force server)
+   (nnrss-possibly-change-group group server)
+   (setq nnrss-server-data
+       (delq (assoc group nnrss-server-data) nnrss-server-data))
+   (nnrss-save-server-data server)
+   (let ((file (expand-file-name
+              (nnrss-translate-file-chars
+               (concat group (and server
+                                  (not (equal server ""))
+                                  "-")
+                       server ".el")) nnrss-directory)))
+     (ignore-errors
+       (delete-file file)))
+   t)
+ 
+ (deffoo nnrss-request-list-newsgroups (&optional server)
+   (nnrss-possibly-change-group nil server)
+   (save-excursion
+     (set-buffer nntp-server-buffer)
+     (erase-buffer)
+     (dolist (elem nnrss-group-alist)
+       (if (third elem)
+         (insert (car elem) "\t" (third elem) "\n"))))
+   t)
+ 
+ (nnoo-define-skeleton nnrss)
+ 
+ ;;; Internal functions
+ (eval-when-compile (defun xml-rpc-method-call (&rest args)))
+ (defun nnrss-fetch (url &optional local)
+   "Fetch the url and put it in a the expected lisp structure."
+   (with-temp-buffer
+   ;some CVS versions of url.el need this to close the connection quickly
+     (let* (xmlform htmlform)
+       ;; bit o' work necessary for w3 pre-cvs and post-cvs
+       (if local
+         (let ((coding-system-for-read 'binary))
+           (insert-file-contents url))
+       (mm-url-insert url))
+ 
+ ;; Because xml-parse-region can't deal with anything that isn't
+ ;; xml and w3-parse-buffer can't deal with some xml, we have to
+ ;; parse with xml-parse-region first and, if that fails, parse
+ ;; with w3-parse-buffer.  Yuck.  Eventually, someone should find out
+ ;; why w3-parse-buffer fails to parse some well-formed xml and
+ ;; fix it.
+ 
+     (condition-case err
+       (setq xmlform (xml-parse-region (point-min) (point-max)))
+       (error (if (fboundp 'w3-parse-buffer)
+                (setq htmlform (caddar (w3-parse-buffer
+                                        (current-buffer))))
+              (message "nnrss: Not valid XML and w3 parse not available (%s)"
+                       url))))
+     (if htmlform
+       htmlform
+       xmlform))))
+ 
+ (defun nnrss-possibly-change-group (&optional group server)
+   (when (and server
+            (not (nnrss-server-opened server)))
+     (nnrss-open-server server))
+   (when (and group (not (equal group nnrss-group)))
+     (nnrss-read-group-data group server)
+     (setq nnrss-group group)))
+ 
+ (defvar nnrss-extra-categories '(nnrss-snarf-moreover-categories))
+ 
+ (defun nnrss-generate-active ()
+   (if (y-or-n-p "fetch extra categories? ")
+       (dolist (func nnrss-extra-categories)
+       (funcall func)))
+   (save-excursion
+     (set-buffer nntp-server-buffer)
+     (erase-buffer)
+     (dolist (elem nnrss-group-alist)
+       (insert (prin1-to-string (car elem)) " 0 1 y\n"))
+     (dolist (elem nnrss-server-data)
+       (unless (assoc (car elem) nnrss-group-alist)
+       (insert (prin1-to-string (car elem)) " 0 1 y\n")))))
+ 
+ ;;; data functions
+ 
+ (defun nnrss-read-server-data (server)
+   (setq nnrss-server-data nil)
+   (let ((file (expand-file-name
+              (nnrss-translate-file-chars
+               (concat "nnrss" (and server
+                                    (not (equal server ""))
+                                    "-")
+                       server
+                       ".el"))
+              nnrss-directory)))
+     (when (file-exists-p file)
+       (with-temp-buffer
+       (let ((coding-system-for-read 'binary)
+             emacs-lisp-mode-hook)
+         (insert-file-contents file)
+         (emacs-lisp-mode)
+         (goto-char (point-min))
+         (eval-buffer))))))
+ 
+ (defun nnrss-save-server-data (server)
+   (gnus-make-directory nnrss-directory)
+   (let ((file (expand-file-name
+              (nnrss-translate-file-chars
+               (concat "nnrss" (and server
+                                    (not (equal server ""))
+                                    "-")
+                       server ".el"))
+              nnrss-directory)))
+     (let ((coding-system-for-write 'binary)
+         print-level print-length)
+       (with-temp-file file
+       (insert "(setq nnrss-group-alist '"
+               (prin1-to-string nnrss-group-alist)
+               ")\n")
+       (insert "(setq nnrss-server-data '"
+               (prin1-to-string nnrss-server-data)
+               ")\n")))))
+ 
+ (defun nnrss-read-group-data (group server)
+   (setq nnrss-group-data nil)
+   (setq nnrss-group-hashtb (gnus-make-hashtable))
+   (let ((pair (assoc group nnrss-server-data)))
+     (setq nnrss-group-max (or (cadr pair) 0))
+     (setq nnrss-group-min (+ nnrss-group-max 1)))
+   (let ((file (expand-file-name
+              (nnrss-translate-file-chars
+               (concat group (and server
+                                  (not (equal server ""))
+                                  "-")
+                       server ".el"))
+              nnrss-directory)))
+     (when (file-exists-p file)
+       (with-temp-buffer
+       (let ((coding-system-for-read 'binary)
+             emacs-lisp-mode-hook)
+         (insert-file-contents file)
+         (emacs-lisp-mode)
+         (goto-char (point-min))
+         (eval-buffer)))
+       (dolist (e nnrss-group-data)
+       (gnus-sethash (nth 2 e) e nnrss-group-hashtb)
+       (if (and (car e) (> nnrss-group-min (car e)))
+           (setq nnrss-group-min (car e)))
+       (if (and (car e) (< nnrss-group-max (car e)))
+           (setq nnrss-group-max (car e)))))))
+ 
+ (defun nnrss-save-group-data (group server)
+   (gnus-make-directory nnrss-directory)
+   (let ((file (expand-file-name
+              (nnrss-translate-file-chars
+               (concat group (and server
+                                  (not (equal server ""))
+                                  "-")
+                       server ".el"))
+              nnrss-directory)))
+     (let ((coding-system-for-write 'binary)
+         print-level print-length)
+       (with-temp-file file
+       (insert "(setq nnrss-group-data '"
+               (prin1-to-string nnrss-group-data)
+               ")\n")))))
+ 
+ ;;; URL interface
+ 
+ (defun nnrss-no-cache (url)
+   "")
+ 
+ (defun nnrss-insert-w3 (url)
+   (mm-with-unibyte-current-buffer
+     (mm-url-insert url)))
+ 
+ (defun nnrss-decode-entities-unibyte-string (string)
+   (if string
+       (mm-with-unibyte-buffer
+       (insert string)
+       (mm-url-decode-entities-nbsp)
+       (buffer-string))))
+ 
+ (defalias 'nnrss-insert 'nnrss-insert-w3)
+ 
+ (if (featurep 'xemacs)
+     (defalias 'nnrss-string-as-multibyte 'identity)
+   (defalias 'nnrss-string-as-multibyte 'string-as-multibyte))
+ 
+ ;;; Snarf functions
+ 
+ (defun nnrss-check-group (group server)
+   (let (file xml subject url extra changed author
+            date rss-ns rdf-ns content-ns dc-ns)
+     (if (and nnrss-use-local
+            (file-exists-p (setq file (expand-file-name
+                                       (nnrss-translate-file-chars
+                                        (concat group ".xml"))
+                                       nnrss-directory))))
+       (setq xml (nnrss-fetch file t))
+       (setq url (or (nth 2 (assoc group nnrss-server-data))
+                   (second (assoc group nnrss-group-alist))))
+       (unless url
+       (setq url
+              (cdr
+               (assoc 'href
+                      (nnrss-discover-feed
+                       (read-string
+                        (format "URL to search for %s: " group) "http://";)))))
+       (let ((pair (assoc group nnrss-server-data)))
+         (if pair
+             (setcdr (cdr pair) (list url))
+           (push (list group nnrss-group-max url) nnrss-server-data)))
+       (setq changed t))
+       (setq xml (nnrss-fetch url)))
+     ;; See
+     ;; http://feeds.archive.org/validator/docs/howto/declare_namespaces.html
+     ;; for more RSS namespaces.
+     (setq dc-ns (nnrss-get-namespace-prefix xml 
"http://purl.org/dc/elements/1.1/";)
+         rdf-ns (nnrss-get-namespace-prefix xml 
"http://www.w3.org/1999/02/22-rdf-syntax-ns#";)
+         rss-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/";)
+         content-ns (nnrss-get-namespace-prefix xml 
"http://purl.org/rss/1.0/modules/content/";))
+     (dolist (item (nreverse (nnrss-find-el (intern (concat rss-ns "item")) 
xml)))
+       (when (and (listp item)
+                (eq (intern (concat rss-ns "item")) (car item))
+                (setq url (nnrss-decode-entities-unibyte-string
+                           (nnrss-node-text rss-ns 'link (cddr item))))
+                (not (gnus-gethash url nnrss-group-hashtb)))
+       (setq subject (nnrss-node-text rss-ns 'title item))
+       (setq extra (or (nnrss-node-text content-ns 'encoded item)
+                       (nnrss-node-text rss-ns 'description item)))
+       (setq author (or (nnrss-node-text rss-ns 'author item)
+                        (nnrss-node-text dc-ns 'creator item)
+                        (nnrss-node-text dc-ns 'contributor item)))
+       (setq date (or (nnrss-node-text dc-ns 'date item)
+                      (nnrss-node-text rss-ns 'pubDate item)
+                      (message-make-date)))
+       (push
+        (list
+         (incf nnrss-group-max)
+         (current-time)
+         url
+         (and subject (nnrss-decode-entities-unibyte-string subject))
+         (and author (nnrss-decode-entities-unibyte-string author))
+         date
+         (and extra (nnrss-decode-entities-unibyte-string extra)))
+        nnrss-group-data)
+       (gnus-sethash url (car nnrss-group-data) nnrss-group-hashtb)
+       (setq changed t)))
+     (when changed
+       (nnrss-save-group-data group server)
+       (let ((pair (assoc group nnrss-server-data)))
+       (if pair
+           (setcar (cdr pair) nnrss-group-max)
+         (push (list group nnrss-group-max) nnrss-server-data)))
+       (nnrss-save-server-data server))))
+ 
+ (defun nnrss-generate-download-script ()
+   "Generate a download script in the current buffer.
+ It is useful when `(setq nnrss-use-local t)'."
+   (interactive)
+   (insert "#!/bin/sh\n")
+   (insert "WGET=wget\n")
+   (insert "RSSDIR='" (expand-file-name nnrss-directory) "'\n")
+   (dolist (elem nnrss-server-data)
+     (let ((url (or (nth 2 elem)
+                  (second (assoc (car elem) nnrss-group-alist)))))
+       (insert "$WGET -q -O \"$RSSDIR\"/'"
+             (nnrss-translate-file-chars (concat (car elem) ".xml"))
+             "' '" url "'\n"))))
+ 
+ (defun nnrss-translate-file-chars (name)
+   (let ((nnheader-file-name-translation-alist
+        (append nnheader-file-name-translation-alist '((?' . ?_)))))
+     (nnheader-translate-file-chars name)))
+ 
+ (defvar nnrss-moreover-url
+   "http://w.moreover.com/categories/category_list_rss.html";
+   "The url of moreover.com categories.")
+ 
+ (defun nnrss-snarf-moreover-categories ()
+   "Snarf RSS links from moreover.com."
+   (interactive)
+   (let (category name url changed)
+     (with-temp-buffer
+       (nnrss-insert nnrss-moreover-url)
+       (goto-char (point-min))
+       (while (re-search-forward
+             "<a name=\"\\([^\"]+\\)\">\\|<a 
href=\"\\(http://[^\"]*moreover\\.com[^\"]+page\\?c=\\([^\"&]+\\)&o=rss\\)" nil 
t)
+       (if (match-string 1)
+           (setq category (match-string 1))
+         (setq url (match-string 2)
+               name (mm-url-decode-entities-string
+                     (rfc2231-decode-encoded-string
+                      (match-string 3))))
+         (if category
+             (setq name (concat category "." name)))
+         (unless (assoc name nnrss-server-data)
+           (setq changed t)
+           (push (list name 0 url) nnrss-server-data)))))
+     (if changed
+       (nnrss-save-server-data ""))))
+ 
+ (defun nnrss-format-string (string)
+   (gnus-replace-in-string (nnrss-string-as-multibyte string) " *\n *" " "))
+ 
+ (defun nnrss-node-text (namespace local-name element)
+   (let* ((node (assq (intern (concat namespace (symbol-name local-name)))
+                    element))
+        (text (if (and node (listp node))
+                  (nnrss-node-just-text node)
+                node))
+        (cleaned-text (if text (gnus-replace-in-string
+                                text "^[\000-\037\177]+\\|^ +\\| +$" ""))))
+     (if (string-equal "" cleaned-text)
+       nil
+       cleaned-text)))
+ 
+ (defun nnrss-node-just-text (node)
+   (if (and node (listp node))
+       (mapconcat 'nnrss-node-just-text (cddr node) " ")
+     node))
+ 
+ (defun nnrss-find-el (tag data &optional found-list)
+   "Find the all matching elements in the data.  Careful with this on
+ large documents!"
+   (if (listp data)
+       (mapcar (lambda (bit)
+               (if (car-safe bit)
+                   (progn (if (equal tag (car bit))
+                              (setq found-list
+                                    (append found-list
+                                            (list bit))))
+                          (if (and (listp (car-safe (caddr bit)))
+                                   (not (stringp (caddr bit))))
+                              (setq found-list
+                                    (append found-list
+                                            (nnrss-find-el
+                                             tag (caddr bit))))
+                            (setq found-list
+                                  (append found-list
+                                          (nnrss-find-el
+                                           tag (cddr bit))))))))
+               data))
+   found-list)
+ 
+ (defun nnrss-rsslink-p (el)
+   "Test if the element we are handed is an RSS autodiscovery link."
+   (and (eq (car-safe el) 'link)
+        (string-equal (cdr (assoc 'rel (cadr el))) "alternate")
+        (or (string-equal (cdr (assoc 'type (cadr el))) 
+                        "application/rss+xml")
+          (string-equal (cdr (assoc 'type (cadr el))) "text/xml"))))
+ 
+ (defun nnrss-get-rsslinks (data)
+   "Extract the <link> elements that are links to RSS from the parsed data."
+   (delq nil (mapcar 
+            (lambda (el)
+              (if (nnrss-rsslink-p el) el))
+            (nnrss-find-el 'link data))))
+ 
+ (defun nnrss-extract-hrefs (data)
+   "Recursively extract hrefs from a page's source.  DATA should be
+ the output of xml-parse-region or w3-parse-buffer."
+   (mapcar (lambda (ahref)
+           (cdr (assoc 'href (cadr ahref))))
+         (nnrss-find-el 'a data)))
+ 
+ (defmacro nnrss-match-macro (base-uri item 
+                                          onsite-list offsite-list)
+   `(cond ((or (string-match (concat "^" ,base-uri) ,item)
+              (not (string-match "://" ,item)))
+          (setq ,onsite-list (append ,onsite-list (list ,item))))
+         (t (setq ,offsite-list (append ,offsite-list (list ,item))))))
+ 
+ (defun nnrss-order-hrefs (base-uri hrefs)
+   "Given a list of hrefs, sort them using the following priorities:
+   1. links ending in .rss
+   2. links ending in .rdf
+   3. links ending in .xml
+   4. links containing the above
+   5. offsite links
+ 
+ BASE-URI is used to determine the location of the links and
+ whether they are `offsite' or `onsite'."
+   (let (rss-onsite-end  rdf-onsite-end  xml-onsite-end
+       rss-onsite-in   rdf-onsite-in   xml-onsite-in
+       rss-offsite-end rdf-offsite-end xml-offsite-end
+       rss-offsite-in rdf-offsite-in xml-offsite-in)
+     (mapcar (lambda (href)
+             (if (not (null href))
+             (cond ((string-match "\\.rss$" href)
+                    (nnrss-match-macro
+                     base-uri href rss-onsite-end rss-offsite-end))
+                   ((string-match "\\.rdf$" href)
+                    (nnrss-match-macro 
+                     base-uri href rdf-onsite-end rdf-offsite-end))
+                   ((string-match "\\.xml$" href)
+                    (nnrss-match-macro
+                     base-uri href xml-onsite-end xml-offsite-end))
+                   ((string-match "rss" href)
+                    (nnrss-match-macro
+                     base-uri href rss-onsite-in rss-offsite-in))
+                   ((string-match "rdf" href)
+                    (nnrss-match-macro
+                     base-uri href rdf-onsite-in rdf-offsite-in))
+                   ((string-match "xml" href)
+                    (nnrss-match-macro
+                     base-uri href xml-onsite-in xml-offsite-in)))))
+           hrefs)
+     (append 
+      rss-onsite-end  rdf-onsite-end  xml-onsite-end
+      rss-onsite-in   rdf-onsite-in   xml-onsite-in
+      rss-offsite-end rdf-offsite-end xml-offsite-end
+      rss-offsite-in rdf-offsite-in xml-offsite-in)))
+ 
+ (defun nnrss-discover-feed (url)
+   "Given a page, find an RSS feed using Mark Pilgrim's
+ `ultra-liberal rss locator' (http://diveintomark.org/2002/08/15.html)."
+ 
+   (let ((parsed-page (nnrss-fetch url)))
+ 
+ ;;    1. if this url is the rss, use it.
+     (if (nnrss-rss-p parsed-page)
+       (let ((rss-ns (nnrss-get-namespace-prefix parsed-page 
"http://purl.org/rss/1.0/";)))
+         (nnrss-rss-title-description rss-ns parsed-page url))
+ 
+ ;;    2. look for the <link rel="alternate"
+ ;;    type="application/rss+xml" and use that if it is there.
+       (let ((links (nnrss-get-rsslinks parsed-page)))
+       (if links
+           (let* ((xml (nnrss-fetch
+                        (cdr (assoc 'href (cadar links)))))
+                  (rss-ns (nnrss-get-namespace-prefix xml 
"http://purl.org/rss/1.0/";)))
+             (nnrss-rss-title-description rss-ns xml (cdr (assoc 'href (cadar 
links)))))
+ 
+ ;;    3. look for links on the site in the following order:
+ ;;       - onsite links ending in .rss, .rdf, or .xml
+ ;;       - onsite links containing any of the above
+ ;;       - offsite links ending in .rss, .rdf, or .xml
+ ;;       - offsite links containing any of the above
+         (let* ((base-uri (progn (string-match ".*://[^/]+/?" url)
+                                 (match-string 0 url)))
+                (hrefs (nnrss-order-hrefs 
+                        base-uri (nnrss-extract-hrefs parsed-page)))
+                (rss-link nil))
+         (while (and (eq rss-link nil) (not (eq hrefs nil)))
+           (let ((href-data (nnrss-fetch (car hrefs))))
+             (if (nnrss-rss-p href-data)
+                 (let* ((rss-ns (nnrss-get-namespace-prefix href-data 
"http://purl.org/rss/1.0/";)))
+                   (setq rss-link (nnrss-rss-title-description
+                                   rss-ns href-data (car hrefs))))
+               (setq hrefs (cdr hrefs)))))
+         (if rss-link rss-link
+ 
+ ;;    4. check syndic8
+           (nnrss-find-rss-via-syndic8 url))))))))
+ 
+ (defun nnrss-find-rss-via-syndic8 (url)
+   "query syndic8 for the rss feeds it has for the url."
+   (if (not (locate-library "xml-rpc"))
+       (progn
+       (message "XML-RPC is not available... not checking Syndic8.")
+       nil)
+     (require 'xml-rpc)
+     (let ((feedid (xml-rpc-method-call
+                  "http://www.syndic8.com/xmlrpc.php";
+                  'syndic8.FindSites
+                  url)))
+       (when feedid
+       (let* ((feedinfo (xml-rpc-method-call 
+                         "http://www.syndic8.com/xmlrpc.php";
+                         'syndic8.GetFeedInfo
+                         feedid))
+              (urllist
+               (delq nil 
+                     (mapcar
+                      (lambda (listinfo)
+                        (if (string-equal 
+                             (cdr (assoc "status" listinfo))
+                             "Syndicated")
+                            (cons
+                             (cdr (assoc "sitename" listinfo))
+                             (list
+                              (cons 'title
+                                    (cdr (assoc 
+                                          "sitename" listinfo)))
+                              (cons 'href
+                                    (cdr (assoc
+                                          "dataurl" listinfo)))))))
+                      feedinfo))))
+         (if (not (> (length urllist) 1))
+             (cdar urllist)
+           (let ((completion-ignore-case t)
+                 (selection 
+                  (mapcar (lambda (listinfo)
+                            (cons (cdr (assoc "sitename" listinfo)) 
+                                  (string-to-int 
+                                   (cdr (assoc "feedid" listinfo)))))
+                          feedinfo)))
+             (cdr (assoc 
+                   (completing-read
+                    "Multiple feeds found.  Select one: "
+                    selection nil t) urllist)))))))))
+ 
+ (defun nnrss-rss-p (data)
+   "Test if data is an RSS feed.  Simply ensures that the first
+ element is rss or rdf."
+   (or (eq (caar data) 'rss)
+       (eq (caar data) 'rdf:RDF)))
+ 
+ (defun nnrss-rss-title-description (rss-namespace data url)
+   "Return the title of an RSS feed."
+   (if (nnrss-rss-p data)
+       (let ((description (intern (concat rss-namespace "description")))
+           (title (intern (concat rss-namespace "title")))
+           (channel (nnrss-find-el (intern (concat rss-namespace "channel"))
+                                   data)))
+       (list
+        (cons 'description (caddr (nth 0 (nnrss-find-el description channel))))
+        (cons 'title (caddr (nth 0 (nnrss-find-el title channel))))
+        (cons 'href url)))))
+ 
+ (defun nnrss-get-namespace-prefix (el uri)
+   "Given EL (containing a parsed element) and URI (containing a string
+ that gives the URI for which you want to retrieve the namespace
+ prefix), return the prefix."
+   (let* ((prefix (car (rassoc uri (cadar el))))
+        (nslist (if prefix 
+                    (split-string (symbol-name prefix) ":")))
+        (ns (cond ((eq (length nslist) 1) ; no prefix given
+                   "")
+                  ((eq (length nslist) 2) ; extract prefix
+                   (cadr nslist)))))
+     (if (and ns (not (eq ns "")))
+       (concat ns ":")
+       ns)))
+ 
+ (provide 'nnrss)
+ 
+ 
+ ;;; nnrss.el ends here
+ 
+ ;;; arch-tag: 12910c07-0cdf-44fb-8d2c-416ded64c267




reply via email to

[Prev in Thread] Current Thread [Next in Thread]