lisp/gnus/nnrss.el

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