Mercurial > emacs
changeset 95675:c9fb857e1ebe
Initial check-in.
| author | Ulf Jasper <ulf.jasper@web.de> |
|---|---|
| date | Sun, 08 Jun 2008 15:35:18 +0000 |
| parents | 0c2f83acfffe |
| children | 57b32cda96c9 |
| files | lisp/net/newsticker-backend.el |
| diffstat | 1 files changed, 2313 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/newsticker-backend.el Sun Jun 08 15:35:18 2008 +0000 @@ -0,0 +1,2313 @@ +;;; newsticker-backend.el --- Retrieval backend for newsticker. + +;; Copyright (C) 2008 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; Author: Ulf Jasper <ulf.jasper@web.de> +;; Filename: newsticker-backend.el +;; URL: http://www.nongnu.org/newsticker +;; Keywords: News, RSS, Atom +;; Time-stamp: "8. Juni 2008, 17:18:04 (ulf)" +;; CVS-Version: $Id: newsticker-backend.el,v 1.16 2008/05/09 17:42:22 u11 Exp $ + +;; ====================================================================== + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;; ====================================================================== + +;;; Commentary: + +;; See newsticker.el + +;; ====================================================================== +;;; Code: + +(require 'derived) +(require 'xml) + +;; Silence warnings +(defvar tool-bar-map) +(defvar w3-mode-map) +(defvar w3m-minor-mode-map) + + +(defvar newsticker--retrieval-timer-list nil + "List of timers for news retrieval. +This is an alist, each element consisting of (feed-name . timer).") + +(defvar newsticker--download-logos nil + "If non-nil download feed logos if available.") + +(defvar newsticker--sentinel-callback nil + "Function called at end of `newsticker--sentinel'.") + +;;;###autoload +(defun newsticker-running-p () + "Check whether newsticker is running. +Return t if newsticker is running, nil otherwise. Newsticker is +considered to be running if the newsticker timer list is not empty." + (> (length newsticker--retrieval-timer-list) 0)) + +;; ====================================================================== +;;; Customization +;; ====================================================================== +(defgroup newsticker nil + "Aggregator for RSS and Atom feeds." + :group 'applications) + +(defconst newsticker--raw-url-list-defaults + '(("CNET News.com" + "http://export.cnet.com/export/feeds/news/rss/1,11176,,00.xml") + ("Debian Security Advisories" + "http://www.debian.org/security/dsa.en.rdf") + ("Debian Security Advisories - Long format" + "http://www.debian.org/security/dsa-long.en.rdf") + ("Emacs Wiki" + "http://www.emacswiki.org/cgi-bin/wiki.pl?action=rss" + nil + 3600) + ("Freshmeat.net" + "http://freshmeat.net/backend/fm.rdf") + ("Kuro5hin.org" + "http://www.kuro5hin.org/backend.rdf") + ("LWN (Linux Weekly News)" + "http://lwn.net/headlines/rss") + ("NewsForge" + "http://newsforge.com/index.rss") + ("NY Times: Technology" + "http://partners.userland.com/nytRss/technology.xml") + ("NY Times" + "http://partners.userland.com/nytRss/nytHomepage.xml") + ("Quote of the day" + "http://www.quotationspage.com/data/qotd.rss" + "07:00" + 86400) + ("The Register" + "http://www.theregister.co.uk/tonys/slashdot.rdf") + ("slashdot" + "http://slashdot.org/index.rss" + nil + 3600) ;/. will ban you if under 3600 seconds! + ("Wired News" + "http://www.wired.com/news_drop/netcenter/netcenter.rdf") + ("Heise News (german)" + "http://www.heise.de/newsticker/heise.rdf") + ("Tagesschau (german)" + "http://www.tagesschau.de/newsticker.rdf" + nil + 1800) + ("Telepolis (german)" + "http://www.heise.de/tp/news.rdf")) + "Default URL list in raw form. +This list is fed into defcustom via `newsticker--splicer'.") + +(defun newsticker--splicer (item) + "Convert ITEM for splicing into `newsticker-url-list-defaults'." + (let ((result (list 'list :tag (nth 0 item) (list 'const (nth 0 item)))) + (element (cdr item))) + (while element + (setq result (append result (list (list 'const (car element))))) + (setq element (cdr element))) + result)) + +(defun newsticker--set-customvar-retrieval (symbol value) + "Set retrieval related newsticker-variable SYMBOL value to VALUE. +Calls all actions which are necessary in order to make the new +value effective." + (if (or (not (boundp symbol)) + (equal (symbol-value symbol) value)) + (set symbol value) + ;; something must have changed + (let ((need-restart nil) + (new-or-changed-feeds nil) + (removed-feeds)) + (cond ((eq symbol 'newsticker-retrieval-interval) + (setq need-restart t)) + ((memq symbol '(newsticker-url-list-defaults newsticker-url-list)) + (dolist (elt value) + (unless (member elt (symbol-value symbol)) + (setq new-or-changed-feeds (cons elt new-or-changed-feeds)))) + (dolist (elt (symbol-value symbol)) + (unless (member elt value) + (setq removed-feeds (cons elt removed-feeds)))))) + (cond (need-restart + (set symbol value) + (when (newsticker-running-p) + (message "Restarting newsticker") + (newsticker-stop) + (newsticker-start))) + (t + (dolist (feed removed-feeds) + (message "Stopping feed `%s'" (car feed)) + (newsticker--stop-feed (car feed))) + (dolist (feed new-or-changed-feeds) + (message "Starting feed `%s'" (car feed)) + (newsticker--stop-feed (car feed)) + (newsticker--start-feed feed)) + (unless new-or-changed-feeds + (when newsticker--sentinel-callback + (funcall newsticker--sentinel-callback))))) + (set symbol value)))) + +;; ====================================================================== +;; retrieval +(defgroup newsticker-retrieval nil + "Settings for news retrieval." + :group 'newsticker) + +(defcustom newsticker-url-list-defaults + '(("Emacs Wiki" + "http://www.emacswiki.org/cgi-bin/wiki.pl?action=rss" + nil + 3600)) + "A customizable list of news feeds to select from. +These were mostly extracted from the Radio Community Server at +http://subhonker6.userland.com/rcsPublic/rssHotlist. + +You may add other entries in `newsticker-url-list'." + :type `(set ,@(mapcar `newsticker--splicer + newsticker--raw-url-list-defaults)) + :set 'newsticker--set-customvar-retrieval + :group 'newsticker-retrieval) + +(defcustom newsticker-url-list nil + "The news feeds which you like to watch. + +This alist will be used in addition to selection made customizing +`newsticker-url-list-defaults'. + +This is an alist. Each element consists of two items: a LABEL and a URL, +optionally followed by a START-TIME, INTERVAL specifier and WGET-ARGUMENTS. + +The LABEL gives the name of the news feed. It can be an arbitrary string. + +The URL gives the location of the news feed. It must point to a valid +RSS or Atom file. The file is retrieved by calling wget, or whatever you +specify as `newsticker-wget-name'. + +URL may also be a function which returns news data. In this case +`newsticker-retrieval-method' etc. are ignored for this feed. + +The START-TIME can be either a string, or nil. If it is a string it +specifies a fixed time at which this feed shall be retrieved for the +first time. (Examples: \"11:00pm\", \"23:00\".) If it is nil (or +unspecified), this feed will be retrieved immediately after calling +`newsticker-start'. + +The INTERVAL specifies the time between retrievals for this feed. If it +is nil (or unspecified) the default interval value as set in +`newsticker-retrieval-interval' is used. + +\(newsticker.el calls `run-at-time'. The newsticker-parameters START-TIME +and INTERVAL correspond to the `run-at-time'-parameters TIME and REPEAT.) + +WGET-ARGUMENTS specifies arguments for wget (see `newsticker-wget-name') +which apply for this feed only, overriding the value of +`newsticker-wget-arguments'." + :type '(repeat (list :tag "News feed" + (string :tag "Label") + (choice :tag "URI" + (string :tag "String") + (function :tag "Function")) + (choice :tag "Start" + (const :tag "Default" nil) + (string :tag "Fixed Time")) + (choice :tag "Interval" + (const :tag "Default" nil) + (const :tag "Hourly" 3600) + (const :tag "Daily" 86400) + (const :tag "Weekly" 604800) + (integer :tag "Interval")) + (choice :tag "Wget Arguments" + (const :tag "Default arguments" nil) + (repeat :tag "Special arguments" string)))) + :set 'newsticker--set-customvar-retrieval + :group 'newsticker-retrieval) + +(defcustom newsticker-retrieval-method + 'intern + "Method for retrieving news from the web, either `intern' or `extern'. +Default value `intern' uses Emacs' built-in asynchronous download +capabilities ('url-retrieve'). If set to `extern' the external +program wget is used, see `newsticker-wget-name'." + :type '(choice :tag "Method" + (const :tag "Intern" intern) + (const :tag "Extern" extern)) + :group 'newsticker-retrieval) + +(defcustom newsticker-wget-name + "wget" + "Name of the program which is called to retrieve news from the web. +The canonical choice is wget but you may take any other program which is +able to return the contents of a news feed file on stdout." + :type 'string + :group 'newsticker-retrieval) + +(defcustom newsticker-wget-arguments + '("-q" "-O" "-") + "Arguments which are passed to wget. +There is probably no reason to change the default settings, unless you +are living behind a firewall." + :type '(repeat (string :tag "Argument")) + :group 'newsticker-retrieval) + +(defcustom newsticker-retrieval-interval + 3600 + "Time interval for retrieving new news items (seconds). +If this value is not positive (i.e. less than or equal to 0) +items are retrieved only once! +Please note that some feeds, e.g. Slashdot, will ban you if you +make it less than 1800 seconds (30 minutes)!" + :type '(choice :tag "Interval" + (const :tag "No automatic retrieval" 0) + (const :tag "Hourly" 3600) + (const :tag "Daily" 86400) + (const :tag "Weekly" 604800) + (integer :tag "Interval")) + :set 'newsticker--set-customvar-retrieval + :group 'newsticker-retrieval) + +(defcustom newsticker-desc-comp-max + 100 + "Relevant length of headline descriptions. +This value gives the maximum number of characters which will be +taken into account when newsticker compares two headline +descriptions." + :type 'integer + :group 'newsticker-retrieval) + +;; ====================================================================== +;; headline processing +(defgroup newsticker-headline-processing nil + "Settings for the automatic processing of headlines." + :group 'newsticker) + +(defcustom newsticker-automatically-mark-items-as-old + t + "Decides whether to automatically mark items as old. +If t a new item is considered as new only after its first retrieval. As +soon as it is retrieved a second time, it becomes old. If not t all +items stay new until you mark them as old. This is done in the +*newsticker* buffer." + :type 'boolean + :group 'newsticker-headline-processing) + +(defcustom newsticker-automatically-mark-visited-items-as-old + t + "Decides whether to automatically mark visited items as old. +If t an item is marked as old as soon as the associated link is +visited, i.e. after pressing RET or mouse2 on the item's +headline." + + :type 'boolean + :group 'newsticker-headline-processing) + +(defcustom newsticker-keep-obsolete-items + t + "Decides whether to keep unread items which have been removed from feed. +If t a new item, which has been removed from the feed, is kept in +the cache until it is marked as read." + :type 'boolean + :group 'newsticker-headline-processing) + +(defcustom newsticker-obsolete-item-max-age + (* 60 60 24) + "Maximal age of obsolete items, in seconds. +Obsolete items which are older than this value will be silently +deleted at the next retrieval." + :type 'integer + :group 'newsticker-headline-processing) + +(defcustom newsticker-auto-mark-filter-list + nil + "A list of filters for automatically marking headlines. + +This is an alist of the form (FEED-NAME PATTERN-LIST). I.e. each +element consists of a FEED-NAME a PATTERN-LIST. Each element of +the pattern-list has the form (AGE TITLE-OR-DESCRIPTION REGEXP). +AGE must be one of the symbols 'old or 'immortal. +TITLE-OR-DESCRIPTION must be on of the symbols 'title, +'description, or 'all. REGEXP is a regular expression, i.e. a +string. + +This filter is checked after a new headline has been retrieved. +If FEED-NAME matches the name of the corresponding news feed, the +pattern-list is checked: The new headline will be marked as AGE +if REGEXP matches the headline's TITLE-OR-DESCRIPTION. + +If, for example, `newsticker-auto-mark-filter-list' looks like + \((slashdot ('old 'title \"^Forget me!$\") ('immortal 'title \"Read me\") + \('immortal 'all \"important\")))) + +then all articles from slashdot are marked as old if they have +the title \"Forget me!\". All articles with a title containing +the string \"Read me\" are marked as immortal. All articles which +contain the string \"important\" in their title or their +description are marked as immortal." + :type '(repeat (list :tag "Auto mark filter" + (string :tag "Feed name") + (repeat + (list :tag "Filter element" + (choice + :tag "Auto-assigned age" + (const :tag "Old" old) + (const :tag "Immortal" immortal)) + (choice + :tag "Title/Description" + (const :tag "Title" title) + (const :tag "Description" description) + (const :tag "All" all)) + (string :tag "Regexp"))))) + :group 'newsticker-headline-processing) + +;; ====================================================================== +;; hooks +(defgroup newsticker-hooks nil + "Settings for newsticker hooks." + :group 'newsticker) + +(defcustom newsticker-start-hook + nil + "Hook run when starting newsticker. +This hook is run at the very end of `newsticker-start'." + :options '(newsticker-start-ticker) + :type 'hook + :group 'newsticker-hooks) + +(defcustom newsticker-stop-hook + nil + "Hook run when stopping newsticker. +This hook is run at the very end of `newsticker-stop'." + :options nil + :type 'hook + :group 'newsticker-hooks) + +(defcustom newsticker-new-item-functions + nil + "List of functions run after a new headline has been retrieved. +Each function is called with the following three arguments: +FEED the name of the corresponding news feed, +TITLE the title of the headline, +DESC the decoded description of the headline. + +See `newsticker-download-images', and +`newsticker-download-enclosures' for sample functions. + +Please note that these functions are called only once for a +headline after it has been retrieved for the first time." + :type 'hook + :options '(newsticker-download-images + newsticker-download-enclosures) + :group 'newsticker-hooks) + +;; ====================================================================== +;; miscellaneous +(defgroup newsticker-miscellaneous nil + "Miscellaneous newsticker settings." + :group 'newsticker) + +(defcustom newsticker-cache-filename + "~/.newsticker-cache" + "Name of the newsticker cache file." + :type 'string + :group 'newsticker-miscellaneous) + +(defcustom newsticker-imagecache-dirname + "~/.newsticker-images" + "Name of the directory where newsticker stores cached images." + :type 'string + :group 'newsticker-miscellaneous) + +;; debugging +(defcustom newsticker-debug + nil + "Enables some features needed for debugging newsticker.el. + +If set to t newsticker.el will print lots of debugging messages, and the +buffers *newsticker-wget-<feed>* will not be closed." + :type 'boolean + :group 'newsticker-miscellaneous) + +;; ====================================================================== +;;; Compatibility section, XEmacs, Emacs +;; ====================================================================== +(unless (fboundp 'time-add) + (require 'time-date);;FIXME + (defun time-add (t1 t2) + (seconds-to-time (+ (time-to-seconds t1) (time-to-seconds t2))))) + +(unless (fboundp 'match-string-no-properties) + (defalias 'match-string-no-properties 'match-string)) + +(when (featurep 'xemacs) + (unless (fboundp 'replace-regexp-in-string) + (defun replace-regexp-in-string (re rp st) + (save-match-data ;; apparently XEmacs needs save-match-data + (replace-in-string st re rp))))) + +;; copied from subr.el +(unless (fboundp 'add-to-invisibility-spec) + (defun add-to-invisibility-spec (arg) + "Add elements to `buffer-invisibility-spec'. +See documentation for `buffer-invisibility-spec' for the kind of elements +that can be added." + (if (eq buffer-invisibility-spec t) + (setq buffer-invisibility-spec (list t))) + (setq buffer-invisibility-spec + (cons arg buffer-invisibility-spec)))) + +;; copied from subr.el +(unless (fboundp 'remove-from-invisibility-spec) + (defun remove-from-invisibility-spec (arg) + "Remove elements from `buffer-invisibility-spec'." + (if (consp buffer-invisibility-spec) + (setq buffer-invisibility-spec + (delete arg buffer-invisibility-spec))))) + +;; ====================================================================== +;;; Internal variables +;; ====================================================================== +(defvar newsticker--item-list nil + "List of newsticker items.") +(defvar newsticker--item-position 0 + "Actual position in list of newsticker items.") +(defvar newsticker--prev-message "There was no previous message yet!" + "Last message that the newsticker displayed.") +(defvar newsticker--scrollable-text "" + "The text which is scrolled smoothly in the echo area.") +(defvar newsticker--buffer-uptodate-p nil + "Tells whether the newsticker buffer is up to date.") +(defvar newsticker--latest-update-time (current-time) + "The time at which the latest news arrived.") +(defvar newsticker--process-ids nil + "List of PIDs of active newsticker processes.") + +(defvar newsticker--cache nil "Cached newsticker data. +This is a list of the form + + ((label1 + (title description link time age index preformatted-contents + preformatted-title extra-elements) + ...) + (label2 + (title description link time age index preformatted-contents + preformatted-title extra-elements) + ...) + ...) + +where LABEL is a symbol. TITLE, DESCRIPTION, and LINK are +strings. TIME is a time value as returned by `current-time'. +AGE is a symbol: 'new, 'old, 'immortal, and 'obsolete denote +ordinary news items, whereas 'feed denotes an item which is not a +headline but describes the feed itself. INDEX denotes the +original position of the item -- used for restoring the original +order. PREFORMATTED-CONTENTS and PREFORMATTED-TITLE hold the +formatted contents of the item's description and title. This +speeds things up if HTML rendering is used, which is rather +slow. EXTRA-ELEMENTS is an alist containing additional elements.") + +(defvar newsticker--auto-narrow-to-feed nil + "Automatically narrow to current news feed. +If non-nil only the items of the current news feed are visible.") + +(defvar newsticker--auto-narrow-to-item nil + "Automatically narrow to current news item. +If non-nil only the current headline is visible.") + +(defconst newsticker--error-headline + "[COULD NOT DOWNLOAD HEADLINES!]" + "Title of error headline which will be inserted if news retrieval fails.") + +;; ====================================================================== +;;; Shortcuts +;; ====================================================================== +(defsubst newsticker--title (item) + "Return title of ITEM." + (nth 0 item)) +(defsubst newsticker--desc (item) + "Return description of ITEM." + (nth 1 item)) +(defsubst newsticker--link (item) + "Return link of ITEM." + (nth 2 item)) +(defsubst newsticker--time (item) + "Return time of ITEM." + (nth 3 item)) +(defsubst newsticker--age (item) + "Return age of ITEM." + (nth 4 item)) +(defsubst newsticker--pos (item) + "Return position/index of ITEM." + (nth 5 item)) +(defsubst newsticker--preformatted-contents (item) + "Return pre-formatted text of ITEM." + (nth 6 item)) +(defsubst newsticker--preformatted-title (item) + "Return pre-formatted title of ITEM." + (nth 7 item)) +(defsubst newsticker--extra (item) + "Return extra attributes of ITEM." + (nth 8 item)) +(defsubst newsticker--guid-to-string (guid) + "Return string representation of GUID." + (if (stringp guid) + guid + (car (xml-node-children guid)))) +(defsubst newsticker--guid (item) + "Return guid of ITEM." + (newsticker--guid-to-string (assoc 'guid (newsticker--extra item)))) +(defsubst newsticker--enclosure (item) + "Return enclosure element of ITEM in the form \(...FIXME...\) or nil." + (let ((enclosure (assoc 'enclosure (newsticker--extra item)))) + (if enclosure + (xml-node-attributes enclosure)))) +(defun newsticker--real-feed-name (feed) + "Return real name of FEED." + (catch 'name + (mapc (lambda (item) + (if (eq (newsticker--age item) 'feed) + (throw 'name (newsticker--title item)))) + (cdr (newsticker--cache-get-feed feed))) + (symbol-name feed))) + + +;; ====================================================================== +;;; User fun +;; ====================================================================== + +(defun newsticker--start-feed (feed &optional do-not-complain-if-running) + "Start retrieval timer for FEED. +If timer is running already a warning message is printed unless +DO-NOT-COMPLAIN-IF-RUNNING is not nil. Add the started +name/timer pair to `newsticker--retrieval-timer-list'." + (let* ((feed-name (car feed)) + (start-time (nth 2 feed)) + (interval (or (nth 3 feed) + newsticker-retrieval-interval)) + (timer (assoc (car feed) + newsticker--retrieval-timer-list))) + (if timer + (or do-not-complain-if-running + (message "Timer for %s is running already!" + feed-name)) + (newsticker--debug-msg "Starting timer for %s: %s, %d" + feed-name start-time interval) + ;; do not repeat retrieval if interval not positive + (if (<= interval 0) + (setq interval nil)) + ;; Suddenly XEmacs doesn't like start-time 0 + (if (or (not start-time) + (and (numberp start-time) (= start-time 0))) + (setq start-time 1)) + ;; (message "start-time %s" start-time) + (setq timer (run-at-time start-time interval + 'newsticker-get-news feed-name)) + (if interval + (add-to-list 'newsticker--retrieval-timer-list + (cons feed-name timer)))))) + +;;;###autoload +(defun newsticker-start (&optional do-not-complain-if-running) + "Start the newsticker. +Start the timers for display and retrieval. If the newsticker, i.e. the +timers, are running already a warning message is printed unless +DO-NOT-COMPLAIN-IF-RUNNING is not nil. +Run `newsticker-start-hook' if newsticker was not running already." + (interactive) + (let ((running (newsticker-running-p))) + ;; read old cache if it exists and newsticker is not running + (unless running + (let ((coding-system-for-read 'utf-8)) + (when (file-exists-p newsticker-cache-filename) + (with-temp-buffer + (insert-file-contents newsticker-cache-filename) + (goto-char (point-min)) + (condition-case nil + (setq newsticker--cache (read (current-buffer))) + (error + (message "Error while reading newsticker cache file!") + (setq newsticker--cache nil))))))) + ;; start retrieval timers -- one timer for each feed + (dolist (feed (append newsticker-url-list-defaults newsticker-url-list)) + (newsticker--start-feed feed)) + (unless running + (run-hooks 'newsticker-start-hook) + (message "Newsticker started!")))) + +(defun newsticker--stop-feed (feed-name) + "Stop retrieval for feed FEED-NAME. +Delete the stopped name/timer pair from `newsticker--retrieval-timer-list'." + (let ((name-and-timer (assoc feed-name newsticker--retrieval-timer-list))) + (when name-and-timer + (cancel-timer (cdr name-and-timer)) + (setq newsticker--retrieval-timer-list + (delete name-and-timer newsticker--retrieval-timer-list))))) + +(defun newsticker-stop () + "Stop the newsticker and the newsticker-ticker. +Cancel the timers for display and retrieval. Run `newsticker-stop-hook' +if newsticker has been running." + (interactive) + (newsticker--cache-update t) + (when (fboundp 'newsticker-stop-ticker) ; silence compiler warnings + (newsticker-stop-ticker)) + (when (newsticker-running-p) + (mapc (lambda (name-and-timer) + (newsticker--stop-feed (car name-and-timer))) + newsticker--retrieval-timer-list) + (setq newsticker--retrieval-timer-list nil) + (run-hooks 'newsticker-stop-hook) + (message "Newsticker stopped!"))) + +(defun newsticker-get-all-news () + "Launch retrieval of news from all configured newsticker sites. +This does NOT start the retrieval timers." + (interactive) + ;; launch retrieval of news + (mapc (lambda (item) + (newsticker-get-news (car item))) + (append newsticker-url-list-defaults newsticker-url-list))) + +(defun newsticker-save-item (feed item) + "Save FEED ITEM." + (interactive) + (let ((filename (read-string "Filename: " + (concat feed ":_" + (replace-regexp-in-string + " " "_" (newsticker--title item)) + ".html")))) + (with-temp-buffer + (insert (newsticker--desc item)) + (write-file filename t)))) + +(defun newsticker-add-url (url name) + "Add given URL under given NAME to `newsticker-url-list'. +If URL is nil it is searched at point." + (interactive + (list + (read-string "URL: " + (save-excursion + (end-of-line) + (and + (re-search-backward + "http://" + (if (> (point) (+ (point-min) 100)) + (- (point) 100) + (point-min)) + t) + (re-search-forward + "http://[-a-zA-Z0-9&/_.]*" + (if (< (point) (- (point-max) 200)) + (+ (point) 200) + (point-max)) + t) + (buffer-substring-no-properties (match-beginning 0) + (match-end 0))))) + (read-string "Name: "))) + (add-to-list 'newsticker-url-list (list name url nil nil nil) t) + (customize-variable 'newsticker-url-list)) + +(defun newsticker-customize () + "Open the newsticker customization group." + (interactive) + (customize-group "newsticker")) + +;; ====================================================================== +;;; Local stuff +;; ====================================================================== +(defun newsticker--get-news-by-funcall (feed-name function) + "Get news for the site FEED-NAME by calling FUNCTION. +See `newsticker-get-news'." + (let ((buffername (concat " *newsticker-funcall-" feed-name "*"))) + (save-excursion + (set-buffer (get-buffer-create buffername)) + (erase-buffer) + (insert (string-to-multibyte (funcall function feed-name))) + (newsticker--sentinel-work nil t feed-name function + (current-buffer))))) + +(defun newsticker--get-news-by-url (feed-name url) + "Get news for the site FEED-NAME from address URL using `url-retrieve'. +See `newsticker-get-news'." + (let ((coding-system-for-read 'no-conversion)) + (url-retrieve url 'newsticker--get-news-by-url-callback (list feed-name))) + (force-mode-line-update)) + +(defun newsticker--get-news-by-url-callback (status feed-name) + "Callback function for `newsticker--get-news-by-url'. +STATUS is the return status as delivered by `url-retrieve', and +FEED-NAME is the name of the feed that the news were retrieved +from." + (let ((buf (get-buffer-create (concat " *newsticker-url-" feed-name "*"))) + (result (string-to-multibyte (buffer-string)))) + (set-buffer buf) + (erase-buffer) + (insert result) + ;; remove MIME header + (goto-char (point-min)) + (search-forward "\n\n") + (delete-region (point-min) (point)) + ;; read the rss/atom contents + (newsticker--sentinel-work nil t feed-name "url-retrieve" (current-buffer)) + (when status + (let ((status-type (car status)) + (status-details (cdr status))) + (cond ((eq status-type :redirect) + ;; don't care about redirects + ) + ((eq status-type :error) + (message "%s: Error while retrieving news from %s: %s: \"%s\"" + (format-time-string "%A, %H:%M" (current-time)) + feed-name + (car status-details) (cdr status-details)))))))) + +(defun newsticker--get-news-by-wget (feed-name url wget-arguments) + "Get news for the site FEED-NAME from address URL using wget. +WGET-ARGUMENTS is a list of arguments for wget. +See `newsticker-get-news'." + (let ((buffername (concat " *newsticker-wget-" feed-name "*"))) + (save-excursion + (set-buffer (get-buffer-create buffername)) + (erase-buffer) + ;; throw an error if there is an old wget-process around + (if (get-process feed-name) + (error "Another wget-process is running for %s" feed-name)) + ;; start wget + (let* ((args (append wget-arguments (list url))) + (proc (apply 'start-process feed-name buffername + newsticker-wget-name args))) + (set-process-coding-system proc 'no-conversion 'no-conversion) + (set-process-sentinel proc 'newsticker--sentinel) + (setq newsticker--process-ids (cons (process-id proc) + newsticker--process-ids)) + (force-mode-line-update))))) + +(defun newsticker-get-news (feed-name) + "Get news from the site FEED-NAME and load feed logo. +FEED-NAME must be a string which occurs as the label (i.e. the first element) +in an element of `newsticker-url-list' or `newsticker-url-list-defaults'." + (newsticker--debug-msg "%s: Getting news for %s" + (format-time-string "%A, %H:%M" (current-time)) + feed-name) + (let* ((item (or (assoc feed-name newsticker-url-list) + (assoc feed-name newsticker-url-list-defaults) + (error + "Cannot get news for %s: Check newsticker-url-list" + feed-name))) + (url (cadr item)) + (wget-arguments (or (car (cdr (cdr (cdr (cdr item))))) + newsticker-wget-arguments))) + (if (functionp url) + (newsticker--get-news-by-funcall feed-name url) + (if (eq newsticker-retrieval-method 'intern) + (newsticker--get-news-by-url feed-name url) + (newsticker--get-news-by-wget feed-name url wget-arguments))))) + +;; ====================================================================== +;; Parsing +;; ====================================================================== + +(defun newsticker--sentinel (process event) + "Sentinel for extracting news titles from an RDF buffer. +Argument PROCESS is the process which has just changed its state. +Argument EVENT tells what has happened to the process." + (let ((p-status (process-status process)) + (exit-status (process-exit-status process)) + (name (process-name process)) + (command (process-command process)) + (buffer (process-buffer process))) + (newsticker--sentinel-work event + (and (eq p-status 'exit) + (= exit-status 0)) + name command buffer))) + +(defun newsticker--sentinel-work (event status-ok name command buffer) + "Actually do the sentinel work. +Argument EVENT tells what has happened to the retrieval process. +Argument STATUS-OK is the final status of the retrieval process, +non-nil meaning retrieval was successful. +Argument NAME is the name of the retrieval process. +Argument COMMAND is the command of the retrieval process. +Argument BUFFER is the buffer of the retrieval process." + (let ((time (current-time)) + (name-symbol (intern name)) + (something-was-added nil)) + ;; catch known errors (zombie processes, rubbish-xml etc. + ;; if an error occurs the news feed is not updated! + (catch 'oops + (unless status-ok + (setq newsticker--cache + (newsticker--cache-add + newsticker--cache + name-symbol + newsticker--error-headline + (format + (concat "%s: Newsticker could not retrieve news from %s.\n" + "Return status: `%s'\n" + "Command was `%s'") + (format-time-string "%A, %H:%M" (current-time)) + name event command) + "" + (current-time) + 'new + 0 nil)) + (message "%s: Error while retrieving news from %s" + (format-time-string "%A, %H:%M" (current-time)) + name) + (throw 'oops nil)) + (let* ((coding-system 'utf-8) + (node-list + (save-current-buffer + (set-buffer buffer) + ;; a very very dirty workaround to overcome the + ;; problems with the newest (20030621) xml.el: + ;; remove all unnecessary whitespace + (goto-char (point-min)) + (while (re-search-forward ">[ \t\r\n]+<" nil t) + (replace-match "><" nil t)) + ;; and another brutal workaround (20031105)! For some + ;; reason the xml parser does not like the colon in the + ;; doctype name "rdf:RDF" + (goto-char (point-min)) + (if (re-search-forward "<!DOCTYPE[ \t\n]+rdf:RDF" nil t) + (replace-match "<!DOCTYPE rdfColonRDF" nil t)) + ;; finally.... ~##^°!!!!! + (goto-char (point-min)) + (while (search-forward "\r\n" nil t) + (replace-match "\n" nil t)) + ;; still more brutal workarounds (20040309)! The xml + ;; parser does not like doctype rss + (goto-char (point-min)) + (if (re-search-forward "<!DOCTYPE[ \t\n]+rss[ \t\n]*>" nil t) + (replace-match "" nil t)) + ;; And another one (20050618)! (Fixed in GNU Emacs 22.0.50.18) + ;; Remove comments to avoid this xml-parsing bug: + ;; "XML files can have only one toplevel tag" + (goto-char (point-min)) + (while (search-forward "<!--" nil t) + (let ((start (match-beginning 0))) + (unless (search-forward "-->" nil t) + (error "Can't find end of comment")) + (delete-region start (point)))) + ;; And another one (20050702)! If description is HTML + ;; encoded and starts with a `<', wrap the whole + ;; description in a CDATA expression. This happened for + ;; http://www.thefreedictionary.com/_/WoD/rss.aspx?type=quote + (goto-char (point-min)) + (while (re-search-forward + "<description>\\(<img.*?\\)</description>" nil t) + (replace-match + "<description><![CDATA[ \\1 ]]></description>")) + ;; And another one (20051123)! XML parser does not + ;; like this: <yweather:location city="Frankfurt/Main" + ;; region="" country="GM" /> + ;; try to "fix" empty attributes + ;; This happened for + ;; http://xml.weather.yahoo.com/forecastrss?p=GMXX0040&u=f + (goto-char (point-min)) + (while (re-search-forward "\\(<[^>]*\\)=\"\"" nil t) + (replace-match "\\1=\" \"")) + ;; + (set-buffer-modified-p nil) + ;; check coding system + (goto-char (point-min)) + (if (re-search-forward "encoding=\"\\([^\"]+\\)\"" + nil t) + (setq coding-system (intern (downcase (match-string 1)))) + (setq coding-system + (condition-case nil + (check-coding-system coding-system) + (coding-system-error + (message + "newsticker.el: ignoring coding system %s for %s" + coding-system name) + nil)))) + ;; Decode if possible + (when coding-system + (decode-coding-region (point-min) (point-max) + coding-system)) + (condition-case errordata + ;; The xml parser might fail + ;; or the xml might be bugged + (xml-parse-region (point-min) (point-max)) + (error (message "Could not parse %s: %s" + (buffer-name) (cadr errordata)) + (throw 'oops nil))))) + (topnode (car node-list)) + (channelnode (car (xml-get-children topnode 'channel))) + (imageurl nil)) + ;; mark all items as obsolete + (newsticker--cache-replace-age newsticker--cache + name-symbol + 'new 'obsolete-new) + (newsticker--cache-replace-age newsticker--cache + name-symbol + 'old 'obsolete-old) + (newsticker--cache-replace-age newsticker--cache + name-symbol + 'feed 'obsolete-old) + + ;; check Atom/RSS version and call corresponding parser + (condition-case error-data + (if (cond + ;; RSS 0.91 + ((and (eq 'rss (xml-node-name topnode)) + (string= "0.91" (xml-get-attribute topnode 'version))) + (setq imageurl (newsticker--get-logo-url-rss-0.91 topnode)) + (newsticker--parse-rss-0.91 name time topnode)) + ;; RSS 0.92 + ((and (eq 'rss (xml-node-name topnode)) + (string= "0.92" (xml-get-attribute topnode 'version))) + (setq imageurl (newsticker--get-logo-url-rss-0.92 topnode)) + (newsticker--parse-rss-0.92 name time topnode)) + ;; RSS 1.0 + ((eq 'rdf:RDF (xml-node-name topnode)) + (setq imageurl (newsticker--get-logo-url-rss-1.0 topnode)) + (newsticker--parse-rss-1.0 name time topnode)) + ;; RSS 2.0 + ((and (eq 'rss (xml-node-name topnode)) + (string= "2.0" (xml-get-attribute topnode 'version))) + (setq imageurl (newsticker--get-logo-url-rss-2.0 topnode)) + (newsticker--parse-rss-2.0 name time topnode)) + ;; Atom 0.3 + ((and (eq 'feed (xml-node-name topnode)) + (string= "http://purl.org/atom/ns#" + (xml-get-attribute topnode 'xmlns))) + (setq imageurl (newsticker--get-logo-url-atom-0.3 topnode)) + (newsticker--parse-atom-0.3 name time topnode)) + ;; Atom 1.0 + ((and (eq 'feed (xml-node-name topnode)) + (string= "http://www.w3.org/2005/Atom" + (xml-get-attribute topnode 'xmlns))) + (setq imageurl (newsticker--get-logo-url-atom-1.0 topnode)) + (newsticker--parse-atom-1.0 name time topnode)) + ;; unknown feed type + (t + (newsticker--debug-msg "Feed type unknown: %s: %s" + (xml-node-name topnode) name) + nil)) + (setq something-was-added t)) + (xerror (message "sentinelerror in %s: %s" name error-data))) + + ;; Remove those old items from cache which have been removed from + ;; the feed + (newsticker--cache-replace-age newsticker--cache + name-symbol 'obsolete-old 'deleteme) + (newsticker--cache-remove newsticker--cache name-symbol + 'deleteme) + ;; Remove those new items from cache which have been removed from + ;; the feed. Or keep them as `obsolete' + (if (not newsticker-keep-obsolete-items) + (newsticker--cache-remove newsticker--cache + name-symbol 'obsolete-new) + (setq newsticker--cache + (newsticker--cache-mark-expired + newsticker--cache name-symbol 'obsolete 'obsolete-expired + newsticker-obsolete-item-max-age)) + (newsticker--cache-remove newsticker--cache + name-symbol 'obsolete-expired) + (newsticker--cache-replace-age newsticker--cache + name-symbol 'obsolete-new + 'obsolete)) + (newsticker--update-process-ids) + ;; setup scrollable text + (when (= 0 (length newsticker--process-ids)) + (when (fboundp 'newsticker--ticker-text-setup) ;silence + ;compiler + ;warnings + (newsticker--ticker-text-setup))) + (setq newsticker--latest-update-time (current-time)) + (when something-was-added + ;; FIXME: should we care about removed items as well? + (newsticker--cache-update) + (when (fboundp 'newsticker--buffer-set-uptodate) ;silence + ;compiler + ;warnings + (newsticker--buffer-set-uptodate nil))) + ;; kill the process buffer if wanted + (unless newsticker-debug + (kill-buffer buffer)) + ;; launch retrieval of image + (when (and imageurl newsticker--download-logos) + (newsticker--image-get name imageurl))))) + (when newsticker--sentinel-callback + (funcall newsticker--sentinel-callback))) + +(defun newsticker--get-logo-url-atom-1.0 (node) + "Return logo URL from atom 1.0 data in NODE." + (car (xml-node-children + (car (xml-get-children node 'logo))))) + +(defun newsticker--get-logo-url-atom-0.3 (node) + "Return logo URL from atom 0.3 data in NODE." + (car (xml-node-children + (car (xml-get-children (car (xml-get-children node 'image)) 'url))))) + +(defun newsticker--get-logo-url-rss-2.0 (node) + "Return logo URL from RSS 2.0 data in NODE." + (car (xml-node-children + (car (xml-get-children + (car (xml-get-children + (car (xml-get-children node 'channel)) 'image)) 'url))))) + +(defun newsticker--get-logo-url-rss-1.0 (node) + "Return logo URL from RSS 1.0 data in NODE." + (car (xml-node-children + (car (xml-get-children (car (xml-get-children node 'image)) 'url))))) + +(defun newsticker--get-logo-url-rss-0.92 (node) + "Return logo URL from RSS 0.92 data in NODE." + (car (xml-node-children + (car (xml-get-children (car (xml-get-children node 'image)) 'url))))) + +(defun newsticker--get-logo-url-rss-0.91 (node) + "Return logo URL from RSS 0.91 data in NODE." + (car (xml-node-children + (car (xml-get-children (car (xml-get-children node 'image)) 'url))))) + +(defun newsticker--parse-atom-0.3 (name time topnode) + "Parse Atom 0.3 data. +Return value as well as arguments NAME, TIME, and TOPNODE are the +same as in `newsticker--parse-atom-1.0'." + (newsticker--debug-msg "Parsing Atom 0.3 feed %s" name) + (let (new-feed new-item) + (setq new-feed (newsticker--parse-generic-feed + name time + ;; title + (car (xml-node-children + (car (xml-get-children topnode 'title)))) + ;; desc + (car (xml-node-children + (car (xml-get-children topnode 'content)))) + ;; link + (xml-get-attribute + (car (xml-get-children topnode 'link)) 'href) + ;; extra-elements + (xml-node-children topnode))) + (setq new-item (newsticker--parse-generic-items + name time (xml-get-children topnode 'entry) + ;; title-fn + (lambda (node) + (car (xml-node-children + (car (xml-get-children node 'title))))) + ;; desc-fn + (lambda (node) + (or (car (xml-node-children + (car (xml-get-children node 'content)))) + (car (xml-node-children + (car (xml-get-children node 'summary)))))) + ;; link-fn + (lambda (node) + (xml-get-attribute + (car (xml-get-children node 'link)) 'href)) + ;; time-fn + (lambda (node) + (newsticker--decode-rfc822-date + (car (xml-node-children + (car (xml-get-children node 'modified)))))) + ;; guid-fn + (lambda (node) + (newsticker--guid-to-string + (assoc 'guid (xml-node-children node)))) + ;; extra-fn + (lambda (node) + (xml-node-children node)))) + (or new-item new-feed))) + +(defun newsticker--parse-atom-1.0 (name time topnode) + "Parse Atom 1.0 data. +Argument NAME gives the name of a news feed. TIME gives the +system time at which the data have been retrieved. TOPNODE +contains the feed data as returned by the xml parser. + +For the Atom 1.0 specification see +http://www.atompub.org/2005/08/17/draft-ietf-atompub-format-11.html" + (newsticker--debug-msg "Parsing Atom 1.0 feed %s" name) + (let (new-feed new-item) + (setq new-feed (newsticker--parse-generic-feed + name time + ;; title + (car (xml-node-children + (car (xml-get-children topnode 'title)))) + ;; desc + (car (xml-node-children + (car (xml-get-children topnode 'subtitle)))) + ;; link + (lambda (node) + (xml-get-attribute + (car (xml-get-children node 'link)) 'href)) + ;; extra-elements + (xml-node-children topnode))) + (setq new-item (newsticker--parse-generic-items + name time (xml-get-children topnode 'entry) + ;; title-fn + (lambda (node) + (car (xml-node-children + (car (xml-get-children node 'title))))) + ;; desc-fn + (lambda (node) + (or (car (xml-node-children + (car (xml-get-children node 'content)))) + (car (xml-node-children + (car (xml-get-children node 'summary)))))) + ;; link-fn + (lambda (node) + (xml-get-attribute + (car (xml-get-children node 'link)) 'href)) + ;; time-fn + (lambda (node) + (newsticker--decode-iso8601-date + (or (car (xml-node-children + (car (xml-get-children node 'updated)))) + (car (xml-node-children + (car (xml-get-children node 'published))))))) + ;; guid-fn + (lambda (node) + (car (xml-node-children + (car (xml-get-children node 'id))))) + ;; extra-fn + (lambda (node) + (xml-node-children node)))) + (or new-item new-feed))) + +(defun newsticker--parse-rss-0.91 (name time topnode) + "Parse RSS 0.91 data. +Return value as well as arguments NAME, TIME, and TOPNODE are the +same as in `newsticker--parse-atom-1.0'. + +For the RSS 0.91 specification see http://backend.userland.com/rss091 or +http://my.netscape.com/publish/formats/rss-spec-0.91.html." + (newsticker--debug-msg "Parsing RSS 0.91 feed %s" name) + (let* ((channelnode (car (xml-get-children topnode 'channel))) + (pub-date (newsticker--decode-rfc822-date + (car (xml-node-children + (car (xml-get-children channelnode 'pubDate)))))) + is-new-feed has-new-items) + (setq is-new-feed (newsticker--parse-generic-feed + name time + ;; title + (car (xml-node-children + (car (xml-get-children channelnode 'title)))) + ;; desc + (car (xml-node-children + (car (xml-get-children channelnode + 'description)))) + ;; link + (car (xml-node-children + (car (xml-get-children channelnode 'link)))) + ;; extra-elements + (xml-node-children channelnode))) + (setq has-new-items (newsticker--parse-generic-items + name time (xml-get-children channelnode 'item) + ;; title-fn + (lambda (node) + (car (xml-node-children + (car (xml-get-children node 'title))))) + ;; desc-fn + (lambda (node) + (car (xml-node-children + (car (xml-get-children node 'description))))) + ;; link-fn + (lambda (node) + (car (xml-node-children + (car (xml-get-children node 'link))))) + ;; time-fn + (lambda (node) + (newsticker--decode-rfc822-date + (car (xml-node-children + (car (xml-get-children node 'pubDate)))))) + ;; guid-fn + (lambda (node) + nil) + ;; extra-fn + (lambda (node) + (xml-node-children node)))) + (or has-new-items is-new-feed))) + +(defun newsticker--parse-rss-0.92 (name time topnode) + "Parse RSS 0.92 data. +Return value as well as arguments NAME, TIME, and TOPNODE are the +same as in `newsticker--parse-atom-1.0'. + +For the RSS 0.92 specification see http://backend.userland.com/rss092." + (newsticker--debug-msg "Parsing RSS 0.92 feed %s" name) + (let* ((channelnode (car (xml-get-children topnode 'channel))) + (pub-date (newsticker--decode-rfc822-date + (car (xml-node-children + (car (xml-get-children channelnode 'pubDate)))))) + is-new-feed has-new-items) + (setq is-new-feed (newsticker--parse-generic-feed + name time + ;; title + (car (xml-node-children + (car (xml-get-children channelnode 'title)))) + ;; desc + (car (xml-node-children + (car (xml-get-children channelnode + 'description)))) + ;; link + (car (xml-node-children + (car (xml-get-children channelnode 'link)))) + ;; extra-elements + (xml-node-children channelnode))) + (setq has-new-items (newsticker--parse-generic-items + name time (xml-get-children channelnode 'item) + ;; title-fn + (lambda (node) + (car (xml-node-children + (car (xml-get-children node 'title))))) + ;; desc-fn + (lambda (node) + (car (xml-node-children + (car (xml-get-children node 'description))))) + ;; link-fn + (lambda (node) + (car (xml-node-children + (car (xml-get-children node 'link))))) + ;; time-fn + (lambda (node) + (newsticker--decode-rfc822-date + (car (xml-node-children + (car (xml-get-children node 'pubDate)))))) + ;; guid-fn + (lambda (node) + nil) + ;; extra-fn + (lambda (node) + (xml-node-children node)))) + (or has-new-items is-new-feed))) + +(defun newsticker--parse-rss-1.0 (name time topnode) + "Parse RSS 1.0 data. +Return value as well as arguments NAME, TIME, and TOPNODE are the +same as in `newsticker--parse-atom-1.0'. + +For the RSS 1.0 specification see http://web.resource.org/rss/1.0/spec." + (newsticker--debug-msg "Parsing RSS 1.0 feed %s" name) + (let* ((channelnode (car (xml-get-children topnode 'channel))) + is-new-feed has-new-items) + (setq is-new-feed (newsticker--parse-generic-feed + name time + ;; title + (car (xml-node-children + (car (xml-get-children channelnode 'title)))) + ;; desc + (car (xml-node-children + (car (xml-get-children channelnode + 'description)))) + ;; link + (car (xml-node-children + (car (xml-get-children channelnode 'link)))) + ;; extra-elements + (xml-node-children channelnode))) + (setq has-new-items (newsticker--parse-generic-items + name time (xml-get-children topnode 'item) + ;; title-fn + (lambda (node) + (car (xml-node-children + (car (xml-get-children node 'title))))) + ;; desc-fn + (lambda (node) + (car (xml-node-children + (car (xml-get-children node + 'description))))) + ;; link-fn + (lambda (node) + (car (xml-node-children + (car (xml-get-children node 'link))))) + ;; time-fn + (lambda (node) + (newsticker--decode-iso8601-date + (car (xml-node-children + (car (xml-get-children node 'dc:date)))))) + ;; guid-fn + (lambda (node) + nil) + ;; extra-fn + (lambda (node) + (xml-node-children node)))) + (or has-new-items is-new-feed))) + +(defun newsticker--parse-rss-2.0 (name time topnode) + "Parse RSS 2.0 data. +Return value as well as arguments NAME, TIME, and TOPNODE are the +same as in `newsticker--parse-atom-1.0'. + +For the RSS 2.0 specification see http://blogs.law.harvard.edu/tech/rss." + (newsticker--debug-msg "Parsing RSS 2.0 feed %s" name) + (let* ((channelnode (car (xml-get-children topnode 'channel))) + is-new-feed has-new-items) + (setq is-new-feed (newsticker--parse-generic-feed + name time + ;; title + (car (xml-node-children + (car (xml-get-children channelnode 'title)))) + ;; desc + (car (xml-node-children + (car (xml-get-children channelnode + 'description)))) + ;; link + (car (xml-node-children + (car (xml-get-children channelnode 'link)))) + ;; extra-elements + (xml-node-children channelnode))) + (setq has-new-items (newsticker--parse-generic-items + name time (xml-get-children channelnode 'item) + ;; title-fn + (lambda (node) + (car (xml-node-children + (car (xml-get-children node 'title))))) + ;; desc-fn + (lambda (node) + (or (car (xml-node-children + (car (xml-get-children node + 'content:encoded)))) + (car (xml-node-children + (car (xml-get-children node + 'description)))))) + ;; link-fn + (lambda (node) + (car (xml-node-children + (car (xml-get-children node 'link))))) + ;; time-fn + (lambda (node) + (newsticker--decode-rfc822-date + (car (xml-node-children + (car (xml-get-children node 'pubDate)))))) + ;; guid-fn + (lambda (node) + (newsticker--guid-to-string + (assoc 'guid (xml-node-children node)))) + ;; extra-fn + (lambda (node) + (xml-node-children node)))) + (or has-new-items is-new-feed))) + +(defun newsticker--parse-generic-feed (name time title desc link + extra-elements) + "Parse generic news feed data. +Argument NAME gives the name of a news feed. TIME gives the +system time at which the data have been retrieved. + +The arguments TITLE, DESC, LINK, and EXTRA-ELEMENTS give the feed's title, +description, link, and extra elements resp." + (let ((title (or title "[untitled]")) + (link (or link "")) + (old-item nil) + (position 0) + (something-was-added nil)) + ;; decode numeric entities + (setq title (newsticker--decode-numeric-entities title)) + (setq desc (newsticker--decode-numeric-entities desc)) + (setq link (newsticker--decode-numeric-entities link)) + ;; remove whitespace from title, desc, and link + (setq title (newsticker--remove-whitespace title)) + (setq desc (newsticker--remove-whitespace desc)) + (setq link (newsticker--remove-whitespace link)) + + ;; handle the feed itself + (unless (newsticker--cache-contains newsticker--cache + (intern name) title + desc link 'feed) + (setq something-was-added t)) + (setq newsticker--cache + (newsticker--cache-add newsticker--cache (intern name) + title desc link time 'feed position + extra-elements time 'feed)) + something-was-added)) + +(defun newsticker--parse-generic-items (name time itemlist + title-fn desc-fn + link-fn time-fn + guid-fn extra-fn) + "Parse generic news feed data. +Argument NAME gives the name of a news feed. TIME gives the +system time at which the data have been retrieved. ITEMLIST +contains the news items returned by the xml parser. + +The arguments TITLE-FN, DESC-FN, LINK-FN, TIME-FN, GUID-FN, and +EXTRA-FN give functions for extracting title, description, link, +time, guid, and extra-elements resp. They are called with one +argument, which is one of the items in ITEMLIST." + (let (title desc link + (old-item nil) + (position 0) + (something-was-added nil)) + ;; gather all items for this feed + (mapc (lambda (node) + (setq position (1+ position)) + (setq title (or (funcall title-fn node) "[untitled]")) + (setq desc (funcall desc-fn node)) + (setq link (or (funcall link-fn node) "")) + (setq time (or (funcall time-fn node) time)) + ;; It happened that the title or description + ;; contained evil HTML code that confused the + ;; xml parser. Therefore: + (unless (stringp title) + (setq title (prin1-to-string title))) + (unless (or (stringp desc) (not desc)) + (setq desc (prin1-to-string desc))) + ;; ignore items with empty title AND empty desc + (when (or (> (length title) 0) + (> (length desc) 0)) + ;; decode numeric entities + (setq title (newsticker--decode-numeric-entities title)) + (when desc + (setq desc (newsticker--decode-numeric-entities desc))) + (setq link (newsticker--decode-numeric-entities link)) + ;; remove whitespace from title, desc, and link + (setq title (newsticker--remove-whitespace title)) + (setq desc (newsticker--remove-whitespace desc)) + (setq link (newsticker--remove-whitespace link)) + ;; add data to cache + ;; do we have this item already? + (let* ((guid (funcall guid-fn node))) + ;;(message "guid=%s" guid) + (setq old-item + (newsticker--cache-contains newsticker--cache + (intern name) title + desc link nil guid))) + ;; add this item, or mark it as old, or do nothing + (let ((age1 'new) + (age2 'old) + (item-new-p nil)) + (if old-item + (let ((prev-age (newsticker--age old-item))) + (unless newsticker-automatically-mark-items-as-old + ;; Some feeds deliver items multiply, the + ;; first time we find an 'obsolete-old one the + ;; cache, the following times we find an 'old + ;; one + (if (memq prev-age '(obsolete-old old)) + (setq age2 'old) + (setq age2 'new))) + (if (eq prev-age 'immortal) + (setq age2 'immortal)) + (setq time (newsticker--time old-item))) + ;; item was not there + (setq item-new-p t) + (setq something-was-added t)) + (setq newsticker--cache + (newsticker--cache-add + newsticker--cache (intern name) title desc link + time age1 position (funcall extra-fn node) + time age2)) + (when item-new-p + (let ((item (newsticker--cache-contains + newsticker--cache (intern name) title + desc link nil))) + (if newsticker-auto-mark-filter-list + (newsticker--run-auto-mark-filter name item)) + (run-hook-with-args + 'newsticker-new-item-functions name item)))))) + itemlist) + something-was-added)) + +;; ====================================================================== +;;; Misc +;; ====================================================================== +(defun newsticker--decode-numeric-entities (string) + "Decode SGML numeric entities by their respective utf characters. +This function replaces numeric entities in the input STRING and +returns the modified string. For example \"*\" gets replaced +by \"*\"." + (if (and string (stringp string)) + (let ((start 0)) + (while (string-match "&#\\([0-9]+\\);" string start) + (condition-case nil + (setq string (replace-match + (string (read (substring string + (match-beginning 1) + (match-end 1)))) + nil nil string)) + (error nil)) + (setq start (1+ (match-beginning 0)))) + string) + nil)) + +(defun newsticker--remove-whitespace (string) + "Remove leading and trailing whitespace from STRING." + ;; we must have ...+ but not ...* in the regexps otherwise xemacs loops + ;; endlessly... + (when (and string (stringp string)) + (replace-regexp-in-string + "[ \t\r\n]+$" "" + (replace-regexp-in-string "^[ \t\r\n]+" "" string)))) + +(defun newsticker--do-forget-preformatted (item) + "Forget pre-formatted data for ITEM. +Remove the pre-formatted from `newsticker--cache'." + (if (nthcdr 7 item) + (setcar (nthcdr 7 item) nil)) + (if (nthcdr 6 item) + (setcar (nthcdr 6 item) nil))) + +(defun newsticker--forget-preformatted () + "Forget all cached pre-formatted data. +Remove the pre-formatted from `newsticker--cache'." + (mapc (lambda (feed) + (mapc 'newsticker--do-forget-preformatted + (cdr feed))) + newsticker--cache) + (when (fboundp 'newsticker--buffer-set-uptodate) + (newsticker--buffer-set-uptodate nil))) + +(defun newsticker--debug-msg (string &rest args) + "Print newsticker debug messages. +This function calls `message' with arguments STRING and ARGS, if +`newsticker-debug' is non-nil." + (and newsticker-debug + ;;(not (active-minibuffer-window)) + ;;(not (current-message)) + (apply 'message string args))) + +(defun newsticker--decode-iso8601-date (iso8601-string) + "Return ISO8601-STRING in format like `decode-time'. +Converts from ISO-8601 to Emacs representation. +Examples: +2004-09-17T05:09:49.001+00:00 +2004-09-17T05:09:49+00:00 +2004-09-17T05:09+00:00 +2004-09-17T05:09:49 +2004-09-17T05:09 +2004-09-17 +2004-09 +2004" + (if iso8601-string + (when (string-match + (concat + "^ *\\([0-9]\\{4\\}\\)" ;year + "\\(-\\([0-9]\\{2\\}\\)" ;month + "\\(-\\([0-9]\\{2\\}\\)" ;day + "\\(T" + "\\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)" ;hour:minute + "\\(:\\([0-9]\\{2\\}\\)\\(\\.[0-9]+\\)?\\)?" ;second + ;timezone + "\\(\\([-+Z]\\)\\(\\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)\\)?\\)?" + "\\)?\\)?\\)? *$") + iso8601-string) + (let ((year (read (match-string 1 iso8601-string))) + (month (read (or (match-string 3 iso8601-string) + "1"))) + (day (read (or (match-string 5 iso8601-string) + "1"))) + (hour (read (or (match-string 7 iso8601-string) + "0"))) + (minute (read (or (match-string 8 iso8601-string) + "0"))) + (second (read (or (match-string 10 iso8601-string) + "0"))) + (sign (match-string 13 iso8601-string)) + (offset-hour (read (or (match-string 15 iso8601-string) + "0"))) + (offset-minute (read (or (match-string 16 iso8601-string) + "0")))) + (cond ((string= sign "+") + (setq hour (- hour offset-hour)) + (setq minute (- minute offset-minute))) + ((string= sign "-") + (setq hour (+ hour offset-hour)) + (setq minute (+ minute offset-minute)))) + ;; if UTC subtract current-time-zone offset + ;;(setq second (+ (car (current-time-zone)) second))) + + (condition-case nil + (encode-time second minute hour day month year t) + (error + (message "Cannot decode \"%s\"" iso8601-string) + nil)))) + nil)) + +(defun newsticker--decode-rfc822-date (rfc822-string) + "Return RFC822-STRING in format like `decode-time'. +Converts from RFC822 to Emacs representation. +Examples: +Sat, 07 September 2002 00:00:01 +0100 +Sat, 07 September 2002 00:00:01 MET +Sat, 07 Sep 2002 00:00:01 GMT +07 Sep 2002 00:00:01 GMT +07 Sep 2002" + (if (and rfc822-string (stringp rfc822-string)) + (when (string-match + (concat + "\\s-*" + ;; week day + "\\(\\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\)\\s-*,?\\)?\\s-*" + ;; day + "\\([0-9]\\{1,2\\}\\)\\s-+" + ;; month + "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|" + "Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\).*?\\s-+" + ;; year + "\\([0-9]\\{2,4\\}\\)" + ;; time may be missing + "\\(\\s-+" + ;; hour + "\\([0-9]\\{2\\}\\)" + ;; minute + ":\\([0-9]\\{2\\}\\)" + ;; second + "\\(:\\([0-9]\\{2\\}\\)\\)?" + ;; zone -- fixme + "\\(\\s-+\\(" + "UT\\|GMT\\|EST\\|EDT\\|CST\\|CDT\\|MST\\|MDT\\|PST\\|PDT" + "\\|\\([-+]\\)\\([0-9]\\{2\\}\\)\\([0-9]\\{2\\}\\)" + "\\)\\)?" + "\\)?") + rfc822-string) + (let ((day (read (match-string 3 rfc822-string))) + (month-name (match-string 4 rfc822-string)) + (month 0) + (year (read (match-string 5 rfc822-string))) + (hour (read (or (match-string 7 rfc822-string) "0"))) + (minute (read (or (match-string 8 rfc822-string) "0"))) + (second (read (or (match-string 10 rfc822-string) "0"))) + (zone (match-string 12 rfc822-string)) + (sign (match-string 13 rfc822-string)) + (offset-hour (read (or (match-string 14 rfc822-string) + "0"))) + (offset-minute (read (or (match-string 15 rfc822-string) + "0"))) + ;;FIXME + ) + (when zone + (cond ((string= sign "+") + (setq hour (- hour offset-hour)) + (setq minute (- minute offset-minute))) + ((string= sign "-") + (setq hour (+ hour offset-hour)) + (setq minute (+ minute offset-minute))))) + (condition-case error-data + (let ((i 1)) + (mapc (lambda (m) + (if (string= month-name m) + (setq month i)) + (setq i (1+ i))) + '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" + "Sep" "Oct" "Nov" "Dec")) + (encode-time second minute hour day month year t)) + (error + (message "Cannot decode \"%s\": %s %s" rfc822-string + (car error-data) (cdr error-data)) + nil)))) + nil)) + +(defun newsticker--lists-intersect-p (list1 list2) + "Return t if LIST1 and LIST2 share elements." + (let ((result nil)) + (mapc (lambda (elt) + (if (memq elt list2) + (setq result t))) + list1) + result)) + +(defun newsticker--update-process-ids () + "Update list of ids of active newsticker processes. +Checks list of active processes against list of newsticker processes." + (let ((active-procs (process-list)) + (new-list nil)) + (mapc (lambda (proc) + (let ((id (process-id proc))) + (if (memq id newsticker--process-ids) + (setq new-list (cons id new-list))))) + active-procs) + (setq newsticker--process-ids new-list)) + (force-mode-line-update)) + +;; ====================================================================== +;;; Images +;; ====================================================================== +(defun newsticker--image-get (feed-name url) + "Get image of the news site FEED-NAME from URL. +If the image has been downloaded in the last 24h do nothing." + (let ((image-name (concat newsticker-imagecache-dirname "/" + feed-name))) + (if (and (file-exists-p image-name) + (time-less-p (current-time) + (time-add (nth 5 (file-attributes image-name)) + (seconds-to-time 86400)))) + (newsticker--debug-msg "%s: Getting image for %s skipped" + (format-time-string "%A, %H:%M" (current-time)) + feed-name) + ;; download + (newsticker--debug-msg "%s: Getting image for %s" + (format-time-string "%A, %H:%M" (current-time)) + feed-name) + (let* ((buffername (concat " *newsticker-wget-image-" feed-name "*")) + (item (or (assoc feed-name newsticker-url-list) + (assoc feed-name newsticker-url-list-defaults) + (error + "Cannot get news for %s: Check newsticker-url-list" + feed-name))) + (wget-arguments (or (car (cdr (cdr (cdr (cdr item))))) + newsticker-wget-arguments))) + (save-excursion + (set-buffer (get-buffer-create buffername)) + (erase-buffer) + ;; throw an error if there is an old wget-process around + (if (get-process feed-name) + (error "Another wget-process is running for image %s" + feed-name)) + ;; start wget + (let* ((args (append wget-arguments (list url))) + (proc (apply 'start-process feed-name buffername + newsticker-wget-name args))) + (set-process-coding-system proc 'no-conversion 'no-conversion) + (set-process-sentinel proc 'newsticker--image-sentinel))))))) + +(defun newsticker--image-sentinel (process event) + "Sentinel for image-retrieving PROCESS caused by EVENT." + (let* ((p-status (process-status process)) + (exit-status (process-exit-status process)) + (feed-name (process-name process))) + ;; catch known errors (zombie processes, rubbish-xml, etc.) + ;; if an error occurs the news feed is not updated! + (catch 'oops + (unless (and (eq p-status 'exit) + (= exit-status 0)) + (message "%s: Error while retrieving image from %s" + (format-time-string "%A, %H:%M" (current-time)) + feed-name) + (throw 'oops nil)) + (let (image-name) + (save-excursion + (set-buffer (process-buffer process)) + (setq image-name (concat newsticker-imagecache-dirname "/" + feed-name)) + (set-buffer-file-coding-system 'no-conversion) + ;; make sure the cache dir exists + (unless (file-directory-p newsticker-imagecache-dirname) + (make-directory newsticker-imagecache-dirname)) + ;; write and close buffer + (let ((require-final-newline nil) + (backup-inhibited t) + (coding-system-for-write 'no-conversion)) + (write-region nil nil image-name nil 'quiet)) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))))))) + + + +(defun newsticker--insert-image (img string) + "Insert IMG with STRING at point." + (insert-image img string)) + +;; ====================================================================== +;;; HTML rendering +;; ====================================================================== +(defun newsticker-htmlr-render (pos1 pos2) ; + "Replacement for `htmlr-render'. +Renders the HTML code in the region POS1 to POS2 using htmlr." + (let ((str (buffer-substring-no-properties pos1 pos2))) + (delete-region pos1 pos2) + (insert + (with-temp-buffer + (insert str) + (goto-char (point-min)) + ;; begin original htmlr-render + (when (fboundp 'htmlr-reset) (htmlr-reset)) + ;; something omitted here... + (when (fboundp 'htmlr-step) + (while (< (point) (point-max)) + (htmlr-step))) + ;; end original htmlr-render + (newsticker--remove-whitespace (buffer-string)))))) + +;; ====================================================================== +;;; Manipulation of cached data +;; ====================================================================== +(defun newsticker--cache-set-preformatted-contents (item contents) + "Set preformatted contents of ITEM to CONTENTS." + (if (nthcdr 6 item) + (setcar (nthcdr 6 item) contents) + (setcdr (nthcdr 5 item) (list contents)))) + +(defun newsticker--cache-set-preformatted-title (item title) + "Set preformatted title of ITEM to TITLE." + (if (nthcdr 7 item) + (setcar (nthcdr 7 item) title) + (setcdr (nthcdr 6 item) title))) + +(defun newsticker--cache-replace-age (data feed old-age new-age) + "Mark all items in DATA in FEED which carry age OLD-AGE with NEW-AGE. +If FEED is 'any it applies to all feeds. If OLD-AGE is 'any, +all marks are replaced by NEW-AGE. Removes all pre-formatted contents." + (mapc (lambda (a-feed) + (when (or (eq feed 'any) + (eq (car a-feed) feed)) + (let ((items (cdr a-feed))) + (mapc (lambda (item) + (when (or (eq old-age 'any) + (eq (newsticker--age item) old-age)) + (setcar (nthcdr 4 item) new-age) + (newsticker--do-forget-preformatted item))) + items)))) + data) + data) + +(defun newsticker--cache-mark-expired (data feed old-age new-age time) + "Mark all expired entries. +This function sets the age entries in DATA in the feed FEED. If +an item's age is OLD-AGE it is set to NEW-AGE if the item is +older than TIME." + (mapc + (lambda (a-feed) + (when (or (eq feed 'any) + (eq (car a-feed) feed)) + (let ((items (cdr a-feed))) + (mapc + (lambda (item) + (when (eq (newsticker--age item) old-age) + (let ((exp-time (time-add (newsticker--time item) + (seconds-to-time time)))) + (when (time-less-p exp-time (current-time)) + (newsticker--debug-msg + "Item `%s' from %s has expired on %s" + (newsticker--title item) + (format-time-string "%Y-%02m-%d, %H:%M" + (newsticker--time item)) + (format-time-string "%Y-%02m-%d, %H:%M" exp-time)) + (setcar (nthcdr 4 item) new-age))))) + items)))) + data) + data) + +(defun newsticker--cache-contains (data feed title desc link age + &optional guid) + "Check DATA whether FEED contains an item with the given properties. +This function returns the contained item or nil if it is not +contained. +The properties which are checked are TITLE, DESC, LINK, AGE, and +GUID. In general all properties must match in order to return a +certain item, except for the following cases. + +If AGE equals 'feed the TITLE, DESCription and LINK do not +matter. If DESC is nil it is ignored as well. If +`newsticker-desc-comp-max' is non-nil, only the first +`newsticker-desc-comp-max' characters of DESC are taken into +account. + +If GUID is non-nil it is sufficient to match this value, and the +other properties are ignored." + ;;(newsticker--debug-msg "Looking for %s guid=%s" title guid) + (condition-case nil + (catch 'found + (when (and desc newsticker-desc-comp-max + (> (length desc) newsticker-desc-comp-max)) + (setq desc (substring desc 0 newsticker-desc-comp-max))) + (mapc + (lambda (this-feed) + (when (eq (car this-feed) feed) + (mapc (lambda (anitem) + (when (cond (guid + ;; global unique id can match + (string= guid (newsticker--guid anitem))) + (t;;FIXME? + (or + ;; or title, desc, etc. + (and + ;;(or (not (eq age 'feed)) + ;; (eq (newsticker--age anitem) 'feed)) + (string= (newsticker--title anitem) + title) + (or (not link) + (string= (newsticker--link anitem) + link)) + (or (not desc) + (if (and desc newsticker-desc-comp-max + (> (length (newsticker--desc + anitem)) + newsticker-desc-comp-max)) + (string= (substring + (newsticker--desc anitem) + 0 + newsticker-desc-comp-max) + desc) + (string= (newsticker--desc anitem) + desc))))))) + ;;(newsticker--debug-msg "Found %s guid=%s" + ;; (newsticker--title anitem) + ;; (newsticker--guid anitem)) + (throw 'found anitem))) + (cdr this-feed)))) + data) + ;;(newsticker--debug-msg "Found nothing") + nil) + (error nil))) + +(defun newsticker--cache-add (data feed-name-symbol title desc link time age + position extra-elements + &optional updated-time updated-age + preformatted-contents + preformatted-title) + "Add another item to cache data. +Add to DATA in the FEED-NAME-SYMBOL an item with TITLE, DESC, +LINK, TIME, AGE, POSITION, and EXTRA-ELEMENTS. If this item is +contained already, its time is set to UPDATED-TIME, its mark is +set to UPDATED-AGE, and its pre-formatted contents is set to +PREFORMATTED-CONTENTS and PREFORMATTED-TITLE. Returns the age +which the item got." + (let* ((guid (newsticker--guid-to-string (assoc 'guid extra-elements))) + (item (newsticker--cache-contains data feed-name-symbol title desc link + age guid))) + ;;(message "guid=%s" guid) + (if item + ;; does exist already -- change age, update time and position + (progn + ;;(newsticker--debug-msg "Updating item %s %s %s %s %s -> %s %s + ;; (guid %s -> %s)" + ;; feed-name-symbol title link time age + ;; updated-time updated-age + ;; guid (newsticker--guid item)) + (if (nthcdr 5 item) + (setcar (nthcdr 5 item) position) + (setcdr (nthcdr 4 item) (list position))) + (setcar (nthcdr 4 item) updated-age) + (if updated-time + (setcar (nthcdr 3 item) updated-time)) + ;; replace cached pre-formatted contents + (newsticker--cache-set-preformatted-contents + item preformatted-contents) + (newsticker--cache-set-preformatted-title + item preformatted-title)) + ;; did not exist or age equals 'feed-name-symbol + (setq item (list title desc link time age position preformatted-contents + preformatted-title extra-elements)) + ;;(newsticker--debug-msg "Adding item %s" item) + (catch 'found + (mapc (lambda (this-feed) + (when (eq (car this-feed) feed-name-symbol) + (setcdr this-feed (nconc (cdr this-feed) (list item))) + (throw 'found this-feed))) + data) + ;; the feed is not contained + (add-to-list 'data (list feed-name-symbol item) t)))) + data) + +(defun newsticker--cache-remove (data feed-symbol age) + "Remove all entries from DATA in the feed FEED-SYMBOL with AGE. +FEED-SYMBOL may be 'any. Entries from old feeds, which are no longer in +`newsticker-url-list' or `newsticker-url-list-defaults', are removed as +well." + (let* ((pos data) + (feed (car pos)) + (last-pos nil)) + (while feed + (if (or (assoc (symbol-name (car feed)) newsticker-url-list) + (assoc (symbol-name (car feed)) newsticker-url-list-defaults)) + ;; feed is still valid=active + ;; (message "Keeping feed %s" (car feed)) + (if (or (eq feed-symbol 'any) + (eq feed-symbol (car feed))) + (let* ((item-pos (cdr feed)) + (item (car item-pos)) + (prev-pos nil)) + (while item + ;;(message "%s" (car item)) + (if (eq age (newsticker--age item)) + ;; remove this item + (progn + ;;(message "Removing item %s" (car item)) + (if prev-pos + (setcdr prev-pos (cdr item-pos)) + (setcdr feed (cdr item-pos)))) + ;;(message "Keeping item %s" (car item)) + (setq prev-pos item-pos)) + (setq item-pos (cdr item-pos)) + (setq item (car item-pos))))) + ;; feed is not active anymore + ;; (message "Removing feed %s" (car feed)) + (if last-pos + (setcdr last-pos (cdr pos)) + (setq data (cdr pos)))) + (setq last-pos pos) + (setq pos (cdr pos)) + (setq feed (car pos))))) + +;; ====================================================================== +;;; Sorting +;; ====================================================================== +(defun newsticker--cache-item-compare-by-time (item1 item2) + "Compare two news items ITEM1 and ITEM2 by comparing their time values." + (catch 'result + (let ((age1 (newsticker--age item1)) + (age2 (newsticker--age item2))) + (if (not (eq age1 age2)) + (cond ((eq age1 'obsolete) + (throw 'result nil)) + ((eq age2 'obsolete) + (throw 'result t))))) + (let* ((time1 (newsticker--time item1)) + (time2 (newsticker--time item2))) + (cond ((< (nth 0 time1) (nth 0 time2)) + nil) + ((> (nth 0 time1) (nth 0 time2)) + t) + ((< (nth 1 time1) (nth 1 time2)) + nil) + ((> (nth 1 time1) (nth 1 time2)) + t) + ((< (or (nth 2 time1) 0) (or (nth 2 time2) 0)) + nil) + ((> (or (nth 2 time1) 0) (or (nth 2 time2) 0)) + t) + (t + nil))))) + +(defun newsticker--cache-item-compare-by-title (item1 item2) + "Compare ITEM1 and ITEM2 by comparing their titles." + (catch 'result + (let ((age1 (newsticker--age item1)) + (age2 (newsticker--age item2))) + (if (not (eq age1 age2)) + (cond ((eq age1 'obsolete) + (throw 'result nil)) + ((eq age2 'obsolete) + (throw 'result t))))) + (string< (newsticker--title item1) (newsticker--title item2)))) + +(defun newsticker--cache-item-compare-by-position (item1 item2) + "Compare ITEM1 and ITEM2 by comparing their original positions." + (catch 'result + (let ((age1 (newsticker--age item1)) + (age2 (newsticker--age item2))) + (if (not (eq age1 age2)) + (cond ((eq age1 'obsolete) + (throw 'result nil)) + ((eq age2 'obsolete) + (throw 'result t))))) + (< (or (newsticker--pos item1) 0) (or (newsticker--pos item2) 0)))) + + + +(defun newsticker--cache-save () + "Update and save newsticker cache file." + (interactive) + (newsticker--cache-update t)) + +(defun newsticker--cache-update (&optional save) + "Update newsticker cache file. +If optional argument SAVE is not nil the cache file is saved to disk." + (save-excursion + (let ((coding-system-for-write 'utf-8)) + (with-temp-buffer + (setq buffer-undo-list t) + (erase-buffer) + (insert ";; -*- coding: utf-8 -*-\n") + (insert (prin1-to-string newsticker--cache)) + (when save + (set-visited-file-name newsticker-cache-filename) + (save-buffer)))))) + +(defun newsticker--cache-get-feed (feed) + "Return the cached data for the feed FEED. +FEED is a symbol!" + (assoc feed newsticker--cache)) + +;; ====================================================================== +;;; Statistics +;; ====================================================================== +(defun newsticker--stat-num-items (feed &rest ages) + "Return number of items in the given FEED which have one of the given AGES. +If AGES is nil, the total number of items is returned." + (let ((items (cdr (newsticker--cache-get-feed feed))) + (num 0)) + (while items + (if ages + (if (memq (newsticker--age (car items)) ages) + (setq num (1+ num))) + (if (memq (newsticker--age (car items)) '(new old immortal obsolete)) + (setq num (1+ num)))) + (setq items (cdr items))) + num)) + +(defun newsticker--stat-num-items-total (&optional age) + "Return total number of items in all feeds which have the given AGE. +If AGE is nil, the total number of items is returned." + (apply '+ + (mapcar (lambda (feed) + (if age + (newsticker--stat-num-items (intern (car feed)) age) + (newsticker--stat-num-items (intern (car feed))))) + (append newsticker-url-list-defaults newsticker-url-list)))) + +;; ====================================================================== +;;; OPML +;; ====================================================================== +(defun newsticker-opml-export () + "OPML subscription export. +Export subscriptions to a buffer in OPML Format." + (interactive) + (with-current-buffer (get-buffer-create "*OPML Export*") + (set-buffer-file-coding-system 'utf-8) + (insert (concat + "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" + "<!-- OPML generated by Emacs newsticker.el -->\n" + "<opml version=\"1.0\">\n" + " <head>\n" + " <title>mySubscriptions</title>\n" + " <dateCreated>" (format-time-string "%a, %d %b %Y %T %z") + "</dateCreated>\n" + " <ownerEmail>" user-mail-address "</ownerEmail>\n" + " <ownerName>" (user-full-name) "</ownerName>\n" + " </head>\n" + " <body>\n")) + (mapc (lambda (sub) + (insert " <outline text=\"") + (insert (newsticker--title sub)) + (insert "\" xmlUrl=\"") + (insert (cadr sub)) + (insert "\"/>\n")) + (append newsticker-url-list newsticker-url-list-defaults)) + (insert " </body>\n</opml>\n")) + (pop-to-buffer "*OPML Export*") + (when (fboundp 'sgml-mode) + (sgml-mode))) + +(defun newsticker--opml-import-outlines (outlines) + "Recursively import OUTLINES from OPML data. +Note that nested outlines are currently flattened -- i.e. grouping is +removed." + (mapc (lambda (outline) + (let ((name (xml-get-attribute outline 'text)) + (url (xml-get-attribute outline 'xmlUrl)) + (children (xml-get-children outline 'outline))) + (unless (string= "" url) + (add-to-list 'newsticker-url-list + (list name url nil nil nil) t)) + (if children + (newsticker--opml-import-outlines children)))) + outlines)) + +(defun newsticker-opml-import (filename) + "Import OPML data from FILENAME." + (interactive "fOPML file: ") + (set-buffer (find-file-noselect filename)) + (goto-char (point-min)) + (let* ((node-list (xml-parse-region (point-min) (point-max))) + (body (car (xml-get-children (car node-list) 'body))) + (outlines (xml-get-children body 'outline))) + (newsticker--opml-import-outlines outlines)) + (customize-variable 'newsticker-url-list)) + +;; ====================================================================== +;;; Auto marking +;; ====================================================================== +(defun newsticker--run-auto-mark-filter (feed item) + "Automatically mark an item as old or immortal. +This function checks the variable `newsticker-auto-mark-filter-list' +for an entry that matches FEED and ITEM." + (let ((case-fold-search t)) + (mapc (lambda (filter) + (let ((filter-feed (car filter)) + (pattern-list (cadr filter))) + (when (string-match filter-feed feed) + (newsticker--do-run-auto-mark-filter item pattern-list)))) + newsticker-auto-mark-filter-list))) + +(defun newsticker--do-run-auto-mark-filter (item list) + "Actually compare ITEM against the pattern-LIST. +LIST must be an element of `newsticker-auto-mark-filter-list'." + (mapc (lambda (pattern) + (let ((age (nth 0 pattern)) + (place (nth 1 pattern)) + (regexp (nth 2 pattern)) + (title (newsticker--title item)) + (desc (newsticker--desc item))) + (when (or (eq place 'title) (eq place 'all)) + (when (and title (string-match regexp title)) + (newsticker--debug-msg "Auto-marking as %s: `%s'" + age (newsticker--title item)) + (setcar (nthcdr 4 item) age))) + (when (or (eq place 'description) (eq place 'all)) + (when (and desc (string-match regexp desc)) + (newsticker--debug-msg "Auto-marking as %s: `%s'" + age (newsticker--title item)) + (setcar (nthcdr 4 item) age))))) + list)) + + +;; ====================================================================== +;;; Hook samples +;; ====================================================================== +(defun newsticker-new-item-functions-sample (feed item) + "Demonstrate the use of the `newsticker-new-item-functions' hook. +This function just prints out the values of the FEED and title of the ITEM." + (message (concat "newsticker-new-item-functions-sample: feed=`%s', " + "title=`%s'") + feed (newsticker--title item))) + +(defun newsticker-download-images (feed item) + "Download the first image. +If FEED equals \"imagefeed\" download the first image URL found +in the description=contents of ITEM to the directory +\"~/tmp/newsticker/FEED/TITLE\" where TITLE is the title of the item." + (when (string= feed "imagefeed") + (let ((title (newsticker--title item)) + (desc (newsticker--desc item))) + (when (string-match "<img src=\"\\(http://[^ \"]+\\)\"" desc) + (let ((url (substring desc (match-beginning 1) (match-end 1))) + (temp-dir (concat "~/tmp/newsticker/" feed "/" title)) + (org-dir default-directory)) + (unless (file-directory-p temp-dir) + (make-directory temp-dir t)) + (cd temp-dir) + (message "Getting image %s" url) + (apply 'start-process "wget-image" + " *newsticker-wget-download-images*" + newsticker-wget-name + (list url)) + (cd org-dir)))))) + +(defun newsticker-download-enclosures (feed item) + "In all FEEDs download the enclosed object of the news ITEM. +The object is saved to the directory \"~/tmp/newsticker/FEED/TITLE\", which +is created if it does not exist. TITLE is the title of the news +item. Argument FEED is ignored. +This function is suited for adding it to `newsticker-new-item-functions'." + (let ((title (newsticker--title item)) + (enclosure (newsticker--enclosure item))) + (when enclosure + (let ((url (cdr (assoc 'url enclosure))) + (temp-dir (concat "~/tmp/newsticker/" feed "/" title)) + (org-dir default-directory)) + (unless (file-directory-p temp-dir) + (make-directory temp-dir t)) + (cd temp-dir) + (message "Getting enclosure %s" url) + (apply 'start-process "wget-enclosure" + " *newsticker-wget-download-enclosures*" + newsticker-wget-name + (list url)) + (cd org-dir))))) + +;; ====================================================================== +;;; Retrieve samples +;; ====================================================================== +(defun newsticker-retrieve-random-message (feed-name) + "Return an artificial RSS string under the name FEED-NAME." + (concat "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?><rss version=\"0.91\">" + "<channel>" + "<title>newsticker-retrieve-random-message</title>" + "<description>Sample retrieval function</description>" + "<pubDate>FIXME Sat, 07 Sep 2005 00:00:01 GMT</pubDate>" + "<item><title>" (format "Your lucky number is %d" (random 10000)) + "</title><description>" (format "Or maybe it is %d" (random 10000)) + "</description></item></channel></rss>")) + +(provide 'newsticker-backend) + +;;; newsticker-backend.el ends here