Merge branch 'develop' into filters-crud

9 files changed, 106 insertions, 92 deletions

diff --git a/README.org b/README.org
index f514b33..949c90d 100644
--- a/README.org
+++ b/README.org
@@ -1,6 +1,6 @@
 #+TEXINFO_DIR_CATEGORY: Emacs
 #+TEXINFO_DIR_TITLE: Mastodon: (mastodon).
-#+TEXINFO_DIR_DESC: Client for Mastodon on ActivityPub networks.
+#+TEXINFO_DIR_DESC: Client for fediverse services using the Mastodon API.
 
 @@html: <a href="https://elpa.nongnu.org/nongnu/mastodon.html"><img alt="ELPA" src="https://elpa.nongnu.org/nongnu/mastodon.svg"></a>@@
 
diff --git a/lisp/mastodon-profile.el b/lisp/mastodon-profile.el
index 0a17a25..093e0a8 100644
--- a/lisp/mastodon-profile.el
+++ b/lisp/mastodon-profile.el
@@ -127,7 +127,7 @@ It contains details of the current user's account.")
   "Keymap for `mastodon-profile-update-mode'.")
 
 (persist-defvar mastodon-profile-account-settings nil
-                "An alist of account settings saved from the server.
+  "An alist of account settings saved from the server.
 Other clients can change these settings on the server at any
 time, so this list is not the canonical source for settings. It
 is updated on entering mastodon mode and on toggle any setting it
@@ -319,13 +319,13 @@ If value is :json-false, return nil."
 (defun mastodon-profile--update-note-count (&rest _args)
   "Display the character count of the profile note buffer."
   (let* ((inhibit-read-only t)
-        (header-region (mastodon-tl--find-property-range 'note-header
+         (header-region (mastodon-tl--find-property-range 'note-header
+                                                          (point-min)))
+         (count-region (mastodon-tl--find-property-range 'note-counter
                                                          (point-min)))
-        (count-region (mastodon-tl--find-property-range 'note-counter
-                                                        (point-min)))
-        (count (number-to-string (mastodon-toot--count-toot-chars
-                                  (buffer-substring-no-properties
-                                   (cdr header-region) (point-max))))))
+         (count (number-to-string (mastodon-toot--count-toot-chars
+                                   (buffer-substring-no-properties
+                                    (cdr header-region) (point-max))))))
     (add-text-properties (car count-region) (cdr count-region)
                          (list 'display count))))
 
diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el
index 5088212..fbd76ff 100644
--- a/lisp/mastodon-tl.el
+++ b/lisp/mastodon-tl.el
@@ -971,16 +971,20 @@ this should be of the form <at-sign><user id>, e.g. \"@Gargon\"."
           buffer-text ; no instance suffix for local mention
         (concat buffer-text "@" host)))))
 
-(defun mastodon-tl--hashtag-from-url (url _instance-url)
+(defun mastodon-tl--hashtag-from-url (url instance-url)
   "Return the hashtag that URL points to or nil if URL is not a tag link.
 INSTANCE-URL is the url of the instance for the toot that the link
 came from (tag links always point to a page on the instance publishing
 the toot)."
-  ;; FIXME: do we rly need to check it against instance-url?
-  (let* ((parsed (url-generic-parse-url url))
+  ;; TODO: do we rly need to check it against instance-url?
+  ;; test suggests we might
+  (let* ((instance-host (url-host
+                         (url-generic-parse-url instance-url)))
+         (parsed (url-generic-parse-url url))
          (path (url-filename parsed))
          (split (string-split path "/")))
-    (when (string-prefix-p "/tag" path) ;; "/tag/" or "/tags/"
+    (when (and (string= instance-host (url-host parsed))
+               (string-prefix-p "/tag" path)) ;; "/tag/" or "/tags/"
       (nth 2 split))))
 
 
@@ -1237,12 +1241,12 @@ SENSITIVE is a flag from the item's JSON data."
        (if (eq 'hidden (mastodon-tl--property 'sensitive-state :no-move))
            ;; display:
            `( display ,data
-              sensitive-state showing))
-       ;; hide:
-       `( sensitive-state hidden
-          display
-          ,(create-image
-            mastodon-media--sensitive-image-data nil t))))))
+              sensitive-state showing)
+         ;; hide:
+         `( sensitive-state hidden
+            display
+            ,(create-image
+              mastodon-media--sensitive-image-data nil t)))))))
 
 
 ;; POLLS
@@ -1363,19 +1367,18 @@ OPTIONS is an alist."
 (defun mastodon-tl--read-poll-option ()
   "Read a poll option to vote on a poll."
   (let* ((toot (mastodon-tl--property 'item-json))
-         (poll (mastodon-tl--field 'poll toot))
-         (options (mastodon-tl--field 'options poll))
-         (titles (mastodon-tl--map-alist 'title options))
-         (number-seq (number-sequence 1 (length options)))
-         (numbers (mapcar #'number-to-string number-seq))
-         (options-alist (cl-mapcar #'cons numbers titles))
-
-         (candidates (mastodon-tl--format-read-poll-option options-alist))
-         (choice (completing-read "Poll option to vote for: "
-                                  candidates nil :match)))
+         (poll (mastodon-tl--field 'poll toot)))
     (if (null poll)
         (user-error "No poll here")
-      (list (cdr (assoc choice candidates))))))
+      (let* ((options (mastodon-tl--field 'options poll))
+             (titles (mastodon-tl--map-alist 'title options))
+             (number-seq (number-sequence 1 (length options)))
+             (numbers (mapcar #'number-to-string number-seq))
+             (options-alist (cl-mapcar #'cons numbers titles))
+             (candidates (mastodon-tl--format-read-poll-option options-alist))
+             (choice (completing-read "Poll option to vote for: "
+                                      candidates nil :match)))
+        (list (cdr (assoc choice candidates)))))))
 
 (defun mastodon-tl--poll-vote (option)
   "If there is a poll at point, prompt user for OPTION to vote on it."
@@ -2397,7 +2400,7 @@ LANGS is the accumulated array param alist if we re-run recursively."
          (car user-handles)
        (completing-read (cond ((or ; TODO: make this "enable/disable notifications"
                                 (equal action "disable")
-                                   (equal action "enable"))
+                                (equal action "enable"))
                                (format "%s notifications when user posts: " action))
                               ((string-suffix-p "boosts" action)
                                (format "%s by user: " action))
diff --git a/lisp/mastodon-toot.el b/lisp/mastodon-toot.el
index 7c5472b..5f4116f 100644
--- a/lisp/mastodon-toot.el
+++ b/lisp/mastodon-toot.el
@@ -225,7 +225,7 @@ Takes its form from `window-configuration-to-register'.")
   "The text of the toot being composed.")
 
 (persist-defvar mastodon-toot-draft-toots-list nil
-                "A list of toots that have been saved as drafts.
+  "A list of toots that have been saved as drafts.
 For the moment we just put all composed toots in here, as we want
 to also capture toots that are \"sent\" but that don't successfully
 send.")
diff --git a/test/ert-helper.el b/test/ert-helper.el
index 4e634b0..5acdc68 100644
--- a/test/ert-helper.el
+++ b/test/ert-helper.el
@@ -15,9 +15,13 @@
 (load-file "lisp/mastodon-async.el")
 
 ;; load tests in bulk to avoid using deprecated `cask exec'
-(let ((tests (cl-remove-if-not (lambda (x)
-                                 (string-suffix-p "-tests.el" x))
-                               (directory-files "test/." t directory-files-no-dot-files-regexp))))
+(let* ((all-test-files
+        (directory-files "test/." t directory-files-no-dot-files-regexp))
+       (tests
+        (cl-remove-if-not
+         (lambda (x)
+           (string-suffix-p "-tests.el" x))
+         all-test-files)))
   (mapc #'load-file tests))
 
 
diff --git a/test/mastodon-media-tests.el b/test/mastodon-media-tests.el
index abf9a1a..5633ca3 100644
--- a/test/mastodon-media-tests.el
+++ b/test/mastodon-media-tests.el
@@ -5,7 +5,7 @@
 (ert-deftest mastodon-media--get-avatar-rendering ()
   "Should return text with all expected properties."
   (with-mock
-    (mock (image-type-available-p 'imagemagick) => t)
+    ;; (mock (image-type-available-p 'imagemagick) => t)
     (mock (create-image * (when (version< emacs-version "27.1") 'imagemagick) t :height 123) => :mock-image)
 
     (let* ((mastodon-media--avatar-height 123)
@@ -39,7 +39,7 @@
      (should (string= "http://example.org/remote/img.png" (plist-get properties 'image-url)))
      (should (eq mastodon-tl--shr-image-map-replacement (plist-get properties 'keymap)))
      (should (string= "image" (plist-get properties 'mastodon-media-type)))
-     (should (string= "RET/i: load full image (prefix: copy URL), +/-: zoom, r: rotate, o: save preview"
+     (should (string= "RET/i: load full image (prefix: copy URL), +/-: zoom, r: rotate, o: save preview, S: toggle sensitive media"
                       (plist-get properties 'help-echo))))))
 
 (ert-deftest mastodon-media:get-media-link-rendering-gif ()
@@ -63,7 +63,7 @@
      (should (string= "http://example.org/remote/img.png" (plist-get properties 'image-url)))
      (should (eq mastodon-tl--shr-image-map-replacement (plist-get properties 'keymap)))
      (should (string= "gifv" (plist-get properties 'mastodon-media-type)))
-     (should (string= "RET/i: load full image (prefix: copy URL), +/-: zoom, r: rotate, o: save preview\nC-RET: play gifv with mpv"
+     (should (string= "RET/i: load full image (prefix: copy URL), +/-: zoom, r: rotate, o: save preview, S: toggle sensitive media\nC-RET: play gifv with mpv"
                  (plist-get properties 'help-echo))))))
 
 (ert-deftest mastodon-media--load-image-from-url-avatar-with-imagemagic ()
@@ -71,7 +71,7 @@
   (let ((url "http://example.org/image.png")
         (mastodon-media--avatar-height 123))
     (with-mock
-      (mock (image-type-available-p 'imagemagick) => t)
+      ;; (mock (image-type-available-p 'imagemagick) => t)
       (mock (create-image
              *
              (when (version< emacs-version "27.1") 'imagemagick)
@@ -94,8 +94,8 @@
   "Should make the right call to url-retrieve."
   (let ((url "http://example.org/image.png"))
     (with-mock
-      (mock (image-type-available-p 'imagemagick) => nil)
-      (mock (image-transforms-p) => nil)
+      ;; (mock (image-type-available-p 'imagemagick) => nil)
+      ;; (mock (image-transforms-p) => nil)
       (mock (create-image * nil t) => '(image foo))
       (mock (copy-marker 7) => :my-marker )
       (mock (url-retrieve
@@ -115,7 +115,7 @@
   "Should make the right call to url-retrieve."
   (let ((url "http://example.org/image.png"))
     (with-mock
-      (mock (image-type-available-p 'imagemagick) => t)
+      ;; (mock (image-type-available-p 'imagemagick) => t)
       (mock (create-image * nil t) => '(image foo))
       (mock (copy-marker 7) => :my-marker )
       (mock (url-retrieve
@@ -134,8 +134,8 @@
   "Should make the right call to url-retrieve."
   (let ((url "http://example.org/image.png"))
     (with-mock
-      (mock (image-type-available-p 'imagemagick) => nil)
-      (mock (image-transforms-p) => nil)
+      ;; (mock (image-type-available-p 'imagemagick) => nil)
+      ;; (mock (image-transforms-p) => nil)
       (mock (create-image * nil t) => '(image foo))
       (mock (copy-marker 7) => :my-marker )
       (mock (url-retrieve
@@ -156,7 +156,7 @@
   (let ((url "http://example.org/image.png")
         (mastodon-media--avatar-height 123))
     (with-mock
-      (mock (image-type-available-p 'imagemagick) => t)
+      ;; (mock (image-type-available-p 'imagemagick) => t)
       (mock (create-image
              *
              (when (version< emacs-version "27.1") 'imagemagick)
diff --git a/test/mastodon-profile-tests.el b/test/mastodon-profile-tests.el
index e0431b4..289e8d9 100644
--- a/test/mastodon-profile-tests.el
+++ b/test/mastodon-profile-tests.el
@@ -234,23 +234,23 @@ content generation in the function under test."
   (with-mock
     ;; Don't start any image loading:
     (mock (mastodon-media--inline-images * *) => nil)
-    (if (version< emacs-version "27.1")
-        (mock (image-type-available-p 'imagemagick) => t)
-      (mock (image-transforms-p) => t))
-    (mock (mastodon-http--get-json "https://instance.url/api/v1/accounts/1/statuses" nil)
+    ;; (if (version< emacs-version "27.1")
+    ;; (mock (image-type-available-p 'imagemagick) => t)
+    ;; (mock (image-transforms-p) => t))
+    (mock (mastodon-http--get-json * *) ;"https://instance.url/api/v1/accounts/1/statuses"
           =>
           gargon-statuses-json)
     (mock (mastodon-profile--get-statuses-pinned *)
           =>
-          [])
-    (mock (mastodon-profile--relationships-get "1")
+          ())
+    (mock (mastodon-profile--relationships-get *) ;"1")
           =>
           '(((id . "1") (following . :json-false) (showing_reblogs . :json-false) (notifying . :json-false) (followed_by . :json-false) (blocking . :json-false) (blocked_by . :json-false) (muting . :json-false) (muting_notifications . :json-false) (requested . :json-false) (domain_blocking . :json-false) (endorsed . :json-false) (note . ""))))
     ;; Let's not do formatting as that makes it hard to not rely on
     ;; window width and reflowing the text.
     (mock (shr-render-region * *) => nil)
     ;; Don't perform the actual update call at the end.
-    ;;(mock (mastodon-tl--timeline *))
+    ;; (mock (mastodon-tl--timeline *))
     (mock (mastodon-profile--fetch-server-account-settings)
           => '(max_toot_chars 1312 privacy "public" display_name "Eugen" discoverable t locked :json-false bot :json-false sensitive :json-false language ""))
 
@@ -263,34 +263,41 @@ content generation in the function under test."
 
       (should
        (equal
-        (buffer-substring-no-properties (point-min) (point-max))
+        (with-current-buffer "*mastodon-Gargron-statuses*"
+          (buffer-substring-no-properties (point-min) (point-max)))
         (concat
          "\n"
          "[img] [img] \n"
          "Eugen\n"
          "@Gargron\n"
-         " ------------\n"
+         " ――――――――――――\n"
          "<p>Developer of Mastodon and administrator of mastodon.social. I post service announcements, development updates, and personal stuff.</p>\n"
          "_ Patreon __ :: <a href=\"https://www.patreon.com/mastodon\" rel=\"me nofollow noopener noreferrer\" target=\"_blank\"><span class=\"invisible\">https://www.</span><span class=\"\">patreon.com/mastodon</span><span class=\"invisible\"></span></a>_ Homepage _ :: <a href=\"https://zeonfederated.com\" rel=\"me nofollow noopener noreferrer\" target=\"_blank\"><span class=\"invisible\">https://</span><span class=\"\">zeonfederated.com</span><span class=\"invisible\"></span></a>"
          "\n"
          "Joined March 2016"
-         "\n\n"
-         " ------------\n"
-         " TOOTS: 70741 | FOLLOWERS: 470905 | FOLLOWING: 451\n"
-         " ------------\n"
+         "\n\n "
+         mastodon-tl--horiz-bar
          "\n"
-         " ------------\n"
-         "     TOOTS   \n"
-         " ------------\n"
+         " TOOTS: 70741 | FOLLOWERS: 470905 | FOLLOWING: 451\n "
+         mastodon-tl--horiz-bar
          "\n"
-         "<p>Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua.</p> \n"
-         "  Eugen (@Gargron) 2021-11-11 11:11:11\n"
-         "  ------------\n"
+         "\n "
+         mastodon-tl--horiz-bar
          "\n"
+         "    TOOTS    \n "
+         mastodon-tl--horiz-bar
          "\n"
-         "<p><span class=\"h-card\"><a href=\"https://social.bau-ha.us/@CCC\" class=\"u-url mention\">@<span>CCC</span></a></span> At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet.</p> \n"
-         "  Eugen (@Gargron) 2021-11-11 00:00:00\n"
-         "  ------------\n"
+         "\n"
+         "<p>Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua.</p>\n"
+         "  Eugen (@Gargron) 2021-11-11 12:11:11\n  "
+         mastodon-tl--horiz-bar
+         " 0 ⭐ | 0 🔁 | 0 💬\n"
+         "\n"
+         "\n"
+         "<p><span class=\"h-card\"><a href=\"https://social.bau-ha.us/@CCC\" class=\"u-url mention\">@<span>CCC</span></a></span> At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet.</p>\n"
+         "  Eugen (@Gargron) 2021-11-11 01:00:00\n  "
+         mastodon-tl--horiz-bar
+         " 0 ⭐ | 2 🔁 | 0 💬\n"
          "\n"
          )))
 
diff --git a/test/mastodon-search-tests.el b/test/mastodon-search-tests.el
index 8dc597a..c736c35 100644
--- a/test/mastodon-search-tests.el
+++ b/test/mastodon-search-tests.el
@@ -139,12 +139,12 @@
     '("TeamBringBackVisibleScrollbars"
       "https://todon.nl/tags/TeamBringBackVisibleScrollbars"))))
 
-(ert-deftest mastodon-search--get-status-info ()
-  "Should return a list of ID, timestamp, content, and spoiler."
-  (should
-   (equal
-    (mastodon-search--get-status-info mastodon-search--test-single-status)
-    '("107230316503209282"
-      "2021-11-06T13:19:40.628Z"
-      ""
-      "<p>This is a nice test toot, for testing purposes. Thank you.</p>"))))
+;; (ert-deftest mastodon-search--get-status-info ()
+;;   "Should return a list of ID, timestamp, content, and spoiler."
+;;   (should
+;;    (equal
+;;     (mastodon-search--get-status-info mastodon-search--test-single-status)
+;;     '("107230316503209282"
+;;       "2021-11-06T13:19:40.628Z"
+;;       ""
+;;       "<p>This is a nice test toot, for testing purposes. Thank you.</p>"))))
diff --git a/test/mastodon-tl-tests.el b/test/mastodon-tl-tests.el
index 02e1157..6d9ab9a 100644
--- a/test/mastodon-tl-tests.el
+++ b/test/mastodon-tl-tests.el
@@ -41,9 +41,9 @@
              (following_count . 13)
              (statuses_count . 101)
              (note . "E"))
-    (media_attachments . [])
-    (mentions . [])
-    (tags . [])
+    (media_attachments . ())
+    (mentions . ())
+    (tags . ())
     (uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status")
     (url . "https://example.space/users/acct42/updates/123456789")
     (content . "<p>Just some text</p>")
@@ -70,9 +70,9 @@
              (following_count . 13)
              (statuses_count . 101)
              (note . "E"))
-    (media_attachments . [])
-    (mentions . [])
-    (tags . [])
+    (media_attachments . ())
+    (mentions . ())
+    (tags . ())
     (uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status")
     (url . "https://example.space/users/acct42/updates/123456789")
     (reblogs_count . 0)
@@ -95,12 +95,12 @@
                      (following_count . 1)
                      (statuses_count . 1)
                      (note . "Other account"))
-            (media_attachments . [])
-            (mentions . [((url . "https://mastodon.social/@johnson")
+            (media_attachments . ())
+            (mentions . (((url . "https://mastodon.social/@johnson")
                           (acct . "acct42")
                           (id . 42)
-                          (username . "acct42"))])
-            (tags . [])
+                          (username . "acct42"))))
+            (tags . ())
             (uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status")
             (content . "<p><span class=\"h-card\"><a href=\"https://example.space/@acct42\">@<span>acct42</span></a></span> boost</p>")
             (url . "https://example.space/users/acct42/updates/123456789")
@@ -1014,27 +1014,27 @@ constant."
 
 (ert-deftest mastodon-tl--extract-hashtag-from-url-mastodon-link ()
   "Should extract the hashtag from a tags url."
-  (should (equal (mastodon-tl--extract-hashtag-from-url
+  (should (equal (mastodon-tl--hashtag-from-url
 		  "https://example.org/tags/foo"
 		  "https://example.org")
 		 "foo")))
 
 (ert-deftest mastodon-tl--extract-hashtag-from-url-other-link ()
   "Should extract the hashtag from a tag url."
-  (should (equal (mastodon-tl--extract-hashtag-from-url
+  (should (equal (mastodon-tl--hashtag-from-url
 		  "https://example.org/tag/foo"
 		  "https://example.org")
 		 "foo")))
 
 (ert-deftest mastodon-tl--extract-hashtag-from-url-wrong-instance ()
   "Should not find a tag when the instance doesn't match."
-  (should (null (mastodon-tl--extract-hashtag-from-url
+  (should (null (mastodon-tl--hashtag-from-url
 		 "https://example.org/tags/foo"
 		 "https://other.example.org"))))
 
 (ert-deftest mastodon-tl--extract-hashtag-from-url-not-tag ()
   "Should not find a hashtag when not a tag url"
-  (should (null (mastodon-tl--extract-hashtag-from-url
+  (should (null (mastodon-tl--hashtag-from-url
 		 "https://example.org/@userid"
 		 "https://example.org"))))
 
@@ -1063,20 +1063,20 @@ constant."
 
 (ert-deftest mastodon-tl--extract-userhandle-from-url-correct-case ()
   "Should extract the user handle from url."
-  (should (equal (mastodon-tl--extract-userhandle-from-url
+  (should (equal (mastodon-tl--userhandle-from-url
                   "https://example.org/@someuser"
                   "@SomeUser")
                  "@SomeUser@example.org")))
 
 (ert-deftest mastodon-tl--extract-userhandle-from-url-missing-at-in-text ()
   "Should not extract a user handle from url if the text is wrong."
-  (should (null (mastodon-tl--extract-userhandle-from-url
+  (should (null (mastodon-tl--userhandle-from-url
                  "https://example.org/@someuser"
                  "SomeUser"))))
 
 (ert-deftest mastodon-tl--extract-userhandle-from-url-query-in-url ()
   "Should not extract a user handle from url if there is a query param."
-  (should (null (mastodon-tl--extract-userhandle-from-url
+  (should (null (mastodon-tl--userhandle-from-url
                  "https://example.org/@someuser?shouldnot=behere"
                  "SomeUser"))))