[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] Changes to newsticker-backend.el
|
From: |
Ulf Jasper |
|
Subject: |
[Emacs-diffs] Changes to newsticker-backend.el |
|
Date: |
Fri, 13 Jun 2008 17:08:25 +0000 |
CVSROOT: /sources/emacs
Module name: emacs
Changes by: Ulf Jasper <u11> 08/06/13 17:08:25
Index: newsticker-backend.el
===================================================================
RCS file: newsticker-backend.el
diff -N newsticker-backend.el
--- newsticker-backend.el 12 Jun 2008 05:49:27 -0000 1.6
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,2313 +0,0 @@
-;;; newsticker-backend.el --- Retrieval backend for newsticker.
-
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008
-;; Free Software Foundation, Inc.
-
-;; Author: Ulf Jasper <address@hidden>
-;; Filename: newsticker-backend.el
-;; URL: http://www.nongnu.org/newsticker
-;; Keywords: News, RSS, Atom
-;; Time-stamp: "8. Juni 2008, 17:18:04 (ulf)"
-
-;; ======================================================================
-
-;; This file is part of GNU Emacs.
-
-;; 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 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)
-
-;; arch-tag: 0e37b658-56e9-49ab-90f9-f2df57e1a659
-;;; newsticker-backend.el ends here