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