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 string " *\n *" " "))
 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                   ;; XEmacs version of `fill-region' inserts newline.
 244                   (unless (bolp)
 245                     (insert "\n"))))
 246               (when (or link enclosure)
 247                 (insert "\n")))
 248             (when link
 249               (insert link "\n"))
 250             (when enclosure
 251               (insert (car enclosure) " "
 252                       (nth 2 enclosure) " "
 253                       (nth 3 enclosure) "\n"))
 254             (when comments
 255               (insert comments "\n"))
 256             (setq body (buffer-substring body (point)))
 257             (insert "<#/part>\n"
 258                     "<#part type=\"text/html\">\n"
 259                     "<html><head></head><body>\n")
 260             (when text
 261               (insert text "\n"))
 262             (when link
 263               (insert "<p><a href=\"" link "\">link</a></p>\n"))
 264             (when enclosure
 265               (insert "<p><a href=\"" (car enclosure) "\">"
 266                       (cadr enclosure) "</a> " (nth 2 enclosure)
 267                       " " (nth 3 enclosure) "</p>\n"))
 268             (when comments
 269               (insert "<p><a href=\"" comments "\">comments</a></p>\n"))
 270             (insert "</body></html>\n"
 271                     "<#/part>\n"
 272                     "<#/multipart>\n"))
 273           (condition-case nil
 274               ;; Allow `mml-to-mime' to generate MIME article without
 275               ;; making inquiry to a user for unknown encoding.
 276               (let ((mml-confirmation-set
 277                      (cons 'unknown-encoding mml-confirmation-set)))
 278                 (mml-to-mime))
 279             (error
 280              (erase-buffer)
 281              (insert header
 282                      "Content-Type: text/plain; charset=gnus-decoded\n"
 283                      "Content-Transfer-Encoding: 8bit\n\n"
 284                      body)
 285              (nnheader-message
 286               3 "Warning - there might be invalid characters"))))
 287         (goto-char (point-min))
 288         (search-forward "\n\n")
 289         (forward-line -1)
 290         (insert (format "Message-ID: <%d@%s.nnrss>\n"
 291                         (car e)
 292                         (let ((rfc2047-encoding-type 'mime)
 293                               rfc2047-encode-max-chars)
 294                           (rfc2047-encode-string
 295                            (replace-regexp-in-string group "[\t\n ]+" "_")))))
 296         (when nnrss-content-function
 297           (funcall nnrss-content-function e group article))))
 298     (cond
 299      (err
 300       (nnheader-report 'nnrss err))
 301      ((not e)
 302       (nnheader-report 'nnrss "no such id: %d" article))
 303      (t
 304       (nnheader-report 'nnrss "article %s retrieved" (car e))
 305       ;; we return the article number.
 306       (cons nnrss-group (car e))))))
 307
 308 (deffoo nnrss-open-server (server &optional defs connectionless)
 309   (nnrss-read-server-data server)
 310   (nnoo-change-server 'nnrss server defs)
 311   t)
 312
 313 (deffoo nnrss-request-expire-articles
 314     (articles group &optional server force)
 315   (setq group (nnrss-decode-group-name group))
 316   (nnrss-possibly-change-group group server)
 317   (let (e days not-expirable changed)
 318     (dolist (art articles)
 319       (if (and (setq e (assq art nnrss-group-data))
 320                (nnmail-expired-article-p
 321                 group
 322                 (if (listp (setq days (nth 1 e))) days
 323                   (days-to-time (- days (time-to-days '(0 0)))))
 324                 force))
 325           (setq nnrss-group-data (delq e nnrss-group-data)
 326                 changed t)
 327         (push art not-expirable)))
 328     (if changed
 329         (nnrss-save-group-data group server))
 330     not-expirable))
 331
 332 (deffoo nnrss-request-delete-group (group &optional force server)
 333   (setq group (nnrss-decode-group-name group))
 334   (nnrss-possibly-change-group group server)
 335   (let (elem)
 336     ;; There may be two or more entries in `nnrss-group-alist' since
 337     ;; this function didn't delete them formerly.
 338     (while (setq elem (assoc group nnrss-group-alist))
 339       (setq nnrss-group-alist (delq elem nnrss-group-alist))))
 340   (setq nnrss-server-data
 341         (delq (assoc group nnrss-server-data) nnrss-server-data))
 342   (nnrss-save-server-data server)
 343   (ignore-errors
 344     (let ((file-name-coding-system nnmail-pathname-coding-system))
 345       (delete-file (nnrss-make-filename group server))))
 346   t)
 347
 348 (deffoo nnrss-request-list-newsgroups (&optional server)
 349   (nnrss-possibly-change-group nil server)
 350   (with-current-buffer nntp-server-buffer
 351     (erase-buffer)
 352     (dolist (elem nnrss-group-alist)
 353       (if (third elem)
 354           (insert (car elem) "\t" (third elem) "\n"))))
 355   t)
 356
 357 (deffoo nnrss-retrieve-groups (groups &optional server)
 358   (dolist (group groups)
 359     (setq group (nnrss-decode-group-name group))
 360     (nnrss-possibly-change-group group server)
 361     (nnrss-check-group group server))
 362   (with-current-buffer nntp-server-buffer
 363     (erase-buffer)
 364     (dolist (group groups)
 365       (let ((elem (assoc (gnus-group-decoded-name group) nnrss-server-data)))
 366         (insert (format "%S %s 1 y\n" group (or (cadr elem) 0)))))
 367     'active))
 368
 369 (nnoo-define-skeleton nnrss)
 370
 371 ;;; Internal functions
 372 (defun nnrss-get-encoding ()
 373   "Return an encoding attribute specified in the current xml contents.
 374 If `nnrss-compatible-encoding-alist' specifies the compatible encoding,
 375 it is used instead.  If the xml contents doesn't specify the encoding,
 376 return `utf-8' which is the default encoding for xml if it is available,
 377 otherwise return nil."
 378   (goto-char (point-min))
 379   (if (re-search-forward
 380        "<\\?[^>]*encoding=\\(?:\"\\([^\">]+\\)\"\\|'\\([^'>]+\\)'\\)"
 381        nil t)
 382       (let ((encoding (intern (downcase (or (match-string 1)
 383                                             (match-string 2))))))
 384         (or
 385          (mm-coding-system-p (cdr (assq encoding
 386                                         nnrss-compatible-encoding-alist)))
 387          (mm-coding-system-p encoding)
 388          (mm-coding-system-p (car (rassq encoding
 389                                          nnrss-compatible-encoding-alist)))))
 390     (mm-coding-system-p 'utf-8)))
 391
 392 (declare-function libxml-parse-html-region "xml.c"
 393                   (start end &optional base-url discard-comments))
 394 (defun nnrss-fetch (url &optional local)
 395   "Fetch URL and put it in a the expected Lisp structure."
 396   (mm-with-unibyte-buffer
 397     ;;some versions of url.el need this to close the connection quickly
 398     (let (cs xmlform htmlform)
 399       ;; bit o' work necessary for w3 pre-cvs and post-cvs
 400       (if local
 401           (let ((coding-system-for-read 'binary))
 402             (insert-file-contents url))
 403         ;; FIXME: shouldn't binding `coding-system-for-read' be moved
 404         ;; to `mm-url-insert'?
 405         (let ((coding-system-for-read 'binary))
 406           (condition-case err
 407               (mm-url-insert url)
 408             (error (if (or debug-on-quit debug-on-error)
 409                        (signal (car err) (cdr err))
 410                      (message "nnrss: Failed to fetch %s" url))))))
 411       (nnheader-remove-cr-followed-by-lf)
 412       ;; Decode text according to the encoding attribute.
 413       (when (setq cs (nnrss-get-encoding))
 414         (insert (prog1
 415                     (decode-coding-string (buffer-string) cs)
 416                   (erase-buffer)
 417                   (mm-enable-multibyte))))
 418       (goto-char (point-min))
 419
 420       (condition-case err1
 421           (setq xmlform (xml-parse-region (point-min) (point-max)))
 422         (error
 423          (condition-case err2
 424              (setq htmlform (libxml-parse-html-region (point-min) (point-max)))
 425            (error
 426             (message "\
 427 nnrss: %s: Not valid XML %s and libxml-parse-html-region doesn't work %s"
 428                      url err1 err2)))))
 429       (if htmlform
 430           htmlform
 431         xmlform))))
 432
 433 (defun nnrss-possibly-change-group (&optional group server)
 434   (when (and server
 435              (not (nnrss-server-opened server)))
 436     (nnrss-open-server server))
 437   (when (and group (not (equal group nnrss-group)))
 438     (nnrss-read-group-data group server)
 439     (setq nnrss-group group)))
 440
 441 (autoload 'timezone-parse-date "timezone")
 442
 443 (defun nnrss-normalize-date (date)
 444   "Return a date string of DATE in the RFC822 style.
 445 This function handles the ISO 8601 date format described in
 446 URL `http://www.w3.org/TR/NOTE-datetime', and also the RFC822 style
 447 which RSS 2.0 allows."
 448   (let (case-fold-search vector year month day time zone cts given)
 449     (cond ((null date))                 ; do nothing for this case
 450           ;; if the date is just digits (unix time stamp):
 451           ((string-match "^[0-9]+$" date)
 452            (setq given (seconds-to-time (string-to-number date))))
 453           ;; RFC822
 454           ((string-match " [0-9]+ " date)
 455            (setq vector (timezone-parse-date date)
 456                  year (string-to-number (aref vector 0)))
 457            (when (>= year 1969)
 458              (setq month (string-to-number (aref vector 1))
 459                    day (string-to-number (aref vector 2)))
 460              (unless (>= (length (setq time (aref vector 3))) 3)
 461                (setq time "00:00:00"))
 462              (when (and (setq zone (aref vector 4))
 463                         (not (string-match "\\`[A-Z+-]" zone)))
 464                (setq zone nil))))
 465           ;; ISO 8601
 466           ((string-match
 467             (eval-when-compile
 468               (concat
 469                ;; 1. year
 470                "\\(199[0-9]\\|20[0-9][0-9]\\)"
 471                "\\(?:-"
 472                ;; 2. month
 473                "\\([01][0-9]\\)"
 474                "\\(?:-"
 475                ;; 3. day
 476                "\\([0-3][0-9]\\)"
 477                "\\)?\\)?\\(?:T"
 478                ;; 4. hh:mm
 479                "\\([012][0-9]:[0-5][0-9]\\)"
 480                "\\(?:"
 481                ;; 5. :ss
 482                "\\(:[0-5][0-9]\\)"
 483                "\\(?:\\.[0-9]+\\)?\\)?\\)?"
 484                ;; 6+7,8,9. zone
 485                "\\(?:\\(?:\\([+-][012][0-9]\\):\\([0-5][0-9]\\)\\)"
 486                "\\|\\([+-][012][0-9][0-5][0-9]\\)"
 487                "\\|\\(Z\\)\\)?"))
 488             date)
 489            (setq year (string-to-number (match-string 1 date))
 490                  month (string-to-number (or (match-string 2 date) "1"))
 491                  day (string-to-number (or (match-string 3 date) "1"))
 492                  time (if (match-beginning 5)
 493                           (substring date (match-beginning 4) (match-end 5))
 494                         (concat (or (match-string 4 date) "00:00") ":00"))
 495                  zone (cond ((match-beginning 6)
 496                              (concat (match-string 6 date)
 497                                      (match-string 7 date)))
 498                             ((match-beginning 9) ;; Z
 499                              "+0000")
 500                             (t ;; nil if zone is not provided.
 501                              (match-string 8 date))))))
 502     (if month
 503         (progn
 504           (setq cts (current-time-string (encode-time 0 0 0 day month year)))
 505           (format "%s, %02d %s %04d %s%s"
 506                   (substring cts 0 3) day (substring cts 4 7) year time
 507                   (if zone
 508                       (concat " " zone)
 509                     "")))
 510       (message-make-date given))))
 511
 512 ;;; data functions
 513
 514 (defun nnrss-read-server-data (server)
 515   (setq nnrss-server-data nil)
 516   (let ((file (nnrss-make-filename "nnrss" server))
 517         (file-name-coding-system nnmail-pathname-coding-system))
 518     (when (file-exists-p file)
 519       (load file nil t t))))
 520
 521 (defun nnrss-save-server-data (server)
 522   (gnus-make-directory nnrss-directory)
 523   (let ((coding-system-for-write nnrss-file-coding-system)
 524         (file-name-coding-system nnmail-pathname-coding-system))
 525     (with-temp-file (nnrss-make-filename "nnrss" server)
 526       (insert (format ";; -*- coding: %s; -*-\n"
 527                       nnrss-file-coding-system))
 528       (gnus-prin1 `(setq nnrss-group-alist ',nnrss-group-alist))
 529       (insert "\n")
 530       (gnus-prin1 `(setq nnrss-server-data ',nnrss-server-data)))))
 531
 532 (defun nnrss-read-group-data (group server)
 533   (setq nnrss-group-data nil)
 534   (if (hash-table-p nnrss-group-hashtb)
 535       (clrhash nnrss-group-hashtb)
 536     (setq nnrss-group-hashtb (make-hash-table :test 'equal)))
 537   (let ((pair (assoc group nnrss-server-data)))
 538     (setq nnrss-group-max (or (cadr pair) 0))
 539     (setq nnrss-group-min (+ nnrss-group-max 1)))
 540   (let ((file (nnrss-make-filename group server))
 541         (file-name-coding-system nnmail-pathname-coding-system))
 542     (when (file-exists-p file)
 543       (load file nil t t)
 544       (dolist (e nnrss-group-data)
 545         (puthash (nth 9 e) t nnrss-group-hashtb)
 546         (when (and (car e) (> nnrss-group-min (car e)))
 547           (setq nnrss-group-min (car e)))
 548         (when (and (car e) (< nnrss-group-max (car e)))
 549           (setq nnrss-group-max (car e)))))))
 550
 551 (defun nnrss-save-group-data (group server)
 552   (gnus-make-directory nnrss-directory)
 553   (let ((coding-system-for-write nnrss-file-coding-system)
 554         (file-name-coding-system nnmail-pathname-coding-system))
 555     (with-temp-file (nnrss-make-filename group server)
 556       (insert (format ";; -*- coding: %s; -*-\n"
 557                       nnrss-file-coding-system))
 558       (gnus-prin1 `(setq nnrss-group-data ',nnrss-group-data)))))
 559
 560 (defun nnrss-make-filename (name server)
 561   (expand-file-name
 562    (nnrss-translate-file-chars
 563     (concat name
 564             (and server
 565                  (not (equal server ""))
 566                  "-")
 567             server
 568             ".el"))
 569    nnrss-directory))
 570
 571 (gnus-add-shutdown 'nnrss-close 'gnus)
 572
 573 (defun nnrss-close ()
 574   "Clear internal nnrss variables."
 575   (setq nnrss-group-data nil
 576         nnrss-server-data nil
 577         nnrss-group-hashtb nil
 578         nnrss-group-alist nil))
 579
 580 ;;; URL interface
 581
 582 (defun nnrss-no-cache (url)
 583   "")
 584
 585 (defun nnrss-insert (url)
 586   (mm-with-unibyte-current-buffer
 587     (condition-case err
 588         (mm-url-insert url)
 589       (error (if (or debug-on-quit debug-on-error)
 590                  (signal (car err) (cdr err))
 591                (message "nnrss: Failed to fetch %s" url))))))
 592
 593 (defun nnrss-decode-entities-string (string)
 594   (if string
 595       (mm-with-multibyte-buffer
 596         (insert string)
 597         (mm-url-decode-entities-nbsp)
 598         (buffer-string))))
 599
 600 (defun nnrss-mime-encode-string (string)
 601   (mm-with-multibyte-buffer
 602     (insert string)
 603     (mm-url-decode-entities-nbsp)
 604     (goto-char (point-min))
 605     (while (re-search-forward "[\t\n ]+" nil t)
 606       (replace-match " "))
 607     (goto-char (point-min))
 608     (skip-chars-forward " ")
 609     (delete-region (point-min) (point))
 610     (goto-char (point-max))
 611     (skip-chars-forward " ")
 612     (delete-region (point) (point-max))
 613     (let ((rfc2047-encoding-type 'mime)
 614           rfc2047-encode-max-chars)
 615       (rfc2047-encode-region (point-min) (point-max)))
 616     (goto-char (point-min))
 617     (while (search-forward "\n" nil t)
 618       (delete-char -1))
 619     (buffer-string)))
 620
 621 ;;; Snarf functions
 622 (defun nnrss-make-hash-index (item)
 623   (gnus-message 9 "nnrss: Making hash index of %s" (gnus-prin1-to-string item))
 624   (setq item (gnus-remove-if
 625               (lambda (field)
 626                 (when (listp field)
 627                   (memq (car field) nnrss-ignore-article-fields)))
 628               item))
 629   (md5 (gnus-prin1-to-string item)
 630        nil nil
 631        nnrss-file-coding-system))
 632
 633 (defun nnrss-check-group (group server)
 634   (let (file xml subject url extra changed author date feed-subject
 635              enclosure comments rss-ns rdf-ns content-ns dc-ns
 636              hash-index)
 637     (if (and nnrss-use-local
 638              (file-exists-p (setq file (expand-file-name
 639                                         (nnrss-translate-file-chars
 640                                          (concat group ".xml"))
 641                                         nnrss-directory))))
 642         (setq xml (nnrss-fetch file t))
 643       (setq url (or (nth 2 (assoc group nnrss-server-data))
 644                     (second (assoc group nnrss-group-alist))))
 645       (unless url
 646         (setq url
 647               (cdr
 648                (assoc 'href
 649                       (nnrss-discover-feed
 650                        (read-string
 651                         (format "URL to search for %s: " group) "http://")))))
 652         (let ((pair (assoc group nnrss-server-data)))
 653           (if pair
 654               (setcdr (cdr pair) (list url))
 655             (push (list group nnrss-group-max url) nnrss-server-data)))
 656         (setq changed t))
 657       (setq xml (nnrss-fetch url)))
 658     (setq dc-ns (nnrss-get-namespace-prefix xml "http://purl.org/dc/elements/1.1/")
 659           rdf-ns (nnrss-get-namespace-prefix xml "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
 660           rss-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/")
 661           content-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/modules/content/"))
 662     (dolist (item (nreverse (nnrss-find-el (intern (concat rss-ns "item")) xml)))
 663       (when (and (listp item)
 664                  (string= (concat rss-ns "item") (car item))
 665                  (progn (setq hash-index (nnrss-make-hash-index item))
 666                         (not (gethash hash-index nnrss-group-hashtb))))
 667         (setq subject (nnrss-node-text rss-ns 'title item))
 668         (setq url (nnrss-decode-entities-string
 669                    (nnrss-node-text rss-ns 'link (cddr item))))
 670         (setq extra (or (nnrss-node-text content-ns 'encoded item)
 671                         (nnrss-node-text rss-ns 'description item)))
 672         (if (setq feed-subject (nnrss-node-text dc-ns 'subject item))
 673             (setq extra (concat feed-subject "<br /><br />" extra)))
 674         (setq author (or (nnrss-node-text rss-ns 'author item)
 675                          (nnrss-node-text dc-ns 'creator item)
 676                          (nnrss-node-text dc-ns 'contributor item)))
 677         (setq date (nnrss-normalize-date
 678                     (or (nnrss-node-text dc-ns 'date item)
 679                         (nnrss-node-text rss-ns 'pubDate item))))
 680         (setq comments (nnrss-node-text rss-ns 'comments item))
 681         (when (setq enclosure (cadr (assq (intern (concat rss-ns "enclosure")) item)))
 682           (let ((url (cdr (assq 'url enclosure)))
 683                 (len (cdr (assq 'length enclosure)))
 684                 (type (cdr (assq 'type enclosure)))
 685                 (name))
 686             (setq len
 687                   (if (and len (integerp (setq len (string-to-number len))))
 688                       ;; actually already in `ls-lisp-format-file-size' but
 689                       ;; probably not worth to require it for one function
 690                       (do ((size (/ len 1.0) (/ size 1024.0))
 691                            (post-fixes (list "" "k" "M" "G" "T" "P" "E")
 692                                        (cdr post-fixes)))
 693                           ((< size 1024)
 694                            (format "%.1f%s" size (car post-fixes))))
 695                     "0"))
 696             (setq url (or url ""))
 697             (setq name (if (string-match "/\\([^/]*\\)$" url)
 698                            (match-string 1 url)
 699                          "file"))
 700             (setq type (or type ""))
 701             (setq enclosure (list url name len type))))
 702         (push
 703          (list
 704           (incf nnrss-group-max)
 705           (current-time)
 706           url
 707           (and subject (nnrss-mime-encode-string subject))
 708           (and author (nnrss-mime-encode-string author))
 709           date
 710           (and extra (nnrss-decode-entities-string extra))
 711           enclosure
 712           comments
 713           hash-index)
 714          nnrss-group-data)
 715         (puthash hash-index t nnrss-group-hashtb)
 716         (setq changed t))
 717       (setq extra nil))
 718     (when changed
 719       (nnrss-save-group-data group server)
 720       (let ((pair (assoc group nnrss-server-data)))
 721         (if pair
 722             (setcar (cdr pair) nnrss-group-max)
 723           (push (list group nnrss-group-max) nnrss-server-data)))
 724       (nnrss-save-server-data server))))
 725
 726 (declare-function gnus-group-make-rss-group "gnus-group" (&optional url))
 727
 728 (defun nnrss-opml-import (opml-file)
 729   "OPML subscriptions import.
 730 Read the file and attempt to subscribe to each Feed in the file."
 731   (interactive "fImport file: ")
 732   (mapc
 733    (lambda (node)
 734      (let ((xmlurl (cdr (assq 'xmlUrl (cadr node)))))
 735        (when (and xmlurl
 736                   (not (string-match "\\`[\t ]*\\'" xmlurl))
 737                   (prog1
 738                       (y-or-n-p (format "Subscribe to %s " xmlurl))
 739                     (message "")))
 740          (condition-case err
 741              (progn
 742                (gnus-group-make-rss-group xmlurl)
 743                (forward-line 1))
 744            (error
 745             (message
 746              "Failed to subscribe to %s (%s); type any key to continue: "
 747              xmlurl
 748              (error-message-string err))
 749             (let ((echo-keystrokes 0))
 750               (read-char)))))))
 751    (nnrss-find-el 'outline
 752                   (mm-with-multibyte-buffer
 753                     (insert-file-contents opml-file)
 754                     (xml-parse-region (point-min) (point-max))))))
 755
 756 (defun nnrss-opml-export ()
 757   "OPML subscription export.
 758 Export subscriptions to a buffer in OPML Format."
 759   (interactive)
 760   (with-current-buffer (get-buffer-create "*OPML Export*")
 761     (set-buffer-file-coding-system 'utf-8)
 762     (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"
 763             "<!-- OPML generated by Emacs Gnus' nnrss.el -->\n"
 764             "<opml version=\"1.1\">\n"
 765             "  <head>\n"
 766             "    <title>mySubscriptions</title>\n"
 767             "    <dateCreated>" (format-time-string "%a, %d %b %Y %T %z")
 768             "</dateCreated>\n"
 769             "    <ownerEmail>" user-mail-address "</ownerEmail>\n"
 770             "    <ownerName>" (user-full-name) "</ownerName>\n"
 771             "  </head>\n"
 772             "  <body>\n")
 773     (dolist (sub nnrss-group-alist)
 774       (insert "    <outline text=\"" (car sub)
 775               "\" xmlUrl=\"" (cadr sub) "\"/>\n"))
 776     (insert "  </body>\n"
 777             "</opml>\n"))
 778   (pop-to-buffer "*OPML Export*")
 779   (when (fboundp 'sgml-mode)
 780     (sgml-mode)))
 781
 782 (defun nnrss-generate-download-script ()
 783   "Generate a download script in the current buffer.
 784 It is useful when `(setq nnrss-use-local t)'."
 785   (interactive)
 786   (insert "#!/bin/sh\n")
 787   (insert "WGET=wget\n")
 788   (insert "RSSDIR='" (expand-file-name nnrss-directory) "'\n")
 789   (dolist (elem nnrss-server-data)
 790     (let ((url (or (nth 2 elem)
 791                    (second (assoc (car elem) nnrss-group-alist)))))
 792       (insert "$WGET -q -O \"$RSSDIR\"/'"
 793               (nnrss-translate-file-chars (concat (car elem) ".xml"))
 794               "' '" url "'\n"))))
 795
 796 (defun nnrss-translate-file-chars (name)
 797   (let ((nnheader-file-name-translation-alist
 798          (append nnheader-file-name-translation-alist '((?' . ?_)))))
 799     (nnheader-translate-file-chars name)))
 800
 801 (defun nnrss-node-text (namespace local-name element)
 802   (let* ((node (assq (intern (concat namespace (symbol-name local-name)))
 803                      element))
 804          (text (if (and node (listp node))
 805                    (nnrss-node-just-text node)
 806                  node))
 807          (cleaned-text (if text
 808                            (replace-regexp-in-string
 809                             (replace-regexp-in-string
 810                              text "^[\000-\037\177]+\\|^ +\\| +$" "")
 811                             "\r\n" "\n"))))
 812     (if (string-equal "" cleaned-text)
 813         nil
 814       cleaned-text)))
 815
 816 (defun nnrss-node-just-text (node)
 817   (if (and node (listp node))
 818       (mapconcat 'nnrss-node-just-text (cddr node) " ")
 819     node))
 820
 821 (defun nnrss-find-el (tag data &optional found-list)
 822   "Find the all matching elements in the data.
 823 Careful with this on large documents!"
 824   (when (consp data)
 825     (dolist (bit data)
 826       (when (car-safe bit)
 827         (when (equal tag (car bit))
 828           ;; Old xml.el may return a list of string.
 829           (when (and (consp (caddr bit))
 830                      (stringp (caaddr bit)))
 831             (setcar (cddr bit) (caaddr bit)))
 832           (setq found-list
 833                 (append found-list
 834                         (list bit))))
 835         (if (and (consp (car-safe (caddr bit)))
 836                  (not (stringp (caddr bit))))
 837             (setq found-list
 838                   (append found-list
 839                           (nnrss-find-el
 840                            tag (caddr bit))))
 841           (setq found-list
 842                 (append found-list
 843                         (nnrss-find-el
 844                          tag (cddr bit))))))))
 845   found-list)
 846
 847 (defun nnrss-rsslink-p (el)
 848   "Test if the element we are handed is an RSS autodiscovery link."
 849   (and (eq (car-safe el) 'link)
 850        (string-equal (cdr (assoc 'rel (cadr el))) "alternate")
 851        (or (string-equal (cdr (assoc 'type (cadr el)))
 852                          "application/rss+xml")
 853            (string-equal (cdr (assoc 'type (cadr el))) "text/xml"))))
 854
 855 (defun nnrss-get-rsslinks (data)
 856   "Extract the <link> elements that are links to RSS from the parsed data."
 857   (delq nil (mapcar
 858              (lambda (el)
 859                (if (nnrss-rsslink-p el) el))
 860              (nnrss-find-el 'link data))))
 861
 862 (defun nnrss-extract-hrefs (data)
 863   "Recursively extract hrefs from a page's source.
 864 DATA should be the output of `xml-parse-region'."
 865   (mapcar (lambda (ahref)
 866             (cdr (assoc 'href (cadr ahref))))
 867           (nnrss-find-el 'a data)))
 868
 869 (defmacro nnrss-match-macro (base-uri item onsite-list offsite-list)
 870   `(cond ((or (string-match (concat "^" ,base-uri) ,item)
 871               (not (string-match "://" ,item)))
 872           (setq ,onsite-list (append ,onsite-list (list ,item))))
 873          (t (setq ,offsite-list (append ,offsite-list (list ,item))))))
 874
 875 (defun nnrss-order-hrefs (base-uri hrefs)
 876   "Given a list of hrefs, sort them using the following priorities:
 877   1. links ending in .rss
 878   2. links ending in .rdf
 879   3. links ending in .xml
 880   4. links containing the above
 881   5. offsite links
 882
 883 BASE-URI is used to determine the location of the links and
 884 whether they are `offsite' or `onsite'."
 885   (let (rss-onsite-end  rdf-onsite-end  xml-onsite-end
 886         rss-onsite-in   rdf-onsite-in   xml-onsite-in
 887         rss-offsite-end rdf-offsite-end xml-offsite-end
 888         rss-offsite-in rdf-offsite-in xml-offsite-in)
 889     (dolist (href hrefs)
 890       (cond ((null href))
 891             ((string-match "\\.rss$" href)
 892              (nnrss-match-macro
 893               base-uri href rss-onsite-end rss-offsite-end))
 894             ((string-match "\\.rdf$" href)
 895              (nnrss-match-macro
 896               base-uri href rdf-onsite-end rdf-offsite-end))
 897             ((string-match "\\.xml$" href)
 898              (nnrss-match-macro
 899               base-uri href xml-onsite-end xml-offsite-end))
 900             ((string-match "rss" href)
 901              (nnrss-match-macro
 902               base-uri href rss-onsite-in rss-offsite-in))
 903             ((string-match "rdf" href)
 904              (nnrss-match-macro
 905               base-uri href rdf-onsite-in rdf-offsite-in))
 906             ((string-match "xml" href)
 907              (nnrss-match-macro
 908               base-uri href xml-onsite-in xml-offsite-in))))
 909     (append
 910      rss-onsite-end  rdf-onsite-end  xml-onsite-end
 911      rss-onsite-in   rdf-onsite-in   xml-onsite-in
 912      rss-offsite-end rdf-offsite-end xml-offsite-end
 913      rss-offsite-in rdf-offsite-in xml-offsite-in)))
 914
 915 (defun nnrss-discover-feed (url)
 916   "Given a page, find an RSS feed.
 917 Use Mark Pilgrim's `ultra-liberal rss locator'."
 918   (let ((parsed-page (nnrss-fetch url)))
 919     ;;    1. if this url is the rss, use it.
 920     (if (nnrss-rss-p parsed-page)
 921         (let ((rss-ns (nnrss-get-namespace-prefix parsed-page "http://purl.org/rss/1.0/")))
 922           (nnrss-rss-title-description rss-ns parsed-page url))
 923
 924       ;;    2. look for the <link rel="alternate"
 925       ;;    type="application/rss+xml" and use that if it is there.
 926       (let ((links (nnrss-get-rsslinks parsed-page)))
 927         (if links
 928             (let* ((xml (nnrss-fetch
 929                          (cdr (assoc 'href (cadar links)))))
 930                    (rss-ns (nnrss-get-namespace-prefix
 931                             xml "http://purl.org/rss/1.0/")))
 932               (nnrss-rss-title-description
 933                rss-ns xml (cdr (assoc 'href (cadar links)))))
 934
 935           ;;    3. look for links on the site in the following order:
 936           ;;       - onsite links ending in .rss, .rdf, or .xml
 937           ;;       - onsite links containing any of the above
 938           ;;       - offsite links ending in .rss, .rdf, or .xml
 939           ;;       - offsite links containing any of the above
 940           (let* ((base-uri (progn (string-match ".*://[^/]+/?" url)
 941                                   (match-string 0 url)))
 942                  (hrefs (nnrss-order-hrefs
 943                          base-uri (nnrss-extract-hrefs parsed-page)))
 944                  (rss-link nil))
 945             (while (and (eq rss-link nil) (not (eq hrefs nil)))
 946               (let ((href-data (nnrss-fetch (car hrefs))))
 947                 (if (nnrss-rss-p href-data)
 948                     (let* ((rss-ns (nnrss-get-namespace-prefix href-data "http://purl.org/rss/1.0/")))
 949                       (setq rss-link (nnrss-rss-title-description
 950                                       rss-ns href-data (car hrefs))))
 951                   (setq hrefs (cdr hrefs)))))
 952             (if rss-link
 953                 rss-link
 954               ;;    4. check syndic8
 955               (nnrss-find-rss-via-syndic8 url))))))))
 956
 957 (declare-function xml-rpc-method-call "ext:xml-rpc"
 958                   (server-url method &rest params))
 959
 960 (defun nnrss-find-rss-via-syndic8 (url)
 961   "Query syndic8 for the rss feeds it has for URL."
 962   (if (not (locate-library "xml-rpc"))
 963       (progn
 964         (message "XML-RPC is not available... not checking Syndic8.")
 965         nil)
 966     (require 'xml-rpc)
 967     (let ((feedid (xml-rpc-method-call
 968                    "http://www.syndic8.com/xmlrpc.php"
 969                    'syndic8.FindSites
 970                    url)))
 971       (when feedid
 972         (let* ((feedinfo (xml-rpc-method-call
 973                           "http://www.syndic8.com/xmlrpc.php"
 974                           'syndic8.GetFeedInfo
 975                           feedid))
 976                (urllist
 977                 (delq nil
 978                       (mapcar
 979                        (lambda (listinfo)
 980                          (if (string-equal
 981                               (cdr (assoc "status" listinfo))
 982                               "Syndicated")
 983                              (cons
 984                               (cdr (assoc "sitename" listinfo))
 985                               (list
 986                                (cons 'title
 987                                      (cdr (assoc
 988                                            "sitename" listinfo)))
 989                                (cons 'href
 990                                      (cdr (assoc
 991                                            "dataurl" listinfo)))))))
 992                        feedinfo))))
 993           (if (not (> (length urllist) 1))
 994               (cdar urllist)
 995             (let ((completion-ignore-case t)
 996                   (selection
 997                    (mapcar (lambda (listinfo)
 998                              (cons (cdr (assoc "sitename" listinfo))
 999                                    (string-to-number
1000                                     (cdr (assoc "feedid" listinfo)))))
1001                            feedinfo)))
1002               (cdr (assoc
1003                     (gnus-completing-read
1004                      "Multiple feeds found. Select one"
1005                      selection t) urllist)))))))))
1006
1007 (defun nnrss-rss-p (data)
1008   "Test if DATA is an RSS feed.
1009 Simply ensures that the first element is rss or rdf."
1010   (or (eq (caar data) 'rss)
1011       (eq (caar data) 'rdf:RDF)))
1012
1013 (defun nnrss-rss-title-description (rss-namespace data url)
1014   "Return the title of an RSS feed."
1015   (if (nnrss-rss-p data)
1016       (let ((description (intern (concat rss-namespace "description")))
1017             (title (intern (concat rss-namespace "title")))
1018             (channel (nnrss-find-el (intern (concat rss-namespace "channel"))
1019                                     data)))
1020         (list
1021          (cons 'description (caddr (nth 0 (nnrss-find-el description channel))))
1022          (cons 'title (caddr (nth 0 (nnrss-find-el title channel))))
1023          (cons 'href url)))))
1024
1025 (defun nnrss-get-namespace-prefix (el uri)
1026   "Given EL (containing a parsed element) and URI (containing a string
1027 that gives the URI for which you want to retrieve the namespace
1028 prefix), return the prefix."
1029   (let* ((prefix (car (rassoc uri (cadar el))))
1030          (nslist (if prefix
1031                      (split-string (symbol-name prefix) ":")))
1032          (ns (cond ((eq (length nslist) 1) ; no prefix given
1033                     "")
1034                    ((eq (length nslist) 2) ; extract prefix
1035                     (cadr nslist)))))
1036     (if (and ns (not (string= ns "")))
1037         (concat ns ":")
1038       ns)))
1039
1040 (provide 'nnrss)
1041
1042 ;;; nnrss.el ends here