;;; newst-backend.el --- Retrieval backend for newsticker.
-;; Copyright (C) 2003-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2003-2015 Free Software Foundation, Inc.
;; Author: Ulf Jasper <ulf.jasper@web.de>
;; Filename: newst-backend.el
;; URL: http://www.nongnu.org/newsticker
;; Keywords: News, RSS, Atom
-;; Time-stamp: "13. Mai 2011, 20:47:05 (ulf)"
;; Package: newsticker
;; ======================================================================
(require 'derived)
(require 'xml)
+(require 'url-parse)
;; Silence warnings
(defvar w3-mode-map)
"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'.")
;; ======================================================================
;;; 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)
(insert result)
;; remove MIME header
(goto-char (point-min))
- (search-forward "\n\n")
+ (search-forward "\n\n" nil t)
(delete-region (point-min) (point))
;; read the rss/atom contents
- (newsticker--sentinel-work nil t feed-name "url-retrieve" (current-buffer))
+ (newsticker--sentinel-work nil
+ (or (not status)
+ (not (eq (car status) :error)))
+ feed-name "url-retrieve"
+ (current-buffer))
(when status
(let ((status-type (car status))
(status-details (cdr status)))
)
((eq status-type :error)
(message "%s: Error while retrieving news from %s: %s: \"%s\""
- (format-time-string "%A, %H:%M" (current-time))
+ (format-time-string "%A, %H:%M")
feed-name
(car status-details) (cdr status-details))))))))
newsticker-wget-name args)))
(set-process-coding-system proc 'no-conversion 'no-conversion)
(set-process-sentinel proc 'newsticker--sentinel)
+ (process-put proc 'nt-feed-name feed-name)
(setq newsticker--process-ids (cons (process-id proc)
newsticker--process-ids))
(force-mode-line-update)))))
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))
+ (format-time-string "%A, %H:%M")
feed-name)
(let* ((item (or (assoc feed-name newsticker-url-list)
(assoc feed-name newsticker-url-list-defaults)
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))
+ (feed-name (process-get process 'nt-feed-name))
(command (process-command process))
(buffer (process-buffer process)))
(newsticker--sentinel-work event
(and (eq p-status 'exit)
(= exit-status 0))
- name command buffer)))
+ feed-name command buffer)))
-(defun newsticker--sentinel-work (event status-ok name command buffer)
+(defun newsticker--sentinel-work (event status-ok feed-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 FEED-NAME is the name of the retrieved feed.
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))
+ (name-symbol (intern feed-name))
+ (something-was-added nil)
+ (ct (current-time)))
;; catch known errors (zombie processes, rubbish-xml etc.
;; if an error occurs the news feed is not updated!
(catch 'oops
(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)
+ (format-time-string "%A, %H:%M")
+ feed-name event command)
""
- (current-time)
+ ct
'new
- 0 nil))
+ 0 '((guid nil "newsticker--download-error"))
+ ct))
(message "%s: Error while retrieving news from %s"
- (format-time-string "%A, %H:%M" (current-time))
- name)
+ (format-time-string "%A, %H:%M")
+ feed-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)
+ (unless (fboundp 'libxml-parse-xml-region)
+ (newsticker--do-xml-workarounds))
;; check coding system
(goto-char (point-min))
- (if (re-search-forward "encoding=\"\\([^\"]+\\)\""
+ (if (re-search-forward "encoding=['\"]\\([^\"]+?\\)['\"]"
nil t)
(setq coding-system (intern (downcase (match-string 1))))
(setq coding-system
(coding-system-error
(message
"newsticker.el: ignoring coding system %s for %s"
- coding-system name)
+ coding-system feed-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))
+ ;; The xml parser might fail or the xml might be
+ ;; bugged
+ (if (fboundp 'libxml-parse-xml-region)
+ (list (libxml-parse-xml-region (point-min) (point-max)
+ nil t))
+ (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))
+ (image-url nil)
+ (icon-url nil))
;; mark all items as obsolete
(newsticker--cache-replace-age newsticker--cache
name-symbol
;; 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))
+ (setq image-url (newsticker--get-logo-url-rss-0.91 topnode))
+ (newsticker--parse-rss-0.91 feed-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))
+ (setq image-url (newsticker--get-logo-url-rss-0.92 topnode))
+ (newsticker--parse-rss-0.92 feed-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))
+ ((or (eq 'RDF (xml-node-name topnode))
+ (eq 'rdf:RDF (xml-node-name topnode)))
+ (setq image-url (newsticker--get-logo-url-rss-1.0 topnode))
+ (newsticker--parse-rss-1.0 feed-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))
+ (setq image-url (newsticker--get-logo-url-rss-2.0 topnode))
+ (newsticker--parse-rss-2.0 feed-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))
+ (setq image-url (newsticker--get-logo-url-atom-0.3 topnode))
+ (newsticker--parse-atom-0.3 feed-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))
+ ;; The test for Atom 1.0 does not work when using
+ ;; libxml, as with libxml the namespace attribute is
+ ;; not in the xml tree. For the time being we skip
+ ;; the check and assume that we are dealing with an
+ ;; Atom 1.0 feed.
+
+ ;; (and (eq 'feed (xml-node-name topnode))
+ ;; (string= "http://www.w3.org/2005/Atom"
+ ;; (xml-get-attribute topnode 'xmlns)))
+ (setq image-url (newsticker--get-logo-url-atom-1.0 topnode))
+ (setq icon-url (newsticker--get-icon-url-atom-1.0 topnode))
+ (newsticker--parse-atom-1.0 feed-name time topnode))
+ ;; unknown feed type
+ ;; (t
+ ;; (newsticker--debug-msg "Feed type unknown: %s: %s"
+ ;; (xml-node-name topnode) feed-name)
+ ;; nil)
+ )
(setq something-was-added t))
- (error (message "sentinelerror in %s: %s" name error-data)))
+ (error (message "sentinelerror in %s: %s" feed-name error-data)))
;; Remove those old items from cache which have been removed from
;; the feed
;; 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)))))
+ ;; launch retrieval of images
+ (when (and (boundp 'newsticker-download-logos)
+ newsticker-download-logos)
+ ;; feed logo
+ (when image-url
+ (newsticker--image-get feed-name feed-name (newsticker--images-dir)
+ image-url))
+ ;; icon / favicon
+ (setq icon-url
+ (or icon-url
+ (let* ((feed-url (newsticker--link (cadr (newsticker--cache-get-feed
+ (intern feed-name)))))
+ (uri (url-generic-parse-url feed-url)))
+ (when (and feed-url uri)
+ (setf (url-filename uri) nil)
+ (setf (url-target uri) nil)
+ (concat (url-recreate-url uri) "favicon.ico")))))
+ (when icon-url
+ (newsticker--image-get feed-name
+ (concat feed-name "."
+ (file-name-extension icon-url))
+ (newsticker--icons-dir)
+ icon-url))))))
(when newsticker--sentinel-callback
(funcall newsticker--sentinel-callback)))
+(defun newsticker--do-xml-workarounds ()
+ "Fix all issues which `xml-parse-region' could be choking on."
+
+ ;; 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))
+
+
(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-icon-url-atom-1.0 (node)
+ "Return icon URL from atom 1.0 data in NODE."
+ (car (xml-node-children
+ (car (xml-get-children node 'icon)))))
+
(defun newsticker--get-logo-url-atom-0.3 (node)
"Return logo URL from atom 0.3 data in NODE."
(car (xml-node-children
(xml-node-children node))))
(or new-item new-feed)))
+(defun newsticker--unxml (node)
+ "Reverse parsing of an xml string.
+Restore an xml-string from a an xml NODE that was returned by xml-parse..."
+ (if (or (not node) (stringp node))
+ node
+ (newsticker--unxml-node node)))
+
+(defun newsticker--unxml-node (node)
+ "Actually restore xml-string of an xml NODE."
+ (let ((qname (symbol-name (car node)))
+ (att-list (cadr node))
+ (children (cddr node)))
+ (concat "<" qname
+ (when att-list " ")
+ (mapconcat 'newsticker--unxml-attribute att-list " ")
+ ">"
+ (mapconcat 'newsticker--unxml children "") "</" qname ">")))
+
+(defun newsticker--unxml-attribute (attribute)
+ "Actually restore xml-string of an ATTRIBUTE of an xml node."
+ (let ((name (symbol-name (car attribute)))
+ (value (cdr attribute)))
+ (concat name "=\"" value "\"")))
+
(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
(car (xml-get-children node 'title)))))
;; desc-fn
(lambda (node)
- (or (car (xml-node-children
- (car (xml-get-children node 'content))))
+ ;; unxml the content or the summary node. Atom
+ ;; allows for integrating (x)html into the atom
+ ;; structure but we need the raw html string.
+ ;; e.g. http://www.heise.de/open/news/news-atom.xml
+ ;; http://feeds.feedburner.com/ru_nix_blogs
+ (or (newsticker--unxml
+ (car (xml-node-children
+ (car (xml-get-children node 'content)))))
+ (newsticker--unxml
+ (car (xml-node-children
+ (car (xml-get-children node 'summary)))))
(car (xml-node-children
(car (xml-get-children node 'summary))))))
;; link-fn
(car (xml-node-children
(car (xml-get-children channelnode 'title))))
;; desc
- (car (xml-node-children
- (car (xml-get-children channelnode
- 'description))))
+ (or (car (xml-node-children
+ (car (xml-get-children channelnode
+ 'encoded))))
+ (car (xml-node-children
+ (car (xml-get-children channelnode
+ 'content:encoded))))
+ (car (xml-node-children
+ (car (xml-get-children channelnode
+ 'description)))))
;; link
(car (xml-node-children
(car (xml-get-children channelnode 'link))))
;; time-fn
(lambda (node)
(newsticker--decode-iso8601-date
- (car (xml-node-children
- (car (xml-get-children node 'dc:date))))))
+ (or (car (xml-node-children
+ (car (xml-get-children node 'dc:date))))
+ (car (xml-node-children
+ (car (xml-get-children node 'date)))))))
;; guid-fn
(lambda (node)
nil)
(car (xml-node-children
(car (xml-get-children channelnode 'title))))
;; desc
- (car (xml-node-children
- (car (xml-get-children channelnode
- 'description))))
+ (or (car (xml-node-children
+ (car (xml-get-children channelnode
+ 'encoded))))
+ (car (xml-node-children
+ (car (xml-get-children channelnode
+ 'content:encoded))))
+ (car (xml-node-children
+ (car (xml-get-children channelnode
+ 'description)))))
;; link
(car (xml-node-children
(car (xml-get-children channelnode 'link))))
;; desc-fn
(lambda (node)
(or (car (xml-node-children
+ (car (xml-get-children node
+ 'encoded))))
+ (car (xml-node-children
(car (xml-get-children node
'content:encoded))))
(car (xml-node-children
;; decode numeric entities
(setq title (xml-substitute-numeric-entities title))
(when desc
- (setq desc (xml-substitute-numeric-entities desc)))
+ (setq desc (xml-substitute-numeric-entities desc)))
(setq link (xml-substitute-numeric-entities link))
;; remove whitespace from title, desc, and link
(setq title (newsticker--remove-whitespace title))
(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
+ ;; first time we find an 'obsolete-old one in
+ ;; the cache, the following times we find an
+ ;; 'old one
(if (memq prev-age '(obsolete-old old))
(setq age2 'old)
(setq age2 'new)))
;; 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))
+ (let ((extra-elements-with-guid (funcall extra-fn node)))
+ (unless (assoc 'guid extra-elements-with-guid)
+ (setq extra-elements-with-guid
+ (cons `(guid nil ,(funcall guid-fn node))
+ extra-elements-with-guid)))
+ (setq newsticker--cache
+ (newsticker--cache-add
+ newsticker--cache (intern name) title desc link
+ time age1 position extra-elements-with-guid
+ time age2)))
(when item-new-p
(let ((item (newsticker--cache-contains
newsticker--cache (intern name) title
;; ======================================================================
(defun newsticker--images-dir ()
"Return directory where feed images are saved."
- (concat newsticker-dir "/images"))
+ (concat newsticker-dir "/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--images-dir) feed-name)))
+(defun newsticker--icons-dir ()
+ "Return directory where feed icons are saved."
+ (concat newsticker-dir "/icons/"))
+
+(defun newsticker--image-get (feed-name filename directory url)
+ "Get image for FEED-NAME by returning FILENAME from DIRECTORY.
+If the file does no exist or if it is older than 24 hours
+download it from URL first."
+ (let ((image-name (concat directory 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))
+ (format-time-string "%A, %H:%M")
feed-name)
;; download
(newsticker--debug-msg "%s: Getting image for %s"
- (format-time-string "%A, %H:%M" (current-time))
+ (format-time-string "%A, %H:%M")
feed-name)
- (let* ((buffername (concat " *newsticker-wget-image-" feed-name "*"))
- (item (or (assoc feed-name newsticker-url-list)
+ (if (eq newsticker-retrieval-method 'intern)
+ (newsticker--image-download-by-url feed-name filename directory url)
+ (newsticker--image-download-by-wget feed-name filename directory url)))))
+
+(defun newsticker--image-download-by-wget (feed-name filename directory url)
+ "Download image for FEED-NAME using external program.
+Save image as FILENAME in DIRECTORY, download it from URL."
+ (let* ((proc-name (concat feed-name "-" filename))
+ (buffername (concat " *newsticker-wget-image-" proc-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"
+ "Cannot get image for %s: Check newsticker-url-list"
feed-name)))
- (wget-arguments (or (car (cdr (cdr (cdr (cdr item)))))
- newsticker-wget-arguments)))
+ (wget-arguments (or (car (cdr (cdr (cdr (cdr item)))))
+ newsticker-wget-arguments)))
(with-current-buffer (get-buffer-create buffername)
(erase-buffer)
;; throw an error if there is an old wget-process around
feed-name))
;; start wget
(let* ((args (append wget-arguments (list url)))
- (proc (apply 'start-process feed-name buffername
+ (proc (apply 'start-process proc-name buffername
newsticker-wget-name args)))
(set-process-coding-system proc 'no-conversion 'no-conversion)
- (set-process-sentinel proc 'newsticker--image-sentinel)))))))
+ (set-process-sentinel proc 'newsticker--image-sentinel)
+ (process-put proc 'nt-directory directory)
+ (process-put proc 'nt-feed-name feed-name)
+ (process-put proc 'nt-filename filename)))))
(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)))
+ (feed-name (process-get process 'nt-feed-name))
+ (directory (process-get process 'nt-directory))
+ (filename (process-get process 'nt-filename)))
;; 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))
+ (format-time-string "%A, %H:%M")
feed-name)
+ (newsticker--image-remove directory feed-name)
(throw 'oops nil))
- (let (image-name)
- (with-current-buffer (process-buffer process)
- (setq image-name (concat (newsticker--images-dir) feed-name))
- (set-buffer-file-coding-system 'no-conversion)
- ;; make sure the cache dir exists
- (unless (file-directory-p (newsticker--images-dir))
- (make-directory (newsticker--images-dir)))
- ;; 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)))))))
+ (newsticker--image-save (process-buffer process) directory filename))))
+
+(defun newsticker--image-save (buffer directory file-name)
+ "Save contents of BUFFER in DIRECTORY as FILE-NAME.
+Finally kill buffer."
+ (with-current-buffer buffer
+ (let ((image-name (concat directory file-name)))
+ (set-buffer-file-coding-system 'no-conversion)
+ ;; make sure the cache dir exists
+ (unless (file-directory-p directory)
+ (make-directory directory))
+ ;; 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 buffer))))
+
+(defun newsticker--image-remove (directory file-name)
+ "In DIRECTORY remove FILE-NAME."
+ (let ((image-name (concat directory file-name)))
+ (when (file-exists-p file-name)
+ (delete-file image-name))))
+
+(defun newsticker--image-download-by-url (feed-name filename directory url)
+ "Download image for FEED-NAME using `url-retrieve'.
+Save image as FILENAME in DIRECTORY, download it from URL."
+ (let ((coding-system-for-read 'no-conversion))
+ (condition-case error-data
+ (url-retrieve url 'newsticker--image-download-by-url-callback
+ (list feed-name directory filename))
+ (error (message "Error retrieving image from %s: %s" feed-name
+ error-data))))
+ (force-mode-line-update))
+
+(defun newsticker--image-download-by-url-callback (status feed-name directory filename)
+ "Callback function for `newsticker--image-download-by-url'.
+STATUS is the return status as delivered by `url-retrieve'.
+FEED-NAME is the name of the feed that the news were retrieved
+from.
+The image is saved in DIRECTORY as FILENAME."
+ (let ((do-save
+ (or (not status)
+ (let ((status-type (car status))
+ (status-details (cdr status)))
+ (cond ((eq status-type :redirect)
+ ;; don't care about redirects
+ t)
+ ((eq status-type :error)
+ ;; silently ignore errors
+ nil))))))
+ (when do-save
+ (let ((buf (get-buffer-create (concat " *newsticker-url-image-" feed-name "-"
+ directory "*")))
+ (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))
+ ;; save
+ (newsticker--image-save buf directory filename)))))
(defun newsticker--insert-image (img string)
"Insert IMG with STRING at point."
(defun newsticker-opml-export ()
"OPML subscription export.
Export subscriptions to a buffer in OPML Format."
+ ;; FIXME: use newsticker-groups
(interactive)
(with-current-buffer (get-buffer-create "*OPML Export*")
(set-buffer-file-coding-system 'utf-8)
(insert " <outline text=\"")
(insert (newsticker--title sub))
(insert "\" xmlUrl=\"")
- (insert (cadr sub))
+ (insert (xml-escape-string (let ((url (cadr sub)))
+ (if (stringp url) url (prin1-to-string url)))))
(insert "\"/>\n"))
(append newsticker-url-list newsticker-url-list-defaults))
(insert " </body>\n</opml>\n"))