commit 218d60b2690051456f90f26bac865858322465cc
parent 14ff7cd71726260127de27dc43df909f38d95bcb
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Wed, 26 Jun 2024 07:25:14 +0300
Move from libxml to builtin xml parsing, also:
- Add deduplication function,
- auxiliary functions used by deduplication.
Diffstat:
1 file changed, 84 insertions(+), 23 deletions(-)
diff --git a/get-craftering-opml.el b/get-craftering-opml.el
@@ -40,7 +40,7 @@
blogger-name))))
(defun gco--get-response-buffer ()
- (url-retrieve-synchronously get-craftering-opml--craftering-url))
+ (url-retrieve-synchronously gco--craftering-url))
(defun gco--url-response-body-position (response-buffer)
(with-current-buffer response-buffer
@@ -56,30 +56,91 @@
(t
(loop (1+ position)))))))
+(defun gco--parse-response-buffer-opml (response-buffer)
+ (with-current-buffer response-buffer
+ (let ((beg (gco--url-response-body-position response-buffer))
+ (end (buffer-end 1)))
+ (xml-parse-region beg
+ end
+ response-buffer))))
+
(defun gco--response-buffer-to-elfeed-feed (response-buffer)
- (let ((xml (with-current-buffer response-buffer
- (libxml-parse-xml-region (get-craftering-opml--url-response-body-position get-craftering-opml--buffer)
- (buffer-end 1)))))
+ (let ((xml (gco--parse-response-buffer-opml response-buffer)))
(pcase xml
- (`(opml ((version . ,version-number))
- (head . ,rest-of-head)
- (body nil . ,rest-of-body))
- (named-let loop ((rest-of-body rest-of-body)
- (accumulator '()))
- (pcase rest-of-body
- ('()
- accumulator)
- (`((outline ,rest-of-outline) . ,rest-of-body)
- (let ((text (cdr (assq 'text
- rest-of-outline)))
- (xml-url (cdr (assq 'xmlUrl
- rest-of-outline))))
- (loop rest-of-body
- (cons (list xml-url
- 'blog
- 'craftering
- (gco--blogger-name-to-symbol text))
- accumulator))))))))))
+ (`((opml . ,rest-of-opml))
+ (let ((body (assq 'body rest-of-opml)))
+ (pcase body
+ ;; TODO: What the hell is this?
+ (`(body ,TODO-WHAT-THE-HELL-IS-THIS? . ,outlines)
+ (named-let loop ((outlines outlines)
+ (accumulator '()))
+ (pcase outlines
+ ('()
+ accumulator)
+ (`((outline . (,outline-values)) . ,rest-of-outlines)
+ (let ((text (cdr (assq 'text
+ outline-values)))
+ (xml-url (cdr (assq 'xmlUrl
+ outline-values))))
+ (loop rest-of-outlines
+ (cons (list xml-url
+ 'blog
+ 'craftering
+ (gco--blogger-name-to-symbol text))
+ accumulator)))))))))))))
+
+(defun gco--elfeed-feeds-entry-url (elfeed-feeds-entry)
+ "Takes an `elfeed-feeds' kind of entry as ELFEED-FEEDS-ENTRY and return its URL."
+ (pcase elfeed-feeds-entry
+ (`(,url . ,tags)
+ url)
+ (url
+ url)))
+
+(defun gco--elfeed-feeds-entry-tags (elfeed-feeds-entry)
+ "Takes an `elfeed-feeds' kind of entry as ELFEED-FEEDS-ENTRY and return its list of tags."
+ (pcase elfeed-feeds-entry
+ (`(,url . ,tags)
+ tags)
+ (url
+ '())))
+
+(defun gco--hash-table-to-alist (hash-table)
+ "Convert an hash-table HASH-TABLE to a list.
+
+TODO: There MUST be a standard function for that, right? Send a
+patch if you know."
+ (mapcar (lambda (key)
+ (cons key
+ (gethash key
+ hash-table)))
+ (sort (hash-table-keys hash-table)
+ 'string<)))
+
+(defun gco--deduplicate-elfeed-feeds (elfeed-feeds)
+ (let (;; XXX: Pass ":test 'equal" into make-hash-table so that
+ ;; string comparisons work, otherwise it'll put many of the
+ ;; same string as keys, each with its own values, like:
+ ;;
+ ;;'(("moo" a) ("moo" b)).
+ (hash (make-hash-table :test 'equal)))
+ (named-let loop ((entries elfeed-feeds))
+ (pcase entries
+ ('()
+ '())
+ (`(,entry . ,rest-of-entries)
+ (let* ((url (gco--elfeed-feeds-entry-url entry))
+ (entry-tags (gco--elfeed-feeds-entry-tags entry))
+ (hash-tags (gethash url
+ hash
+ '()))
+ (merged-tags (elfeed-normalize-tags (append hash-tags
+ entry-tags))))
+ (puthash url
+ merged-tags
+ hash)
+ (loop rest-of-entries)))))
+ (gco--hash-table-to-alist hash)))
(provide 'get-craftering-opml)
