diff options
| -rw-r--r-- | lisp/mastodon-tl.el | 92 | ||||
| -rw-r--r-- | test/mastodon-tl-tests.el | 47 |
2 files changed, 119 insertions, 20 deletions
diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index 252cefd..9fe58ae 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -189,8 +189,12 @@ This also skips tab items in invisible text, i.e. hidden spoiler text." (let* ((word (or (word-at-point) "")) (input (read-string (format "Tag(%s): " word))) (tag (if (equal input "") word input))) - (mastodon-tl--init - (concat "tag-" tag) (concat "timelines/tag/" tag) 'mastodon-tl--timeline))) + (mastodon-tl--show-tag-timeline tag))) + +(defun mastodon-tl--show-tag-timeline (tag) + "Opens a new buffer showing the timeline of posts with hastag TAG." + (mastodon-tl--init + (concat "tag-" tag) (concat "timelines/tag/" tag) 'mastodon-tl--timeline)) (defun mastodon-tl--goto-toot-pos (find-pos refresh &optional pos) "Search for toot with FIND-POS. @@ -356,33 +360,79 @@ TIME-STAMP is assumed to be in the past." 'toot-id id 'toot-json toot)))) -(defun mastodon-tl--render-text (string) - "Returns a propertized text giving the rendering of the given HTML string." +(defun mastodon-tl--render-text (string toot) + "Returns a propertized text giving the rendering of the given HTML string STRING. + +The contents comes from the given TOOT which is used in parsing +links in the text." (with-temp-buffer (insert string) (let ((shr-use-fonts mastodon-tl--enable-proportional-fonts) (shr-width (when mastodon-tl--enable-proportional-fonts (window-width)))) (shr-render-region (point-min) (point-max))) - ;; Make all links a tab stop recognized by our own logic and - ;; update keymaps where needed. - ;; - ;; TODO: Once we have views for users and tags we need to - ;; recognize these links and turn them into links to our own - ;; views. + ;; Make all links a tab stop recognized by our own logic, make things point + ;; to our own logic (e.g. hashtags), and update keymaps where needed: (let (region) (while (setq region (mastodon-tl--find-property-range 'shr-url (or (cdr region) (point-min)))) - (let* ((start (car region)) - (end (cdr region)) - (keymap (if (eq shr-map (get-text-property start 'keymap)) - mastodon-tl--shr-map-replacement - mastodon-tl--shr-image-map-replacement))) - (add-text-properties start end - (list 'mastodon-tab-stop 'shr-url - 'keymap keymap))))) + (mastodon-tl--process-link toot + (car region) (cdr region) + (get-text-property (car region) 'shr-url)))) (buffer-string))) +(defun mastodon-tl--process-link (toot start end url) + (let* (mastodon-tab-stop-type + keymap + (help-echo (get-text-property start 'help-echo)) + extra-properties + (parsed-url (url-generic-parse-url url)) + (toot-url (mastodon-tl--field 'url toot)) + (toot-url (when toot-url (url-generic-parse-url toot-url))) + (toot-instance-url (if toot-url + (concat (url-type toot-url) "://" + (url-host toot-url)) + mastodon-instance-url)) + (maybe-hashtag (mastodon-tl--extract-hashtag-from-url + url toot-instance-url))) + ;; TODO: Recognize user handles + (cond (;; Hashtags: + maybe-hashtag + (setq mastodon-tab-stop-type 'hashtag + keymap mastodon-tl--link-keymap + help-echo (concat "Browse tag #" maybe-hashtag) + extra-properties (list 'mastodon-tag maybe-hashtag))) + ;; Anything else: + (t + ;; Leave it as a url handled by shr.el. + ;; (We still have to replace the keymap so that tabbing works.) + (setq keymap (if (eq shr-map (get-text-property start 'keymap)) + mastodon-tl--shr-map-replacement + mastodon-tl--shr-image-map-replacement) + mastodon-tab-stop-type 'shr-url))) + (add-text-properties start end + (append + (list 'mastodon-tab-stop mastodon-tab-stop-type + 'keymap keymap + 'help-echo help-echo) + extra-properties)))) + +(defun mastodon-tl--extract-hashtag-from-url (url instance-url) + "Returns 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)." + (cond + ;; Mastodon type tag link: + ((string-prefix-p (concat instance-url "/tags/") url) + (substring url (length (concat instance-url "/tags/")))) + ;; Link from some other ostatus site we've encountered: + ((string-prefix-p (concat instance-url "/tag/") url) + (substring url (length (concat instance-url "/tag/")))) + ;; If nothing matches we assume it is not a hashtag link: + (t nil))) + (defun mastodon-tl--set-face (string face) "Returns the propertized STRING with the face property set to FACE." (propertize string 'face face)) @@ -419,6 +469,8 @@ LINK-TYPE is the type of link to produce." (let ((link-type (get-text-property position 'mastodon-tab-stop))) (cond ((eq link-type 'content-warning) (mastodon-tl--toggle-spoiler-text position)) + ((eq link-type 'hashtag) + (mastodon-tl--show-tag-timeline (get-text-property position 'mastodon-tag))) (t (error "unknown link type %s" link-type))))) @@ -442,7 +494,7 @@ message is a link which unhides/hides the main body." (string (mastodon-tl--set-face ;; remove trailing whitespace (replace-regexp-in-string "[\t\n ]*\\'" "" - (mastodon-tl--render-text spoiler)) + (mastodon-tl--render-text spoiler toot)) 'default)) (message (concat "\n" " ---------------\n" @@ -480,7 +532,7 @@ message is a link which unhides/hides the main body." "Retrieve text content from TOOT." (let ((content (mastodon-tl--field 'content toot))) (concat - (mastodon-tl--render-text content) + (mastodon-tl--render-text content toot) (mastodon-tl--media toot)))) (defun mastodon-tl--toot (toot) diff --git a/test/mastodon-tl-tests.el b/test/mastodon-tl-tests.el index 189916d..6e75d26 100644 --- a/test/mastodon-tl-tests.el +++ b/test/mastodon-tl-tests.el @@ -821,3 +821,50 @@ constant." ;; The body is invisible again: (should (eq t (get-text-property body-position 'invisible)))))) + +(ert-deftest mastodon-tl--hashtag () + "Should recognise hashtags in a toot and add the required properties to it." + ;; Travis's Emacs doesn't have libxml so we fake things by inputting + ;; propertized text and stubbing shr-render-region + (let* ((fake-input-text + (concat "Tag:" + (propertize + "sampletag" + 'shr-url "https://example.space/tags/sampletag" + 'keymap shr-map + 'help-echo "https://example.space/tags/sampletag") + " some text after")) + (rendered (with-mock + (stub shr-render-region => nil) + (mastodon-tl--render-text + fake-input-text + mastodon-tl-test-base-toot))) + (tag-location 7)) + (should (eq (get-text-property tag-location 'mastodon-tab-stop rendered) + 'hashtag)) + (should (equal (get-text-property tag-location 'mastodon-tag rendered) + "sampletag")) + (should (equal (get-text-property tag-location 'help-echo rendered) + "Browse tag #sampletag")))) + +(ert-deftest mastodon-tl--extract-hashtag-from-url-mastodon-link () + (should (equal (mastodon-tl--extract-hashtag-from-url + "https://example.org/tags/foo" + "https://example.org") + "foo"))) + +(ert-deftest mastodon-tl--extract-hashtag-from-url-other-link () + (should (equal (mastodon-tl--extract-hashtag-from-url + "https://example.org/tag/foo" + "https://example.org") + "foo"))) + +(ert-deftest mastodon-tl--extract-hashtag-from-url-wrong-instance () + (should (null (mastodon-tl--extract-hashtag-from-url + "https://example.org/tags/foo" + "https://other.example.org")))) + +(ert-deftest mastodon-tl--extract-hashtag-from-url-not-tag () + (should (null (mastodon-tl--extract-hashtag-from-url + "https://example.org/@userid" + "https://example.org")))) |