Preserve group structure on opml import and export.

* lisp/net/newst-backend.el (newsticker--raw-url-list-defaults),
  (newsticker-url-list-defaults),
  (newsticker--get-news-by-url),
  (newsticker--sentinel-work),
  (newsticker--parse-atom-0.3),
  (newsticker--decode-rfc822-date),
  (newsticker--image-download-by-wget),
  (newsticker--image-save),
  (newsticker--image-download-by-url),
  (newsticker--cache-save),
  (newsticker--stat-num-items): Fix indentation.
  (newsticker-opml-export): Preserve group structure on export.
  (newsticker--opml-insert-elt),
  (newsticker--opml-insert-group),
  (newsticker--opml-insert-feed): New.
  (newsticker--opml-import-outlines):
  (newsticker-opml-import): Preserve group structure on import. (Fixes
  fourth issue in Bug#41376.)

1 files changed, 127 insertions, 91 deletions

diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el
index f5b47610787..9096d681a82 100644
--- a/lisp/net/newst-backend.el
+++ b/lisp/net/newst-backend.el
@@ -66,35 +66,34 @@ considered to be running if the newsticker timer list is not empty."
 
 ;; Hard-coding URLs like this is a recipe for propagating obsolete info.
 (defconst newsticker--raw-url-list-defaults
-  '(
-    ("Debian Security Advisories"
-    "http://www.debian.org/security/dsa.en.rdf")
+  '(("Debian Security Advisories"
+     "http://www.debian.org/security/dsa.en.rdf")
     ("Debian Security Advisories - Long format"
-    "http://www.debian.org/security/dsa-long.en.rdf")
+     "http://www.debian.org/security/dsa-long.en.rdf")
     ("Emacs Wiki"
-    "https://www.emacswiki.org/emacs?action=rss"
-    nil
-    3600)
+     "https://www.emacswiki.org/emacs?action=rss"
+     nil
+     3600)
     ("LWN (Linux Weekly News)"
-    "https://lwn.net/headlines/rss")
+     "https://lwn.net/headlines/rss")
     ("Quote of the day"
-    "http://feeds.feedburner.com/quotationspage/qotd"
-    "07:00"
-    86400)
+     "http://feeds.feedburner.com/quotationspage/qotd"
+     "07:00"
+     86400)
     ("The Register"
-    "https://www.theregister.co.uk/headlines.rss")
+     "https://www.theregister.co.uk/headlines.rss")
     ("slashdot"
-    "http://rss.slashdot.org/Slashdot/slashdot"
-    nil
-    3600)                        ;/. will ban you if under 3600 seconds!
+     "http://rss.slashdot.org/Slashdot/slashdot"
+     nil
+     3600)                        ;/. will ban you if under 3600 seconds!
     ("Wired News"
-    "https://www.wired.com/feed/rss")
+     "https://www.wired.com/feed/rss")
     ("Heise News (german)"
-    "http://www.heise.de/newsticker/heise.rdf")
+     "http://www.heise.de/newsticker/heise.rdf")
     ("Tagesschau (german)"
-    "http://www.tagesschau.de/newsticker.rdf"
-    nil
-    1800))
+     "http://www.tagesschau.de/newsticker.rdf"
+     nil
+     1800))
   "Default URL list in raw form.
 This list is fed into defcustom via `newsticker--splicer'.")
 
@@ -153,10 +152,10 @@ value effective."
   :group 'newsticker)
 
 (defcustom newsticker-url-list-defaults
- '(("Emacs Wiki"
-    "https://www.emacswiki.org/emacs?action=rss"
-    nil
-    3600))
+  '(("Emacs Wiki"
+     "https://www.emacswiki.org/emacs?action=rss"
+     nil
+     3600))
   "A customizable list of news feeds to select from.
 These were mostly extracted from the Radio Community Server
 <http://rcs.userland.com/>.
@@ -680,8 +679,8 @@ See `newsticker-get-news'."
     (condition-case error-data
         (url-retrieve url 'newsticker--get-news-by-url-callback
                       (list feed-name))
-          (error (message "Error retrieving news from %s: %s" feed-name
-                          error-data))))
+      (error (message "Error retrieving news from %s: %s" feed-name
+                      error-data))))
   (force-mode-line-update))
 
 (defun newsticker--get-news-by-url-callback (status feed-name)
@@ -825,7 +824,7 @@ Argument BUFFER is the buffer of the retrieval process."
                     (setq coding-system (intern (downcase (match-string 1))))
                   (setq coding-system
                         (condition-case nil
-                              (check-coding-system coding-system)
+                            (check-coding-system coding-system)
                           (coding-system-error
                            (message
                             "newsticker.el: ignoring coding system %s for %s"
@@ -936,8 +935,8 @@ Argument BUFFER is the buffer of the retrieval process."
         ;; setup scrollable text
         (when (= 0 (length newsticker--process-ids))
           (when (fboundp 'newsticker--ticker-text-setup) ;silence
-                                                         ;compiler
-                                                         ;warnings
+                                        ;compiler
+                                        ;warnings
             (newsticker--ticker-text-setup)))
         (setq newsticker--latest-update-time (current-time))
         (when something-was-added
@@ -945,8 +944,8 @@ Argument BUFFER is the buffer of the retrieval process."
           (newsticker--cache-save-feed
            (newsticker--cache-get-feed name-symbol))
           (when (fboundp 'newsticker--buffer-set-uptodate) ;silence
-                                                           ;compiler
-                                                           ;warnings
+                                        ;compiler
+                                        ;warnings
             (newsticker--buffer-set-uptodate nil)))
         ;; kill the process buffer if wanted
         (unless newsticker-debug
@@ -1107,8 +1106,8 @@ same as in `newsticker--parse-atom-1.0'."
                     ;; time-fn
                     (lambda (node)
                       (newsticker--decode-rfc822-date
-                            (car (xml-node-children
-                                  (car (xml-get-children node 'modified))))))
+                       (car (xml-node-children
+                             (car (xml-get-children node 'modified))))))
                     ;; guid-fn
                     (lambda (node)
                       (newsticker--guid-to-string
@@ -1679,7 +1678,7 @@ Sat, 07 Sep 2002 00:00:01 GMT
              (message "Cannot decode \"%s\": %s %s" rfc822-string
                       (car error-data) (cdr error-data))
              nil))))
-      nil))
+    nil))
 
 (defun newsticker--lists-intersect-p (list1 list2)
   "Return t if LIST1 and LIST2 share elements."
@@ -1738,27 +1737,27 @@ Save image as FILENAME in DIRECTORY, download it from URL."
   (let* ((proc-name (concat feed-name "-" filename))
          (buffername (concat " *newsticker-wget-image-" proc-name "*"))
          (item (or (assoc feed-name newsticker-url-list)
-                       (assoc feed-name newsticker-url-list-defaults)
-                       (error
-                        "Cannot get image for %s: Check newsticker-url-list"
-                        feed-name)))
+                   (assoc feed-name newsticker-url-list-defaults)
+                   (error
+                    "Cannot get image for %s: Check newsticker-url-list"
+                    feed-name)))
          (wget-arguments (or (car (cdr (cdr (cdr (cdr item)))))
                              newsticker-wget-arguments)))
-        (with-current-buffer (get-buffer-create buffername)
-          (erase-buffer)
-          ;; throw an error if there is an old wget-process around
-          (if (get-process feed-name)
-              (error "Another wget-process is running for image %s"
-                     feed-name))
-          ;; start wget
-          (let* ((args (append wget-arguments (list url)))
-                 (proc (apply 'start-process proc-name buffername
-                              newsticker-wget-name args)))
-            (set-process-coding-system proc 'no-conversion 'no-conversion)
-            (set-process-sentinel proc 'newsticker--image-sentinel)
-            (process-put proc 'nt-directory directory)
-            (process-put proc 'nt-feed-name feed-name)
-            (process-put proc 'nt-filename filename)))))
+    (with-current-buffer (get-buffer-create buffername)
+      (erase-buffer)
+      ;; throw an error if there is an old wget-process around
+      (if (get-process feed-name)
+          (error "Another wget-process is running for image %s"
+                 feed-name))
+      ;; start wget
+      (let* ((args (append wget-arguments (list url)))
+             (proc (apply 'start-process proc-name buffername
+                          newsticker-wget-name args)))
+        (set-process-coding-system proc 'no-conversion 'no-conversion)
+        (set-process-sentinel proc 'newsticker--image-sentinel)
+        (process-put proc 'nt-directory directory)
+        (process-put proc 'nt-feed-name feed-name)
+        (process-put proc 'nt-filename filename)))))
 
 (defun newsticker--image-sentinel (process _event)
   "Sentinel for image-retrieving PROCESS caused by EVENT."
@@ -1783,18 +1782,18 @@ Save image as FILENAME in DIRECTORY, download it from URL."
   "Save contents of BUFFER in DIRECTORY as FILE-NAME.
 Finally kill buffer."
   (with-current-buffer buffer
-      (let ((image-name (concat directory file-name)))
-        (set-buffer-file-coding-system 'no-conversion)
-        ;; make sure the cache dir exists
-        (unless (file-directory-p directory)
-          (make-directory directory))
-        ;; write and close buffer
-        (let ((require-final-newline nil)
-              (backup-inhibited t)
-              (coding-system-for-write 'no-conversion))
-          (write-region nil nil image-name nil 'quiet))
-        (set-buffer-modified-p nil)
-        (kill-buffer buffer))))
+    (let ((image-name (concat directory file-name)))
+      (set-buffer-file-coding-system 'no-conversion)
+      ;; make sure the cache dir exists
+      (unless (file-directory-p directory)
+        (make-directory directory))
+      ;; write and close buffer
+      (let ((require-final-newline nil)
+            (backup-inhibited t)
+            (coding-system-for-write 'no-conversion))
+        (write-region nil nil image-name nil 'quiet))
+      (set-buffer-modified-p nil)
+      (kill-buffer buffer))))
 
 (defun newsticker--image-remove (directory file-name)
   "In DIRECTORY remove FILE-NAME."
@@ -1809,8 +1808,8 @@ Save image as FILENAME in DIRECTORY, download it from URL."
     (condition-case error-data
         (url-retrieve url 'newsticker--image-download-by-url-callback
                       (list feed-name directory filename))
-          (error (message "Error retrieving image from %s: %s" feed-name
-                          error-data))))
+      (error (message "Error retrieving image from %s: %s" feed-name
+                      error-data))))
   (force-mode-line-update))
 
 (defun newsticker--image-download-by-url-callback (status feed-name directory filename)
@@ -2147,11 +2146,11 @@ FEED is a symbol!"
   (concat newsticker-dir "/feeds"))
 
 (defun newsticker--cache-save ()
-    "Save cache data for all feeds."
-    (unless (file-directory-p newsticker-dir)
-      (make-directory newsticker-dir t))
-    (mapc 'newsticker--cache-save-feed newsticker--cache)
-    nil)
+  "Save cache data for all feeds."
+  (unless (file-directory-p newsticker-dir)
+    (make-directory newsticker-dir t))
+  (mapc 'newsticker--cache-save-feed newsticker--cache)
+  nil)
 
 (defun newsticker--cache-save-feed (feed)
   "Save cache data for FEED."
@@ -2217,7 +2216,7 @@ If AGES is nil, the total number of items is returned."
           (if (memq (newsticker--age (car items)) ages)
               (setq num (1+ num)))
         (if (memq (newsticker--age (car items)) '(new old immortal obsolete))
-              (setq num (1+ num))))
+            (setq num (1+ num))))
       (setq items (cdr items)))
     num))
 
@@ -2240,36 +2239,64 @@ Export subscriptions to a buffer in OPML Format."
   ;; FIXME: use newsticker-groups
   (interactive)
   (with-current-buffer (get-buffer-create "*OPML Export*")
+    (erase-buffer)
     (set-buffer-file-coding-system 'utf-8)
     (insert (concat
              "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"
              "<!-- OPML generated by Emacs newsticker.el -->\n"
              "<opml version=\"1.0\">\n"
              "  <head>\n"
-             "    <title>mySubscriptions</title>\n"
+             "    <title>Emacs newsticker subscriptions</title>\n"
              "    <dateCreated>" (format-time-string "%a, %d %b %Y %T %z")
              "</dateCreated>\n"
              "    <ownerEmail>" user-mail-address "</ownerEmail>\n"
              "    <ownerName>" (user-full-name) "</ownerName>\n"
              "  </head>\n"
              "  <body>\n"))
-    (dolist (sub (append newsticker-url-list newsticker-url-list-defaults))
-      (insert "    <outline text=\"")
-      (insert (newsticker--title sub))
-      (insert "\" xmlUrl=\"")
-      (insert (xml-escape-string (let ((url (cadr sub)))
-                                   (if (stringp url) url (prin1-to-string url)))))
-      (insert "\"/>\n"))
-    (insert "  </body>\n</opml>\n"))
+    (let ((feeds (append newsticker-url-list newsticker-url-list-defaults))
+          ;; insert the feed groups and all feeds that are contained
+          (saved-feed-names (newsticker--opml-insert-elt newsticker-groups 2)))
+      ;; to be safe: insert all feeds that are not contained in any group
+      (dolist (f feeds)
+        (unless (seq-find (lambda (sfn) (string= (car f) sfn)) saved-feed-names)
+          (newsticker--opml-insert-feed (car f) 4)))
+      (insert "  </body>\n</opml>\n")))
   (pop-to-buffer "*OPML Export*")
   (when (fboundp 'sgml-mode)
     (sgml-mode)))
 
+(defun newsticker--opml-insert-elt (elt depth)
+  "Insert an OPML ELT with indentation level DEPTH."
+  (if (listp elt)
+      (newsticker--opml-insert-group elt (+ 2 depth))
+    (newsticker--opml-insert-feed elt (+ 2 depth))))
+
+(defun newsticker--opml-insert-group (group depth)
+  "Insert an OPML GROUP with indentation level DEPTH."
+  (let (saved-feeds)
+    (insert (make-string depth ? ) "<outline type=\"folder\" text=\"" (car group) "\">\n")
+    (setq saved-feeds (mapcar (lambda (e)
+                                (newsticker--opml-insert-elt e depth))
+                              (cdr group)))
+    (insert (make-string depth ? ) "</outline>\n")
+    (flatten-tree saved-feeds)))
+
+(defun newsticker--opml-insert-feed (feed-name depth)
+  "Insert an OPML FEED-NAME with indentation level DEPTH."
+  (let* ((feed-definition (seq-find (lambda (f)
+                                      (string= feed-name (car f)))
+                                    (append newsticker-url-list newsticker-url-list-defaults)))
+         (url (nth 1 feed-definition))
+         (url-string (if (functionp url) (prin1-to-string url)
+                       (xml-escape-string url))))
+    (insert (make-string depth ? ) "<outline text=\"" feed-name
+            "\" xmlUrl=\"" url-string
+            "\"/>\n"))
+  feed-name)
+
 (defun newsticker--opml-import-outlines (outlines)
-  "Recursively import OUTLINES from OPML data.
-Note that nested outlines are currently flattened -- i.e. grouping is
-removed."
-  (mapc (lambda (outline)
+  "Recursively import OUTLINES from OPML data."
+  (mapcar (lambda (outline)
             (let ((name (xml-get-attribute outline 'text))
                   (url (xml-get-attribute outline 'xmlUrl))
                   (children (xml-get-children outline 'outline)))
@@ -2277,18 +2304,27 @@ removed."
                 (add-to-list 'newsticker-url-list
                              (list name url nil nil nil) t))
               (if children
-                  (newsticker--opml-import-outlines children))))
-        outlines))
+                        (append (list name)
+                                (newsticker--opml-import-outlines children))
+                      name)))
+          outlines))
 
 (defun newsticker-opml-import (filename)
-  "Import OPML data from FILENAME."
+  "Import OPML data from FILENAME.
+Feeds are added to 'newsticker-url-list and 'newsticker-groups
+preserving the outline structure."
   (interactive "fOPML file: ")
   (set-buffer (find-file-noselect filename))
   (goto-char (point-min))
   (let* ((node-list (xml-parse-region (point-min) (point-max)))
+         (title (car (xml-node-children
+                      (car (xml-get-children
+                            (car (xml-get-children (car node-list) 'head))
+                            'title)))))
          (body (car (xml-get-children (car node-list) 'body)))
-         (outlines (xml-get-children body 'outline)))
-    (newsticker--opml-import-outlines outlines))
+         (outlines (xml-get-children body 'outline))
+         (imported-groups-data (newsticker--opml-import-outlines outlines)))
+    (add-to-list 'newsticker-groups (cons title imported-groups-data) t))
   (customize-variable 'newsticker-url-list))
 
 ;; ======================================================================