git.chise.org Git - elisp/gnus.git-/blob - lisp/nnrss.el

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