| 1 | ;;; newst-backend.el --- Retrieval backend for newsticker. |
| 2 | |
| 3 | ;; Copyright (C) 2003-2011 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Ulf Jasper <ulf.jasper@web.de> |
| 6 | ;; Filename: newst-backend.el |
| 7 | ;; URL: http://www.nongnu.org/newsticker |
| 8 | ;; Keywords: News, RSS, Atom |
| 9 | ;; Time-stamp: "13. Mai 2011, 20:47:05 (ulf)" |
| 10 | ;; Package: newsticker |
| 11 | |
| 12 | ;; ====================================================================== |
| 13 | |
| 14 | ;; This file is part of GNU Emacs. |
| 15 | |
| 16 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 17 | ;; it under the terms of the GNU General Public License as published by |
| 18 | ;; the Free Software Foundation, either version 3 of the License, or |
| 19 | ;; (at your option) any later version. |
| 20 | |
| 21 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 22 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 23 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 24 | ;; GNU General Public License for more details. |
| 25 | |
| 26 | ;; You should have received a copy of the GNU General Public License |
| 27 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 28 | |
| 29 | ;; ====================================================================== |
| 30 | |
| 31 | ;;; Commentary: |
| 32 | |
| 33 | ;; See newsticker.el |
| 34 | |
| 35 | ;; ====================================================================== |
| 36 | ;;; Code: |
| 37 | |
| 38 | (require 'derived) |
| 39 | (require 'xml) |
| 40 | |
| 41 | ;; Silence warnings |
| 42 | (defvar w3-mode-map) |
| 43 | (defvar w3m-minor-mode-map) |
| 44 | |
| 45 | |
| 46 | (defvar newsticker--retrieval-timer-list nil |
| 47 | "List of timers for news retrieval. |
| 48 | This is an alist, each element consisting of (feed-name . timer).") |
| 49 | |
| 50 | (defvar newsticker--download-logos nil |
| 51 | "If non-nil download feed logos if available.") |
| 52 | |
| 53 | (defvar newsticker--sentinel-callback nil |
| 54 | "Function called at end of `newsticker--sentinel'.") |
| 55 | |
| 56 | ;;;###autoload |
| 57 | (defun newsticker-running-p () |
| 58 | "Check whether newsticker is running. |
| 59 | Return t if newsticker is running, nil otherwise. Newsticker is |
| 60 | considered to be running if the newsticker timer list is not empty." |
| 61 | (> (length newsticker--retrieval-timer-list) 0)) |
| 62 | |
| 63 | ;; ====================================================================== |
| 64 | ;;; Customization |
| 65 | ;; ====================================================================== |
| 66 | (defgroup newsticker nil |
| 67 | "Aggregator for RSS and Atom feeds." |
| 68 | :group 'applications) |
| 69 | |
| 70 | (defconst newsticker--raw-url-list-defaults |
| 71 | '(("CNET News.com" |
| 72 | "http://export.cnet.com/export/feeds/news/rss/1,11176,,00.xml") |
| 73 | ("Debian Security Advisories" |
| 74 | "http://www.debian.org/security/dsa.en.rdf") |
| 75 | ("Debian Security Advisories - Long format" |
| 76 | "http://www.debian.org/security/dsa-long.en.rdf") |
| 77 | ("Emacs Wiki" |
| 78 | "http://www.emacswiki.org/cgi-bin/wiki.pl?action=rss" |
| 79 | nil |
| 80 | 3600) |
| 81 | ("Freshmeat.net" |
| 82 | "http://freshmeat.net/index.atom") |
| 83 | ("Kuro5hin.org" |
| 84 | "http://www.kuro5hin.org/backend.rdf") |
| 85 | ("LWN (Linux Weekly News)" |
| 86 | "http://lwn.net/headlines/rss") |
| 87 | ("NY Times: Technology" |
| 88 | "http://partners.userland.com/nytRss/technology.xml") |
| 89 | ("NY Times" |
| 90 | "http://partners.userland.com/nytRss/nytHomepage.xml") |
| 91 | ("Quote of the day" |
| 92 | "http://www.quotationspage.com/data/qotd.rss" |
| 93 | "07:00" |
| 94 | 86400) |
| 95 | ("The Register" |
| 96 | "http://www.theregister.co.uk/tonys/slashdot.rdf") |
| 97 | ("slashdot" |
| 98 | "http://slashdot.org/index.rss" |
| 99 | nil |
| 100 | 3600) ;/. will ban you if under 3600 seconds! |
| 101 | ("Wired News" |
| 102 | "http://www.wired.com/news_drop/netcenter/netcenter.rdf") |
| 103 | ("Heise News (german)" |
| 104 | "http://www.heise.de/newsticker/heise.rdf") |
| 105 | ("Tagesschau (german)" |
| 106 | "http://www.tagesschau.de/newsticker.rdf" |
| 107 | nil |
| 108 | 1800) |
| 109 | ("Telepolis (german)" |
| 110 | "http://www.heise.de/tp/news.rdf")) |
| 111 | "Default URL list in raw form. |
| 112 | This list is fed into defcustom via `newsticker--splicer'.") |
| 113 | |
| 114 | (defun newsticker--splicer (item) |
| 115 | "Convert ITEM for splicing into `newsticker-url-list-defaults'." |
| 116 | (let ((result (list 'list :tag (nth 0 item) (list 'const (nth 0 item)))) |
| 117 | (element (cdr item))) |
| 118 | (while element |
| 119 | (setq result (append result (list (list 'const (car element))))) |
| 120 | (setq element (cdr element))) |
| 121 | result)) |
| 122 | |
| 123 | (defun newsticker--set-customvar-retrieval (symbol value) |
| 124 | "Set retrieval related newsticker-variable SYMBOL value to VALUE. |
| 125 | Calls all actions which are necessary in order to make the new |
| 126 | value effective." |
| 127 | (if (or (not (boundp symbol)) |
| 128 | (equal (symbol-value symbol) value)) |
| 129 | (set symbol value) |
| 130 | ;; something must have changed |
| 131 | (let ((need-restart nil) |
| 132 | (new-or-changed-feeds nil) |
| 133 | (removed-feeds)) |
| 134 | (cond ((eq symbol 'newsticker-retrieval-interval) |
| 135 | (setq need-restart t)) |
| 136 | ((memq symbol '(newsticker-url-list-defaults newsticker-url-list)) |
| 137 | (dolist (elt value) |
| 138 | (unless (member elt (symbol-value symbol)) |
| 139 | (setq new-or-changed-feeds (cons elt new-or-changed-feeds)))) |
| 140 | (dolist (elt (symbol-value symbol)) |
| 141 | (unless (member elt value) |
| 142 | (setq removed-feeds (cons elt removed-feeds)))))) |
| 143 | (cond (need-restart |
| 144 | (set symbol value) |
| 145 | (when (newsticker-running-p) |
| 146 | (message "Restarting newsticker") |
| 147 | (newsticker-stop) |
| 148 | (newsticker-start))) |
| 149 | (t |
| 150 | (dolist (feed removed-feeds) |
| 151 | (message "Stopping feed `%s'" (car feed)) |
| 152 | (newsticker--stop-feed (car feed))) |
| 153 | (dolist (feed new-or-changed-feeds) |
| 154 | (message "Starting feed `%s'" (car feed)) |
| 155 | (newsticker--stop-feed (car feed)) |
| 156 | (newsticker--start-feed feed)) |
| 157 | (unless new-or-changed-feeds |
| 158 | (when newsticker--sentinel-callback |
| 159 | (funcall newsticker--sentinel-callback))))) |
| 160 | (set symbol value)))) |
| 161 | |
| 162 | ;; ====================================================================== |
| 163 | ;; retrieval |
| 164 | (defgroup newsticker-retrieval nil |
| 165 | "Settings for news retrieval." |
| 166 | :group 'newsticker) |
| 167 | |
| 168 | (defcustom newsticker-url-list-defaults |
| 169 | '(("Emacs Wiki" |
| 170 | "http://www.emacswiki.org/cgi-bin/wiki.pl?action=rss" |
| 171 | nil |
| 172 | 3600)) |
| 173 | "A customizable list of news feeds to select from. |
| 174 | These were mostly extracted from the Radio Community Server at |
| 175 | http://subhonker6.userland.com/rcsPublic/rssHotlist. |
| 176 | |
| 177 | You may add other entries in `newsticker-url-list'." |
| 178 | :type `(set ,@(mapcar `newsticker--splicer |
| 179 | newsticker--raw-url-list-defaults)) |
| 180 | :set 'newsticker--set-customvar-retrieval |
| 181 | :group 'newsticker-retrieval) |
| 182 | |
| 183 | (defcustom newsticker-url-list nil |
| 184 | "The news feeds which you like to watch. |
| 185 | |
| 186 | This alist will be used in addition to selection made customizing |
| 187 | `newsticker-url-list-defaults'. |
| 188 | |
| 189 | This is an alist. Each element consists of two items: a LABEL and a URL, |
| 190 | optionally followed by a START-TIME, INTERVAL specifier and WGET-ARGUMENTS. |
| 191 | |
| 192 | The LABEL gives the name of the news feed. It can be an arbitrary string. |
| 193 | |
| 194 | The URL gives the location of the news feed. It must point to a valid |
| 195 | RSS or Atom file. The file is retrieved by calling wget, or whatever you |
| 196 | specify as `newsticker-wget-name'. |
| 197 | |
| 198 | URL may also be a function which returns news data. In this case |
| 199 | `newsticker-retrieval-method' etc. are ignored for this feed. |
| 200 | |
| 201 | The START-TIME can be either a string, or nil. If it is a string it |
| 202 | specifies a fixed time at which this feed shall be retrieved for the |
| 203 | first time. (Examples: \"11:00pm\", \"23:00\".) If it is nil (or |
| 204 | unspecified), this feed will be retrieved immediately after calling |
| 205 | `newsticker-start'. |
| 206 | |
| 207 | The INTERVAL specifies the time between retrievals for this feed. If it |
| 208 | is nil (or unspecified) the default interval value as set in |
| 209 | `newsticker-retrieval-interval' is used. |
| 210 | |
| 211 | \(newsticker.el calls `run-at-time'. The newsticker-parameters START-TIME |
| 212 | and INTERVAL correspond to the `run-at-time'-parameters TIME and REPEAT.) |
| 213 | |
| 214 | WGET-ARGUMENTS specifies arguments for wget (see `newsticker-wget-name') |
| 215 | which apply for this feed only, overriding the value of |
| 216 | `newsticker-wget-arguments'." |
| 217 | :type '(repeat (list :tag "News feed" |
| 218 | (string :tag "Label") |
| 219 | (choice :tag "URI" |
| 220 | (string :tag "String") |
| 221 | (function :tag "Function")) |
| 222 | (choice :tag "Start" |
| 223 | (const :tag "Default" nil) |
| 224 | (string :tag "Fixed Time")) |
| 225 | (choice :tag "Interval" |
| 226 | (const :tag "Default" nil) |
| 227 | (const :tag "Hourly" 3600) |
| 228 | (const :tag "Daily" 86400) |
| 229 | (const :tag "Weekly" 604800) |
| 230 | (integer :tag "Interval")) |
| 231 | (choice :tag "Wget Arguments" |
| 232 | (const :tag "Default arguments" nil) |
| 233 | (repeat :tag "Special arguments" string)))) |
| 234 | :set 'newsticker--set-customvar-retrieval |
| 235 | :group 'newsticker-retrieval) |
| 236 | |
| 237 | (defcustom newsticker-retrieval-method |
| 238 | 'intern |
| 239 | "Method for retrieving news from the web, either `intern' or `extern'. |
| 240 | Default value `intern' uses Emacs' built-in asynchronous download |
| 241 | capabilities ('url-retrieve'). If set to `extern' the external |
| 242 | program wget is used, see `newsticker-wget-name'." |
| 243 | :type '(choice :tag "Method" |
| 244 | (const :tag "Intern" intern) |
| 245 | (const :tag "Extern" extern)) |
| 246 | :group 'newsticker-retrieval) |
| 247 | |
| 248 | (defcustom newsticker-wget-name |
| 249 | "wget" |
| 250 | "Name of the program which is called to retrieve news from the web. |
| 251 | The canonical choice is wget but you may take any other program which is |
| 252 | able to return the contents of a news feed file on stdout." |
| 253 | :type 'string |
| 254 | :group 'newsticker-retrieval) |
| 255 | |
| 256 | (defcustom newsticker-wget-arguments |
| 257 | '("-q" "-O" "-") |
| 258 | "Arguments which are passed to wget. |
| 259 | There is probably no reason to change the default settings, unless you |
| 260 | are living behind a firewall." |
| 261 | :type '(repeat (string :tag "Argument")) |
| 262 | :group 'newsticker-retrieval) |
| 263 | |
| 264 | (defcustom newsticker-retrieval-interval |
| 265 | 3600 |
| 266 | "Time interval for retrieving new news items (seconds). |
| 267 | If this value is not positive (i.e. less than or equal to 0) |
| 268 | items are retrieved only once! |
| 269 | Please note that some feeds, e.g. Slashdot, will ban you if you |
| 270 | make it less than 1800 seconds (30 minutes)!" |
| 271 | :type '(choice :tag "Interval" |
| 272 | (const :tag "No automatic retrieval" 0) |
| 273 | (const :tag "Hourly" 3600) |
| 274 | (const :tag "Daily" 86400) |
| 275 | (const :tag "Weekly" 604800) |
| 276 | (integer :tag "Interval")) |
| 277 | :set 'newsticker--set-customvar-retrieval |
| 278 | :group 'newsticker-retrieval) |
| 279 | |
| 280 | (defcustom newsticker-desc-comp-max |
| 281 | 100 |
| 282 | "Relevant length of headline descriptions. |
| 283 | This value gives the maximum number of characters which will be |
| 284 | taken into account when newsticker compares two headline |
| 285 | descriptions." |
| 286 | :type 'integer |
| 287 | :group 'newsticker-retrieval) |
| 288 | |
| 289 | ;; ====================================================================== |
| 290 | ;; headline processing |
| 291 | (defgroup newsticker-headline-processing nil |
| 292 | "Settings for the automatic processing of headlines." |
| 293 | :group 'newsticker) |
| 294 | |
| 295 | (defcustom newsticker-automatically-mark-items-as-old |
| 296 | t |
| 297 | "Decides whether to automatically mark items as old. |
| 298 | If t a new item is considered as new only after its first retrieval. As |
| 299 | soon as it is retrieved a second time, it becomes old. If not t all |
| 300 | items stay new until you mark them as old. This is done in the |
| 301 | *newsticker* buffer." |
| 302 | :type 'boolean |
| 303 | :group 'newsticker-headline-processing) |
| 304 | |
| 305 | (defcustom newsticker-automatically-mark-visited-items-as-old |
| 306 | t |
| 307 | "Decides whether to automatically mark visited items as old. |
| 308 | If t an item is marked as old as soon as the associated link is |
| 309 | visited, i.e. after pressing RET or mouse2 on the item's |
| 310 | headline." |
| 311 | |
| 312 | :type 'boolean |
| 313 | :group 'newsticker-headline-processing) |
| 314 | |
| 315 | (defcustom newsticker-keep-obsolete-items |
| 316 | t |
| 317 | "Decides whether to keep unread items which have been removed from feed. |
| 318 | If t a new item, which has been removed from the feed, is kept in |
| 319 | the cache until it is marked as read." |
| 320 | :type 'boolean |
| 321 | :group 'newsticker-headline-processing) |
| 322 | |
| 323 | (defcustom newsticker-obsolete-item-max-age |
| 324 | (* 60 60 24) |
| 325 | "Maximal age of obsolete items, in seconds. |
| 326 | Obsolete items which are older than this value will be silently |
| 327 | deleted at the next retrieval." |
| 328 | :type 'integer |
| 329 | :group 'newsticker-headline-processing) |
| 330 | |
| 331 | (defcustom newsticker-auto-mark-filter-list |
| 332 | nil |
| 333 | "A list of filters for automatically marking headlines. |
| 334 | |
| 335 | This is an alist of the form (FEED-NAME PATTERN-LIST). I.e. each |
| 336 | element consists of a FEED-NAME a PATTERN-LIST. Each element of |
| 337 | the pattern-list has the form (AGE TITLE-OR-DESCRIPTION REGEXP). |
| 338 | AGE must be one of the symbols 'old or 'immortal. |
| 339 | TITLE-OR-DESCRIPTION must be on of the symbols 'title, |
| 340 | 'description, or 'all. REGEXP is a regular expression, i.e. a |
| 341 | string. |
| 342 | |
| 343 | This filter is checked after a new headline has been retrieved. |
| 344 | If FEED-NAME matches the name of the corresponding news feed, the |
| 345 | pattern-list is checked: The new headline will be marked as AGE |
| 346 | if REGEXP matches the headline's TITLE-OR-DESCRIPTION. |
| 347 | |
| 348 | If, for example, `newsticker-auto-mark-filter-list' looks like |
| 349 | \((slashdot ('old 'title \"^Forget me!$\") ('immortal 'title \"Read me\") |
| 350 | \('immortal 'all \"important\")))) |
| 351 | |
| 352 | then all articles from slashdot are marked as old if they have |
| 353 | the title \"Forget me!\". All articles with a title containing |
| 354 | the string \"Read me\" are marked as immortal. All articles which |
| 355 | contain the string \"important\" in their title or their |
| 356 | description are marked as immortal." |
| 357 | :type '(repeat (list :tag "Auto mark filter" |
| 358 | (string :tag "Feed name") |
| 359 | (repeat |
| 360 | (list :tag "Filter element" |
| 361 | (choice |
| 362 | :tag "Auto-assigned age" |
| 363 | (const :tag "Old" old) |
| 364 | (const :tag "Immortal" immortal)) |
| 365 | (choice |
| 366 | :tag "Title/Description" |
| 367 | (const :tag "Title" title) |
| 368 | (const :tag "Description" description) |
| 369 | (const :tag "All" all)) |
| 370 | (string :tag "Regexp"))))) |
| 371 | :group 'newsticker-headline-processing) |
| 372 | |
| 373 | ;; ====================================================================== |
| 374 | ;; hooks |
| 375 | (defgroup newsticker-hooks nil |
| 376 | "Settings for newsticker hooks." |
| 377 | :group 'newsticker) |
| 378 | |
| 379 | (defcustom newsticker-start-hook |
| 380 | nil |
| 381 | "Hook run when starting newsticker. |
| 382 | This hook is run at the very end of `newsticker-start'." |
| 383 | :options '(newsticker-start-ticker) |
| 384 | :type 'hook |
| 385 | :group 'newsticker-hooks) |
| 386 | |
| 387 | (defcustom newsticker-stop-hook |
| 388 | nil |
| 389 | "Hook run when stopping newsticker. |
| 390 | This hook is run at the very end of `newsticker-stop'." |
| 391 | :options nil |
| 392 | :type 'hook |
| 393 | :group 'newsticker-hooks) |
| 394 | |
| 395 | (defcustom newsticker-new-item-functions |
| 396 | nil |
| 397 | "List of functions run after a new headline has been retrieved. |
| 398 | Each function is called with the following three arguments: |
| 399 | FEED the name of the corresponding news feed, |
| 400 | TITLE the title of the headline, |
| 401 | DESC the decoded description of the headline. |
| 402 | |
| 403 | See `newsticker-download-images', and |
| 404 | `newsticker-download-enclosures' for sample functions. |
| 405 | |
| 406 | Please note that these functions are called only once for a |
| 407 | headline after it has been retrieved for the first time." |
| 408 | :type 'hook |
| 409 | :options '(newsticker-download-images |
| 410 | newsticker-download-enclosures) |
| 411 | :group 'newsticker-hooks) |
| 412 | |
| 413 | ;; ====================================================================== |
| 414 | ;; miscellaneous |
| 415 | (defgroup newsticker-miscellaneous nil |
| 416 | "Miscellaneous newsticker settings." |
| 417 | :group 'newsticker) |
| 418 | |
| 419 | (defcustom newsticker-cache-filename |
| 420 | "~/.newsticker-cache" |
| 421 | "Name of the newsticker cache file." |
| 422 | :type 'string |
| 423 | :group 'newsticker-miscellaneous) |
| 424 | (make-obsolete 'newsticker-cache-filename 'newsticker-dir "23.1") |
| 425 | |
| 426 | (defcustom newsticker-dir |
| 427 | (locate-user-emacs-file "newsticker/" ".newsticker/") |
| 428 | "Directory where newsticker saves data." |
| 429 | :type 'directory |
| 430 | :group 'newsticker-miscellaneous) |
| 431 | |
| 432 | ;; debugging |
| 433 | (defcustom newsticker-debug |
| 434 | nil |
| 435 | "Enables some features needed for debugging newsticker.el. |
| 436 | |
| 437 | If set to t newsticker.el will print lots of debugging messages, and the |
| 438 | buffers *newsticker-wget-<feed>* will not be closed." |
| 439 | :type 'boolean |
| 440 | :group 'newsticker-miscellaneous) |
| 441 | |
| 442 | ;; ====================================================================== |
| 443 | ;;; Compatibility section, XEmacs, Emacs |
| 444 | ;; ====================================================================== |
| 445 | |
| 446 | ;; FIXME It is bad practice to define compat functions with such generic names. |
| 447 | |
| 448 | ;; This is not needed in Emacs >= 22.1. |
| 449 | (unless (fboundp 'time-add) |
| 450 | (require 'time-date);;FIXME |
| 451 | (defun time-add (t1 t2) |
| 452 | (with-no-warnings ; don't warn about obsolete time-to-seconds in 23.2 |
| 453 | (seconds-to-time (+ (time-to-seconds t1) (time-to-seconds t2)))))) |
| 454 | |
| 455 | (unless (fboundp 'match-string-no-properties) |
| 456 | (defalias 'match-string-no-properties 'match-string)) |
| 457 | |
| 458 | (when (featurep 'xemacs) |
| 459 | (unless (fboundp 'replace-regexp-in-string) |
| 460 | (defun replace-regexp-in-string (re rp st) |
| 461 | (save-match-data ;; apparently XEmacs needs save-match-data |
| 462 | (replace-in-string st re rp))))) |
| 463 | |
| 464 | ;; copied from subr.el |
| 465 | (unless (fboundp 'add-to-invisibility-spec) |
| 466 | (defun add-to-invisibility-spec (arg) |
| 467 | "Add elements to `buffer-invisibility-spec'. |
| 468 | See documentation for `buffer-invisibility-spec' for the kind of elements |
| 469 | that can be added." |
| 470 | (if (eq buffer-invisibility-spec t) |
| 471 | (setq buffer-invisibility-spec (list t))) |
| 472 | (setq buffer-invisibility-spec |
| 473 | (cons arg buffer-invisibility-spec)))) |
| 474 | |
| 475 | ;; copied from subr.el |
| 476 | (unless (fboundp 'remove-from-invisibility-spec) |
| 477 | (defun remove-from-invisibility-spec (arg) |
| 478 | "Remove elements from `buffer-invisibility-spec'." |
| 479 | (if (consp buffer-invisibility-spec) |
| 480 | (setq buffer-invisibility-spec |
| 481 | (delete arg buffer-invisibility-spec))))) |
| 482 | |
| 483 | ;; ====================================================================== |
| 484 | ;;; Internal variables |
| 485 | ;; ====================================================================== |
| 486 | (defvar newsticker--item-list nil |
| 487 | "List of newsticker items.") |
| 488 | (defvar newsticker--item-position 0 |
| 489 | "Actual position in list of newsticker items.") |
| 490 | (defvar newsticker--prev-message "There was no previous message yet!" |
| 491 | "Last message that the newsticker displayed.") |
| 492 | (defvar newsticker--scrollable-text "" |
| 493 | "The text which is scrolled smoothly in the echo area.") |
| 494 | (defvar newsticker--buffer-uptodate-p nil |
| 495 | "Tells whether the newsticker buffer is up to date.") |
| 496 | (defvar newsticker--latest-update-time (current-time) |
| 497 | "The time at which the latest news arrived.") |
| 498 | (defvar newsticker--process-ids nil |
| 499 | "List of PIDs of active newsticker processes.") |
| 500 | |
| 501 | (defvar newsticker--cache nil "Cached newsticker data. |
| 502 | This is a list of the form |
| 503 | |
| 504 | ((label1 |
| 505 | (title description link time age index preformatted-contents |
| 506 | preformatted-title extra-elements) |
| 507 | ...) |
| 508 | (label2 |
| 509 | (title description link time age index preformatted-contents |
| 510 | preformatted-title extra-elements) |
| 511 | ...) |
| 512 | ...) |
| 513 | |
| 514 | where LABEL is a symbol. TITLE, DESCRIPTION, and LINK are |
| 515 | strings. TIME is a time value as returned by `current-time'. |
| 516 | AGE is a symbol: 'new, 'old, 'immortal, and 'obsolete denote |
| 517 | ordinary news items, whereas 'feed denotes an item which is not a |
| 518 | headline but describes the feed itself. INDEX denotes the |
| 519 | original position of the item -- used for restoring the original |
| 520 | order. PREFORMATTED-CONTENTS and PREFORMATTED-TITLE hold the |
| 521 | formatted contents of the item's description and title. This |
| 522 | speeds things up if HTML rendering is used, which is rather |
| 523 | slow. EXTRA-ELEMENTS is an alist containing additional elements.") |
| 524 | |
| 525 | (defvar newsticker--auto-narrow-to-feed nil |
| 526 | "Automatically narrow to current news feed. |
| 527 | If non-nil only the items of the current news feed are visible.") |
| 528 | |
| 529 | (defvar newsticker--auto-narrow-to-item nil |
| 530 | "Automatically narrow to current news item. |
| 531 | If non-nil only the current headline is visible.") |
| 532 | |
| 533 | (defconst newsticker--error-headline |
| 534 | "[COULD NOT DOWNLOAD HEADLINES!]" |
| 535 | "Title of error headline which will be inserted if news retrieval fails.") |
| 536 | |
| 537 | ;; ====================================================================== |
| 538 | ;;; Shortcuts |
| 539 | ;; ====================================================================== |
| 540 | (defsubst newsticker--title (item) |
| 541 | "Return title of ITEM." |
| 542 | (nth 0 item)) |
| 543 | (defsubst newsticker--desc (item) |
| 544 | "Return description of ITEM." |
| 545 | (nth 1 item)) |
| 546 | (defsubst newsticker--link (item) |
| 547 | "Return link of ITEM." |
| 548 | (nth 2 item)) |
| 549 | (defsubst newsticker--time (item) |
| 550 | "Return time of ITEM." |
| 551 | (nth 3 item)) |
| 552 | (defsubst newsticker--age (item) |
| 553 | "Return age of ITEM." |
| 554 | (nth 4 item)) |
| 555 | (defsubst newsticker--pos (item) |
| 556 | "Return position/index of ITEM." |
| 557 | (nth 5 item)) |
| 558 | (defsubst newsticker--preformatted-contents (item) |
| 559 | "Return pre-formatted text of ITEM." |
| 560 | (nth 6 item)) |
| 561 | (defsubst newsticker--preformatted-title (item) |
| 562 | "Return pre-formatted title of ITEM." |
| 563 | (nth 7 item)) |
| 564 | (defsubst newsticker--extra (item) |
| 565 | "Return extra attributes of ITEM." |
| 566 | (nth 8 item)) |
| 567 | (defsubst newsticker--guid-to-string (guid) |
| 568 | "Return string representation of GUID." |
| 569 | (if (stringp guid) |
| 570 | guid |
| 571 | (car (xml-node-children guid)))) |
| 572 | (defsubst newsticker--guid (item) |
| 573 | "Return guid of ITEM." |
| 574 | (newsticker--guid-to-string (assoc 'guid (newsticker--extra item)))) |
| 575 | (defsubst newsticker--enclosure (item) |
| 576 | "Return enclosure element of ITEM in the form \(...FIXME...\) or nil." |
| 577 | (let ((enclosure (assoc 'enclosure (newsticker--extra item)))) |
| 578 | (if enclosure |
| 579 | (xml-node-attributes enclosure)))) |
| 580 | (defun newsticker--real-feed-name (feed) |
| 581 | "Return real name of FEED." |
| 582 | (catch 'name |
| 583 | (mapc (lambda (item) |
| 584 | (if (eq (newsticker--age item) 'feed) |
| 585 | (throw 'name (newsticker--title item)))) |
| 586 | (cdr (newsticker--cache-get-feed feed))) |
| 587 | (symbol-name feed))) |
| 588 | |
| 589 | |
| 590 | ;; ====================================================================== |
| 591 | ;;; User fun |
| 592 | ;; ====================================================================== |
| 593 | |
| 594 | (defun newsticker--start-feed (feed &optional do-not-complain-if-running) |
| 595 | "Start retrieval timer for FEED. |
| 596 | If timer is running already a warning message is printed unless |
| 597 | DO-NOT-COMPLAIN-IF-RUNNING is not nil. Add the started |
| 598 | name/timer pair to `newsticker--retrieval-timer-list'." |
| 599 | (let* ((feed-name (car feed)) |
| 600 | (start-time (nth 2 feed)) |
| 601 | (interval (or (nth 3 feed) |
| 602 | newsticker-retrieval-interval)) |
| 603 | (timer (assoc (car feed) |
| 604 | newsticker--retrieval-timer-list))) |
| 605 | (if timer |
| 606 | (or do-not-complain-if-running |
| 607 | (message "Timer for %s is running already!" |
| 608 | feed-name)) |
| 609 | (newsticker--debug-msg "Starting timer for %s: %s, %d" |
| 610 | feed-name start-time interval) |
| 611 | ;; do not repeat retrieval if interval not positive |
| 612 | (if (<= interval 0) |
| 613 | (setq interval nil)) |
| 614 | ;; Suddenly XEmacs doesn't like start-time 0 |
| 615 | (if (or (not start-time) |
| 616 | (and (numberp start-time) (= start-time 0))) |
| 617 | (setq start-time 1)) |
| 618 | ;; (message "start-time %s" start-time) |
| 619 | (setq timer (run-at-time start-time interval |
| 620 | 'newsticker-get-news feed-name)) |
| 621 | (if interval |
| 622 | (add-to-list 'newsticker--retrieval-timer-list |
| 623 | (cons feed-name timer)))))) |
| 624 | |
| 625 | ;;;###autoload |
| 626 | (defun newsticker-start (&optional do-not-complain-if-running) |
| 627 | "Start the newsticker. |
| 628 | Start the timers for display and retrieval. If the newsticker, i.e. the |
| 629 | timers, are running already a warning message is printed unless |
| 630 | DO-NOT-COMPLAIN-IF-RUNNING is not nil. |
| 631 | Run `newsticker-start-hook' if newsticker was not running already." |
| 632 | (interactive) |
| 633 | (let ((running (newsticker-running-p))) |
| 634 | ;; read old cache if it exists and newsticker is not running |
| 635 | (unless running |
| 636 | (newsticker--cache-read)) |
| 637 | ;; start retrieval timers -- one timer for each feed |
| 638 | (dolist (feed (append newsticker-url-list-defaults newsticker-url-list)) |
| 639 | (newsticker--start-feed feed)) |
| 640 | (unless running |
| 641 | (run-hooks 'newsticker-start-hook) |
| 642 | (message "Newsticker started!")))) |
| 643 | |
| 644 | (defun newsticker--stop-feed (feed-name) |
| 645 | "Stop retrieval for feed FEED-NAME. |
| 646 | Delete the stopped name/timer pair from `newsticker--retrieval-timer-list'." |
| 647 | (let ((name-and-timer (assoc feed-name newsticker--retrieval-timer-list))) |
| 648 | (when name-and-timer |
| 649 | (cancel-timer (cdr name-and-timer)) |
| 650 | (setq newsticker--retrieval-timer-list |
| 651 | (delete name-and-timer newsticker--retrieval-timer-list))))) |
| 652 | |
| 653 | (defun newsticker-stop () |
| 654 | "Stop the newsticker and the newsticker-ticker. |
| 655 | Cancel the timers for display and retrieval. Run `newsticker-stop-hook' |
| 656 | if newsticker has been running." |
| 657 | (interactive) |
| 658 | (newsticker--cache-save) |
| 659 | (when (fboundp 'newsticker-stop-ticker) ; silence compiler warnings |
| 660 | (newsticker-stop-ticker)) |
| 661 | (when (newsticker-running-p) |
| 662 | (mapc (lambda (name-and-timer) |
| 663 | (newsticker--stop-feed (car name-and-timer))) |
| 664 | newsticker--retrieval-timer-list) |
| 665 | (setq newsticker--retrieval-timer-list nil) |
| 666 | (run-hooks 'newsticker-stop-hook) |
| 667 | (message "Newsticker stopped!"))) |
| 668 | |
| 669 | (defun newsticker-get-all-news () |
| 670 | "Launch retrieval of news from all configured newsticker sites. |
| 671 | This does NOT start the retrieval timers." |
| 672 | (interactive) |
| 673 | ;; launch retrieval of news |
| 674 | (mapc (lambda (item) |
| 675 | (newsticker-get-news (car item))) |
| 676 | (append newsticker-url-list-defaults newsticker-url-list))) |
| 677 | |
| 678 | (defun newsticker-save-item (feed item) |
| 679 | "Save FEED ITEM." |
| 680 | (interactive) |
| 681 | (let ((filename (read-string "Filename: " |
| 682 | (concat feed ":_" |
| 683 | (replace-regexp-in-string |
| 684 | " " "_" (newsticker--title item)) |
| 685 | ".html")))) |
| 686 | (with-temp-buffer |
| 687 | (insert (newsticker--desc item)) |
| 688 | (write-file filename t)))) |
| 689 | |
| 690 | (defun newsticker-add-url (url name) |
| 691 | "Add given URL under given NAME to `newsticker-url-list'. |
| 692 | If URL is nil it is searched at point." |
| 693 | (interactive |
| 694 | (list |
| 695 | (read-string "URL: " |
| 696 | (save-excursion |
| 697 | (end-of-line) |
| 698 | (and |
| 699 | (re-search-backward |
| 700 | "http://" |
| 701 | (if (> (point) (+ (point-min) 100)) |
| 702 | (- (point) 100) |
| 703 | (point-min)) |
| 704 | t) |
| 705 | (re-search-forward |
| 706 | "http://[-a-zA-Z0-9&/_.]*" |
| 707 | (if (< (point) (- (point-max) 200)) |
| 708 | (+ (point) 200) |
| 709 | (point-max)) |
| 710 | t) |
| 711 | (buffer-substring-no-properties (match-beginning 0) |
| 712 | (match-end 0))))) |
| 713 | (read-string "Name: "))) |
| 714 | (add-to-list 'newsticker-url-list (list name url nil nil nil) t) |
| 715 | (customize-variable 'newsticker-url-list)) |
| 716 | |
| 717 | (defun newsticker-customize () |
| 718 | "Open the newsticker customization group." |
| 719 | (interactive) |
| 720 | (delete-other-windows) |
| 721 | (customize-group "newsticker")) |
| 722 | |
| 723 | ;; ====================================================================== |
| 724 | ;;; Local stuff |
| 725 | ;; ====================================================================== |
| 726 | (defun newsticker--get-news-by-funcall (feed-name function) |
| 727 | "Get news for the site FEED-NAME by calling FUNCTION. |
| 728 | See `newsticker-get-news'." |
| 729 | (let ((buffername (concat " *newsticker-funcall-" feed-name "*"))) |
| 730 | (with-current-buffer (get-buffer-create buffername) |
| 731 | (erase-buffer) |
| 732 | (insert (string-to-multibyte (funcall function feed-name))) |
| 733 | (newsticker--sentinel-work nil t feed-name function |
| 734 | (current-buffer))))) |
| 735 | |
| 736 | (defun newsticker--get-news-by-url (feed-name url) |
| 737 | "Get news for the site FEED-NAME from address URL using `url-retrieve'. |
| 738 | See `newsticker-get-news'." |
| 739 | (let ((coding-system-for-read 'no-conversion)) |
| 740 | (condition-case error-data |
| 741 | (url-retrieve url 'newsticker--get-news-by-url-callback |
| 742 | (list feed-name)) |
| 743 | (error (message "Error retrieving news from %s: %s" feed-name |
| 744 | error-data)))) |
| 745 | (force-mode-line-update)) |
| 746 | |
| 747 | (defun newsticker--get-news-by-url-callback (status feed-name) |
| 748 | "Callback function for `newsticker--get-news-by-url'. |
| 749 | STATUS is the return status as delivered by `url-retrieve', and |
| 750 | FEED-NAME is the name of the feed that the news were retrieved |
| 751 | from." |
| 752 | (let ((buf (get-buffer-create (concat " *newsticker-url-" feed-name "*"))) |
| 753 | (result (string-to-multibyte (buffer-string)))) |
| 754 | (set-buffer buf) |
| 755 | (erase-buffer) |
| 756 | (insert result) |
| 757 | ;; remove MIME header |
| 758 | (goto-char (point-min)) |
| 759 | (search-forward "\n\n") |
| 760 | (delete-region (point-min) (point)) |
| 761 | ;; read the rss/atom contents |
| 762 | (newsticker--sentinel-work nil t feed-name "url-retrieve" (current-buffer)) |
| 763 | (when status |
| 764 | (let ((status-type (car status)) |
| 765 | (status-details (cdr status))) |
| 766 | (cond ((eq status-type :redirect) |
| 767 | ;; don't care about redirects |
| 768 | ) |
| 769 | ((eq status-type :error) |
| 770 | (message "%s: Error while retrieving news from %s: %s: \"%s\"" |
| 771 | (format-time-string "%A, %H:%M" (current-time)) |
| 772 | feed-name |
| 773 | (car status-details) (cdr status-details)))))))) |
| 774 | |
| 775 | (defun newsticker--get-news-by-wget (feed-name url wget-arguments) |
| 776 | "Get news for the site FEED-NAME from address URL using wget. |
| 777 | WGET-ARGUMENTS is a list of arguments for wget. |
| 778 | See `newsticker-get-news'." |
| 779 | (let ((buffername (concat " *newsticker-wget-" feed-name "*"))) |
| 780 | (with-current-buffer (get-buffer-create buffername) |
| 781 | (erase-buffer) |
| 782 | ;; throw an error if there is an old wget-process around |
| 783 | (if (get-process feed-name) |
| 784 | (error "Another wget-process is running for %s" feed-name)) |
| 785 | ;; start wget |
| 786 | (let* ((args (append wget-arguments (list url))) |
| 787 | (proc (apply 'start-process feed-name buffername |
| 788 | newsticker-wget-name args))) |
| 789 | (set-process-coding-system proc 'no-conversion 'no-conversion) |
| 790 | (set-process-sentinel proc 'newsticker--sentinel) |
| 791 | (setq newsticker--process-ids (cons (process-id proc) |
| 792 | newsticker--process-ids)) |
| 793 | (force-mode-line-update))))) |
| 794 | |
| 795 | (defun newsticker-get-news (feed-name) |
| 796 | "Get news from the site FEED-NAME and load feed logo. |
| 797 | FEED-NAME must be a string which occurs as the label (i.e. the first element) |
| 798 | in an element of `newsticker-url-list' or `newsticker-url-list-defaults'." |
| 799 | (newsticker--debug-msg "%s: Getting news for %s" |
| 800 | (format-time-string "%A, %H:%M" (current-time)) |
| 801 | feed-name) |
| 802 | (let* ((item (or (assoc feed-name newsticker-url-list) |
| 803 | (assoc feed-name newsticker-url-list-defaults) |
| 804 | (error |
| 805 | "Cannot get news for %s: Check newsticker-url-list" |
| 806 | feed-name))) |
| 807 | (url (cadr item)) |
| 808 | (wget-arguments (or (car (cdr (cdr (cdr (cdr item))))) |
| 809 | newsticker-wget-arguments))) |
| 810 | (if (functionp url) |
| 811 | (newsticker--get-news-by-funcall feed-name url) |
| 812 | (if (eq newsticker-retrieval-method 'intern) |
| 813 | (newsticker--get-news-by-url feed-name url) |
| 814 | (newsticker--get-news-by-wget feed-name url wget-arguments))))) |
| 815 | |
| 816 | ;; ====================================================================== |
| 817 | ;; Parsing |
| 818 | ;; ====================================================================== |
| 819 | |
| 820 | (defun newsticker--sentinel (process event) |
| 821 | "Sentinel for extracting news titles from an RDF buffer. |
| 822 | Argument PROCESS is the process which has just changed its state. |
| 823 | Argument EVENT tells what has happened to the process." |
| 824 | (let ((p-status (process-status process)) |
| 825 | (exit-status (process-exit-status process)) |
| 826 | (name (process-name process)) |
| 827 | (command (process-command process)) |
| 828 | (buffer (process-buffer process))) |
| 829 | (newsticker--sentinel-work event |
| 830 | (and (eq p-status 'exit) |
| 831 | (= exit-status 0)) |
| 832 | name command buffer))) |
| 833 | |
| 834 | (defun newsticker--sentinel-work (event status-ok name command buffer) |
| 835 | "Actually do the sentinel work. |
| 836 | Argument EVENT tells what has happened to the retrieval process. |
| 837 | Argument STATUS-OK is the final status of the retrieval process, |
| 838 | non-nil meaning retrieval was successful. |
| 839 | Argument NAME is the name of the retrieval process. |
| 840 | Argument COMMAND is the command of the retrieval process. |
| 841 | Argument BUFFER is the buffer of the retrieval process." |
| 842 | (let ((time (current-time)) |
| 843 | (name-symbol (intern name)) |
| 844 | (something-was-added nil)) |
| 845 | ;; catch known errors (zombie processes, rubbish-xml etc. |
| 846 | ;; if an error occurs the news feed is not updated! |
| 847 | (catch 'oops |
| 848 | (unless status-ok |
| 849 | (setq newsticker--cache |
| 850 | (newsticker--cache-add |
| 851 | newsticker--cache |
| 852 | name-symbol |
| 853 | newsticker--error-headline |
| 854 | (format |
| 855 | (concat "%s: Newsticker could not retrieve news from %s.\n" |
| 856 | "Return status: `%s'\n" |
| 857 | "Command was `%s'") |
| 858 | (format-time-string "%A, %H:%M" (current-time)) |
| 859 | name event command) |
| 860 | "" |
| 861 | (current-time) |
| 862 | 'new |
| 863 | 0 nil)) |
| 864 | (message "%s: Error while retrieving news from %s" |
| 865 | (format-time-string "%A, %H:%M" (current-time)) |
| 866 | name) |
| 867 | (throw 'oops nil)) |
| 868 | (let* ((coding-system 'utf-8) |
| 869 | (node-list |
| 870 | (save-current-buffer |
| 871 | (set-buffer buffer) |
| 872 | ;; a very very dirty workaround to overcome the |
| 873 | ;; problems with the newest (20030621) xml.el: |
| 874 | ;; remove all unnecessary whitespace |
| 875 | (goto-char (point-min)) |
| 876 | (while (re-search-forward ">[ \t\r\n]+<" nil t) |
| 877 | (replace-match "><" nil t)) |
| 878 | ;; and another brutal workaround (20031105)! For some |
| 879 | ;; reason the xml parser does not like the colon in the |
| 880 | ;; doctype name "rdf:RDF" |
| 881 | (goto-char (point-min)) |
| 882 | (if (re-search-forward "<!DOCTYPE[ \t\n]+rdf:RDF" nil t) |
| 883 | (replace-match "<!DOCTYPE rdfColonRDF" nil t)) |
| 884 | ;; finally.... ~##^°!!!!! |
| 885 | (goto-char (point-min)) |
| 886 | (while (search-forward "\r\n" nil t) |
| 887 | (replace-match "\n" nil t)) |
| 888 | ;; still more brutal workarounds (20040309)! The xml |
| 889 | ;; parser does not like doctype rss |
| 890 | (goto-char (point-min)) |
| 891 | (if (re-search-forward "<!DOCTYPE[ \t\n]+rss[ \t\n]*>" nil t) |
| 892 | (replace-match "" nil t)) |
| 893 | ;; And another one (20050618)! (Fixed in GNU Emacs 22.0.50.18) |
| 894 | ;; Remove comments to avoid this xml-parsing bug: |
| 895 | ;; "XML files can have only one toplevel tag" |
| 896 | (goto-char (point-min)) |
| 897 | (while (search-forward "<!--" nil t) |
| 898 | (let ((start (match-beginning 0))) |
| 899 | (unless (search-forward "-->" nil t) |
| 900 | (error "Can't find end of comment")) |
| 901 | (delete-region start (point)))) |
| 902 | ;; And another one (20050702)! If description is HTML |
| 903 | ;; encoded and starts with a `<', wrap the whole |
| 904 | ;; description in a CDATA expression. This happened for |
| 905 | ;; http://www.thefreedictionary.com/_/WoD/rss.aspx?type=quote |
| 906 | (goto-char (point-min)) |
| 907 | (while (re-search-forward |
| 908 | "<description>\\(<img.*?\\)</description>" nil t) |
| 909 | (replace-match |
| 910 | "<description><![CDATA[ \\1 ]]></description>")) |
| 911 | ;; And another one (20051123)! XML parser does not |
| 912 | ;; like this: <yweather:location city="Frankfurt/Main" |
| 913 | ;; region="" country="GM" /> |
| 914 | ;; try to "fix" empty attributes |
| 915 | ;; This happened for |
| 916 | ;; http://xml.weather.yahoo.com/forecastrss?p=GMXX0040&u=f |
| 917 | (goto-char (point-min)) |
| 918 | (while (re-search-forward "\\(<[^>]*\\)=\"\"" nil t) |
| 919 | (replace-match "\\1=\" \"")) |
| 920 | ;; |
| 921 | (set-buffer-modified-p nil) |
| 922 | ;; check coding system |
| 923 | (goto-char (point-min)) |
| 924 | (if (re-search-forward "encoding=\"\\([^\"]+\\)\"" |
| 925 | nil t) |
| 926 | (setq coding-system (intern (downcase (match-string 1)))) |
| 927 | (setq coding-system |
| 928 | (condition-case nil |
| 929 | (check-coding-system coding-system) |
| 930 | (coding-system-error |
| 931 | (message |
| 932 | "newsticker.el: ignoring coding system %s for %s" |
| 933 | coding-system name) |
| 934 | nil)))) |
| 935 | ;; Decode if possible |
| 936 | (when coding-system |
| 937 | (decode-coding-region (point-min) (point-max) |
| 938 | coding-system)) |
| 939 | (condition-case errordata |
| 940 | ;; The xml parser might fail |
| 941 | ;; or the xml might be bugged |
| 942 | (xml-parse-region (point-min) (point-max)) |
| 943 | (error (message "Could not parse %s: %s" |
| 944 | (buffer-name) (cadr errordata)) |
| 945 | (throw 'oops nil))))) |
| 946 | (topnode (car node-list)) |
| 947 | (channelnode (car (xml-get-children topnode 'channel))) |
| 948 | (imageurl nil)) |
| 949 | ;; mark all items as obsolete |
| 950 | (newsticker--cache-replace-age newsticker--cache |
| 951 | name-symbol |
| 952 | 'new 'obsolete-new) |
| 953 | (newsticker--cache-replace-age newsticker--cache |
| 954 | name-symbol |
| 955 | 'old 'obsolete-old) |
| 956 | (newsticker--cache-replace-age newsticker--cache |
| 957 | name-symbol |
| 958 | 'feed 'obsolete-old) |
| 959 | |
| 960 | ;; check Atom/RSS version and call corresponding parser |
| 961 | (condition-case error-data |
| 962 | (if (cond |
| 963 | ;; RSS 0.91 |
| 964 | ((and (eq 'rss (xml-node-name topnode)) |
| 965 | (string= "0.91" (xml-get-attribute topnode 'version))) |
| 966 | (setq imageurl (newsticker--get-logo-url-rss-0.91 topnode)) |
| 967 | (newsticker--parse-rss-0.91 name time topnode)) |
| 968 | ;; RSS 0.92 |
| 969 | ((and (eq 'rss (xml-node-name topnode)) |
| 970 | (string= "0.92" (xml-get-attribute topnode 'version))) |
| 971 | (setq imageurl (newsticker--get-logo-url-rss-0.92 topnode)) |
| 972 | (newsticker--parse-rss-0.92 name time topnode)) |
| 973 | ;; RSS 1.0 |
| 974 | ((eq 'rdf:RDF (xml-node-name topnode)) |
| 975 | (setq imageurl (newsticker--get-logo-url-rss-1.0 topnode)) |
| 976 | (newsticker--parse-rss-1.0 name time topnode)) |
| 977 | ;; RSS 2.0 |
| 978 | ((and (eq 'rss (xml-node-name topnode)) |
| 979 | (string= "2.0" (xml-get-attribute topnode 'version))) |
| 980 | (setq imageurl (newsticker--get-logo-url-rss-2.0 topnode)) |
| 981 | (newsticker--parse-rss-2.0 name time topnode)) |
| 982 | ;; Atom 0.3 |
| 983 | ((and (eq 'feed (xml-node-name topnode)) |
| 984 | (string= "http://purl.org/atom/ns#" |
| 985 | (xml-get-attribute topnode 'xmlns))) |
| 986 | (setq imageurl (newsticker--get-logo-url-atom-0.3 topnode)) |
| 987 | (newsticker--parse-atom-0.3 name time topnode)) |
| 988 | ;; Atom 1.0 |
| 989 | ((and (eq 'feed (xml-node-name topnode)) |
| 990 | (string= "http://www.w3.org/2005/Atom" |
| 991 | (xml-get-attribute topnode 'xmlns))) |
| 992 | (setq imageurl (newsticker--get-logo-url-atom-1.0 topnode)) |
| 993 | (newsticker--parse-atom-1.0 name time topnode)) |
| 994 | ;; unknown feed type |
| 995 | (t |
| 996 | (newsticker--debug-msg "Feed type unknown: %s: %s" |
| 997 | (xml-node-name topnode) name) |
| 998 | nil)) |
| 999 | (setq something-was-added t)) |
| 1000 | (error (message "sentinelerror in %s: %s" name error-data))) |
| 1001 | |
| 1002 | ;; Remove those old items from cache which have been removed from |
| 1003 | ;; the feed |
| 1004 | (newsticker--cache-replace-age newsticker--cache |
| 1005 | name-symbol 'obsolete-old 'deleteme) |
| 1006 | (newsticker--cache-remove newsticker--cache name-symbol |
| 1007 | 'deleteme) |
| 1008 | ;; Remove those new items from cache which have been removed from |
| 1009 | ;; the feed. Or keep them as `obsolete' |
| 1010 | (if (not newsticker-keep-obsolete-items) |
| 1011 | (newsticker--cache-remove newsticker--cache |
| 1012 | name-symbol 'obsolete-new) |
| 1013 | (setq newsticker--cache |
| 1014 | (newsticker--cache-mark-expired |
| 1015 | newsticker--cache name-symbol 'obsolete 'obsolete-expired |
| 1016 | newsticker-obsolete-item-max-age)) |
| 1017 | (newsticker--cache-remove newsticker--cache |
| 1018 | name-symbol 'obsolete-expired) |
| 1019 | (newsticker--cache-replace-age newsticker--cache |
| 1020 | name-symbol 'obsolete-new |
| 1021 | 'obsolete)) |
| 1022 | (newsticker--update-process-ids) |
| 1023 | ;; setup scrollable text |
| 1024 | (when (= 0 (length newsticker--process-ids)) |
| 1025 | (when (fboundp 'newsticker--ticker-text-setup) ;silence |
| 1026 | ;compiler |
| 1027 | ;warnings |
| 1028 | (newsticker--ticker-text-setup))) |
| 1029 | (setq newsticker--latest-update-time (current-time)) |
| 1030 | (when something-was-added |
| 1031 | ;; FIXME: should we care about removed items as well? |
| 1032 | (newsticker--cache-save-feed |
| 1033 | (newsticker--cache-get-feed name-symbol)) |
| 1034 | (when (fboundp 'newsticker--buffer-set-uptodate) ;silence |
| 1035 | ;compiler |
| 1036 | ;warnings |
| 1037 | (newsticker--buffer-set-uptodate nil))) |
| 1038 | ;; kill the process buffer if wanted |
| 1039 | (unless newsticker-debug |
| 1040 | (kill-buffer buffer)) |
| 1041 | ;; launch retrieval of image |
| 1042 | (when (and imageurl newsticker--download-logos) |
| 1043 | (newsticker--image-get name imageurl))))) |
| 1044 | (when newsticker--sentinel-callback |
| 1045 | (funcall newsticker--sentinel-callback))) |
| 1046 | |
| 1047 | (defun newsticker--get-logo-url-atom-1.0 (node) |
| 1048 | "Return logo URL from atom 1.0 data in NODE." |
| 1049 | (car (xml-node-children |
| 1050 | (car (xml-get-children node 'logo))))) |
| 1051 | |
| 1052 | (defun newsticker--get-logo-url-atom-0.3 (node) |
| 1053 | "Return logo URL from atom 0.3 data in NODE." |
| 1054 | (car (xml-node-children |
| 1055 | (car (xml-get-children (car (xml-get-children node 'image)) 'url))))) |
| 1056 | |
| 1057 | (defun newsticker--get-logo-url-rss-2.0 (node) |
| 1058 | "Return logo URL from RSS 2.0 data in NODE." |
| 1059 | (car (xml-node-children |
| 1060 | (car (xml-get-children |
| 1061 | (car (xml-get-children |
| 1062 | (car (xml-get-children node 'channel)) 'image)) 'url))))) |
| 1063 | |
| 1064 | (defun newsticker--get-logo-url-rss-1.0 (node) |
| 1065 | "Return logo URL from RSS 1.0 data in NODE." |
| 1066 | (car (xml-node-children |
| 1067 | (car (xml-get-children (car (xml-get-children node 'image)) 'url))))) |
| 1068 | |
| 1069 | (defun newsticker--get-logo-url-rss-0.92 (node) |
| 1070 | "Return logo URL from RSS 0.92 data in NODE." |
| 1071 | (car (xml-node-children |
| 1072 | (car (xml-get-children (car (xml-get-children node 'image)) 'url))))) |
| 1073 | |
| 1074 | (defun newsticker--get-logo-url-rss-0.91 (node) |
| 1075 | "Return logo URL from RSS 0.91 data in NODE." |
| 1076 | (car (xml-node-children |
| 1077 | (car (xml-get-children (car (xml-get-children node 'image)) 'url))))) |
| 1078 | |
| 1079 | (defun newsticker--parse-atom-0.3 (name time topnode) |
| 1080 | "Parse Atom 0.3 data. |
| 1081 | Return value as well as arguments NAME, TIME, and TOPNODE are the |
| 1082 | same as in `newsticker--parse-atom-1.0'." |
| 1083 | (newsticker--debug-msg "Parsing Atom 0.3 feed %s" name) |
| 1084 | (let (new-feed new-item) |
| 1085 | (setq new-feed (newsticker--parse-generic-feed |
| 1086 | name time |
| 1087 | ;; title |
| 1088 | (car (xml-node-children |
| 1089 | (car (xml-get-children topnode 'title)))) |
| 1090 | ;; desc |
| 1091 | (car (xml-node-children |
| 1092 | (car (xml-get-children topnode 'content)))) |
| 1093 | ;; link |
| 1094 | (xml-get-attribute |
| 1095 | (car (xml-get-children topnode 'link)) 'href) |
| 1096 | ;; extra-elements |
| 1097 | (xml-node-children topnode))) |
| 1098 | (setq new-item (newsticker--parse-generic-items |
| 1099 | name time (xml-get-children topnode 'entry) |
| 1100 | ;; title-fn |
| 1101 | (lambda (node) |
| 1102 | (car (xml-node-children |
| 1103 | (car (xml-get-children node 'title))))) |
| 1104 | ;; desc-fn |
| 1105 | (lambda (node) |
| 1106 | (or (car (xml-node-children |
| 1107 | (car (xml-get-children node 'content)))) |
| 1108 | (car (xml-node-children |
| 1109 | (car (xml-get-children node 'summary)))))) |
| 1110 | ;; link-fn |
| 1111 | (lambda (node) |
| 1112 | (xml-get-attribute |
| 1113 | (car (xml-get-children node 'link)) 'href)) |
| 1114 | ;; time-fn |
| 1115 | (lambda (node) |
| 1116 | (newsticker--decode-rfc822-date |
| 1117 | (car (xml-node-children |
| 1118 | (car (xml-get-children node 'modified)))))) |
| 1119 | ;; guid-fn |
| 1120 | (lambda (node) |
| 1121 | (newsticker--guid-to-string |
| 1122 | (assoc 'guid (xml-node-children node)))) |
| 1123 | ;; extra-fn |
| 1124 | (lambda (node) |
| 1125 | (xml-node-children node)))) |
| 1126 | (or new-item new-feed))) |
| 1127 | |
| 1128 | (defun newsticker--parse-atom-1.0 (name time topnode) |
| 1129 | "Parse Atom 1.0 data. |
| 1130 | Argument NAME gives the name of a news feed. TIME gives the |
| 1131 | system time at which the data have been retrieved. TOPNODE |
| 1132 | contains the feed data as returned by the xml parser. |
| 1133 | |
| 1134 | For the Atom 1.0 specification see |
| 1135 | URL `http://www.atompub.org/2005/08/17/draft-ietf-atompub-format-11.html'" |
| 1136 | (newsticker--debug-msg "Parsing Atom 1.0 feed %s" name) |
| 1137 | (let (new-feed new-item) |
| 1138 | (setq new-feed (newsticker--parse-generic-feed |
| 1139 | name time |
| 1140 | ;; title |
| 1141 | (car (xml-node-children |
| 1142 | (car (xml-get-children topnode 'title)))) |
| 1143 | ;; desc |
| 1144 | (car (xml-node-children |
| 1145 | (car (xml-get-children topnode 'subtitle)))) |
| 1146 | ;; link |
| 1147 | (lambda (node) |
| 1148 | (xml-get-attribute |
| 1149 | (car (xml-get-children node 'link)) 'href)) |
| 1150 | ;; extra-elements |
| 1151 | (xml-node-children topnode))) |
| 1152 | (setq new-item (newsticker--parse-generic-items |
| 1153 | name time (xml-get-children topnode 'entry) |
| 1154 | ;; title-fn |
| 1155 | (lambda (node) |
| 1156 | (car (xml-node-children |
| 1157 | (car (xml-get-children node 'title))))) |
| 1158 | ;; desc-fn |
| 1159 | (lambda (node) |
| 1160 | (or (car (xml-node-children |
| 1161 | (car (xml-get-children node 'content)))) |
| 1162 | (car (xml-node-children |
| 1163 | (car (xml-get-children node 'summary)))))) |
| 1164 | ;; link-fn |
| 1165 | (lambda (node) |
| 1166 | (xml-get-attribute |
| 1167 | (car (xml-get-children node 'link)) 'href)) |
| 1168 | ;; time-fn |
| 1169 | (lambda (node) |
| 1170 | (newsticker--decode-iso8601-date |
| 1171 | (or (car (xml-node-children |
| 1172 | (car (xml-get-children node 'updated)))) |
| 1173 | (car (xml-node-children |
| 1174 | (car (xml-get-children node 'published))))))) |
| 1175 | ;; guid-fn |
| 1176 | (lambda (node) |
| 1177 | (car (xml-node-children |
| 1178 | (car (xml-get-children node 'id))))) |
| 1179 | ;; extra-fn |
| 1180 | (lambda (node) |
| 1181 | (xml-node-children node)))) |
| 1182 | (or new-item new-feed))) |
| 1183 | |
| 1184 | (defun newsticker--parse-rss-0.91 (name time topnode) |
| 1185 | "Parse RSS 0.91 data. |
| 1186 | Return value as well as arguments NAME, TIME, and TOPNODE are the |
| 1187 | same as in `newsticker--parse-atom-1.0'. |
| 1188 | |
| 1189 | For the RSS 0.91 specification see URL `http://backend.userland.com/rss091' |
| 1190 | or URL `http://my.netscape.com/publish/formats/rss-spec-0.91.html'." |
| 1191 | (newsticker--debug-msg "Parsing RSS 0.91 feed %s" name) |
| 1192 | (let* ((channelnode (car (xml-get-children topnode 'channel))) |
| 1193 | (pub-date (newsticker--decode-rfc822-date |
| 1194 | (car (xml-node-children |
| 1195 | (car (xml-get-children channelnode 'pubDate)))))) |
| 1196 | is-new-feed has-new-items) |
| 1197 | (setq is-new-feed (newsticker--parse-generic-feed |
| 1198 | name time |
| 1199 | ;; title |
| 1200 | (car (xml-node-children |
| 1201 | (car (xml-get-children channelnode 'title)))) |
| 1202 | ;; desc |
| 1203 | (car (xml-node-children |
| 1204 | (car (xml-get-children channelnode |
| 1205 | 'description)))) |
| 1206 | ;; link |
| 1207 | (car (xml-node-children |
| 1208 | (car (xml-get-children channelnode 'link)))) |
| 1209 | ;; extra-elements |
| 1210 | (xml-node-children channelnode))) |
| 1211 | (setq has-new-items (newsticker--parse-generic-items |
| 1212 | name time (xml-get-children channelnode 'item) |
| 1213 | ;; title-fn |
| 1214 | (lambda (node) |
| 1215 | (car (xml-node-children |
| 1216 | (car (xml-get-children node 'title))))) |
| 1217 | ;; desc-fn |
| 1218 | (lambda (node) |
| 1219 | (car (xml-node-children |
| 1220 | (car (xml-get-children node 'description))))) |
| 1221 | ;; link-fn |
| 1222 | (lambda (node) |
| 1223 | (car (xml-node-children |
| 1224 | (car (xml-get-children node 'link))))) |
| 1225 | ;; time-fn |
| 1226 | (lambda (node) |
| 1227 | (newsticker--decode-rfc822-date |
| 1228 | (car (xml-node-children |
| 1229 | (car (xml-get-children node 'pubDate)))))) |
| 1230 | ;; guid-fn |
| 1231 | (lambda (node) |
| 1232 | nil) |
| 1233 | ;; extra-fn |
| 1234 | (lambda (node) |
| 1235 | (xml-node-children node)))) |
| 1236 | (or has-new-items is-new-feed))) |
| 1237 | |
| 1238 | (defun newsticker--parse-rss-0.92 (name time topnode) |
| 1239 | "Parse RSS 0.92 data. |
| 1240 | Return value as well as arguments NAME, TIME, and TOPNODE are the |
| 1241 | same as in `newsticker--parse-atom-1.0'. |
| 1242 | |
| 1243 | For the RSS 0.92 specification see URL `http://backend.userland.com/rss092'." |
| 1244 | (newsticker--debug-msg "Parsing RSS 0.92 feed %s" name) |
| 1245 | (let* ((channelnode (car (xml-get-children topnode 'channel))) |
| 1246 | (pub-date (newsticker--decode-rfc822-date |
| 1247 | (car (xml-node-children |
| 1248 | (car (xml-get-children channelnode 'pubDate)))))) |
| 1249 | is-new-feed has-new-items) |
| 1250 | (setq is-new-feed (newsticker--parse-generic-feed |
| 1251 | name time |
| 1252 | ;; title |
| 1253 | (car (xml-node-children |
| 1254 | (car (xml-get-children channelnode 'title)))) |
| 1255 | ;; desc |
| 1256 | (car (xml-node-children |
| 1257 | (car (xml-get-children channelnode |
| 1258 | 'description)))) |
| 1259 | ;; link |
| 1260 | (car (xml-node-children |
| 1261 | (car (xml-get-children channelnode 'link)))) |
| 1262 | ;; extra-elements |
| 1263 | (xml-node-children channelnode))) |
| 1264 | (setq has-new-items (newsticker--parse-generic-items |
| 1265 | name time (xml-get-children channelnode 'item) |
| 1266 | ;; title-fn |
| 1267 | (lambda (node) |
| 1268 | (car (xml-node-children |
| 1269 | (car (xml-get-children node 'title))))) |
| 1270 | ;; desc-fn |
| 1271 | (lambda (node) |
| 1272 | (car (xml-node-children |
| 1273 | (car (xml-get-children node 'description))))) |
| 1274 | ;; link-fn |
| 1275 | (lambda (node) |
| 1276 | (car (xml-node-children |
| 1277 | (car (xml-get-children node 'link))))) |
| 1278 | ;; time-fn |
| 1279 | (lambda (node) |
| 1280 | (newsticker--decode-rfc822-date |
| 1281 | (car (xml-node-children |
| 1282 | (car (xml-get-children node 'pubDate)))))) |
| 1283 | ;; guid-fn |
| 1284 | (lambda (node) |
| 1285 | nil) |
| 1286 | ;; extra-fn |
| 1287 | (lambda (node) |
| 1288 | (xml-node-children node)))) |
| 1289 | (or has-new-items is-new-feed))) |
| 1290 | |
| 1291 | (defun newsticker--parse-rss-1.0 (name time topnode) |
| 1292 | "Parse RSS 1.0 data. |
| 1293 | Return value as well as arguments NAME, TIME, and TOPNODE are the |
| 1294 | same as in `newsticker--parse-atom-1.0'. |
| 1295 | |
| 1296 | For the RSS 1.0 specification see URL `http://web.resource.org/rss/1.0/spec'." |
| 1297 | (newsticker--debug-msg "Parsing RSS 1.0 feed %s" name) |
| 1298 | (let* ((channelnode (car (xml-get-children topnode 'channel))) |
| 1299 | is-new-feed has-new-items) |
| 1300 | (setq is-new-feed (newsticker--parse-generic-feed |
| 1301 | name time |
| 1302 | ;; title |
| 1303 | (car (xml-node-children |
| 1304 | (car (xml-get-children channelnode 'title)))) |
| 1305 | ;; desc |
| 1306 | (car (xml-node-children |
| 1307 | (car (xml-get-children channelnode |
| 1308 | 'description)))) |
| 1309 | ;; link |
| 1310 | (car (xml-node-children |
| 1311 | (car (xml-get-children channelnode 'link)))) |
| 1312 | ;; extra-elements |
| 1313 | (xml-node-children channelnode))) |
| 1314 | (setq has-new-items (newsticker--parse-generic-items |
| 1315 | name time (xml-get-children topnode 'item) |
| 1316 | ;; title-fn |
| 1317 | (lambda (node) |
| 1318 | (car (xml-node-children |
| 1319 | (car (xml-get-children node 'title))))) |
| 1320 | ;; desc-fn |
| 1321 | (lambda (node) |
| 1322 | (car (xml-node-children |
| 1323 | (car (xml-get-children node |
| 1324 | 'description))))) |
| 1325 | ;; link-fn |
| 1326 | (lambda (node) |
| 1327 | (car (xml-node-children |
| 1328 | (car (xml-get-children node 'link))))) |
| 1329 | ;; time-fn |
| 1330 | (lambda (node) |
| 1331 | (newsticker--decode-iso8601-date |
| 1332 | (car (xml-node-children |
| 1333 | (car (xml-get-children node 'dc:date)))))) |
| 1334 | ;; guid-fn |
| 1335 | (lambda (node) |
| 1336 | nil) |
| 1337 | ;; extra-fn |
| 1338 | (lambda (node) |
| 1339 | (xml-node-children node)))) |
| 1340 | (or has-new-items is-new-feed))) |
| 1341 | |
| 1342 | (defun newsticker--parse-rss-2.0 (name time topnode) |
| 1343 | "Parse RSS 2.0 data. |
| 1344 | Return value as well as arguments NAME, TIME, and TOPNODE are the |
| 1345 | same as in `newsticker--parse-atom-1.0'. |
| 1346 | |
| 1347 | For the RSS 2.0 specification see URL `http://blogs.law.harvard.edu/tech/rss'." |
| 1348 | (newsticker--debug-msg "Parsing RSS 2.0 feed %s" name) |
| 1349 | (let* ((channelnode (car (xml-get-children topnode 'channel))) |
| 1350 | is-new-feed has-new-items) |
| 1351 | (setq is-new-feed (newsticker--parse-generic-feed |
| 1352 | name time |
| 1353 | ;; title |
| 1354 | (car (xml-node-children |
| 1355 | (car (xml-get-children channelnode 'title)))) |
| 1356 | ;; desc |
| 1357 | (car (xml-node-children |
| 1358 | (car (xml-get-children channelnode |
| 1359 | 'description)))) |
| 1360 | ;; link |
| 1361 | (car (xml-node-children |
| 1362 | (car (xml-get-children channelnode 'link)))) |
| 1363 | ;; extra-elements |
| 1364 | (xml-node-children channelnode))) |
| 1365 | (setq has-new-items (newsticker--parse-generic-items |
| 1366 | name time (xml-get-children channelnode 'item) |
| 1367 | ;; title-fn |
| 1368 | (lambda (node) |
| 1369 | (car (xml-node-children |
| 1370 | (car (xml-get-children node 'title))))) |
| 1371 | ;; desc-fn |
| 1372 | (lambda (node) |
| 1373 | (or (car (xml-node-children |
| 1374 | (car (xml-get-children node |
| 1375 | 'content:encoded)))) |
| 1376 | (car (xml-node-children |
| 1377 | (car (xml-get-children node |
| 1378 | 'description)))))) |
| 1379 | ;; link-fn |
| 1380 | (lambda (node) |
| 1381 | (car (xml-node-children |
| 1382 | (car (xml-get-children node 'link))))) |
| 1383 | ;; time-fn |
| 1384 | (lambda (node) |
| 1385 | (newsticker--decode-rfc822-date |
| 1386 | (car (xml-node-children |
| 1387 | (car (xml-get-children node 'pubDate)))))) |
| 1388 | ;; guid-fn |
| 1389 | (lambda (node) |
| 1390 | (newsticker--guid-to-string |
| 1391 | (assoc 'guid (xml-node-children node)))) |
| 1392 | ;; extra-fn |
| 1393 | (lambda (node) |
| 1394 | (xml-node-children node)))) |
| 1395 | (or has-new-items is-new-feed))) |
| 1396 | |
| 1397 | (defun newsticker--parse-generic-feed (name time title desc link |
| 1398 | extra-elements) |
| 1399 | "Parse generic news feed data. |
| 1400 | Argument NAME gives the name of a news feed. TIME gives the |
| 1401 | system time at which the data have been retrieved. |
| 1402 | |
| 1403 | The arguments TITLE, DESC, LINK, and EXTRA-ELEMENTS give the feed's title, |
| 1404 | description, link, and extra elements resp." |
| 1405 | (let ((title (or title "[untitled]")) |
| 1406 | (link (or link "")) |
| 1407 | (old-item nil) |
| 1408 | (position 0) |
| 1409 | (something-was-added nil)) |
| 1410 | ;; decode numeric entities |
| 1411 | (setq title (xml-substitute-numeric-entities title)) |
| 1412 | (setq desc (xml-substitute-numeric-entities desc)) |
| 1413 | (setq link (xml-substitute-numeric-entities link)) |
| 1414 | ;; remove whitespace from title, desc, and link |
| 1415 | (setq title (newsticker--remove-whitespace title)) |
| 1416 | (setq desc (newsticker--remove-whitespace desc)) |
| 1417 | (setq link (newsticker--remove-whitespace link)) |
| 1418 | |
| 1419 | ;; handle the feed itself |
| 1420 | (unless (newsticker--cache-contains newsticker--cache |
| 1421 | (intern name) title |
| 1422 | desc link 'feed) |
| 1423 | (setq something-was-added t)) |
| 1424 | (setq newsticker--cache |
| 1425 | (newsticker--cache-add newsticker--cache (intern name) |
| 1426 | title desc link time 'feed position |
| 1427 | extra-elements time 'feed)) |
| 1428 | something-was-added)) |
| 1429 | |
| 1430 | (defun newsticker--parse-generic-items (name time itemlist |
| 1431 | title-fn desc-fn |
| 1432 | link-fn time-fn |
| 1433 | guid-fn extra-fn) |
| 1434 | "Parse generic news feed data. |
| 1435 | Argument NAME gives the name of a news feed. TIME gives the |
| 1436 | system time at which the data have been retrieved. ITEMLIST |
| 1437 | contains the news items returned by the xml parser. |
| 1438 | |
| 1439 | The arguments TITLE-FN, DESC-FN, LINK-FN, TIME-FN, GUID-FN, and |
| 1440 | EXTRA-FN give functions for extracting title, description, link, |
| 1441 | time, guid, and extra-elements resp. They are called with one |
| 1442 | argument, which is one of the items in ITEMLIST." |
| 1443 | (let (title desc link |
| 1444 | (old-item nil) |
| 1445 | (position 0) |
| 1446 | (something-was-added nil)) |
| 1447 | ;; gather all items for this feed |
| 1448 | (mapc (lambda (node) |
| 1449 | (setq position (1+ position)) |
| 1450 | (setq title (or (funcall title-fn node) "[untitled]")) |
| 1451 | (setq desc (funcall desc-fn node)) |
| 1452 | (setq link (or (funcall link-fn node) "")) |
| 1453 | (setq time (or (funcall time-fn node) time)) |
| 1454 | ;; It happened that the title or description |
| 1455 | ;; contained evil HTML code that confused the |
| 1456 | ;; xml parser. Therefore: |
| 1457 | (unless (stringp title) |
| 1458 | (setq title (prin1-to-string title))) |
| 1459 | (unless (or (stringp desc) (not desc)) |
| 1460 | (setq desc (prin1-to-string desc))) |
| 1461 | ;; ignore items with empty title AND empty desc |
| 1462 | (when (or (> (length title) 0) |
| 1463 | (> (length desc) 0)) |
| 1464 | ;; decode numeric entities |
| 1465 | (setq title (xml-substitute-numeric-entities title)) |
| 1466 | (when desc |
| 1467 | (setq desc (xml-substitute-numeric-entities desc))) |
| 1468 | (setq link (xml-substitute-numeric-entities link)) |
| 1469 | ;; remove whitespace from title, desc, and link |
| 1470 | (setq title (newsticker--remove-whitespace title)) |
| 1471 | (setq desc (newsticker--remove-whitespace desc)) |
| 1472 | (setq link (newsticker--remove-whitespace link)) |
| 1473 | ;; add data to cache |
| 1474 | ;; do we have this item already? |
| 1475 | (let* ((guid (funcall guid-fn node))) |
| 1476 | ;;(message "guid=%s" guid) |
| 1477 | (setq old-item |
| 1478 | (newsticker--cache-contains newsticker--cache |
| 1479 | (intern name) title |
| 1480 | desc link nil guid))) |
| 1481 | ;; add this item, or mark it as old, or do nothing |
| 1482 | (let ((age1 'new) |
| 1483 | (age2 'old) |
| 1484 | (item-new-p nil)) |
| 1485 | (if old-item |
| 1486 | (let ((prev-age (newsticker--age old-item))) |
| 1487 | (unless newsticker-automatically-mark-items-as-old |
| 1488 | ;; Some feeds deliver items multiply, the |
| 1489 | ;; first time we find an 'obsolete-old one the |
| 1490 | ;; cache, the following times we find an 'old |
| 1491 | ;; one |
| 1492 | (if (memq prev-age '(obsolete-old old)) |
| 1493 | (setq age2 'old) |
| 1494 | (setq age2 'new))) |
| 1495 | (if (eq prev-age 'immortal) |
| 1496 | (setq age2 'immortal)) |
| 1497 | (setq time (newsticker--time old-item))) |
| 1498 | ;; item was not there |
| 1499 | (setq item-new-p t) |
| 1500 | (setq something-was-added t)) |
| 1501 | (setq newsticker--cache |
| 1502 | (newsticker--cache-add |
| 1503 | newsticker--cache (intern name) title desc link |
| 1504 | time age1 position (funcall extra-fn node) |
| 1505 | time age2)) |
| 1506 | (when item-new-p |
| 1507 | (let ((item (newsticker--cache-contains |
| 1508 | newsticker--cache (intern name) title |
| 1509 | desc link nil))) |
| 1510 | (if newsticker-auto-mark-filter-list |
| 1511 | (newsticker--run-auto-mark-filter name item)) |
| 1512 | (run-hook-with-args |
| 1513 | 'newsticker-new-item-functions name item)))))) |
| 1514 | itemlist) |
| 1515 | something-was-added)) |
| 1516 | |
| 1517 | ;; ====================================================================== |
| 1518 | ;;; Misc |
| 1519 | ;; ====================================================================== |
| 1520 | |
| 1521 | (defun newsticker--remove-whitespace (string) |
| 1522 | "Remove leading and trailing whitespace from STRING." |
| 1523 | ;; we must have ...+ but not ...* in the regexps otherwise xemacs loops |
| 1524 | ;; endlessly... |
| 1525 | (when (and string (stringp string)) |
| 1526 | (replace-regexp-in-string |
| 1527 | "[ \t\r\n]+$" "" |
| 1528 | (replace-regexp-in-string "^[ \t\r\n]+" "" string)))) |
| 1529 | |
| 1530 | (defun newsticker--do-forget-preformatted (item) |
| 1531 | "Forget pre-formatted data for ITEM. |
| 1532 | Remove the pre-formatted from `newsticker--cache'." |
| 1533 | (if (nthcdr 7 item) |
| 1534 | (setcar (nthcdr 7 item) nil)) |
| 1535 | (if (nthcdr 6 item) |
| 1536 | (setcar (nthcdr 6 item) nil))) |
| 1537 | |
| 1538 | (defun newsticker--forget-preformatted () |
| 1539 | "Forget all cached pre-formatted data. |
| 1540 | Remove the pre-formatted from `newsticker--cache'." |
| 1541 | (mapc (lambda (feed) |
| 1542 | (mapc 'newsticker--do-forget-preformatted |
| 1543 | (cdr feed))) |
| 1544 | newsticker--cache) |
| 1545 | (when (fboundp 'newsticker--buffer-set-uptodate) |
| 1546 | (newsticker--buffer-set-uptodate nil))) |
| 1547 | |
| 1548 | (defun newsticker--debug-msg (string &rest args) |
| 1549 | "Print newsticker debug messages. |
| 1550 | This function calls `message' with arguments STRING and ARGS, if |
| 1551 | `newsticker-debug' is non-nil." |
| 1552 | (and newsticker-debug |
| 1553 | ;;(not (active-minibuffer-window)) |
| 1554 | ;;(not (current-message)) |
| 1555 | (apply 'message string args))) |
| 1556 | |
| 1557 | (defun newsticker--decode-iso8601-date (iso8601-string) |
| 1558 | "Return ISO8601-STRING in format like `decode-time'. |
| 1559 | Converts from ISO-8601 to Emacs representation. |
| 1560 | Examples: |
| 1561 | 2004-09-17T05:09:49.001+00:00 |
| 1562 | 2004-09-17T05:09:49+00:00 |
| 1563 | 2004-09-17T05:09+00:00 |
| 1564 | 2004-09-17T05:09:49 |
| 1565 | 2004-09-17T05:09 |
| 1566 | 2004-09-17 |
| 1567 | 2004-09 |
| 1568 | 2004" |
| 1569 | (if iso8601-string |
| 1570 | (when (string-match |
| 1571 | (concat |
| 1572 | "^ *\\([0-9]\\{4\\}\\)" ;year |
| 1573 | "\\(-\\([0-9]\\{2\\}\\)" ;month |
| 1574 | "\\(-\\([0-9]\\{2\\}\\)" ;day |
| 1575 | "\\(T" |
| 1576 | "\\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)" ;hour:minute |
| 1577 | "\\(:\\([0-9]\\{2\\}\\)\\(\\.[0-9]+\\)?\\)?" ;second |
| 1578 | ;timezone |
| 1579 | "\\(\\([-+Z]\\)\\(\\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)\\)?\\)?" |
| 1580 | "\\)?\\)?\\)? *$") |
| 1581 | iso8601-string) |
| 1582 | (let ((year (read (match-string 1 iso8601-string))) |
| 1583 | (month (read (or (match-string 3 iso8601-string) |
| 1584 | "1"))) |
| 1585 | (day (read (or (match-string 5 iso8601-string) |
| 1586 | "1"))) |
| 1587 | (hour (read (or (match-string 7 iso8601-string) |
| 1588 | "0"))) |
| 1589 | (minute (read (or (match-string 8 iso8601-string) |
| 1590 | "0"))) |
| 1591 | (second (read (or (match-string 10 iso8601-string) |
| 1592 | "0"))) |
| 1593 | (sign (match-string 13 iso8601-string)) |
| 1594 | (offset-hour (read (or (match-string 15 iso8601-string) |
| 1595 | "0"))) |
| 1596 | (offset-minute (read (or (match-string 16 iso8601-string) |
| 1597 | "0")))) |
| 1598 | (cond ((string= sign "+") |
| 1599 | (setq hour (- hour offset-hour)) |
| 1600 | (setq minute (- minute offset-minute))) |
| 1601 | ((string= sign "-") |
| 1602 | (setq hour (+ hour offset-hour)) |
| 1603 | (setq minute (+ minute offset-minute)))) |
| 1604 | ;; if UTC subtract current-time-zone offset |
| 1605 | ;;(setq second (+ (car (current-time-zone)) second))) |
| 1606 | |
| 1607 | (condition-case nil |
| 1608 | (encode-time second minute hour day month year t) |
| 1609 | (error |
| 1610 | (message "Cannot decode \"%s\"" iso8601-string) |
| 1611 | nil)))) |
| 1612 | nil)) |
| 1613 | |
| 1614 | (defun newsticker--decode-rfc822-date (rfc822-string) |
| 1615 | "Return RFC822-STRING in format like `decode-time'. |
| 1616 | Converts from RFC822 to Emacs representation. |
| 1617 | Examples: |
| 1618 | Sat, 07 September 2002 00:00:01 +0100 |
| 1619 | Sat, 07 September 2002 00:00:01 MET |
| 1620 | Sat, 07 Sep 2002 00:00:01 GMT |
| 1621 | 07 Sep 2002 00:00:01 GMT |
| 1622 | 07 Sep 2002" |
| 1623 | (if (and rfc822-string (stringp rfc822-string)) |
| 1624 | (when (string-match |
| 1625 | (concat |
| 1626 | "\\s-*" |
| 1627 | ;; week day |
| 1628 | "\\(\\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\)\\s-*,?\\)?\\s-*" |
| 1629 | ;; day |
| 1630 | "\\([0-9]\\{1,2\\}\\)\\s-+" |
| 1631 | ;; month |
| 1632 | "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|" |
| 1633 | "Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\).*?\\s-+" |
| 1634 | ;; year |
| 1635 | "\\([0-9]\\{2,4\\}\\)" |
| 1636 | ;; time may be missing |
| 1637 | "\\(\\s-+" |
| 1638 | ;; hour |
| 1639 | "\\([0-9]\\{2\\}\\)" |
| 1640 | ;; minute |
| 1641 | ":\\([0-9]\\{2\\}\\)" |
| 1642 | ;; second |
| 1643 | "\\(:\\([0-9]\\{2\\}\\)\\)?" |
| 1644 | ;; zone -- fixme |
| 1645 | "\\(\\s-+\\(" |
| 1646 | "UT\\|GMT\\|EST\\|EDT\\|CST\\|CDT\\|MST\\|MDT\\|PST\\|PDT" |
| 1647 | "\\|\\([-+]\\)\\([0-9]\\{2\\}\\)\\([0-9]\\{2\\}\\)" |
| 1648 | "\\)\\)?" |
| 1649 | "\\)?") |
| 1650 | rfc822-string) |
| 1651 | (let ((day (read (match-string 3 rfc822-string))) |
| 1652 | (month-name (match-string 4 rfc822-string)) |
| 1653 | (month 0) |
| 1654 | (year (read (match-string 5 rfc822-string))) |
| 1655 | (hour (read (or (match-string 7 rfc822-string) "0"))) |
| 1656 | (minute (read (or (match-string 8 rfc822-string) "0"))) |
| 1657 | (second (read (or (match-string 10 rfc822-string) "0"))) |
| 1658 | (zone (match-string 12 rfc822-string)) |
| 1659 | (sign (match-string 13 rfc822-string)) |
| 1660 | (offset-hour (read (or (match-string 14 rfc822-string) |
| 1661 | "0"))) |
| 1662 | (offset-minute (read (or (match-string 15 rfc822-string) |
| 1663 | "0"))) |
| 1664 | ;;FIXME |
| 1665 | ) |
| 1666 | (when zone |
| 1667 | (cond ((string= sign "+") |
| 1668 | (setq hour (- hour offset-hour)) |
| 1669 | (setq minute (- minute offset-minute))) |
| 1670 | ((string= sign "-") |
| 1671 | (setq hour (+ hour offset-hour)) |
| 1672 | (setq minute (+ minute offset-minute))))) |
| 1673 | (condition-case error-data |
| 1674 | (let ((i 1)) |
| 1675 | (mapc (lambda (m) |
| 1676 | (if (string= month-name m) |
| 1677 | (setq month i)) |
| 1678 | (setq i (1+ i))) |
| 1679 | '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" |
| 1680 | "Sep" "Oct" "Nov" "Dec")) |
| 1681 | (encode-time second minute hour day month year t)) |
| 1682 | (error |
| 1683 | (message "Cannot decode \"%s\": %s %s" rfc822-string |
| 1684 | (car error-data) (cdr error-data)) |
| 1685 | nil)))) |
| 1686 | nil)) |
| 1687 | |
| 1688 | (defun newsticker--lists-intersect-p (list1 list2) |
| 1689 | "Return t if LIST1 and LIST2 share elements." |
| 1690 | (let ((result nil)) |
| 1691 | (mapc (lambda (elt) |
| 1692 | (if (memq elt list2) |
| 1693 | (setq result t))) |
| 1694 | list1) |
| 1695 | result)) |
| 1696 | |
| 1697 | (defun newsticker--update-process-ids () |
| 1698 | "Update list of ids of active newsticker processes. |
| 1699 | Checks list of active processes against list of newsticker processes." |
| 1700 | (let ((active-procs (process-list)) |
| 1701 | (new-list nil)) |
| 1702 | (mapc (lambda (proc) |
| 1703 | (let ((id (process-id proc))) |
| 1704 | (if (memq id newsticker--process-ids) |
| 1705 | (setq new-list (cons id new-list))))) |
| 1706 | active-procs) |
| 1707 | (setq newsticker--process-ids new-list)) |
| 1708 | (force-mode-line-update)) |
| 1709 | |
| 1710 | ;; ====================================================================== |
| 1711 | ;;; Images |
| 1712 | ;; ====================================================================== |
| 1713 | (defun newsticker--images-dir () |
| 1714 | "Return directory where feed images are saved." |
| 1715 | (concat newsticker-dir "/images")) |
| 1716 | |
| 1717 | (defun newsticker--image-get (feed-name url) |
| 1718 | "Get image of the news site FEED-NAME from URL. |
| 1719 | If the image has been downloaded in the last 24h do nothing." |
| 1720 | (let ((image-name (concat (newsticker--images-dir) feed-name))) |
| 1721 | (if (and (file-exists-p image-name) |
| 1722 | (time-less-p (current-time) |
| 1723 | (time-add (nth 5 (file-attributes image-name)) |
| 1724 | (seconds-to-time 86400)))) |
| 1725 | (newsticker--debug-msg "%s: Getting image for %s skipped" |
| 1726 | (format-time-string "%A, %H:%M" (current-time)) |
| 1727 | feed-name) |
| 1728 | ;; download |
| 1729 | (newsticker--debug-msg "%s: Getting image for %s" |
| 1730 | (format-time-string "%A, %H:%M" (current-time)) |
| 1731 | feed-name) |
| 1732 | (let* ((buffername (concat " *newsticker-wget-image-" feed-name "*")) |
| 1733 | (item (or (assoc feed-name newsticker-url-list) |
| 1734 | (assoc feed-name newsticker-url-list-defaults) |
| 1735 | (error |
| 1736 | "Cannot get news for %s: Check newsticker-url-list" |
| 1737 | feed-name))) |
| 1738 | (wget-arguments (or (car (cdr (cdr (cdr (cdr item))))) |
| 1739 | newsticker-wget-arguments))) |
| 1740 | (with-current-buffer (get-buffer-create buffername) |
| 1741 | (erase-buffer) |
| 1742 | ;; throw an error if there is an old wget-process around |
| 1743 | (if (get-process feed-name) |
| 1744 | (error "Another wget-process is running for image %s" |
| 1745 | feed-name)) |
| 1746 | ;; start wget |
| 1747 | (let* ((args (append wget-arguments (list url))) |
| 1748 | (proc (apply 'start-process feed-name buffername |
| 1749 | newsticker-wget-name args))) |
| 1750 | (set-process-coding-system proc 'no-conversion 'no-conversion) |
| 1751 | (set-process-sentinel proc 'newsticker--image-sentinel))))))) |
| 1752 | |
| 1753 | (defun newsticker--image-sentinel (process event) |
| 1754 | "Sentinel for image-retrieving PROCESS caused by EVENT." |
| 1755 | (let* ((p-status (process-status process)) |
| 1756 | (exit-status (process-exit-status process)) |
| 1757 | (feed-name (process-name process))) |
| 1758 | ;; catch known errors (zombie processes, rubbish-xml, etc.) |
| 1759 | ;; if an error occurs the news feed is not updated! |
| 1760 | (catch 'oops |
| 1761 | (unless (and (eq p-status 'exit) |
| 1762 | (= exit-status 0)) |
| 1763 | (message "%s: Error while retrieving image from %s" |
| 1764 | (format-time-string "%A, %H:%M" (current-time)) |
| 1765 | feed-name) |
| 1766 | (throw 'oops nil)) |
| 1767 | (let (image-name) |
| 1768 | (with-current-buffer (process-buffer process) |
| 1769 | (setq image-name (concat (newsticker--images-dir) feed-name)) |
| 1770 | (set-buffer-file-coding-system 'no-conversion) |
| 1771 | ;; make sure the cache dir exists |
| 1772 | (unless (file-directory-p (newsticker--images-dir)) |
| 1773 | (make-directory (newsticker--images-dir))) |
| 1774 | ;; write and close buffer |
| 1775 | (let ((require-final-newline nil) |
| 1776 | (backup-inhibited t) |
| 1777 | (coding-system-for-write 'no-conversion)) |
| 1778 | (write-region nil nil image-name nil 'quiet)) |
| 1779 | (set-buffer-modified-p nil) |
| 1780 | (kill-buffer (current-buffer))))))) |
| 1781 | |
| 1782 | (defun newsticker--insert-image (img string) |
| 1783 | "Insert IMG with STRING at point." |
| 1784 | (insert-image img string)) |
| 1785 | |
| 1786 | ;; ====================================================================== |
| 1787 | ;;; HTML rendering |
| 1788 | ;; ====================================================================== |
| 1789 | (defun newsticker-htmlr-render (pos1 pos2) ; |
| 1790 | "Replacement for `htmlr-render'. |
| 1791 | Renders the HTML code in the region POS1 to POS2 using htmlr." |
| 1792 | (let ((str (buffer-substring-no-properties pos1 pos2))) |
| 1793 | (delete-region pos1 pos2) |
| 1794 | (insert |
| 1795 | (with-temp-buffer |
| 1796 | (insert str) |
| 1797 | (goto-char (point-min)) |
| 1798 | ;; begin original htmlr-render |
| 1799 | (when (fboundp 'htmlr-reset) (htmlr-reset)) |
| 1800 | ;; something omitted here... |
| 1801 | (when (fboundp 'htmlr-step) |
| 1802 | (while (< (point) (point-max)) |
| 1803 | (htmlr-step))) |
| 1804 | ;; end original htmlr-render |
| 1805 | (newsticker--remove-whitespace (buffer-string)))))) |
| 1806 | |
| 1807 | ;; ====================================================================== |
| 1808 | ;;; Manipulation of cached data |
| 1809 | ;; ====================================================================== |
| 1810 | (defun newsticker--cache-set-preformatted-contents (item contents) |
| 1811 | "Set preformatted contents of ITEM to CONTENTS." |
| 1812 | (if (nthcdr 6 item) |
| 1813 | (setcar (nthcdr 6 item) contents) |
| 1814 | (setcdr (nthcdr 5 item) (list contents)))) |
| 1815 | |
| 1816 | (defun newsticker--cache-set-preformatted-title (item title) |
| 1817 | "Set preformatted title of ITEM to TITLE." |
| 1818 | (if (nthcdr 7 item) |
| 1819 | (setcar (nthcdr 7 item) title) |
| 1820 | (setcdr (nthcdr 6 item) title))) |
| 1821 | |
| 1822 | (defun newsticker--cache-replace-age (data feed old-age new-age) |
| 1823 | "Mark all items in DATA in FEED which carry age OLD-AGE with NEW-AGE. |
| 1824 | If FEED is 'any it applies to all feeds. If OLD-AGE is 'any, |
| 1825 | all marks are replaced by NEW-AGE. Removes all pre-formatted contents." |
| 1826 | (mapc (lambda (a-feed) |
| 1827 | (when (or (eq feed 'any) |
| 1828 | (eq (car a-feed) feed)) |
| 1829 | (let ((items (cdr a-feed))) |
| 1830 | (mapc (lambda (item) |
| 1831 | (when (or (eq old-age 'any) |
| 1832 | (eq (newsticker--age item) old-age)) |
| 1833 | (setcar (nthcdr 4 item) new-age) |
| 1834 | (newsticker--do-forget-preformatted item))) |
| 1835 | items)))) |
| 1836 | data) |
| 1837 | data) |
| 1838 | |
| 1839 | (defun newsticker--cache-mark-expired (data feed old-age new-age time) |
| 1840 | "Mark all expired entries. |
| 1841 | This function sets the age entries in DATA in the feed FEED. If |
| 1842 | an item's age is OLD-AGE it is set to NEW-AGE if the item is |
| 1843 | older than TIME." |
| 1844 | (mapc |
| 1845 | (lambda (a-feed) |
| 1846 | (when (or (eq feed 'any) |
| 1847 | (eq (car a-feed) feed)) |
| 1848 | (let ((items (cdr a-feed))) |
| 1849 | (mapc |
| 1850 | (lambda (item) |
| 1851 | (when (eq (newsticker--age item) old-age) |
| 1852 | (let ((exp-time (time-add (newsticker--time item) |
| 1853 | (seconds-to-time time)))) |
| 1854 | (when (time-less-p exp-time (current-time)) |
| 1855 | (newsticker--debug-msg |
| 1856 | "Item `%s' from %s has expired on %s" |
| 1857 | (newsticker--title item) |
| 1858 | (format-time-string "%Y-%02m-%d, %H:%M" |
| 1859 | (newsticker--time item)) |
| 1860 | (format-time-string "%Y-%02m-%d, %H:%M" exp-time)) |
| 1861 | (setcar (nthcdr 4 item) new-age))))) |
| 1862 | items)))) |
| 1863 | data) |
| 1864 | data) |
| 1865 | |
| 1866 | (defun newsticker--cache-contains (data feed title desc link age |
| 1867 | &optional guid) |
| 1868 | "Check DATA whether FEED contains an item with the given properties. |
| 1869 | This function returns the contained item or nil if it is not |
| 1870 | contained. |
| 1871 | The properties which are checked are TITLE, DESC, LINK, AGE, and |
| 1872 | GUID. In general all properties must match in order to return a |
| 1873 | certain item, except for the following cases. |
| 1874 | |
| 1875 | If AGE equals 'feed the TITLE, DESCription and LINK do not |
| 1876 | matter. If DESC is nil it is ignored as well. If |
| 1877 | `newsticker-desc-comp-max' is non-nil, only the first |
| 1878 | `newsticker-desc-comp-max' characters of DESC are taken into |
| 1879 | account. |
| 1880 | |
| 1881 | If GUID is non-nil it is sufficient to match this value, and the |
| 1882 | other properties are ignored." |
| 1883 | ;;(newsticker--debug-msg "Looking for %s guid=%s" title guid) |
| 1884 | (condition-case nil |
| 1885 | (catch 'found |
| 1886 | (when (and desc newsticker-desc-comp-max |
| 1887 | (> (length desc) newsticker-desc-comp-max)) |
| 1888 | (setq desc (substring desc 0 newsticker-desc-comp-max))) |
| 1889 | (mapc |
| 1890 | (lambda (this-feed) |
| 1891 | (when (eq (car this-feed) feed) |
| 1892 | (mapc (lambda (anitem) |
| 1893 | (when (cond (guid |
| 1894 | ;; global unique id can match |
| 1895 | (string= guid (newsticker--guid anitem))) |
| 1896 | (t;;FIXME? |
| 1897 | (or |
| 1898 | ;; or title, desc, etc. |
| 1899 | (and |
| 1900 | ;;(or (not (eq age 'feed)) |
| 1901 | ;; (eq (newsticker--age anitem) 'feed)) |
| 1902 | (string= (newsticker--title anitem) |
| 1903 | title) |
| 1904 | (or (not link) |
| 1905 | (string= (newsticker--link anitem) |
| 1906 | link)) |
| 1907 | (or (not desc) |
| 1908 | (if (and desc newsticker-desc-comp-max |
| 1909 | (> (length (newsticker--desc |
| 1910 | anitem)) |
| 1911 | newsticker-desc-comp-max)) |
| 1912 | (string= (substring |
| 1913 | (newsticker--desc anitem) |
| 1914 | 0 |
| 1915 | newsticker-desc-comp-max) |
| 1916 | desc) |
| 1917 | (string= (newsticker--desc anitem) |
| 1918 | desc))))))) |
| 1919 | ;;(newsticker--debug-msg "Found %s guid=%s" |
| 1920 | ;; (newsticker--title anitem) |
| 1921 | ;; (newsticker--guid anitem)) |
| 1922 | (throw 'found anitem))) |
| 1923 | (cdr this-feed)))) |
| 1924 | data) |
| 1925 | ;;(newsticker--debug-msg "Found nothing") |
| 1926 | nil) |
| 1927 | (error nil))) |
| 1928 | |
| 1929 | (defun newsticker--cache-add (data feed-name-symbol title desc link time age |
| 1930 | position extra-elements |
| 1931 | &optional updated-time updated-age |
| 1932 | preformatted-contents |
| 1933 | preformatted-title) |
| 1934 | "Add another item to cache data. |
| 1935 | Add to DATA in the FEED-NAME-SYMBOL an item with TITLE, DESC, |
| 1936 | LINK, TIME, AGE, POSITION, and EXTRA-ELEMENTS. If this item is |
| 1937 | contained already, its time is set to UPDATED-TIME, its mark is |
| 1938 | set to UPDATED-AGE, and its pre-formatted contents is set to |
| 1939 | PREFORMATTED-CONTENTS and PREFORMATTED-TITLE. Returns the age |
| 1940 | which the item got." |
| 1941 | (let* ((guid (newsticker--guid-to-string (assoc 'guid extra-elements))) |
| 1942 | (item (newsticker--cache-contains data feed-name-symbol title desc link |
| 1943 | age guid))) |
| 1944 | ;;(message "guid=%s" guid) |
| 1945 | (if item |
| 1946 | ;; does exist already -- change age, update time and position |
| 1947 | (progn |
| 1948 | ;;(newsticker--debug-msg "Updating item %s %s %s %s %s -> %s %s |
| 1949 | ;; (guid %s -> %s)" |
| 1950 | ;; feed-name-symbol title link time age |
| 1951 | ;; updated-time updated-age |
| 1952 | ;; guid (newsticker--guid item)) |
| 1953 | (if (nthcdr 5 item) |
| 1954 | (setcar (nthcdr 5 item) position) |
| 1955 | (setcdr (nthcdr 4 item) (list position))) |
| 1956 | (setcar (nthcdr 4 item) updated-age) |
| 1957 | (if updated-time |
| 1958 | (setcar (nthcdr 3 item) updated-time)) |
| 1959 | ;; replace cached pre-formatted contents |
| 1960 | (newsticker--cache-set-preformatted-contents |
| 1961 | item preformatted-contents) |
| 1962 | (newsticker--cache-set-preformatted-title |
| 1963 | item preformatted-title)) |
| 1964 | ;; did not exist or age equals 'feed-name-symbol |
| 1965 | (setq item (list title desc link time age position preformatted-contents |
| 1966 | preformatted-title extra-elements)) |
| 1967 | ;;(newsticker--debug-msg "Adding item %s" item) |
| 1968 | (catch 'found |
| 1969 | (mapc (lambda (this-feed) |
| 1970 | (when (eq (car this-feed) feed-name-symbol) |
| 1971 | (setcdr this-feed (nconc (cdr this-feed) (list item))) |
| 1972 | (throw 'found this-feed))) |
| 1973 | data) |
| 1974 | ;; the feed is not contained |
| 1975 | (add-to-list 'data (list feed-name-symbol item) t)))) |
| 1976 | data) |
| 1977 | |
| 1978 | (defun newsticker--cache-remove (data feed-symbol age) |
| 1979 | "Remove all entries from DATA in the feed FEED-SYMBOL with AGE. |
| 1980 | FEED-SYMBOL may be 'any. Entries from old feeds, which are no longer in |
| 1981 | `newsticker-url-list' or `newsticker-url-list-defaults', are removed as |
| 1982 | well." |
| 1983 | (let* ((pos data) |
| 1984 | (feed (car pos)) |
| 1985 | (last-pos nil)) |
| 1986 | (while feed |
| 1987 | (if (or (assoc (symbol-name (car feed)) newsticker-url-list) |
| 1988 | (assoc (symbol-name (car feed)) newsticker-url-list-defaults)) |
| 1989 | ;; feed is still valid=active |
| 1990 | ;; (message "Keeping feed %s" (car feed)) |
| 1991 | (if (or (eq feed-symbol 'any) |
| 1992 | (eq feed-symbol (car feed))) |
| 1993 | (let* ((item-pos (cdr feed)) |
| 1994 | (item (car item-pos)) |
| 1995 | (prev-pos nil)) |
| 1996 | (while item |
| 1997 | ;;(message "%s" (car item)) |
| 1998 | (if (eq age (newsticker--age item)) |
| 1999 | ;; remove this item |
| 2000 | (progn |
| 2001 | ;;(message "Removing item %s" (car item)) |
| 2002 | (if prev-pos |
| 2003 | (setcdr prev-pos (cdr item-pos)) |
| 2004 | (setcdr feed (cdr item-pos)))) |
| 2005 | ;;(message "Keeping item %s" (car item)) |
| 2006 | (setq prev-pos item-pos)) |
| 2007 | (setq item-pos (cdr item-pos)) |
| 2008 | (setq item (car item-pos))))) |
| 2009 | ;; feed is not active anymore |
| 2010 | ;; (message "Removing feed %s" (car feed)) |
| 2011 | (if last-pos |
| 2012 | (setcdr last-pos (cdr pos)) |
| 2013 | (setq data (cdr pos)))) |
| 2014 | (setq last-pos pos) |
| 2015 | (setq pos (cdr pos)) |
| 2016 | (setq feed (car pos))))) |
| 2017 | |
| 2018 | ;; ====================================================================== |
| 2019 | ;;; Sorting |
| 2020 | ;; ====================================================================== |
| 2021 | (defun newsticker--cache-item-compare-by-time (item1 item2) |
| 2022 | "Compare two news items ITEM1 and ITEM2 by comparing their time values." |
| 2023 | (catch 'result |
| 2024 | (let ((age1 (newsticker--age item1)) |
| 2025 | (age2 (newsticker--age item2))) |
| 2026 | (if (not (eq age1 age2)) |
| 2027 | (cond ((eq age1 'obsolete) |
| 2028 | (throw 'result nil)) |
| 2029 | ((eq age2 'obsolete) |
| 2030 | (throw 'result t))))) |
| 2031 | (let* ((time1 (newsticker--time item1)) |
| 2032 | (time2 (newsticker--time item2))) |
| 2033 | (cond ((< (nth 0 time1) (nth 0 time2)) |
| 2034 | nil) |
| 2035 | ((> (nth 0 time1) (nth 0 time2)) |
| 2036 | t) |
| 2037 | ((< (nth 1 time1) (nth 1 time2)) |
| 2038 | nil) |
| 2039 | ((> (nth 1 time1) (nth 1 time2)) |
| 2040 | t) |
| 2041 | ((< (or (nth 2 time1) 0) (or (nth 2 time2) 0)) |
| 2042 | nil) |
| 2043 | ((> (or (nth 2 time1) 0) (or (nth 2 time2) 0)) |
| 2044 | t) |
| 2045 | (t |
| 2046 | nil))))) |
| 2047 | |
| 2048 | (defun newsticker--cache-item-compare-by-title (item1 item2) |
| 2049 | "Compare ITEM1 and ITEM2 by comparing their titles." |
| 2050 | (catch 'result |
| 2051 | (let ((age1 (newsticker--age item1)) |
| 2052 | (age2 (newsticker--age item2))) |
| 2053 | (if (not (eq age1 age2)) |
| 2054 | (cond ((eq age1 'obsolete) |
| 2055 | (throw 'result nil)) |
| 2056 | ((eq age2 'obsolete) |
| 2057 | (throw 'result t))))) |
| 2058 | (string< (newsticker--title item1) (newsticker--title item2)))) |
| 2059 | |
| 2060 | (defun newsticker--cache-item-compare-by-position (item1 item2) |
| 2061 | "Compare ITEM1 and ITEM2 by comparing their original positions." |
| 2062 | (catch 'result |
| 2063 | (let ((age1 (newsticker--age item1)) |
| 2064 | (age2 (newsticker--age item2))) |
| 2065 | (if (not (eq age1 age2)) |
| 2066 | (cond ((eq age1 'obsolete) |
| 2067 | (throw 'result nil)) |
| 2068 | ((eq age2 'obsolete) |
| 2069 | (throw 'result t))))) |
| 2070 | (< (or (newsticker--pos item1) 0) (or (newsticker--pos item2) 0)))) |
| 2071 | |
| 2072 | (defun newsticker--cache-save-version1 () |
| 2073 | "Update and save newsticker cache file." |
| 2074 | (interactive) |
| 2075 | (newsticker--cache-update t)) |
| 2076 | |
| 2077 | (defun newsticker--cache-update (&optional save) |
| 2078 | "Update newsticker cache file. |
| 2079 | If optional argument SAVE is not nil the cache file is saved to disk." |
| 2080 | (save-excursion |
| 2081 | (unless (file-directory-p newsticker-dir) |
| 2082 | (make-directory newsticker-dir t)) |
| 2083 | (let ((coding-system-for-write 'utf-8) |
| 2084 | (buf (find-file-noselect newsticker-cache-filename))) |
| 2085 | (when buf |
| 2086 | (set-buffer buf) |
| 2087 | (setq buffer-undo-list t) |
| 2088 | (erase-buffer) |
| 2089 | (insert ";; -*- coding: utf-8 -*-\n") |
| 2090 | (insert (prin1-to-string newsticker--cache)) |
| 2091 | (when save |
| 2092 | (save-buffer)))))) |
| 2093 | |
| 2094 | (defun newsticker--cache-get-feed (feed) |
| 2095 | "Return the cached data for the feed FEED. |
| 2096 | FEED is a symbol!" |
| 2097 | (assoc feed newsticker--cache)) |
| 2098 | |
| 2099 | (defun newsticker--cache-dir () |
| 2100 | "Return directory for saving cache data." |
| 2101 | (concat newsticker-dir "/feeds")) |
| 2102 | |
| 2103 | (defun newsticker--cache-save () |
| 2104 | "Save cache data for all feeds." |
| 2105 | (unless (file-directory-p newsticker-dir) |
| 2106 | (make-directory newsticker-dir t)) |
| 2107 | (mapc 'newsticker--cache-save-feed newsticker--cache) |
| 2108 | nil) |
| 2109 | |
| 2110 | (defun newsticker--cache-save-feed (feed) |
| 2111 | "Save cache data for FEED." |
| 2112 | (let ((dir (concat (newsticker--cache-dir) "/" (symbol-name (car feed))))) |
| 2113 | (unless (file-directory-p dir) |
| 2114 | (make-directory dir t)) |
| 2115 | (let ((coding-system-for-write 'utf-8)) |
| 2116 | (with-temp-file (concat dir "/data") |
| 2117 | (insert ";; -*- coding: utf-8 -*-\n") |
| 2118 | (insert (prin1-to-string (cdr feed))))))) |
| 2119 | |
| 2120 | (defun newsticker--cache-read-version1 () |
| 2121 | "Read version1 cache data." |
| 2122 | (let ((coding-system-for-read 'utf-8)) |
| 2123 | (when (file-exists-p newsticker-cache-filename) |
| 2124 | (with-temp-buffer |
| 2125 | (insert-file-contents newsticker-cache-filename) |
| 2126 | (goto-char (point-min)) |
| 2127 | (condition-case nil |
| 2128 | (setq newsticker--cache (read (current-buffer))) |
| 2129 | (error |
| 2130 | (message "Error while reading newsticker cache file!") |
| 2131 | (setq newsticker--cache nil))))))) |
| 2132 | |
| 2133 | (defun newsticker--cache-read () |
| 2134 | "Read cache data." |
| 2135 | (setq newsticker--cache nil) |
| 2136 | (if (file-exists-p newsticker-cache-filename) |
| 2137 | (progn |
| 2138 | (when (y-or-n-p "Old newsticker cache file exists. Read it? ") |
| 2139 | (newsticker--cache-read-version1)) |
| 2140 | (when (y-or-n-p (format "Delete old newsticker cache file? ")) |
| 2141 | (delete-file newsticker-cache-filename))) |
| 2142 | (mapc (lambda (f) |
| 2143 | (newsticker--cache-read-feed (car f))) |
| 2144 | (append newsticker-url-list-defaults newsticker-url-list)))) |
| 2145 | |
| 2146 | (defun newsticker--cache-read-feed (feed-name) |
| 2147 | "Read cache data for feed named FEED-NAME." |
| 2148 | (let ((file-name (concat (newsticker--cache-dir) "/" feed-name "/data")) |
| 2149 | (coding-system-for-read 'utf-8)) |
| 2150 | (when (file-exists-p file-name) |
| 2151 | (with-temp-buffer |
| 2152 | (insert-file-contents file-name) |
| 2153 | (goto-char (point-min)) |
| 2154 | (condition-case nil |
| 2155 | (add-to-list 'newsticker--cache (cons (intern feed-name) |
| 2156 | (read (current-buffer)))) |
| 2157 | (error |
| 2158 | (message "Error while reading newsticker cache file %s!" |
| 2159 | file-name) |
| 2160 | (setq newsticker--cache nil))))))) |
| 2161 | |
| 2162 | ;; ====================================================================== |
| 2163 | ;;; Statistics |
| 2164 | ;; ====================================================================== |
| 2165 | (defun newsticker--stat-num-items (feed &rest ages) |
| 2166 | "Return number of items in the given FEED which have one of the given AGES. |
| 2167 | If AGES is nil, the total number of items is returned." |
| 2168 | (let ((items (cdr (newsticker--cache-get-feed feed))) |
| 2169 | (num 0)) |
| 2170 | (while items |
| 2171 | (if ages |
| 2172 | (if (memq (newsticker--age (car items)) ages) |
| 2173 | (setq num (1+ num))) |
| 2174 | (if (memq (newsticker--age (car items)) '(new old immortal obsolete)) |
| 2175 | (setq num (1+ num)))) |
| 2176 | (setq items (cdr items))) |
| 2177 | num)) |
| 2178 | |
| 2179 | (defun newsticker--stat-num-items-total (&optional age) |
| 2180 | "Return total number of items in all feeds which have the given AGE. |
| 2181 | If AGE is nil, the total number of items is returned." |
| 2182 | (apply '+ |
| 2183 | (mapcar (lambda (feed) |
| 2184 | (if age |
| 2185 | (newsticker--stat-num-items (intern (car feed)) age) |
| 2186 | (newsticker--stat-num-items (intern (car feed))))) |
| 2187 | (append newsticker-url-list-defaults newsticker-url-list)))) |
| 2188 | |
| 2189 | ;; ====================================================================== |
| 2190 | ;;; OPML |
| 2191 | ;; ====================================================================== |
| 2192 | (defun newsticker-opml-export () |
| 2193 | "OPML subscription export. |
| 2194 | Export subscriptions to a buffer in OPML Format." |
| 2195 | (interactive) |
| 2196 | (with-current-buffer (get-buffer-create "*OPML Export*") |
| 2197 | (set-buffer-file-coding-system 'utf-8) |
| 2198 | (insert (concat |
| 2199 | "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" |
| 2200 | "<!-- OPML generated by Emacs newsticker.el -->\n" |
| 2201 | "<opml version=\"1.0\">\n" |
| 2202 | " <head>\n" |
| 2203 | " <title>mySubscriptions</title>\n" |
| 2204 | " <dateCreated>" (format-time-string "%a, %d %b %Y %T %z") |
| 2205 | "</dateCreated>\n" |
| 2206 | " <ownerEmail>" user-mail-address "</ownerEmail>\n" |
| 2207 | " <ownerName>" (user-full-name) "</ownerName>\n" |
| 2208 | " </head>\n" |
| 2209 | " <body>\n")) |
| 2210 | (mapc (lambda (sub) |
| 2211 | (insert " <outline text=\"") |
| 2212 | (insert (newsticker--title sub)) |
| 2213 | (insert "\" xmlUrl=\"") |
| 2214 | (insert (cadr sub)) |
| 2215 | (insert "\"/>\n")) |
| 2216 | (append newsticker-url-list newsticker-url-list-defaults)) |
| 2217 | (insert " </body>\n</opml>\n")) |
| 2218 | (pop-to-buffer "*OPML Export*") |
| 2219 | (when (fboundp 'sgml-mode) |
| 2220 | (sgml-mode))) |
| 2221 | |
| 2222 | (defun newsticker--opml-import-outlines (outlines) |
| 2223 | "Recursively import OUTLINES from OPML data. |
| 2224 | Note that nested outlines are currently flattened -- i.e. grouping is |
| 2225 | removed." |
| 2226 | (mapc (lambda (outline) |
| 2227 | (let ((name (xml-get-attribute outline 'text)) |
| 2228 | (url (xml-get-attribute outline 'xmlUrl)) |
| 2229 | (children (xml-get-children outline 'outline))) |
| 2230 | (unless (string= "" url) |
| 2231 | (add-to-list 'newsticker-url-list |
| 2232 | (list name url nil nil nil) t)) |
| 2233 | (if children |
| 2234 | (newsticker--opml-import-outlines children)))) |
| 2235 | outlines)) |
| 2236 | |
| 2237 | (defun newsticker-opml-import (filename) |
| 2238 | "Import OPML data from FILENAME." |
| 2239 | (interactive "fOPML file: ") |
| 2240 | (set-buffer (find-file-noselect filename)) |
| 2241 | (goto-char (point-min)) |
| 2242 | (let* ((node-list (xml-parse-region (point-min) (point-max))) |
| 2243 | (body (car (xml-get-children (car node-list) 'body))) |
| 2244 | (outlines (xml-get-children body 'outline))) |
| 2245 | (newsticker--opml-import-outlines outlines)) |
| 2246 | (customize-variable 'newsticker-url-list)) |
| 2247 | |
| 2248 | ;; ====================================================================== |
| 2249 | ;;; Auto marking |
| 2250 | ;; ====================================================================== |
| 2251 | (defun newsticker--run-auto-mark-filter (feed item) |
| 2252 | "Automatically mark an item as old or immortal. |
| 2253 | This function checks the variable `newsticker-auto-mark-filter-list' |
| 2254 | for an entry that matches FEED and ITEM." |
| 2255 | (let ((case-fold-search t)) |
| 2256 | (mapc (lambda (filter) |
| 2257 | (let ((filter-feed (car filter)) |
| 2258 | (pattern-list (cadr filter))) |
| 2259 | (when (string-match filter-feed feed) |
| 2260 | (newsticker--do-run-auto-mark-filter item pattern-list)))) |
| 2261 | newsticker-auto-mark-filter-list))) |
| 2262 | |
| 2263 | (defun newsticker--do-run-auto-mark-filter (item list) |
| 2264 | "Actually compare ITEM against the pattern-LIST. |
| 2265 | LIST must be an element of `newsticker-auto-mark-filter-list'." |
| 2266 | (mapc (lambda (pattern) |
| 2267 | (let ((place (nth 1 pattern)) |
| 2268 | (regexp (nth 2 pattern)) |
| 2269 | (title (newsticker--title item)) |
| 2270 | (desc (newsticker--desc item))) |
| 2271 | (when (or (eq place 'title) (eq place 'all)) |
| 2272 | (when (and title (string-match regexp title)) |
| 2273 | (newsticker--process-auto-mark-filter-match item pattern))) |
| 2274 | (when (or (eq place 'description) (eq place 'all)) |
| 2275 | (when (and desc (string-match regexp desc)) |
| 2276 | (newsticker--process-auto-mark-filter-match item pattern))))) |
| 2277 | list)) |
| 2278 | |
| 2279 | (defun newsticker--process-auto-mark-filter-match (item pattern) |
| 2280 | "Process ITEM that matches an auto-mark-filter PATTERN." |
| 2281 | (let ((age (nth 0 pattern)) |
| 2282 | (place (nth 1 pattern)) |
| 2283 | (regexp (nth 2 pattern))) |
| 2284 | (newsticker--debug-msg "Auto-mark-filter %s matches `%s'" |
| 2285 | pattern (newsticker--title item)) |
| 2286 | (setcar (nthcdr 4 item) age) |
| 2287 | (nconc (newsticker--extra item) |
| 2288 | (list (list 'newsticker-auto-mark nil |
| 2289 | (format "age=%s, title/desc=%s, regexp=%s" |
| 2290 | age place regexp)))))) |
| 2291 | |
| 2292 | ;; ====================================================================== |
| 2293 | ;;; Hook samples |
| 2294 | ;; ====================================================================== |
| 2295 | (defun newsticker-new-item-functions-sample (feed item) |
| 2296 | "Demonstrate the use of the `newsticker-new-item-functions' hook. |
| 2297 | This function just prints out the values of the FEED and title of the ITEM." |
| 2298 | (message (concat "newsticker-new-item-functions-sample: feed=`%s', " |
| 2299 | "title=`%s'") |
| 2300 | feed (newsticker--title item))) |
| 2301 | |
| 2302 | (defun newsticker-download-images (feed item) |
| 2303 | "Download the first image. |
| 2304 | If FEED equals \"imagefeed\" download the first image URL found |
| 2305 | in the description=contents of ITEM to the directory |
| 2306 | \"~/tmp/newsticker/FEED/TITLE\" where TITLE is the title of the item." |
| 2307 | (when (string= feed "imagefeed") |
| 2308 | (let ((title (newsticker--title item)) |
| 2309 | (desc (newsticker--desc item))) |
| 2310 | (when (string-match "<img src=\"\\(http://[^ \"]+\\)\"" desc) |
| 2311 | (let ((url (substring desc (match-beginning 1) (match-end 1))) |
| 2312 | (temp-dir (concat "~/tmp/newsticker/" feed "/" title)) |
| 2313 | (org-dir default-directory)) |
| 2314 | (unless (file-directory-p temp-dir) |
| 2315 | (make-directory temp-dir t)) |
| 2316 | (cd temp-dir) |
| 2317 | (message "Getting image %s" url) |
| 2318 | (apply 'start-process "wget-image" |
| 2319 | " *newsticker-wget-download-images*" |
| 2320 | newsticker-wget-name |
| 2321 | (list url)) |
| 2322 | (cd org-dir)))))) |
| 2323 | |
| 2324 | (defun newsticker-download-enclosures (feed item) |
| 2325 | "In all FEEDs download the enclosed object of the news ITEM. |
| 2326 | The object is saved to the directory \"~/tmp/newsticker/FEED/TITLE\", which |
| 2327 | is created if it does not exist. TITLE is the title of the news |
| 2328 | item. Argument FEED is ignored. |
| 2329 | This function is suited for adding it to `newsticker-new-item-functions'." |
| 2330 | (let ((title (newsticker--title item)) |
| 2331 | (enclosure (newsticker--enclosure item))) |
| 2332 | (when enclosure |
| 2333 | (let ((url (cdr (assoc 'url enclosure))) |
| 2334 | (temp-dir (concat "~/tmp/newsticker/" feed "/" title)) |
| 2335 | (org-dir default-directory)) |
| 2336 | (unless (file-directory-p temp-dir) |
| 2337 | (make-directory temp-dir t)) |
| 2338 | (cd temp-dir) |
| 2339 | (message "Getting enclosure %s" url) |
| 2340 | (apply 'start-process "wget-enclosure" |
| 2341 | " *newsticker-wget-download-enclosures*" |
| 2342 | newsticker-wget-name |
| 2343 | (list url)) |
| 2344 | (cd org-dir))))) |
| 2345 | |
| 2346 | ;; ====================================================================== |
| 2347 | ;;; Retrieve samples |
| 2348 | ;; ====================================================================== |
| 2349 | (defun newsticker-retrieve-random-message (feed-name) |
| 2350 | "Return an artificial RSS string under the name FEED-NAME." |
| 2351 | (concat "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?><rss version=\"0.91\">" |
| 2352 | "<channel>" |
| 2353 | "<title>newsticker-retrieve-random-message</title>" |
| 2354 | "<description>Sample retrieval function</description>" |
| 2355 | "<pubDate>FIXME Sat, 07 Sep 2005 00:00:01 GMT</pubDate>" |
| 2356 | "<item><title>" (format "Your lucky number is %d" (random 10000)) |
| 2357 | "</title><description>" (format "Or maybe it is %d" (random 10000)) |
| 2358 | "</description></item></channel></rss>")) |
| 2359 | |
| 2360 | (provide 'newst-backend) |
| 2361 | |
| 2362 | ;;; newst-backend.el ends here |