code.delx.au - gnu-emacs/blob - lisp/gnus/nnrss.el

   1 ;;; nnrss.el --- interfacing with RSS
   2
   3 ;; Copyright (C) 2001-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
   6 ;; Keywords: RSS
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (eval-when-compile (require 'cl))
  28
  29 (require 'gnus)
  30 (require 'nnoo)
  31 (require 'nnmail)
  32 (require 'message)
  33 (require 'mm-util)
  34 (require 'gnus-util)
  35 (require 'time-date)
  36 (require 'rfc2231)
  37 (require 'mm-url)
  38 (require 'rfc2047)
  39 (require 'mml)
  40 (require 'xml)
  41
  42 (nnoo-declare nnrss)
  43
  44 (defvoo nnrss-directory (nnheader-concat gnus-directory "rss/")
  45   "Where nnrss will save its files.")
  46
  47 (defvoo nnrss-ignore-article-fields '(slash:comments)
  48   "*List of fields that should be ignored when comparing RSS articles.
  49 Some RSS feeds update article fields during their lives, e.g. to
  50 indicate the number of comments or the number of times the
  51 articles have been seen.  However, if there is a difference
  52 between the local article and the distant one, the latter is
  53 considered to be new.  To avoid this and discard some fields, set
  54 this variable to the list of fields to be ignored.")
  55
  56 ;; (group max rss-url)
  57 (defvoo nnrss-server-data nil)
  58
  59 ;; (num timestamp url subject author date extra)
  60 (defvoo nnrss-group-data nil)
  61 (defvoo nnrss-group-max 0)
  62 (defvoo nnrss-group-min 1)
  63 (defvoo nnrss-group nil)
  64 (defvoo nnrss-group-hashtb (make-hash-table :test 'equal))
  65 (defvoo nnrss-status-string "")
  66
  67 (defconst nnrss-version "nnrss 1.0")
  68
  69 (defvar nnrss-group-alist '()
  70   "List of RSS addresses.")
  71
  72 (defvar nnrss-use-local nil
  73   "If non-nil nnrss will read the feeds from local files in nnrss-directory.")
  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 mm-universal-coding-system
  90   "*Coding system used when reading and writing files.
  91 If you run Gnus with various versions of Emacsen, the value of this
  92 variable should be the coding system that all those Emacsen support.
  93 Note that you have to regenerate all the nnrss groups if you change
  94 the value.  Moreover, you should be patient even if you are made to
  95 read the same articles twice, that arises for the difference of the
  96 versions of xml.el.")
  97
  98 (defvar nnrss-compatible-encoding-alist
  99   (delq nil (mapcar (lambda (elem)
 100                       (if (and (mm-coding-system-p (car elem))
 101                                (mm-coding-system-p (cdr elem)))
 102                           elem))
 103                     mm-charset-override-alist))
 104   "Alist of encodings and those supersets.
 105 The cdr of each element is used to decode data if it is available when
 106 the car is what the data specify as the encoding.  Or, the car is used
 107 for decoding when the cdr that the data specify is not available.")
 108
 109 (nnoo-define-basics nnrss)
 110
 111 ;;; Interface functions
 112
 113 (defsubst nnrss-format-string (string)
 114   (replace-regexp-in-string " *\n *" " " string))
 115
 116 (defun nnrss-decode-group-name (group)
 117   (if (and group (mm-coding-system-p 'utf-8))
 118       (setq group (decode-coding-string group 'utf-8))
 119     group))
 120
 121 (deffoo nnrss-retrieve-headers (articles &optional group server fetch-old)
 122   (setq group (nnrss-decode-group-name group))
 123   (nnrss-possibly-change-group group server)
 124   (let (e)
 125     (with-current-buffer nntp-server-buffer
 126       (erase-buffer)
 127       (dolist (article articles)
 128         (if (setq e (assq article nnrss-group-data))
 129             (insert (number-to-string (car e)) "\t" ;; number
 130                     ;; subject
 131                     (or (nth 3 e) "")
 132                     "\t"
 133                     ;; from
 134                     (or (nth 4 e) "(nobody)")
 135                     "\t"
 136                     ;; date
 137                     (or (nth 5 e) "")
 138                     "\t"
 139                     ;; id
 140                     (format "<%d@%s.nnrss>" (car e) group)
 141                     "\t"
 142                     ;; refs
 143                     "\t"
 144                     ;; chars
 145                     "-1" "\t"
 146                     ;; lines
 147                     "-1" "\t"
 148                     ;; Xref
 149                     "" "\t"
 150                     (if (and (nth 6 e)
 151                              (memq nnrss-description-field
 152                                    nnmail-extra-headers))
 153                         (concat (symbol-name nnrss-description-field)
 154                                 ": "
 155                                 (nnrss-format-string (nth 6 e))
 156                                 "\t")
 157                       "")
 158                     (if (and (nth 2 e)
 159                              (memq nnrss-url-field
 160                                    nnmail-extra-headers))
 161                         (concat (symbol-name nnrss-url-field)
 162                                 ": "
 163                                 (nnrss-format-string (nth 2 e))
 164                                 "\t")
 165                       "")
 166                     "\n")))))
 167   'nov)
 168
 169 (deffoo nnrss-request-group (group &optional server dont-check info)
 170   (setq group (nnrss-decode-group-name group))
 171   (nnheader-message 6 "nnrss: Requesting %s..." group)
 172   (nnrss-possibly-change-group group server)
 173   (prog1
 174       (if dont-check
 175           t
 176         (nnrss-check-group group server)
 177         (nnheader-report 'nnrss "Opened group %s" group)
 178         (nnheader-insert
 179          "211 %d %d %d %s\n" nnrss-group-max nnrss-group-min nnrss-group-max
 180          (prin1-to-string group)
 181          t))
 182     (nnheader-message 6 "nnrss: Requesting %s...done" group)))
 183
 184 (deffoo nnrss-close-group (group &optional server)
 185   t)
 186
 187 (deffoo nnrss-request-article (article &optional group server buffer)
 188   (setq group (nnrss-decode-group-name group))
 189   (when (stringp article)
 190     (setq article (if (string-match "\\`<\\([0-9]+\\)@" article)
 191                       (string-to-number (match-string 1 article))
 192                     0)))
 193   (nnrss-possibly-change-group group server)
 194   (let ((e (assq article nnrss-group-data))
 195         (nntp-server-buffer (or buffer nntp-server-buffer))
 196         post err)
 197     (when e
 198       (with-current-buffer nntp-server-buffer
 199         (erase-buffer)
 200         (if group
 201             (insert "Newsgroups: " group "\n"))
 202         (if (nth 3 e)
 203             (insert "Subject: " (nth 3 e) "\n"))
 204         (if (nth 4 e)
 205             (insert "From: " (nth 4 e) "\n"))
 206         (if (nth 5 e)
 207             (insert "Date: " (nnrss-format-string (nth 5 e)) "\n"))
 208         (let ((header (buffer-string))
 209               (text (nth 6 e))
 210               (link (nth 2 e))
 211               (enclosure (nth 7 e))
 212               (comments (nth 8 e))
 213               (rfc2047-header-encoding-alist
 214                (if (mm-coding-system-p 'utf-8)
 215                    (cons '("Newsgroups" . utf-8)
 216                          rfc2047-header-encoding-alist)
 217                  rfc2047-header-encoding-alist))
 218               rfc2047-encode-encoded-words body fn)
 219           (when (or text link enclosure comments)
 220             (insert "\n")
 221             (insert "<#multipart type=alternative>\n"
 222                     "<#part type=\"text/plain\">\n")
 223             (setq body (point))
 224             (when text
 225               (insert text)
 226               (goto-char body)
 227               (while (re-search-forward "\n+" nil t)
 228                 (replace-match " "))
 229               (goto-char body)
 230               ;; See `nnrss-check-group', which inserts "<br /><br />".
 231               (when (search-forward "<br /><br />" nil t)
 232                 (if (eobp)
 233                     (replace-match "\n")
 234                   (replace-match "\n\n")))
 235               (unless (eobp)
 236                 (let ((fill-column (default-value 'fill-column))
 237                       (window (get-buffer-window nntp-server-buffer)))
 238                   (when window
 239                     (setq fill-column
 240                           (max 1 (/ (* (window-width window) 7) 8))))
 241                   (fill-region (point) (point-max))
 242                   (goto-char (point-max))
 243                   (unless (bolp)
 244                     (insert "\n"))))
 245               (when (or link enclosure)
 246                 (insert "\n")))
 247             (when link
 248               (insert link "\n"))
 249             (when enclosure
 250               (insert (car enclosure) " "
 251                       (nth 2 enclosure) " "
 252                       (nth 3 enclosure) "\n"))
 253             (when comments
 254               (insert comments "\n"))
 255             (setq body (buffer-substring body (point)))
 256             (insert "<#/part>\n"
 257                     "<#part type=\"text/html\">\n"
 258                     "<html><head></head><body>\n")
 259             (when text
 260               (insert text "\n"))
 261             (when link
 262               (insert "<p><a href=\"" link "\">link</a></p>\n"))
 263             (when enclosure
 264               (insert "<p><a href=\"" (car enclosure) "\">"
 265                       (cadr enclosure) "</a> " (nth 2 enclosure)
 266                       " " (nth 3 enclosure) "</p>\n"))
 267             (when comments
 268               (insert "<p><a href=\"" comments "\">comments</a></p>\n"))
 269             (insert "</body></html>\n"
 270                     "<#/part>\n"
 271                     "<#/multipart>\n"))
 272           (condition-case nil
 273               ;; Allow `mml-to-mime' to generate MIME article without
 274               ;; making inquiry to a user for unknown encoding.
 275               (let ((mml-confirmation-set
 276                      (cons 'unknown-encoding mml-confirmation-set)))
 277                 (mml-to-mime))
 278             (error
 279              (erase-buffer)
 280              (insert header
 281                      "Content-Type: text/plain; charset=gnus-decoded\n"
 282                      "Content-Transfer-Encoding: 8bit\n\n"
 283                      body)
 284              (nnheader-message
 285               3 "Warning - there might be invalid characters"))))
 286         (goto-char (point-min))
 287         (search-forward "\n\n")
 288         (forward-line -1)
 289         (insert (format "Message-ID: <%d@%s.nnrss>\n"
 290                         (car e)
 291                         (let ((rfc2047-encoding-type 'mime)
 292                               rfc2047-encode-max-chars)
 293                           (rfc2047-encode-string
 294                            (replace-regexp-in-string "[\t\n ]+" "_" group)))))
 295         (when nnrss-content-function
 296           (funcall nnrss-content-function e group article))))
 297     (cond
 298      (err
 299       (nnheader-report 'nnrss err))
 300      ((not e)
 301       (nnheader-report 'nnrss "no such id: %d" article))
 302      (t
 303       (nnheader-report 'nnrss "article %s retrieved" (car e))
 304       ;; we return the article number.
 305       (cons nnrss-group (car e))))))
 306
 307 (deffoo nnrss-open-server (server &optional defs connectionless)
 308   (nnrss-read-server-data server)
 309   (nnoo-change-server 'nnrss server defs)
 310   t)
 311
 312 (deffoo nnrss-request-expire-articles
 313     (articles group &optional server force)
 314   (setq group (nnrss-decode-group-name group))
 315   (nnrss-possibly-change-group group server)
 316   (let (e days not-expirable changed)
 317     (dolist (art articles)
 318       (if (and (setq e (assq art nnrss-group-data))
 319                (nnmail-expired-article-p
 320                 group
 321                 (if (listp (setq days (nth 1 e))) days
 322                   (days-to-time (- days (time-to-days '(0 0)))))
 323                 force))
 324           (setq nnrss-group-data (delq e nnrss-group-data)
 325                 changed t)
 326         (push art not-expirable)))
 327     (if changed
 328         (nnrss-save-group-data group server))
 329     not-expirable))
 330
 331 (deffoo nnrss-request-delete-group (group &optional force server)
 332   (setq group (nnrss-decode-group-name group))
 333   (nnrss-possibly-change-group group server)
 334   (let (elem)
 335     ;; There may be two or more entries in `nnrss-group-alist' since
 336     ;; this function didn't delete them formerly.
 337     (while (setq elem (assoc group nnrss-group-alist))
 338       (setq nnrss-group-alist (delq elem nnrss-group-alist))))
 339   (setq nnrss-server-data
 340         (delq (assoc group nnrss-server-data) nnrss-server-data))
 341   (nnrss-save-server-data server)
 342   (ignore-errors
 343     (let ((file-name-coding-system nnmail-pathname-coding-system))
 344       (delete-file (nnrss-make-filename group server))))
 345   t)
 346
 347 (deffoo nnrss-request-list-newsgroups (&optional server)
 348   (nnrss-possibly-change-group nil server)
 349   (with-current-buffer nntp-server-buffer
 350     (erase-buffer)
 351     (dolist (elem nnrss-group-alist)
 352       (if (third elem)
 353           (insert (car elem) "\t" (third elem) "\n"))))
 354   t)
 355
 356 (deffoo nnrss-retrieve-groups (groups &optional server)
 357   (dolist (group groups)
 358     (setq group (nnrss-decode-group-name group))
 359     (nnrss-possibly-change-group group server)
 360     (nnrss-check-group group server))
 361   (with-current-buffer nntp-server-buffer
 362     (erase-buffer)
 363     (dolist (group groups)
 364       (let ((elem (assoc (gnus-group-decoded-name group) nnrss-server-data)))
 365         (insert (format "%S %s 1 y\n" group (or (cadr elem) 0)))))
 366     'active))
 367
 368 (nnoo-define-skeleton nnrss)
 369
 370 ;;; Internal functions
 371 (defun nnrss-get-encoding ()
 372   "Return an encoding attribute specified in the current xml contents.
 373 If `nnrss-compatible-encoding-alist' specifies the compatible encoding,
 374 it is used instead.  If the xml contents doesn't specify the encoding,
 375 return `utf-8' which is the default encoding for xml if it is available,
 376 otherwise return nil."
 377   (goto-char (point-min))
 378   (if (re-search-forward
 379        "<\\?[^>]*encoding=\\(?:\"\\([^\">]+\\)\"\\|'\\([^'>]+\\)'\\)"
 380        nil t)
 381       (let ((encoding (intern (downcase (or (match-string 1)
 382                                             (match-string 2))))))
 383         (or
 384          (mm-coding-system-p (cdr (assq encoding
 385                                         nnrss-compatible-encoding-alist)))
 386          (mm-coding-system-p encoding)
 387          (mm-coding-system-p (car (rassq encoding
 388                                          nnrss-compatible-encoding-alist)))))
 389     (mm-coding-system-p 'utf-8)))
 390
 391 (declare-function libxml-parse-html-region "xml.c"
 392                   (start end &optional base-url discard-comments))
 393 (defun nnrss-fetch (url &optional local)
 394   "Fetch URL and put it in a the expected Lisp structure."
 395   (mm-with-unibyte-buffer
 396     ;;some versions of url.el need this to close the connection quickly
 397     (let (cs xmlform htmlform)
 398       ;; bit o' work necessary for w3 pre-cvs and post-cvs
 399       (if local
 400           (let ((coding-system-for-read 'binary))
 401             (insert-file-contents url))
 402         ;; FIXME: shouldn't binding `coding-system-for-read' be moved
 403         ;; to `mm-url-insert'?
 404         (let ((coding-system-for-read 'binary))
 405           (condition-case err
 406               (mm-url-insert url)
 407             (error (if (or debug-on-quit debug-on-error)
 408                        (signal (car err) (cdr err))
 409                      (message "nnrss: Failed to fetch %s" url))))))
 410       (nnheader-remove-cr-followed-by-lf)
 411       ;; Decode text according to the encoding attribute.
 412       (when (setq cs (nnrss-get-encoding))
 413         (insert (prog1
 414                     (decode-coding-string (buffer-string) cs)
 415                   (erase-buffer)
 416                   (mm-enable-multibyte))))
 417       (goto-char (point-min))
 418
 419       (condition-case err1
 420           (setq xmlform (xml-parse-region (point-min) (point-max)))
 421         (error
 422          (condition-case err2
 423              (setq htmlform (libxml-parse-html-region (point-min) (point-max)))
 424            (error
 425             (message "\
 426 nnrss: %s: Not valid XML %s and libxml-parse-html-region doesn't work %s"
 427                      url err1 err2)))))
 428       (if htmlform
 429           htmlform
 430         xmlform))))
 431
 432 (defun nnrss-possibly-change-group (&optional group server)
 433   (when (and server
 434              (not (nnrss-server-opened server)))
 435     (nnrss-open-server server))
 436   (when (and group (not (equal group nnrss-group)))
 437     (nnrss-read-group-data group server)
 438     (setq nnrss-group group)))
 439
 440 (autoload 'timezone-parse-date "timezone")
 441
 442 (defun nnrss-normalize-date (date)
 443   "Return a date string of DATE in the RFC822 style.
 444 This function handles the ISO 8601 date format described in
 445 URL `http://www.w3.org/TR/NOTE-datetime', and also the RFC822 style
 446 which RSS 2.0 allows."
 447   (let (case-fold-search vector year month day time zone cts given)
 448     (cond ((null date))                 ; do nothing for this case
 449           ;; if the date is just digits (unix time stamp):
 450           ((string-match "^[0-9]+$" date)
 451            (setq given (seconds-to-time (string-to-number date))))
 452           ;; RFC822
 453           ((string-match " [0-9]+ " date)
 454            (setq vector (timezone-parse-date date)
 455                  year (string-to-number (aref vector 0)))
 456            (when (>= year 1969)
 457              (setq month (string-to-number (aref vector 1))
 458                    day (string-to-number (aref vector 2)))
 459              (unless (>= (length (setq time (aref vector 3))) 3)
 460                (setq time "00:00:00"))
 461              (when (and (setq zone (aref vector 4))
 462                         (not (string-match "\\`[A-Z+-]" zone)))
 463                (setq zone nil))))
 464           ;; ISO 8601
 465           ((string-match
 466             (eval-when-compile
 467               (concat
 468                ;; 1. year
 469                "\\(199[0-9]\\|20[0-9][0-9]\\)"
 470                "\\(?:-"
 471                ;; 2. month
 472                "\\([01][0-9]\\)"
 473                "\\(?:-"
 474                ;; 3. day
 475                "\\([0-3][0-9]\\)"
 476                "\\)?\\)?\\(?:T"
 477                ;; 4. hh:mm
 478                "\\([012][0-9]:[0-5][0-9]\\)"
 479                "\\(?:"
 480                ;; 5. :ss
 481                "\\(:[0-5][0-9]\\)"
 482                "\\(?:\\.[0-9]+\\)?\\)?\\)?"
 483                ;; 6+7,8,9. zone
 484                "\\(?:\\(?:\\([+-][012][0-9]\\):\\([0-5][0-9]\\)\\)"
 485                "\\|\\([+-][012][0-9][0-5][0-9]\\)"
 486                "\\|\\(Z\\)\\)?"))
 487             date)
 488            (setq year (string-to-number (match-string 1 date))
 489                  month (string-to-number (or (match-string 2 date) "1"))
 490                  day (string-to-number (or (match-string 3 date) "1"))
 491                  time (if (match-beginning 5)
 492                           (substring date (match-beginning 4) (match-end 5))
 493                         (concat (or (match-string 4 date) "00:00") ":00"))
 494                  zone (cond ((match-beginning 6)
 495                              (concat (match-string 6 date)
 496                                      (match-string 7 date)))
 497                             ((match-beginning 9) ;; Z
 498                              "+0000")
 499                             (t ;; nil if zone is not provided.
 500                              (match-string 8 date))))))
 501     (if month
 502         (progn
 503           (setq cts (current-time-string (encode-time 0 0 0 day month year)))
 504           (format "%s, %02d %s %04d %s%s"
 505                   (substring cts 0 3) day (substring cts 4 7) year time
 506                   (if zone
 507                       (concat " " zone)
 508                     "")))
 509       (message-make-date given))))
 510
 511 ;;; data functions
 512
 513 (defun nnrss-read-server-data (server)
 514   (setq nnrss-server-data nil)
 515   (let ((file (nnrss-make-filename "nnrss" server))
 516         (file-name-coding-system nnmail-pathname-coding-system))
 517     (when (file-exists-p file)
 518       (load file nil t t))))
 519
 520 (defun nnrss-save-server-data (server)
 521   (gnus-make-directory nnrss-directory)
 522   (let ((coding-system-for-write nnrss-file-coding-system)
 523         (file-name-coding-system nnmail-pathname-coding-system))
 524     (with-temp-file (nnrss-make-filename "nnrss" server)
 525       (insert (format ";; -*- coding: %s; -*-\n"
 526                       nnrss-file-coding-system))
 527       (gnus-prin1 `(setq nnrss-group-alist ',nnrss-group-alist))
 528       (insert "\n")
 529       (gnus-prin1 `(setq nnrss-server-data ',nnrss-server-data)))))
 530
 531 (defun nnrss-read-group-data (group server)
 532   (setq nnrss-group-data nil)
 533   (if (hash-table-p nnrss-group-hashtb)
 534       (clrhash nnrss-group-hashtb)
 535     (setq nnrss-group-hashtb (make-hash-table :test 'equal)))
 536   (let ((pair (assoc group nnrss-server-data)))
 537     (setq nnrss-group-max (or (cadr pair) 0))
 538     (setq nnrss-group-min (+ nnrss-group-max 1)))
 539   (let ((file (nnrss-make-filename group server))
 540         (file-name-coding-system nnmail-pathname-coding-system))
 541     (when (file-exists-p file)
 542       (load file nil t t)
 543       (dolist (e nnrss-group-data)
 544         (puthash (nth 9 e) t nnrss-group-hashtb)
 545         (when (and (car e) (> nnrss-group-min (car e)))
 546           (setq nnrss-group-min (car e)))
 547         (when (and (car e) (< nnrss-group-max (car e)))
 548           (setq nnrss-group-max (car e)))))))
 549
 550 (defun nnrss-save-group-data (group server)
 551   (gnus-make-directory nnrss-directory)
 552   (let ((coding-system-for-write nnrss-file-coding-system)
 553         (file-name-coding-system nnmail-pathname-coding-system))
 554     (with-temp-file (nnrss-make-filename group server)
 555       (insert (format ";; -*- coding: %s; -*-\n"
 556                       nnrss-file-coding-system))
 557       (gnus-prin1 `(setq nnrss-group-data ',nnrss-group-data)))))
 558
 559 (defun nnrss-make-filename (name server)
 560   (expand-file-name
 561    (nnrss-translate-file-chars
 562     (concat name
 563             (and server
 564                  (not (equal server ""))
 565                  "-")
 566             server
 567             ".el"))
 568    nnrss-directory))
 569
 570 (gnus-add-shutdown 'nnrss-close 'gnus)
 571
 572 (defun nnrss-close ()
 573   "Clear internal nnrss variables."
 574   (setq nnrss-group-data nil
 575         nnrss-server-data nil
 576         nnrss-group-hashtb nil
 577         nnrss-group-alist nil))
 578
 579 ;;; URL interface
 580
 581 (defun nnrss-no-cache (url)
 582   "")
 583
 584 (defun nnrss-insert (url)
 585   (condition-case err
 586       (mm-url-insert url)
 587     (error (if (or debug-on-quit debug-on-error)
 588                (signal (car err) (cdr err))
 589              (message "nnrss: Failed to fetch %s" url)))))
 590
 591 (defun nnrss-decode-entities-string (string)
 592   (if string
 593       (mm-with-multibyte-buffer
 594         (insert string)
 595         (mm-url-decode-entities-nbsp)
 596         (buffer-string))))
 597
 598 (defun nnrss-mime-encode-string (string)
 599   (mm-with-multibyte-buffer
 600     (insert string)
 601     (mm-url-decode-entities-nbsp)
 602     (goto-char (point-min))
 603     (while (re-search-forward "[\t\n ]+" nil t)
 604       (replace-match " "))
 605     (goto-char (point-min))
 606     (skip-chars-forward " ")
 607     (delete-region (point-min) (point))
 608     (goto-char (point-max))
 609     (skip-chars-forward " ")
 610     (delete-region (point) (point-max))
 611     (let ((rfc2047-encoding-type 'mime)
 612           rfc2047-encode-max-chars)
 613       (rfc2047-encode-region (point-min) (point-max)))
 614     (goto-char (point-min))
 615     (while (search-forward "\n" nil t)
 616       (delete-char -1))
 617     (buffer-string)))
 618
 619 ;;; Snarf functions
 620 (defun nnrss-make-hash-index (item)
 621   (gnus-message 9 "nnrss: Making hash index of %s" (gnus-prin1-to-string item))
 622   (setq item (gnus-remove-if
 623               (lambda (field)
 624                 (when (listp field)
 625                   (memq (car field) nnrss-ignore-article-fields)))
 626               item))
 627   (md5 (gnus-prin1-to-string item)
 628        nil nil
 629        nnrss-file-coding-system))
 630
 631 (defun nnrss-check-group (group server)
 632   (let (file xml subject url extra changed author date feed-subject
 633              enclosure comments rss-ns rdf-ns content-ns dc-ns
 634              hash-index)
 635     (if (and nnrss-use-local
 636              (file-exists-p (setq file (expand-file-name
 637                                         (nnrss-translate-file-chars
 638                                          (concat group ".xml"))
 639                                         nnrss-directory))))
 640         (setq xml (nnrss-fetch file t))
 641       (setq url (or (nth 2 (assoc group nnrss-server-data))
 642                     (second (assoc group nnrss-group-alist))))
 643       (unless url
 644         (setq url
 645               (cdr
 646                (assoc 'href
 647                       (nnrss-discover-feed
 648                        (read-string
 649                         (format "URL to search for %s: " group) "http://")))))
 650         (let ((pair (assoc group nnrss-server-data)))
 651           (if pair
 652               (setcdr (cdr pair) (list url))
 653             (push (list group nnrss-group-max url) nnrss-server-data)))
 654         (setq changed t))
 655       (setq xml (nnrss-fetch url)))
 656     (setq dc-ns (nnrss-get-namespace-prefix xml "http://purl.org/dc/elements/1.1/")
 657           rdf-ns (nnrss-get-namespace-prefix xml "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
 658           rss-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/")
 659           content-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/modules/content/"))
 660     (dolist (item (nreverse (nnrss-find-el (intern (concat rss-ns "item")) xml)))
 661       (when (and (listp item)
 662                  (string= (concat rss-ns "item") (car item))
 663                  (progn (setq hash-index (nnrss-make-hash-index item))
 664                         (not (gethash hash-index nnrss-group-hashtb))))
 665         (setq subject (nnrss-node-text rss-ns 'title item))
 666         (setq url (nnrss-decode-entities-string
 667                    (nnrss-node-text rss-ns 'link (cddr item))))
 668         (setq extra (or (nnrss-node-text content-ns 'encoded item)
 669                         (nnrss-node-text rss-ns 'description item)))
 670         (if (setq feed-subject (nnrss-node-text dc-ns 'subject item))
 671             (setq extra (concat feed-subject "<br /><br />" extra)))
 672         (setq author (or (nnrss-node-text rss-ns 'author item)
 673                          (nnrss-node-text dc-ns 'creator item)
 674                          (nnrss-node-text dc-ns 'contributor item)))
 675         (setq date (nnrss-normalize-date
 676                     (or (nnrss-node-text dc-ns 'date item)
 677                         (nnrss-node-text rss-ns 'pubDate item))))
 678         (setq comments (nnrss-node-text rss-ns 'comments item))
 679         (when (setq enclosure (cadr (assq (intern (concat rss-ns "enclosure")) item)))
 680           (let ((url (cdr (assq 'url enclosure)))
 681                 (len (cdr (assq 'length enclosure)))
 682                 (type (cdr (assq 'type enclosure)))
 683                 (name))
 684             (setq len
 685                   (if (and len (integerp (setq len (string-to-number len))))
 686                       ;; actually already in `ls-lisp-format-file-size' but
 687                       ;; probably not worth to require it for one function
 688                       (do ((size (/ len 1.0) (/ size 1024.0))
 689                            (post-fixes (list "" "k" "M" "G" "T" "P" "E")
 690                                        (cdr post-fixes)))
 691                           ((< size 1024)
 692                            (format "%.1f%s" size (car post-fixes))))
 693                     "0"))
 694             (setq url (or url ""))
 695             (setq name (if (string-match "/\\([^/]*\\)$" url)
 696                            (match-string 1 url)
 697                          "file"))
 698             (setq type (or type ""))
 699             (setq enclosure (list url name len type))))
 700         (push
 701          (list
 702           (incf nnrss-group-max)
 703           (current-time)
 704           url
 705           (and subject (nnrss-mime-encode-string subject))
 706           (and author (nnrss-mime-encode-string author))
 707           date
 708           (and extra (nnrss-decode-entities-string extra))
 709           enclosure
 710           comments
 711           hash-index)
 712          nnrss-group-data)
 713         (puthash hash-index t nnrss-group-hashtb)
 714         (setq changed t))
 715       (setq extra nil))
 716     (when changed
 717       (nnrss-save-group-data group server)
 718       (let ((pair (assoc group nnrss-server-data)))
 719         (if pair
 720             (setcar (cdr pair) nnrss-group-max)
 721           (push (list group nnrss-group-max) nnrss-server-data)))
 722       (nnrss-save-server-data server))))
 723
 724 (declare-function gnus-group-make-rss-group "gnus-group" (&optional url))
 725
 726 (defun nnrss-opml-import (opml-file)
 727   "OPML subscriptions import.
 728 Read the file and attempt to subscribe to each Feed in the file."
 729   (interactive "fImport file: ")
 730   (mapc
 731    (lambda (node)
 732      (let ((xmlurl (cdr (assq 'xmlUrl (cadr node)))))
 733        (when (and xmlurl
 734                   (not (string-match "\\`[\t ]*\\'" xmlurl))
 735                   (prog1
 736                       (y-or-n-p (format "Subscribe to %s " xmlurl))
 737                     (message "")))
 738          (condition-case err
 739              (progn
 740                (gnus-group-make-rss-group xmlurl)
 741                (forward-line 1))
 742            (error
 743             (message
 744              "Failed to subscribe to %s (%s); type any key to continue: "
 745              xmlurl
 746              (error-message-string err))
 747             (let ((echo-keystrokes 0))
 748               (read-char)))))))
 749    (nnrss-find-el 'outline
 750                   (mm-with-multibyte-buffer
 751                     (insert-file-contents opml-file)
 752                     (xml-parse-region (point-min) (point-max))))))
 753
 754 (defun nnrss-opml-export ()
 755   "OPML subscription export.
 756 Export subscriptions to a buffer in OPML Format."
 757   (interactive)
 758   (with-current-buffer (get-buffer-create "*OPML Export*")
 759     (set-buffer-file-coding-system 'utf-8)
 760     (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"
 761             "<!-- OPML generated by Emacs Gnus' nnrss.el -->\n"
 762             "<opml version=\"1.1\">\n"
 763             "  <head>\n"
 764             "    <title>mySubscriptions</title>\n"
 765             "    <dateCreated>" (format-time-string "%a, %d %b %Y %T %z")
 766             "</dateCreated>\n"
 767             "    <ownerEmail>" user-mail-address "</ownerEmail>\n"
 768             "    <ownerName>" (user-full-name) "</ownerName>\n"
 769             "  </head>\n"
 770             "  <body>\n")
 771     (dolist (sub nnrss-group-alist)
 772       (insert "    <outline text=\"" (car sub)
 773               "\" xmlUrl=\"" (cadr sub) "\"/>\n"))
 774     (insert "  </body>\n"
 775             "</opml>\n"))
 776   (pop-to-buffer "*OPML Export*")
 777   (when (fboundp 'sgml-mode)
 778     (sgml-mode)))
 779
 780 (defun nnrss-generate-download-script ()
 781   "Generate a download script in the current buffer.
 782 It is useful when `(setq nnrss-use-local t)'."
 783   (interactive)
 784   (insert "#!/bin/sh\n")
 785   (insert "WGET=wget\n")
 786   (insert "RSSDIR='" (expand-file-name nnrss-directory) "'\n")
 787   (dolist (elem nnrss-server-data)
 788     (let ((url (or (nth 2 elem)
 789                    (second (assoc (car elem) nnrss-group-alist)))))
 790       (insert "$WGET -q -O \"$RSSDIR\"/'"
 791               (nnrss-translate-file-chars (concat (car elem) ".xml"))
 792               "' '" url "'\n"))))
 793
 794 (defun nnrss-translate-file-chars (name)
 795   (let ((nnheader-file-name-translation-alist
 796          (append nnheader-file-name-translation-alist '((?' . ?_)))))
 797     (nnheader-translate-file-chars name)))
 798
 799 (defun nnrss-node-text (namespace local-name element)
 800   (let* ((node (assq (intern (concat namespace (symbol-name local-name)))
 801                      element))
 802          (text (if (and node (listp node))
 803                    (nnrss-node-just-text node)
 804                  node))
 805          (cleaned-text (if text
 806                            (replace-regexp-in-string
 807                             "\r\n" "\n"
 808                             (replace-regexp-in-string
 809                              "^[\000-\037\177]+\\|^ +\\| +$" ""
 810                              text)))))
 811     (if (string-equal "" cleaned-text)
 812         nil
 813       cleaned-text)))
 814
 815 (defun nnrss-node-just-text (node)
 816   (if (and node (listp node))
 817       (mapconcat 'nnrss-node-just-text (cddr node) " ")
 818     node))
 819
 820 (defun nnrss-find-el (tag data &optional found-list)
 821   "Find the all matching elements in the data.
 822 Careful with this on large documents!"
 823   (when (consp data)
 824     (dolist (bit data)
 825       (when (car-safe bit)
 826         (when (equal tag (car bit))
 827           ;; Old xml.el may return a list of string.
 828           (when (and (consp (caddr bit))
 829                      (stringp (caaddr bit)))
 830             (setcar (cddr bit) (caaddr bit)))
 831           (setq found-list
 832                 (append found-list
 833                         (list bit))))
 834         (if (and (consp (car-safe (caddr bit)))
 835                  (not (stringp (caddr bit))))
 836             (setq found-list
 837                   (append found-list
 838                           (nnrss-find-el
 839                            tag (caddr bit))))
 840           (setq found-list
 841                 (append found-list
 842                         (nnrss-find-el
 843                          tag (cddr bit))))))))
 844   found-list)
 845
 846 (defun nnrss-rsslink-p (el)
 847   "Test if the element we are handed is an RSS autodiscovery link."
 848   (and (eq (car-safe el) 'link)
 849        (string-equal (cdr (assoc 'rel (cadr el))) "alternate")
 850        (or (string-equal (cdr (assoc 'type (cadr el)))
 851                          "application/rss+xml")
 852            (string-equal (cdr (assoc 'type (cadr el))) "text/xml"))))
 853
 854 (defun nnrss-get-rsslinks (data)
 855   "Extract the <link> elements that are links to RSS from the parsed data."
 856   (delq nil (mapcar
 857              (lambda (el)
 858                (if (nnrss-rsslink-p el) el))
 859              (nnrss-find-el 'link data))))
 860
 861 (defun nnrss-extract-hrefs (data)
 862   "Recursively extract hrefs from a page's source.
 863 DATA should be the output of `xml-parse-region'."
 864   (mapcar (lambda (ahref)
 865             (cdr (assoc 'href (cadr ahref))))
 866           (nnrss-find-el 'a data)))
 867
 868 (defmacro nnrss-match-macro (base-uri item onsite-list offsite-list)
 869   `(cond ((or (string-match (concat "^" ,base-uri) ,item)
 870               (not (string-match "://" ,item)))
 871           (setq ,onsite-list (append ,onsite-list (list ,item))))
 872          (t (setq ,offsite-list (append ,offsite-list (list ,item))))))
 873
 874 (defun nnrss-order-hrefs (base-uri hrefs)
 875   "Given a list of hrefs, sort them using the following priorities:
 876   1. links ending in .rss
 877   2. links ending in .rdf
 878   3. links ending in .xml
 879   4. links containing the above
 880   5. offsite links
 881
 882 BASE-URI is used to determine the location of the links and
 883 whether they are `offsite' or `onsite'."
 884   (let (rss-onsite-end  rdf-onsite-end  xml-onsite-end
 885         rss-onsite-in   rdf-onsite-in   xml-onsite-in
 886         rss-offsite-end rdf-offsite-end xml-offsite-end
 887         rss-offsite-in rdf-offsite-in xml-offsite-in)
 888     (dolist (href hrefs)
 889       (cond ((null href))
 890             ((string-match "\\.rss$" href)
 891              (nnrss-match-macro
 892               base-uri href rss-onsite-end rss-offsite-end))
 893             ((string-match "\\.rdf$" href)
 894              (nnrss-match-macro
 895               base-uri href rdf-onsite-end rdf-offsite-end))
 896             ((string-match "\\.xml$" href)
 897              (nnrss-match-macro
 898               base-uri href xml-onsite-end xml-offsite-end))
 899             ((string-match "rss" href)
 900              (nnrss-match-macro
 901               base-uri href rss-onsite-in rss-offsite-in))
 902             ((string-match "rdf" href)
 903              (nnrss-match-macro
 904               base-uri href rdf-onsite-in rdf-offsite-in))
 905             ((string-match "xml" href)
 906              (nnrss-match-macro
 907               base-uri href xml-onsite-in xml-offsite-in))))
 908     (append
 909      rss-onsite-end  rdf-onsite-end  xml-onsite-end
 910      rss-onsite-in   rdf-onsite-in   xml-onsite-in
 911      rss-offsite-end rdf-offsite-end xml-offsite-end
 912      rss-offsite-in rdf-offsite-in xml-offsite-in)))
 913
 914 (defun nnrss-discover-feed (url)
 915   "Given a page, find an RSS feed.
 916 Use Mark Pilgrim's `ultra-liberal rss locator'."
 917   (let ((parsed-page (nnrss-fetch url)))
 918     ;;    1. if this url is the rss, use it.
 919     (if (nnrss-rss-p parsed-page)
 920         (let ((rss-ns (nnrss-get-namespace-prefix parsed-page "http://purl.org/rss/1.0/")))
 921           (nnrss-rss-title-description rss-ns parsed-page url))
 922
 923       ;;    2. look for the <link rel="alternate"
 924       ;;    type="application/rss+xml" and use that if it is there.
 925       (let ((links (nnrss-get-rsslinks parsed-page)))
 926         (if links
 927             (let* ((xml (nnrss-fetch
 928                          (cdr (assoc 'href (cadar links)))))
 929                    (rss-ns (nnrss-get-namespace-prefix
 930                             xml "http://purl.org/rss/1.0/")))
 931               (nnrss-rss-title-description
 932                rss-ns xml (cdr (assoc 'href (cadar links)))))
 933
 934           ;;    3. look for links on the site in the following order:
 935           ;;       - onsite links ending in .rss, .rdf, or .xml
 936           ;;       - onsite links containing any of the above
 937           ;;       - offsite links ending in .rss, .rdf, or .xml
 938           ;;       - offsite links containing any of the above
 939           (let* ((base-uri (progn (string-match ".*://[^/]+/?" url)
 940                                   (match-string 0 url)))
 941                  (hrefs (nnrss-order-hrefs
 942                          base-uri (nnrss-extract-hrefs parsed-page)))
 943                  (rss-link nil))
 944             (while (and (eq rss-link nil) (not (eq hrefs nil)))
 945               (let ((href-data (nnrss-fetch (car hrefs))))
 946                 (if (nnrss-rss-p href-data)
 947                     (let* ((rss-ns (nnrss-get-namespace-prefix href-data "http://purl.org/rss/1.0/")))
 948                       (setq rss-link (nnrss-rss-title-description
 949                                       rss-ns href-data (car hrefs))))
 950                   (setq hrefs (cdr hrefs)))))
 951             (if rss-link
 952                 rss-link
 953               ;;    4. check syndic8
 954               (nnrss-find-rss-via-syndic8 url))))))))
 955
 956 (declare-function xml-rpc-method-call "ext:xml-rpc"
 957                   (server-url method &rest params))
 958
 959 (defun nnrss-find-rss-via-syndic8 (url)
 960   "Query syndic8 for the rss feeds it has for URL."
 961   (if (not (locate-library "xml-rpc"))
 962       (progn
 963         (message "XML-RPC is not available... not checking Syndic8.")
 964         nil)
 965     (require 'xml-rpc)
 966     (let ((feedid (xml-rpc-method-call
 967                    "http://www.syndic8.com/xmlrpc.php"
 968                    'syndic8.FindSites
 969                    url)))
 970       (when feedid
 971         (let* ((feedinfo (xml-rpc-method-call
 972                           "http://www.syndic8.com/xmlrpc.php"
 973                           'syndic8.GetFeedInfo
 974                           feedid))
 975                (urllist
 976                 (delq nil
 977                       (mapcar
 978                        (lambda (listinfo)
 979                          (if (string-equal
 980                               (cdr (assoc "status" listinfo))
 981                               "Syndicated")
 982                              (cons
 983                               (cdr (assoc "sitename" listinfo))
 984                               (list
 985                                (cons 'title
 986                                      (cdr (assoc
 987                                            "sitename" listinfo)))
 988                                (cons 'href
 989                                      (cdr (assoc
 990                                            "dataurl" listinfo)))))))
 991                        feedinfo))))
 992           (if (not (> (length urllist) 1))
 993               (cdar urllist)
 994             (let ((completion-ignore-case t)
 995                   (selection
 996                    (mapcar (lambda (listinfo)
 997                              (cons (cdr (assoc "sitename" listinfo))
 998                                    (string-to-number
 999                                     (cdr (assoc "feedid" listinfo)))))
1000                            feedinfo)))
1001               (cdr (assoc
1002                     (gnus-completing-read
1003                      "Multiple feeds found. Select one"
1004                      selection t) urllist)))))))))
1005
1006 (defun nnrss-rss-p (data)
1007   "Test if DATA is an RSS feed.
1008 Simply ensures that the first element is rss or rdf."
1009   (or (eq (caar data) 'rss)
1010       (eq (caar data) 'rdf:RDF)))
1011
1012 (defun nnrss-rss-title-description (rss-namespace data url)
1013   "Return the title of an RSS feed."
1014   (if (nnrss-rss-p data)
1015       (let ((description (intern (concat rss-namespace "description")))
1016             (title (intern (concat rss-namespace "title")))
1017             (channel (nnrss-find-el (intern (concat rss-namespace "channel"))
1018                                     data)))
1019         (list
1020          (cons 'description (caddr (nth 0 (nnrss-find-el description channel))))
1021          (cons 'title (caddr (nth 0 (nnrss-find-el title channel))))
1022          (cons 'href url)))))
1023
1024 (defun nnrss-get-namespace-prefix (el uri)
1025   "Given EL (containing a parsed element) and URI (containing a string
1026 that gives the URI for which you want to retrieve the namespace
1027 prefix), return the prefix."
1028   (let* ((prefix (car (rassoc uri (cadar el))))
1029          (nslist (if prefix
1030                      (split-string (symbol-name prefix) ":")))
1031          (ns (cond ((eq (length nslist) 1) ; no prefix given
1032                     "")
1033                    ((eq (length nslist) 2) ; extract prefix
1034                     (cadr nslist)))))
1035     (if (and ns (not (string= ns "")))
1036         (concat ns ":")
1037       ns)))
1038
1039 (provide 'nnrss)
1040
1041 ;;; nnrss.el ends here