cgit.sxemacs.org Git - gnus/blob - lisp/nnrss.el

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