From 3602d13fe7687a3b931ba037365191307e99da8d Mon Sep 17 00:00:00 2001 From: Holger Dürer Date: Mon, 5 Jun 2017 18:19:18 +0100 Subject: More robust bad url detection. --- lisp/mastodon-media.el | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/mastodon-media.el b/lisp/mastodon-media.el index f5d67ca..0a4c3de 100644 --- a/lisp/mastodon-media.el +++ b/lisp/mastodon-media.el @@ -201,9 +201,10 @@ found." "Checks to make sure that the missing string has not been returned." - (let ((missing "/files/small/missing.png")) - (and link - (not (equal link missing))))) + (and link + (> (length link) 8) + (or (string= "http://" (substring link 0 7)) + (string= "https://" (substring link 0 8))))) (defun mastodon-media--inline-images () "Find all `Media_Links:' in the buffer replacing them with the referenced image." -- cgit v1.2.3 From 2105887042e5bca3b364a04ed74aecc13d70ce7f Mon Sep 17 00:00:00 2001 From: Holger Dürer Date: Wed, 7 Jun 2017 18:29:10 +0100 Subject: Catch any errors thrown during url-retrieve. On Emacs24 I've been able to reliably fail url fetching which exposed issues in loading a timeline (it aborts the loading). This catches any errors, marking the image load as failed so that we won't retry (retries are a TODO item I guess) and then succeeds the function so the rest of the timeline loading can proceed. --- lisp/mastodon-media.el | 15 ++++++++++++--- test/mastodon-media-tests.el | 18 ++++++++++++++++++ 2 files changed, 30 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/mastodon-media.el b/lisp/mastodon-media.el index 0a4c3de..50f79dd 100644 --- a/lisp/mastodon-media.el +++ b/lisp/mastodon-media.el @@ -170,9 +170,18 @@ MEDIA-TYPE is a symbol and either 'avatar or 'media-link." `(:height ,mastodon-media--avatar-height)) ((eq media-type 'media-link) `(:max-height ,mastodon-media--preview-max-height)))))) - (url-retrieve url - #'mastodon-media--process-image-response - (list (copy-marker start) image-options region-length)))) + (let ((buffer (current-buffer)) + (marker (copy-marker start))) + (condition-case nil + ;; catch any errors in url-retrieve so as to not abort + ;; whatever called us + (url-retrieve url + #'mastodon-media--process-image-response + (list marker image-options region-length)) + (error (with-current-buffer buffer + ;; TODO: Consider adding retries + (put-text-property marker (+ marker region-length) 'media-state 'loading-failed) + :loading-failed)))))) (defun mastodon-media--select-next-media-line () "Find coordinates of the next media to load. diff --git a/test/mastodon-media-tests.el b/test/mastodon-media-tests.el index 4bb89c7..7031e90 100644 --- a/test/mastodon-media-tests.el +++ b/test/mastodon-media-tests.el @@ -111,6 +111,24 @@ (let ((mastodon-media--preview-max-height 321)) (should (eq :called-as-expected (mastodon-media--load-image-from-url url 'media-link 7 5)))))))) +(ert-deftest mastodon-media:load-image-from-url:url-fetching-fails () + "Should cope with failures in url-retrieve." + (let ((url "http://example.org/image.png") + (mastodon-media--avatar-height 123)) + (with-mock + (mock (image-type-available-p 'imagemagick) => t) + (mock (create-image * 'imagemagick t :height 123) => '(image foo)) + (stub url-retrieve => (error "url-retrieve failed")) + + (with-temp-buffer + (insert (concat "Start:" + (mastodon-media--get-avatar-rendering "http://example.org/img.png") + ":rest")) + + (should (eq :loading-failed (mastodon-media--load-image-from-url url 'avatar 7 1))) + ;; the media state was updated so we won't load this again: + (should (eq 'loading-failed (get-text-property 7 'media-state))))))) + (ert-deftest mastodon-media:process-image-response () "Should process the HTTP response and adjust the source buffer." (with-temp-buffer -- cgit v1.2.3 From d746a724db23fc3d897a6c6f11fca75b709b727c Mon Sep 17 00:00:00 2001 From: Johnson Denen Date: Mon, 19 Jun 2017 11:28:37 -0400 Subject: Bump version to 0.7.1 --- lisp/mastodon-auth.el | 2 +- lisp/mastodon-client.el | 2 +- lisp/mastodon-http.el | 2 +- lisp/mastodon-inspect.el | 2 +- lisp/mastodon-media.el | 2 +- lisp/mastodon-tl.el | 2 +- lisp/mastodon-toot.el | 2 +- lisp/mastodon.el | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) (limited to 'lisp') diff --git a/lisp/mastodon-auth.el b/lisp/mastodon-auth.el index ed756f8..83d7d04 100644 --- a/lisp/mastodon-auth.el +++ b/lisp/mastodon-auth.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.0 +;; Version: 0.7.1 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) diff --git a/lisp/mastodon-client.el b/lisp/mastodon-client.el index cbb276b..b97197e 100644 --- a/lisp/mastodon-client.el +++ b/lisp/mastodon-client.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.0 +;; Version: 0.7.1 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) diff --git a/lisp/mastodon-http.el b/lisp/mastodon-http.el index 1e6e037..75cca2f 100644 --- a/lisp/mastodon-http.el +++ b/lisp/mastodon-http.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.0 +;; Version: 0.7.1 ;; Package-Requires: ((emacs "24.4")) ;; Homepage: https://github.com/jdenen/mastodon.el diff --git a/lisp/mastodon-inspect.el b/lisp/mastodon-inspect.el index 29368a9..a44fb2c 100644 --- a/lisp/mastodon-inspect.el +++ b/lisp/mastodon-inspect.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.0 +;; Version: 0.7.1 ;; Package-Requires: ((emacs "24.4")) ;; Homepage: https://github.com/jdenen/mastodon.el diff --git a/lisp/mastodon-media.el b/lisp/mastodon-media.el index 50f79dd..612fad5 100644 --- a/lisp/mastodon-media.el +++ b/lisp/mastodon-media.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.0 +;; Version: 0.7.1 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index eeed6b5..66452dd 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.0 +;; Version: 0.7.1 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) diff --git a/lisp/mastodon-toot.el b/lisp/mastodon-toot.el index 7d33116..6ec3174 100644 --- a/lisp/mastodon-toot.el +++ b/lisp/mastodon-toot.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.0 +;; Version: 0.7.1 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) diff --git a/lisp/mastodon.el b/lisp/mastodon.el index 2bf5e84..c031774 100644 --- a/lisp/mastodon.el +++ b/lisp/mastodon.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.0 +;; Version: 0.7.1 ;; Package-Requires: ((emacs "24.4")) ;; Homepage: https://github.com/jdenen/mastodon.el -- cgit v1.2.3 From 20e3b77a9a37373754d0adedcee2ede6cf1f5922 Mon Sep 17 00:00:00 2001 From: Holger Dürer Date: Fri, 19 May 2017 22:10:38 +0100 Subject: Show the posting date in a more readable, relative to current time format. This is still static, i.e. doesn't update as time progresses. --- lisp/mastodon-tl.el | 38 ++++++++++++++++++++++++++++++++- test/mastodon-tl-tests.el | 54 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 91 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index 66452dd..4556613 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -146,6 +146,38 @@ Return value from boosted content if available." (or (cdr (assoc field (cdr (assoc 'reblog toot)))) (cdr (assoc field toot)))) +(defun mastodon-tl--relative-time-description (time-stamp) + "Returns a string with a human readable description of TIME-STMAP relative to the current time. + +E.g. this could return something like \"1 min ago\", \"yesterday\", etc. +TIME-STAMP is assumed to be in the past." + (let* ((now (current-time)) + (time-difference (time-subtract now time-stamp)) + (seconds-difference (float-time time-difference))) + (cond + ((< seconds-difference 60) + "less than a minute ago") + ((<= seconds-difference (* 1.5 60)) + "one minute ago") + ((< seconds-difference (* 60 59.5)) + (format "%d minutes ago" (round (/ seconds-difference 60)))) + ((<= seconds-difference (* 1.5 60 60)) + "one hour ago") + ((< seconds-difference (* 60 60 23.5)) + (format "%d hours ago" (round (/ seconds-difference 60 60)))) + ((<= seconds-difference (* 1.5 60 60 24)) + "one day ago") + ((<= seconds-difference (* 60 60 24 6.5)) + (format "%d days ago" (round (/ seconds-difference 60 60 24)))) + ((<= seconds-difference (* 1.5 60 60 24 7)) + "one week ago") + ((<= seconds-difference (* 60 60 24 365)) + (format "%d weeks ago" (round (/ seconds-difference 60 60 24 7)))) + ((<= seconds-difference (* 1.5 60 60 24 365)) + "one year ago") + (t + (format "%d years ago" (round (/ seconds-difference 60 60 24 365.25))))))) + (defun mastodon-tl--byline (toot) "Generate byline for TOOT." (let ((id (cdr (assoc 'id toot))) @@ -163,7 +195,11 @@ Return value from boosted content if available." (mastodon-tl--byline-author toot) (mastodon-tl--byline-boosted toot) " " - (format-time-string mastodon-toot-timestamp-format (date-to-time timestamp)) + (let ((parsed-time (date-to-time timestamp))) + (propertize + (format-time-string mastodon-toot-timestamp-format parsed-time) + 'timestamp parsed-time + 'display (mastodon-tl--relative-time-description parsed-time))) (propertize "\n ------------" 'face 'default)) 'favourited-p faved 'boosted-p boosted diff --git a/test/mastodon-tl-tests.el b/test/mastodon-tl-tests.el index 8c706f5..ed16b1b 100644 --- a/test/mastodon-tl-tests.el +++ b/test/mastodon-tl-tests.el @@ -1,4 +1,5 @@ (require 'el-mock) +(require 'cl-macs) (defconst mastodon-tl-test-base-toot '((id . 61208) @@ -103,6 +104,44 @@ (mock (mastodon-http--get-json "https://instance.url/api/v1/timelines/foo?max_id=12345")) (mastodon-tl--more-json "timelines/foo" 12345)))) +(ert-deftest mastodon-tl--relative-time-description () + "Should format relative time as expected" + (cl-labels ((minutes (n) (* n 60)) + (hours (n) (* n (minutes 60))) + (days (n) (* n (hours 24))) + (weeks (n) (* n (days 7))) + (years (n) (* n (days 365))) + (format-seconds-since (seconds) + (let ((time-stamp (time-subtract (current-time) (seconds-to-time seconds)))) + (mastodon-tl--relative-time-description time-stamp))) + (check (seconds expected) + (should (string= (format-seconds-since seconds) expected)))) + (check 1 "less than a minute ago") + (check 59 "less than a minute ago") + (check 60 "one minute ago") + (check 89 "one minute ago") ;; rounding down + (check 91 "2 minutes ago") ;; rounding up + (check (minutes 3.49) "3 minutes ago") ;; rounding down + (check (minutes 3.52) "4 minutes ago") + (check (minutes 59) "59 minutes ago") + (check (minutes 60) "one hour ago") + (check (minutes 89) "one hour ago") + (check (minutes 91) "2 hours ago") + (check (hours 3.49) "3 hours ago") ;; rounding down + (check (hours 3.51) "4 hours ago") ;; rounding down + (check (hours 23.4) "23 hours ago") + (check (hours 23.6) "one day ago") ;; rounding up + (check (days 1.48) "one day ago") ;; rounding down + (check (days 1.52) "2 days ago") ;; rounding up + (check (days 6.6) "one week ago") ;; rounding up + (check (weeks 2.49) "2 weeks ago") ;; rounding down + (check (weeks 2.51) "3 weeks ago") ;; rounding down + (check (weeks 52) "52 weeks ago") + (check (weeks 53) "one year ago") + (check (years 2.49) "2 years ago") ;; rounding down + (check (years 2.51) "3 years ago") ;; rounding down + )) + (ert-deftest mastodon-tl--byline-regular () "Should format the regular toot correctly." (let ((mastodon-tl--show-avatars-p nil) @@ -236,3 +275,18 @@ | (B) (F) Account 42 (@acct42@example.space) Boosted Account 43 (@acct43@example.space) original time ------------"))))) +(ert-deftest mastodon-tl--byline-timestamp-has-relative-display () + "Should display the timestamp with a relative time." + (let ((mastodon-tl--show-avatars-p nil) + (timestamp (cdr (assoc 'created_at mastodon-tl-test-base-toot)))) + (with-mock + (mock (date-to-time timestamp) => '(22782 21551)) + (mock (current-time) => '(22782 22000)) + (mock (format-time-string mastodon-toot-timestamp-format '(22782 21551)) => "2999-99-99 00:11:22") + + (let* ((formatted-string (mastodon-tl--byline mastodon-tl-test-base-toot)) + (timestamp-start (string-match "2999-99-99" formatted-string)) + (properties (text-properties-at timestamp-start formatted-string))) + (should (equal '(22782 21551) (plist-get properties 'timestamp))) + (should (string-equal "7 minutes ago" (plist-get properties 'display))))))) + -- cgit v1.2.3 From 746694f0ea75f5fa76739d49509836ccd67d7d65 Mon Sep 17 00:00:00 2001 From: Holger Dürer Date: Sat, 20 May 2017 20:00:24 +0100 Subject: Add periodic updating of the timestamp displays. For each buffer we add a timer that periodically checks all timestamps and updates them as needed. The logic tries to be smart and - only schedule an update when at least one timestamps display needs changing (although at the moment we update at least every 5 minutes), and - only do a limited amount of work in each timer callback so as to not block Emacs's interactive work. --- lisp/mastodon-tl.el | 204 +++++++++++++++++++++++++++----- test/mastodon-tl-tests.el | 294 +++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 463 insertions(+), 35 deletions(-) (limited to 'lisp') diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index 4556613..caa5249 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -48,11 +48,20 @@ (defvar mastodon-tl--buffer-spec nil "A unique identifier and functions for each Mastodon buffer.") +(make-variable-buffer-local 'mastodon-tl--buffer-spec) (defvar mastodon-tl--show-avatars-p (image-type-available-p 'imagemagick) "A boolean value stating whether to show avatars in timelines.") +(defvar mastodon-tl--timestamp-next-update nil + "The timestamp when the buffer should next be scanned to update the timestamps.") +(make-variable-buffer-local 'mastodon-tl--timestamp-next-update) + +(defvar mastodon-tl--timestamp-update-timer nil + "The timer that, when set will scan the buffer to update the timestamps.") +(make-variable-buffer-local 'mastodon-tl--timestamp-update-timer) + (defun mastodon-tl--get-federated-timeline () "Opens federated timeline." @@ -146,37 +155,70 @@ Return value from boosted content if available." (or (cdr (assoc field (cdr (assoc 'reblog toot)))) (cdr (assoc field toot)))) -(defun mastodon-tl--relative-time-description (time-stamp) - "Returns a string with a human readable description of TIME-STMAP relative to the current time. +(defun mastodon-tl--relative-time-details (timestamp &optional current-time) + "Returns cons of (descriptive string . next change) for the TIMESTAMP. + +Use the optional CURRENT-TIME as the current time (only used for +reliable testing). + +The descriptive string is a human readable version relative to +the current time while the next change timestamp give the first +time that this description will change in the future. + +TIMESTAMP is assumed to be in the past." + (let* ((now (or current-time (current-time))) + (time-difference (time-subtract now timestamp)) + (seconds-difference (float-time time-difference)) + (regular-response + (lambda (seconds-difference multiplier unit-name) + (let ((n (floor (+ 0.5 (/ seconds-difference multiplier))))) + (cons (format "%d %ss ago" n unit-name) + (* (+ 0.5 n) multiplier))))) + (relative-result + (cond + ((< seconds-difference 60) + (cons "less than a minute ago" + 60)) + ((< seconds-difference (* 1.5 60)) + (cons "one minute ago" + 90)) ;; at 90 secs + ((< seconds-difference (* 60 59.5)) + (funcall regular-response seconds-difference 60 "minute")) + ((< seconds-difference (* 1.5 60 60)) + (cons "one hour ago" + (* 60 90))) ;; at 90 minutes + ((< seconds-difference (* 60 60 23.5)) + (funcall regular-response seconds-difference (* 60 60) "hour")) + ((< seconds-difference (* 1.5 60 60 24)) + (cons "one day ago" + (* 1.5 60 60 24))) ;; at a day and a half + ((< seconds-difference (* 60 60 24 6.5)) + (funcall regular-response seconds-difference (* 60 60 24) "day")) + ((< seconds-difference (* 1.5 60 60 24 7)) + (cons "one week ago" + (* 1.5 60 60 24 7))) ;; a week and a half + ((< seconds-difference (* 60 60 24 7 52)) + (if (= 52 (floor (+ 0.5 (/ seconds-difference 60 60 24 7)))) + (cons "52 weeks ago" + (* 60 60 24 7 52)) + (funcall regular-response seconds-difference (* 60 60 24 7) "week"))) + ((< seconds-difference (* 1.5 60 60 24 365)) + (cons "one year ago" + (* 60 60 24 365 1.5))) ;; a year and a half + (t + (funcall regular-response seconds-difference (* 60 60 24 365.25) "year"))))) + (cons (car relative-result) + (time-add timestamp (seconds-to-time (cdr relative-result)))))) + +(defun mastodon-tl--relative-time-description (timestamp &optional current-time) + "Returns a string with a human readable description of TIMESTMAP relative to the current time. + +Use the optional CURRENT-TIME as the current time (only used for +reliable testing). E.g. this could return something like \"1 min ago\", \"yesterday\", etc. TIME-STAMP is assumed to be in the past." - (let* ((now (current-time)) - (time-difference (time-subtract now time-stamp)) - (seconds-difference (float-time time-difference))) - (cond - ((< seconds-difference 60) - "less than a minute ago") - ((<= seconds-difference (* 1.5 60)) - "one minute ago") - ((< seconds-difference (* 60 59.5)) - (format "%d minutes ago" (round (/ seconds-difference 60)))) - ((<= seconds-difference (* 1.5 60 60)) - "one hour ago") - ((< seconds-difference (* 60 60 23.5)) - (format "%d hours ago" (round (/ seconds-difference 60 60)))) - ((<= seconds-difference (* 1.5 60 60 24)) - "one day ago") - ((<= seconds-difference (* 60 60 24 6.5)) - (format "%d days ago" (round (/ seconds-difference 60 60 24)))) - ((<= seconds-difference (* 1.5 60 60 24 7)) - "one week ago") - ((<= seconds-difference (* 60 60 24 365)) - (format "%d weeks ago" (round (/ seconds-difference 60 60 24 7)))) - ((<= seconds-difference (* 1.5 60 60 24 365)) - "one year ago") - (t - (format "%d years ago" (round (/ seconds-difference 60 60 24 365.25))))))) + (car (mastodon-tl--relative-time-details timestamp current-time))) (defun mastodon-tl--byline (toot) "Generate byline for TOOT." @@ -370,6 +412,98 @@ Move forward (down) the timeline unless BACKWARD is non-nil." (funcall update-function json) (goto-char point-before))))) +(defun mastodon-tl--find-property-range (property start-point) + "Finds (start . end) range around or after START-POINT where PROPERTY is set to a consistent value. + +If PROPERTY is set at START-POINT returns a range aroung +START-POINT otherwise after START-POINT." + (if (get-text-property start-point property) + ;; We are within a range, so look backwards for the start: + (cons (or (previous-single-property-change start-point property) + (point-min)) + (or (next-single-property-change start-point property) + (point-max))) + (let* ((start (next-single-property-change start-point property)) + (end (and start + (or (next-single-property-change start property) + (point-max))))) + (when start + (cons start end))))) + +(defun mastodon-tl--consider-timestamp-for-updates (timestamp) + "Take note that TIMESTAMP is used in buffer and ajust timers as needed. + +This calculates the next time the text for TIMESTAMP will change +and may adjust existing or future timer runs should that time +before current plans to run the update function. + +The adjustment is only made if it is significantly (a few +seconds) before the currently scheduled time. This helps reduce +the number of occasions where we schedule an update only to +schedule the next one on completion to be within a few seconds." + (let ((this-update (cdr (mastodon-tl--relative-time-details timestamp)))) + (when (time-less-p this-update + (time-subtract mastodon-tl--timestamp-next-update + (seconds-to-time 10))) + (setq mastodon-tl--timestamp-next-update this-update) + (when mastodon-tl--timestamp-update-timer + ;; We need to re-schedule for an earlier time + (cancel-timer mastodon-tl--timestamp-update-timer) + (setq mastodon-tl--timestamp-update-timer + (run-at-time this-update + nil ;; don't repeat + #'mastodon-tl--update-timestamps-callback + (current-buffer) nil)))))) + +(defun mastodon-tl--update-timestamps-callback (buffer previous-marker) + "Update the next few timestamp displays in BUFFER. + +Start searching for more timestamps from PREVIOUS-MARKER or +from the start if it is nil." + ;; only do things if the buffer hasn't been killed in the meantime + (when (buffer-live-p buffer) + (save-excursion + (with-current-buffer buffer + (let ((previous-timestamp (if previous-marker + (marker-position previous-marker) + (point-min))) + (iteration 0) + next-timestamp-range) + (if previous-marker + ;; This is a follow-up call to process the next batch of + ;; timestamps. + ;; Release the marker to not slow things down. + (set-marker previous-marker nil) + ;; Otherwise this is a rew run, so let's initialize the next-run time. + (setq mastodon-tl--timestamp-next-update (time-add (current-time) + (seconds-to-time 300)) + mastodon-tl--timestamp-update-timer nil)) + (while (and (< iteration 5) + (setq next-timestamp-range (mastodon-tl--find-property-range 'timestamp + previous-timestamp))) + (let* ((start (car next-timestamp-range)) + (end (cdr next-timestamp-range)) + (timestamp (get-text-property start 'timestamp)) + (current-display (get-text-property start 'display)) + (new-display (mastodon-tl--relative-time-description timestamp))) + (unless (string= current-display new-display) + (let ((inhibit-read-only t)) + (add-text-properties start end + (list 'display (mastodon-tl--relative-time-description timestamp))))) + (mastodon-tl--consider-timestamp-for-updates timestamp) + (setq iteration (1+ iteration) + previous-timestamp (1+ (cdr next-timestamp-range))))) + (if next-timestamp-range + ;; schedule the next batch from the previous location to + ;; start very soon in the future: + (run-at-time 0.1 nil #'mastodon-tl--update-timestamps-callback buffer (copy-marker previous-timestamp)) + ;; otherwise we are done for now; schedule a new run for when needed + (setq mastodon-tl--timestamp-update-timer + (run-at-time mastodon-tl--timestamp-next-update + nil ;; don't repeat + #'mastodon-tl--update-timestamps-callback + buffer nil)))))))) + (defun mastodon-tl--update () "Update timeline with new toots." (interactive) @@ -382,7 +516,6 @@ Move forward (down) the timeline unless BACKWARD is non-nil." (goto-char (point-min)) (funcall update-function json))))) - (defun mastodon-tl--init (buffer-name endpoint update-function) "Initialize BUFFER-NAME with timeline targeted by ENDPOINT. @@ -392,14 +525,23 @@ UPDATE-FUNCTION is used to recieve more toots." (json (mastodon-http--get-json url))) (with-output-to-temp-buffer buffer (switch-to-buffer buffer) + (setq + ;; Initialize with a minimal interval; we re-scan at least once + ;; every 5 minutes to catch any timestamps we may have missed + mastodon-tl--timestamp-next-update (time-add (current-time) + (seconds-to-time 300))) (funcall update-function json)) (mastodon-mode) (with-current-buffer buffer - (make-local-variable 'mastodon-tl--buffer-spec) (setq mastodon-tl--buffer-spec `(buffer-name ,buffer-name endpoint ,endpoint update-function - ,update-function))) + ,update-function) + mastodon-tl--timestamp-update-timer (run-at-time mastodon-tl--timestamp-next-update + nil ;; don't repeat + #'mastodon-tl--update-timestamps-callback + (current-buffer) + nil))) buffer)) (provide 'mastodon-tl) diff --git a/test/mastodon-tl-tests.el b/test/mastodon-tl-tests.el index ed16b1b..8c7dc4c 100644 --- a/test/mastodon-tl-tests.el +++ b/test/mastodon-tl-tests.el @@ -112,8 +112,8 @@ (weeks (n) (* n (days 7))) (years (n) (* n (days 365))) (format-seconds-since (seconds) - (let ((time-stamp (time-subtract (current-time) (seconds-to-time seconds)))) - (mastodon-tl--relative-time-description time-stamp))) + (let ((timestamp (time-subtract (current-time) (seconds-to-time seconds)))) + (mastodon-tl--relative-time-description timestamp))) (check (seconds expected) (should (string= (format-seconds-since seconds) expected)))) (check 1 "less than a minute ago") @@ -136,12 +136,74 @@ (check (days 6.6) "one week ago") ;; rounding up (check (weeks 2.49) "2 weeks ago") ;; rounding down (check (weeks 2.51) "3 weeks ago") ;; rounding down - (check (weeks 52) "52 weeks ago") - (check (weeks 53) "one year ago") + (check (1- (weeks 52)) "52 weeks ago") + (check (weeks 52) "one year ago") (check (years 2.49) "2 years ago") ;; rounding down (check (years 2.51) "3 years ago") ;; rounding down )) +(ert-deftest mastodon-tl--relative-time-details--next-update () + "Should calculate the next update time information as expected" + (let ((current-time (current-time))) + (cl-labels ((minutes (n) (* n 60)) + (hours (n) (* n (minutes 60))) + (days (n) (* n (hours 24))) + (weeks (n) (* n (days 7))) + (years (n) (* n (days 365.25))) + (next-update (seconds-ago) + (let* ((timestamp (time-subtract current-time + (seconds-to-time seconds-ago)))) + (cdr (mastodon-tl--relative-time-details timestamp current-time)))) + (check (seconds-ago) + (let* ((timestamp (time-subtract current-time (seconds-to-time seconds-ago))) + (at-now (mastodon-tl--relative-time-description timestamp current-time)) + (at-one-second-before (mastodon-tl--relative-time-description + timestamp + (time-subtract (next-update seconds-ago) + (seconds-to-time 1)))) + (at-result (mastodon-tl--relative-time-description + timestamp + (next-update seconds-ago)))) + (when nil ;; change to t to debug test failures + (prin1 (format "\nFor %s: %s / %s" + seconds-ago + (time-to-seconds + (time-subtract (next-update seconds-ago) + timestamp)) + (round + (time-to-seconds + (time-subtract (next-update seconds-ago) + current-time)))))) + ;; a second earlier the description is the same as at current time + (should (string= at-now at-one-second-before)) + ;; but at the result time it is different + (should-not (string= at-one-second-before at-result))))) + (check 0) + (check 1) + (check 59) + (check 60) + (check 89) + (check 90) + (check 149) + (check 150) + (check (1- (hours 1.5))) ;; just before we switch from "one hour" to "2 hours" + (check (hours 1.5)) + (check (hours 2.1)) + (check (1- (hours 23.5))) ;; just before "23 hours" -> "one day" + (check (hours 23.5)) + (check (1- (days 1.5))) ;; just before "one day" -> "2 days" + (check (days 1.5)) ;; just before "one day" -> "2 days" + (check (days 2.1)) + (check (1- (days 6.5))) ;; just before "6 days" -> "one week" + (check (days 6.5)) ;; "one week" -> "2 weeks" + (check (weeks 2.1)) + (check (1- (weeks 52))) ;; just before "52 weeks" -> "one year" + (check (weeks 52)) + (check (days 365)) + (check (days 366)) + (check (years 2.1)) + ))) + (ert-deftest mastodon-tl--byline-regular () "Should format the regular toot correctly." (let ((mastodon-tl--show-avatars-p nil) @@ -290,3 +352,227 @@ (should (equal '(22782 21551) (plist-get properties 'timestamp))) (should (string-equal "7 minutes ago" (plist-get properties 'display))))))) +(ert-deftest mastodon-tl--consider-timestamp-for-updates-no-active-callback () + "Should update the timestamp update variables as expected." + + (let* ((now (current-time)) + (soon-in-the-future (time-add now (seconds-to-time 10000))) + (long-in-the-future (time-add now (seconds-to-time 10000000)))) + (with-temp-buffer + ;; start with timer way into the future and no active callback + (setq mastodon-tl--timestamp-next-update long-in-the-future + mastodon-tl--timestamp-update-timer nil) + + ;; something a later update doesn't update: + (with-mock + (mock (mastodon-tl--relative-time-details 'fake-timestamp) => + (cons "xxx ago" (time-add long-in-the-future (seconds-to-time 100)))) + + (mastodon-tl--consider-timestamp-for-updates 'fake-timestamp) + + (should (null mastodon-tl--timestamp-update-timer)) + (should (eq mastodon-tl--timestamp-next-update long-in-the-future))) + + ;; something only shortly sooner doesn't update: + (with-mock + (mock (mastodon-tl--relative-time-details 'fake-timestamp) => + (cons "xxx ago" (time-subtract long-in-the-future (seconds-to-time 9)))) + + (mastodon-tl--consider-timestamp-for-updates 'fake-timestamp) + + (should (null mastodon-tl--timestamp-update-timer)) + (should (eq mastodon-tl--timestamp-next-update long-in-the-future))) + + ;; something much sooner, does update + (with-mock + (mock (mastodon-tl--relative-time-details 'fake-timestamp) => + (cons "xxx ago" soon-in-the-future)) + + (mastodon-tl--consider-timestamp-for-updates 'fake-timestamp) + + (should (null mastodon-tl--timestamp-update-timer)) + (should (eq mastodon-tl--timestamp-next-update soon-in-the-future))) + ))) + +(ert-deftest mastodon-tl--consider-timestamp-for-updates-with-active-callback () + "Should update the timestamp update variables as expected." + + (let* ((now (current-time)) + (soon-in-the-future (time-add now (seconds-to-time 10000))) + (long-in-the-future (time-add now (seconds-to-time 10000000)))) + (with-temp-buffer + ;; start with timer way into the future and no active callback + (setq mastodon-tl--timestamp-next-update long-in-the-future + mastodon-tl--timestamp-update-timer 'initial-timer) + + ;; something a later update doesn't update: + (with-mock + (mock (mastodon-tl--relative-time-details 'fake-timestamp) => + (cons "xxx ago" (time-add long-in-the-future (seconds-to-time 100)))) + + (mastodon-tl--consider-timestamp-for-updates 'fake-timestamp) + + (should (eq 'initial-timer mastodon-tl--timestamp-update-timer)) + (should (eq mastodon-tl--timestamp-next-update long-in-the-future))) + + ;; something much sooner, does update + (with-mock + (mock (mastodon-tl--relative-time-details 'fake-timestamp) => + (cons "xxx ago" soon-in-the-future)) + (mock (cancel-timer 'initial-timer)) + (mock (run-at-time soon-in-the-future nil + #'mastodon-tl--update-timestamps-callback + (current-buffer) nil) => 'new-timer) + + (mastodon-tl--consider-timestamp-for-updates 'fake-timestamp) + + (should (eq 'new-timer mastodon-tl--timestamp-update-timer)) + (should (eq mastodon-tl--timestamp-next-update soon-in-the-future))) + ))) + +(ert-deftest mastodon-tl--find-property-range--no-tag () + "Should cope with a buffer completely lacking the tag." + (with-temp-buffer + (insert "Just some random text") + (insert (propertize "More text with a different property" 'other-property 'set)) + + (should (null (mastodon-tl--find-property-range 'test-property 2))))) + +(ert-deftest mastodon-tl--find-property-range--earlier-tag () + "Should cope with a buffer completely lacking the tag." + (with-temp-buffer + (insert (propertize "Just some text with a the sought property" 'test-property 'set)) + (let ((end-of-region (point))) + (insert "More random text") + + (should (null (mastodon-tl--find-property-range 'test-property end-of-region)))))) + +(ert-deftest mastodon-tl--find-property-range--successful-finding () + "Should find the sought tag in all expected circumstances." + (with-temp-buffer + (insert "Previous text") + (let ((start-of-region (point)) + end-of-region) + (insert (propertize "Just some text with a the sought property" 'test-property 'set)) + (setq end-of-region (point)) + (insert "More random text") + + ;; before the region + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property 1))) + ;; in the region + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property (+ 2 start-of-region)))) + ;; at end of region + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property (1- end-of-region))))))) + +(ert-deftest mastodon-tl--find-property-range--successful-finding-at-start () + "Should cope with a tag at start." + (with-temp-buffer + (insert (propertize "Just some text with a the sought property" 'test-property 'set)) + (let ((end-of-region (point))) + (insert "More random text") + + ;; at start of the region + (should (equal (cons 1 end-of-region) + (mastodon-tl--find-property-range 'test-property 1))) + ;; in the region + (should (equal (cons 1 end-of-region) + (mastodon-tl--find-property-range 'test-property 3))) + ;; at end of region + (should (equal (cons 1 end-of-region) + (mastodon-tl--find-property-range 'test-property (1- end-of-region))))))) + +(ert-deftest mastodon-tl--find-property-range--successful-finding-at-end () + "Should cope with a tag at end." + (with-temp-buffer + (insert "More random text") + (let ((start-of-region (point)) + end-of-region) + (insert (propertize "Just some text with a the sought property" 'test-property 'set)) + (setq end-of-region (point-max)) + + ;; before the region + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property 1))) + ;; in the region + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property (1+ start-of-region)))) + ;; at end of region + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property (1- end-of-region))))))) + +(ert-deftest mastodon-tl--find-property-range--successful-finding-whole-buffer () + "Should cope with a tag being set for the whole buffer." + (with-temp-buffer + (insert (propertize "Just some text with a the sought property" 'test-property 'set)) + + ;; before the region + (should (equal (cons (point-min) (point-max)) + (mastodon-tl--find-property-range 'test-property 2))))) + +(defun tl-tests--all-regions-with-property (property) + "Returns a list with (start . end) regions where PROPERTY is set." + (let (result + region) + (goto-char (point-min)) + (while (and (< (point) (point-max)) + (setq region (mastodon-tl--find-property-range property (point)))) + (push region result) + (goto-char (min (point-max) (cdr region)))) + (nreverse result))) + +(defun tl-tests--property-values-at (property ranges) + "Returns a list with property values at the given ranges. + +The property value for PROPERTY within a region is assumed to be +constant." + (let (result) + (dolist (range ranges (nreverse result)) + (push (get-text-property (car range) property) result)))) + +(ert-deftest mastodon-tl--update-timestamps-callback () + "Should update the 5 timestamps at a time as expected." + (let ((now (current-time)) + markers) + (cl-labels ((insert-timestamp (n) + (insert (format "\nSome text before timestamp %s:" n)) + (insert (propertize + (format "timestamp #%s" n) + 'timestamp (time-subtract now (seconds-to-time (* 60 n))) + 'display (format "unset %s" n))) + (push (copy-marker (point)) markers) + (insert " some more text."))) + (with-temp-buffer + (cl-dotimes (n 12) (insert-timestamp (+ n 2))) + (setq markers (nreverse markers)) + + (with-mock + (mock (current-time) => now) + (stub run-at-time => 'fake-timer) + + ;; make the initial call + (mastodon-tl--update-timestamps-callback (current-buffer) nil) + (should (equal '("2 minutes ago" "3 minutes ago" "4 minutes ago" "5 minutes ago" "6 minutes ago" + "unset 7" "unset 8" "unset 9" "unset 10" "unset 11" "unset 12" "unset 13") + (tl-tests--property-values-at 'display + (tl-tests--all-regions-with-property 'timestamp)))) + + ;; fake the follow-up call + (mastodon-tl--update-timestamps-callback (current-buffer) (nth 4 markers)) + (should (equal '("2 minutes ago" "3 minutes ago" "4 minutes ago" "5 minutes ago" "6 minutes ago" + "7 minutes ago" "8 minutes ago" "9 minutes ago" "10 minutes ago" "11 minutes ago" + "unset 12" "unset 13") + (tl-tests--property-values-at 'display + (tl-tests--all-regions-with-property 'timestamp)))) + (should (null (marker-position (nth 4 markers)))) + + ;; fake the follow-up call + (mastodon-tl--update-timestamps-callback (current-buffer) (nth 9 markers)) + (should (equal '("2 minutes ago" "3 minutes ago" "4 minutes ago" "5 minutes ago" "6 minutes ago" + "7 minutes ago" "8 minutes ago" "9 minutes ago" "10 minutes ago" "11 minutes ago" + "12 minutes ago" "13 minutes ago") + (tl-tests--property-values-at 'display + (tl-tests--all-regions-with-property 'timestamp)))) + (should (null (marker-position (nth 9 markers))))))))) -- cgit v1.2.3 From 2d2ef1aaebd0f7ba8815554eefcb3234bd17d483 Mon Sep 17 00:00:00 2001 From: Holger Dürer Date: Thu, 8 Jun 2017 18:26:56 +0100 Subject: Review comments from alexjgriffith: - Simplify let structure in byline generation - Allow disabling of relative timestamps via customization Maybe still to do: - use of cl-macs in tests Punted to a later PR: - Using correct form in docstrings throughout --- lisp/mastodon-tl.el | 66 ++++++++++++++++++++++++++++++++--------------------- 1 file changed, 40 insertions(+), 26 deletions(-) (limited to 'lisp') diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index caa5249..dc5350d 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -46,6 +46,14 @@ :prefix "mastodon-tl-" :group 'mastodon) +(defcustom mastodon-tl--enable-relative-timestamps t + "Nonnil to enable showing relative (to the current time) timestamps. + +This will require periodic updates of a timeline buffer to +keep the timestamps current as time progresses." + :group 'mastodon-tl + :type '(boolean :tag "Enable relative timestamps and background updater task")) + (defvar mastodon-tl--buffer-spec nil "A unique identifier and functions for each Mastodon buffer.") (make-variable-buffer-local 'mastodon-tl--buffer-spec) @@ -223,7 +231,7 @@ TIME-STAMP is assumed to be in the past." (defun mastodon-tl--byline (toot) "Generate byline for TOOT." (let ((id (cdr (assoc 'id toot))) - (timestamp (mastodon-tl--field 'created_at toot)) + (parsed-time (date-to-time (mastodon-tl--field 'created_at toot))) (faved (mastodon-tl--field 'favourited toot)) (boosted (mastodon-tl--field 'reblogged toot))) (propertize @@ -237,11 +245,10 @@ TIME-STAMP is assumed to be in the past." (mastodon-tl--byline-author toot) (mastodon-tl--byline-boosted toot) " " - (let ((parsed-time (date-to-time timestamp))) - (propertize - (format-time-string mastodon-toot-timestamp-format parsed-time) - 'timestamp parsed-time - 'display (mastodon-tl--relative-time-description parsed-time))) + (propertize + (format-time-string mastodon-toot-timestamp-format parsed-time) + 'timestamp parsed-time + 'display (mastodon-tl--relative-time-description parsed-time)) (propertize "\n ------------" 'face 'default)) 'favourited-p faved 'boosted-p boosted @@ -440,20 +447,25 @@ before current plans to run the update function. The adjustment is only made if it is significantly (a few seconds) before the currently scheduled time. This helps reduce the number of occasions where we schedule an update only to -schedule the next one on completion to be within a few seconds." - (let ((this-update (cdr (mastodon-tl--relative-time-details timestamp)))) - (when (time-less-p this-update - (time-subtract mastodon-tl--timestamp-next-update - (seconds-to-time 10))) - (setq mastodon-tl--timestamp-next-update this-update) - (when mastodon-tl--timestamp-update-timer - ;; We need to re-schedule for an earlier time - (cancel-timer mastodon-tl--timestamp-update-timer) - (setq mastodon-tl--timestamp-update-timer - (run-at-time this-update - nil ;; don't repeat - #'mastodon-tl--update-timestamps-callback - (current-buffer) nil)))))) +schedule the next one on completion to be within a few seconds. + +If relative timestamps are +disabled (`mastodon-tl--enable-relative-timestamps` is nil) this +is a no-op." + (when mastodon-tl--enable-relative-timestamps + (let ((this-update (cdr (mastodon-tl--relative-time-details timestamp)))) + (when (time-less-p this-update + (time-subtract mastodon-tl--timestamp-next-update + (seconds-to-time 10))) + (setq mastodon-tl--timestamp-next-update this-update) + (when mastodon-tl--timestamp-update-timer + ;; We need to re-schedule for an earlier time + (cancel-timer mastodon-tl--timestamp-update-timer) + (setq mastodon-tl--timestamp-update-timer + (run-at-time this-update + nil ;; don't repeat + #'mastodon-tl--update-timestamps-callback + (current-buffer) nil))))))) (defun mastodon-tl--update-timestamps-callback (buffer previous-marker) "Update the next few timestamp displays in BUFFER. @@ -461,7 +473,8 @@ schedule the next one on completion to be within a few seconds." Start searching for more timestamps from PREVIOUS-MARKER or from the start if it is nil." ;; only do things if the buffer hasn't been killed in the meantime - (when (buffer-live-p buffer) + (when (and mastodon-tl--enable-relative-timestamps ;; should be true but just in case... + (buffer-live-p buffer)) (save-excursion (with-current-buffer buffer (let ((previous-timestamp (if previous-marker @@ -537,11 +550,12 @@ UPDATE-FUNCTION is used to recieve more toots." `(buffer-name ,buffer-name endpoint ,endpoint update-function ,update-function) - mastodon-tl--timestamp-update-timer (run-at-time mastodon-tl--timestamp-next-update - nil ;; don't repeat - #'mastodon-tl--update-timestamps-callback - (current-buffer) - nil))) + mastodon-tl--timestamp-update-timer (when mastodon-tl--enable-relative-timestamps + (run-at-time mastodon-tl--timestamp-next-update + nil ;; don't repeat + #'mastodon-tl--update-timestamps-callback + (current-buffer) + nil)))) buffer)) (provide 'mastodon-tl) -- cgit v1.2.3 From 0108cd1e7abf621cf65a89e4f6ad12f8dcaa2eed Mon Sep 17 00:00:00 2001 From: Holger Dürer Date: Mon, 5 Jun 2017 18:19:18 +0100 Subject: More robust bad url detection. --- lisp/mastodon-media.el | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/mastodon-media.el b/lisp/mastodon-media.el index f5d67ca..0a4c3de 100644 --- a/lisp/mastodon-media.el +++ b/lisp/mastodon-media.el @@ -201,9 +201,10 @@ found." "Checks to make sure that the missing string has not been returned." - (let ((missing "/files/small/missing.png")) - (and link - (not (equal link missing))))) + (and link + (> (length link) 8) + (or (string= "http://" (substring link 0 7)) + (string= "https://" (substring link 0 8))))) (defun mastodon-media--inline-images () "Find all `Media_Links:' in the buffer replacing them with the referenced image." -- cgit v1.2.3 From 60ac9773d29a0d761d8be42878b471c755a59779 Mon Sep 17 00:00:00 2001 From: Holger Dürer Date: Wed, 7 Jun 2017 18:29:10 +0100 Subject: Catch any errors thrown during url-retrieve. On Emacs24 I've been able to reliably fail url fetching which exposed issues in loading a timeline (it aborts the loading). This catches any errors, marking the image load as failed so that we won't retry (retries are a TODO item I guess) and then succeeds the function so the rest of the timeline loading can proceed. --- lisp/mastodon-media.el | 15 ++++++++++++--- test/mastodon-media-tests.el | 18 ++++++++++++++++++ 2 files changed, 30 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/mastodon-media.el b/lisp/mastodon-media.el index 0a4c3de..50f79dd 100644 --- a/lisp/mastodon-media.el +++ b/lisp/mastodon-media.el @@ -170,9 +170,18 @@ MEDIA-TYPE is a symbol and either 'avatar or 'media-link." `(:height ,mastodon-media--avatar-height)) ((eq media-type 'media-link) `(:max-height ,mastodon-media--preview-max-height)))))) - (url-retrieve url - #'mastodon-media--process-image-response - (list (copy-marker start) image-options region-length)))) + (let ((buffer (current-buffer)) + (marker (copy-marker start))) + (condition-case nil + ;; catch any errors in url-retrieve so as to not abort + ;; whatever called us + (url-retrieve url + #'mastodon-media--process-image-response + (list marker image-options region-length)) + (error (with-current-buffer buffer + ;; TODO: Consider adding retries + (put-text-property marker (+ marker region-length) 'media-state 'loading-failed) + :loading-failed)))))) (defun mastodon-media--select-next-media-line () "Find coordinates of the next media to load. diff --git a/test/mastodon-media-tests.el b/test/mastodon-media-tests.el index 4bb89c7..7031e90 100644 --- a/test/mastodon-media-tests.el +++ b/test/mastodon-media-tests.el @@ -111,6 +111,24 @@ (let ((mastodon-media--preview-max-height 321)) (should (eq :called-as-expected (mastodon-media--load-image-from-url url 'media-link 7 5)))))))) +(ert-deftest mastodon-media:load-image-from-url:url-fetching-fails () + "Should cope with failures in url-retrieve." + (let ((url "http://example.org/image.png") + (mastodon-media--avatar-height 123)) + (with-mock + (mock (image-type-available-p 'imagemagick) => t) + (mock (create-image * 'imagemagick t :height 123) => '(image foo)) + (stub url-retrieve => (error "url-retrieve failed")) + + (with-temp-buffer + (insert (concat "Start:" + (mastodon-media--get-avatar-rendering "http://example.org/img.png") + ":rest")) + + (should (eq :loading-failed (mastodon-media--load-image-from-url url 'avatar 7 1))) + ;; the media state was updated so we won't load this again: + (should (eq 'loading-failed (get-text-property 7 'media-state))))))) + (ert-deftest mastodon-media:process-image-response () "Should process the HTTP response and adjust the source buffer." (with-temp-buffer -- cgit v1.2.3 From f5cd8832412ffb16def55807fd68b3d85d4be9b5 Mon Sep 17 00:00:00 2001 From: Johnson Denen Date: Mon, 19 Jun 2017 11:28:37 -0400 Subject: Bump version to 0.7.1 --- lisp/mastodon-auth.el | 2 +- lisp/mastodon-client.el | 2 +- lisp/mastodon-http.el | 2 +- lisp/mastodon-inspect.el | 2 +- lisp/mastodon-media.el | 2 +- lisp/mastodon-tl.el | 2 +- lisp/mastodon-toot.el | 2 +- lisp/mastodon.el | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) (limited to 'lisp') diff --git a/lisp/mastodon-auth.el b/lisp/mastodon-auth.el index ed756f8..83d7d04 100644 --- a/lisp/mastodon-auth.el +++ b/lisp/mastodon-auth.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.0 +;; Version: 0.7.1 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) diff --git a/lisp/mastodon-client.el b/lisp/mastodon-client.el index cbb276b..b97197e 100644 --- a/lisp/mastodon-client.el +++ b/lisp/mastodon-client.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.0 +;; Version: 0.7.1 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) diff --git a/lisp/mastodon-http.el b/lisp/mastodon-http.el index 1e6e037..75cca2f 100644 --- a/lisp/mastodon-http.el +++ b/lisp/mastodon-http.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.0 +;; Version: 0.7.1 ;; Package-Requires: ((emacs "24.4")) ;; Homepage: https://github.com/jdenen/mastodon.el diff --git a/lisp/mastodon-inspect.el b/lisp/mastodon-inspect.el index 29368a9..a44fb2c 100644 --- a/lisp/mastodon-inspect.el +++ b/lisp/mastodon-inspect.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.0 +;; Version: 0.7.1 ;; Package-Requires: ((emacs "24.4")) ;; Homepage: https://github.com/jdenen/mastodon.el diff --git a/lisp/mastodon-media.el b/lisp/mastodon-media.el index 50f79dd..612fad5 100644 --- a/lisp/mastodon-media.el +++ b/lisp/mastodon-media.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.0 +;; Version: 0.7.1 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index eeed6b5..66452dd 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.0 +;; Version: 0.7.1 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) diff --git a/lisp/mastodon-toot.el b/lisp/mastodon-toot.el index 7d33116..6ec3174 100644 --- a/lisp/mastodon-toot.el +++ b/lisp/mastodon-toot.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.0 +;; Version: 0.7.1 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) diff --git a/lisp/mastodon.el b/lisp/mastodon.el index 2bf5e84..c031774 100644 --- a/lisp/mastodon.el +++ b/lisp/mastodon.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.0 +;; Version: 0.7.1 ;; Package-Requires: ((emacs "24.4")) ;; Homepage: https://github.com/jdenen/mastodon.el -- cgit v1.2.3 From 3dc3e258b4a4bfee4ff8bfaa91ab1bbc7af29f5f Mon Sep 17 00:00:00 2001 From: alexjgriffith Date: Sat, 24 Feb 2018 14:19:11 -0500 Subject: Check if an id is a number before attempting to convert it. Closes #150 --- lisp/mastodon-tl.el | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index 66452dd..9acf51a 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -267,7 +267,9 @@ also render the html" "&" "?") "max_id=" - (number-to-string id))))) + (if (numberp id ) + (number-to-string id) + id))))) (mastodon-http--get-json url))) ;; TODO @@ -280,7 +282,9 @@ also render the html" "&" "?") "since_id=" - (number-to-string id))))) + (if (numberp id) + (number-to-string id) + id))))) (mastodon-http--get-json url))) (defun mastodon-tl--property (prop &optional backward) -- cgit v1.2.3 From b8ce6fcd2b5e7ff0ab1aa571ddaca0678b6ab311 Mon Sep 17 00:00:00 2001 From: Alexander Griffith Date: Sun, 25 Feb 2018 15:18:10 -0500 Subject: use absolute time stamps when mastodon-tl--enable-relative-timestamps is nil --- lisp/mastodon-tl.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index dc5350d..c44ac01 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -248,7 +248,9 @@ TIME-STAMP is assumed to be in the past." (propertize (format-time-string mastodon-toot-timestamp-format parsed-time) 'timestamp parsed-time - 'display (mastodon-tl--relative-time-description parsed-time)) + 'display (if mastodon-tl--enable-relative-timestamps + (mastodon-tl--relative-time-description parsed-time) + parsed-time)) (propertize "\n ------------" 'face 'default)) 'favourited-p faved 'boosted-p boosted -- cgit v1.2.3 From 5a8ede2990c208b1c4059092f21d216203bd0db5 Mon Sep 17 00:00:00 2001 From: Alexander Griffith Date: Wed, 28 Feb 2018 12:44:33 -0500 Subject: Closes #152 and extends the fix for #150 as well as a host of bug fixes We now kill the http get request buffer once JSON has been extracted. mastodon-tl--as-string was implemented and replaced any occurrence of number-to-string or int-to-string Added variable mastodon-tl--display-media-p. By default it is 't but can be made a local buffer variable and set to nil. When nil rather than displaying the media it just provides a link Media:: Fixed checking for faves and boosts, they should now render properly. The return from json-read-from-string for nil is :json-false which evaluates to 't in elisp. Fixed the format string that gets printed when faving and boosting Fixed mastodon-tl--thread updating and requesting and changed its behaviour such that it tries to open the original toot thread rather than the boosted thread. Added tests for both the new mastodon-tl--as-string function and the mastodon-tl--toot-id utility. enter mastodon mode before defining local buffer variable mastodon-tl--buffer-spec. This fixes some oddities with the local buffer variable. --- lisp/mastodon-http.el | 1 + lisp/mastodon-inspect.el | 2 +- lisp/mastodon-tl.el | 63 ++++++++++++++++++++++++++++++++++------------- lisp/mastodon-toot.el | 14 ++++++----- test/mastodon-tl-tests.el | 22 +++++++++++++++++ 5 files changed, 78 insertions(+), 24 deletions(-) (limited to 'lisp') diff --git a/lisp/mastodon-http.el b/lisp/mastodon-http.el index 75cca2f..f519e20 100644 --- a/lisp/mastodon-http.el +++ b/lisp/mastodon-http.el @@ -107,6 +107,7 @@ Pass response buffer to CALLBACK function." (decode-coding-string (buffer-substring-no-properties (point) (point-max)) 'utf-8))) + (kill-buffer) (json-read-from-string json-string))))) json-vector)) diff --git a/lisp/mastodon-inspect.el b/lisp/mastodon-inspect.el index a44fb2c..c5b2924 100644 --- a/lisp/mastodon-inspect.el +++ b/lisp/mastodon-inspect.el @@ -55,7 +55,7 @@ (interactive) (mastodon-inspect--dump-json-in-buffer (concat "*mastodon-inspect-toot-" - (int-to-string (mastodon-tl--property 'toot-id)) + (mastodon-tl--as-string (mastodon-tl--property 'toot-id)) "*") (mastodon-tl--property 'toot-json))) diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index 38aee76..dbc815f 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -62,6 +62,9 @@ keep the timestamps current as time progresses." (image-type-available-p 'imagemagick) "A boolean value stating whether to show avatars in timelines.") +(defvar mastodon-tl--display-media-p t + "A boolean value stating whether to show media in timelines.") + (defvar mastodon-tl--timestamp-next-update nil "The timestamp when the buffer should next be scanned to update the timestamps.") (make-variable-buffer-local 'mastodon-tl--timestamp-next-update) @@ -138,7 +141,7 @@ Optionally start from POS." (name (cdr (assoc 'display_name account))) (avatar-url (cdr (assoc 'avatar account)))) (concat - (when mastodon-tl--show-avatars-p + (when (and mastodon-tl--show-avatars-p mastodon-tl--display-media-p) (mastodon-media--get-avatar-rendering avatar-url)) (propertize name 'face 'mastodon-display-name-face) (propertize (concat " (@" @@ -232,8 +235,8 @@ TIME-STAMP is assumed to be in the past." "Generate byline for TOOT." (let ((id (cdr (assoc 'id toot))) (parsed-time (date-to-time (mastodon-tl--field 'created_at toot))) - (faved (mastodon-tl--field 'favourited toot)) - (boosted (mastodon-tl--field 'reblogged toot))) + (faved (equal 't (mastodon-tl--field 'favourited toot))) + (boosted (equal 't (mastodon-tl--field 'reblogged toot)))) (propertize (concat (propertize "\n | " 'face 'default) (when boosted @@ -289,11 +292,14 @@ also render the html" (lambda (media-attachement) (let ((preview-url (cdr (assoc 'preview_url media-attachement)))) - (mastodon-media--get-media-link-rendering - preview-url))) + (if mastodon-tl--display-media-p + (mastodon-media--get-media-link-rendering + preview-url) + (concat "Media::" preview-url "\n")))) media-attachements ""))) - (if (not (equal media-string "")) - (concat "\n" media-string ) ""))) + (if (not (and (not mastodon-tl--display-media-p) + (equal media-string ""))) + (concat "\n" media-string) ""))) (defun mastodon-tl--content (toot) @@ -324,7 +330,8 @@ also render the html" (goto-char (point-min)) (while (search-forward "\n\n\n | " nil t) (replace-match "\n | ")) - (mastodon-media--inline-images)) + (when mastodon-tl--display-media-p + (mastodon-media--inline-images))) (defun mastodon-tl--get-update-function (&optional buffer) "Get the UPDATE-FUNCTION stored in `mastodon-tl--buffer-spec'" @@ -354,9 +361,7 @@ also render the html" "&" "?") "max_id=" - (if (numberp id ) - (number-to-string id) - id))))) + (mastodon-tl--as-string id))))) (mastodon-http--get-json url))) ;; TODO @@ -369,9 +374,7 @@ also render the html" "&" "?") "since_id=" - (if (numberp id) - (number-to-string id) - id))))) + (mastodon-tl--as-string id))))) (mastodon-http--get-json url))) (defun mastodon-tl--property (prop &optional backward) @@ -395,21 +398,47 @@ Move forward (down) the timeline unless BACKWARD is non-nil." (goto-char (point-max)) (mastodon-tl--property 'toot-id t)) +(defun mastodon-tl--as-string(numeric) + "Convert NUMERIC to string." + (cond ((numberp numeric) + (number-to-string numeric)) + ((stringp numeric) numeric) + (t (error + "Numeric:%s must be either a string or a number" + numeric)))) + +(defun mastodon-tl--toot-id (json) + "Find approproiate toot id in JSON. + +If the toot has been boosted use the id found in the +reblog portion of the toot. Otherwise, use the body of +the toot. This is the same behaviour as the mastodon.social +webapp" + (let ((id (cdr (assoc 'id json))) + (reblog (cdr (assoc 'reblog json)))) + (if reblog (cdr (assoc 'id reblog)) id))) + (defun mastodon-tl--thread () "Open thread buffer for toot under `point'." (interactive) - (let* ((id (number-to-string (mastodon-tl--property 'toot-id))) + (let* ((id (mastodon-tl--as-string (mastodon-tl--toot-id + (mastodon-tl--property 'toot-json)))) (url (mastodon-http--api (format "statuses/%s/context" id))) (buffer (format "*mastodon-thread-%s*" id)) (toot (mastodon-tl--property 'toot-json)) (context (mastodon-http--get-json url))) (with-output-to-temp-buffer buffer (switch-to-buffer buffer) + (mastodon-mode) + (setq mastodon-tl--buffer-spec + `(buffer-name ,buffer + endpoint ,(format "statuses/%s/context" id) + update-function + (lambda(toot) (message "END of thread.")))) (mastodon-tl--timeline (vconcat (cdr (assoc 'ancestors context)) `(,toot) - (cdr (assoc 'descendants context))))) - (mastodon-mode))) + (cdr (assoc 'descendants context))))))) (defun mastodon-tl--more () "Append older toots to timeline." diff --git a/lisp/mastodon-toot.el b/lisp/mastodon-toot.el index 6ec3174..7e2451e 100644 --- a/lisp/mastodon-toot.el +++ b/lisp/mastodon-toot.el @@ -70,7 +70,7 @@ Remove MARKER if RM is non-nil." "Take ACTION on toot at point, then execute CALLBACK." (let* ((id (mastodon-tl--property 'toot-id)) (url (mastodon-http--api (concat "statuses/" - (number-to-string id) + (mastodon-tl--as-string id) "/" action)))) (let ((response (mastodon-http--post url nil nil))) @@ -79,7 +79,8 @@ Remove MARKER if RM is non-nil." (defun mastodon-toot--toggle-boost () "Boost/unboost toot at `point'." (interactive) - (let* ((id (mastodon-tl--property 'toot-id)) + (let* ((id (mastodon-tl--as-string + (mastodon-tl--property 'toot-id))) (boosted (get-text-property (point) 'boosted-p)) (action (if boosted "unreblog" "reblog")) (msg (if boosted "unboosted" "boosted")) @@ -87,19 +88,20 @@ Remove MARKER if RM is non-nil." (mastodon-toot--action action (lambda () (mastodon-toot--action-success "B" remove) - (message (format "%s #%d" msg id)))))) + (message (format "%s #%s" msg id)))))) (defun mastodon-toot--toggle-favourite () "Favourite/unfavourite toot at `point'." (interactive) - (let* ((id (mastodon-tl--property 'toot-id)) + (let* ((id (mastodon-tl--as-string + (mastodon-tl--property 'toot-id))) (faved (get-text-property (point) 'favourited-p)) (action (if faved "unfavourite" "favourite")) (remove (when faved t))) (mastodon-toot--action action (lambda () (mastodon-toot--action-success "F" remove) - (message (format "%sd #%d" action id)))))) + (message (format "%s #%s" action id)))))) (defun mastodon-toot--kill () "Kill `mastodon-toot-mode' buffer and window. @@ -144,7 +146,7 @@ Set `mastodon-toot--content-warning' to nil." "Reply to toot at `point'." (interactive) (let* ((toot (mastodon-tl--property 'toot-json)) - (id (number-to-string (mastodon-tl--field 'id toot))) + (id (mastodon-tl--as-string (mastodon-tl--field 'id toot))) (account (mastodon-tl--field 'account toot)) (user (cdr (assoc 'username account)))) (mastodon-toot user id))) diff --git a/test/mastodon-tl-tests.el b/test/mastodon-tl-tests.el index 7d6a08f..5d7699e 100644 --- a/test/mastodon-tl-tests.el +++ b/test/mastodon-tl-tests.el @@ -97,6 +97,28 @@ (let ((input "foobar

")) (should (string= (mastodon-tl--remove-html input) "foobar\n\n")))) +(ert-deftest toot-id-boosted () + "If a toot is boostedm, return the reblog id." + (should (string= (mastodon-tl--as-string + (mastodon-tl--toot-id mastodon-tl-test-base-boosted-toot)) + "4543919"))) + +(ert-deftest toot-id () + "If a toot is boostedm, return the reblog id." + (should (string= (mastodon-tl--as-string + (mastodon-tl--toot-id mastodon-tl-test-base-toot)) + "61208"))) + +(ert-deftest as-string-1 () + "Should accept a string or number and return a string." + (let ((id "1000")) + (should (string= (mastodon-tl--as-string id) id)))) + +(ert-deftest as-string-2 () + "Should accept a string or number and return a string." + (let ((id 1000)) + (should (string= (mastodon-tl--as-string id) (number-to-string id))))) + (ert-deftest more-json () "Should request toots older than max_id." (let ((mastodon-instance-url "https://instance.url")) -- cgit v1.2.3 From f9f683f4abb3ef7ddf3f90c4bb216153bb05d23d Mon Sep 17 00:00:00 2001 From: Holger Dürer Date: Thu, 1 Mar 2018 17:40:44 +0000 Subject: When processing the result of an async image fetch, ensure the buffer still exists. This should fix https://github.com/jdenen/mastodon.el/issues/156. --- lisp/mastodon-media.el | 51 +++++++++++++++++++++++++------------------------- 1 file changed, 26 insertions(+), 25 deletions(-) (limited to 'lisp') diff --git a/lisp/mastodon-media.el b/lisp/mastodon-media.el index 612fad5..94c6e9f 100644 --- a/lisp/mastodon-media.el +++ b/lisp/mastodon-media.el @@ -133,31 +133,32 @@ IMAGE-OPTIONS are the precomputed options to apply to the image. MARKER is the marker to where the response should be visible. REGION-LENGTH is the length of the region that should be replaced with the image. " - (let ((url-buffer (current-buffer)) - (is-error-response-p (eq :error (car status-plist)))) - (unwind-protect - (let* ((data (unless is-error-response-p - (goto-char (point-min)) - (search-forward "\n\n") - (buffer-substring (point) (point-max)))) - (image (when data - (apply #'create-image data (when image-options 'imagemagick) - t image-options)))) - (switch-to-buffer (marker-buffer marker)) - ;; Save narrowing in our buffer - (let ((inhibit-read-only t)) - (save-restriction - (widen) - (put-text-property marker (+ marker region-length) 'media-state 'loaded) - (when image - ;; We only set the image to display if we could load - ;; it; we already have set a default image when we - ;; added the tag. - (put-text-property marker (+ marker region-length) - 'display image)) - ;; We are done with the marker; release it: - (set-marker marker nil))) - (kill-buffer url-buffer))))) + (when (marker-buffer marker) ; only if the buffer hasn't been kill in the meantime + (let ((url-buffer (current-buffer)) + (is-error-response-p (eq :error (car status-plist)))) + (unwind-protect + (let* ((data (unless is-error-response-p + (goto-char (point-min)) + (search-forward "\n\n") + (buffer-substring (point) (point-max)))) + (image (when data + (apply #'create-image data (when image-options 'imagemagick) + t image-options)))) + (switch-to-buffer (marker-buffer marker)) + ;; Save narrowing in our buffer + (let ((inhibit-read-only t)) + (save-restriction + (widen) + (put-text-property marker (+ marker region-length) 'media-state 'loaded) + (when image + ;; We only set the image to display if we could load + ;; it; we already have set a default image when we + ;; added the tag. + (put-text-property marker (+ marker region-length) + 'display image)) + ;; We are done with the marker; release it: + (set-marker marker nil))) + (kill-buffer url-buffer)))))) (defun mastodon-media--load-image-from-url (url media-type start region-length) "Takes a URL and MEDIA-TYPE and load the image asynchronously. -- cgit v1.2.3 From 3eae90ac03aea4c609f2cf2660b85338a33d9f89 Mon Sep 17 00:00:00 2001 From: Alexander Griffith Date: Thu, 1 Mar 2018 21:32:00 -0500 Subject: Fixes buffer switching issue and closes issue #158 - Small logic fix in mastodon-tl--media to remove redundant newline - Replaced switch-to-buffer with with-current-buffer in mastodon-media--process-image-response - Squashed with merge to develop --- lisp/mastodon-media.el | 30 +++++++++++++++--------------- lisp/mastodon-tl.el | 2 +- 2 files changed, 16 insertions(+), 16 deletions(-) (limited to 'lisp') diff --git a/lisp/mastodon-media.el b/lisp/mastodon-media.el index 94c6e9f..f010fee 100644 --- a/lisp/mastodon-media.el +++ b/lisp/mastodon-media.el @@ -144,21 +144,21 @@ REGION-LENGTH is the length of the region that should be replaced with the image (image (when data (apply #'create-image data (when image-options 'imagemagick) t image-options)))) - (switch-to-buffer (marker-buffer marker)) - ;; Save narrowing in our buffer - (let ((inhibit-read-only t)) - (save-restriction - (widen) - (put-text-property marker (+ marker region-length) 'media-state 'loaded) - (when image - ;; We only set the image to display if we could load - ;; it; we already have set a default image when we - ;; added the tag. - (put-text-property marker (+ marker region-length) - 'display image)) - ;; We are done with the marker; release it: - (set-marker marker nil))) - (kill-buffer url-buffer)))))) + (with-current-buffer (marker-buffer marker) + ;; Save narrowing in our buffer + (let ((inhibit-read-only t)) + (save-restriction + (widen) + (put-text-property marker (+ marker region-length) 'media-state 'loaded) + (when image + ;; We only set the image to display if we could load + ;; it; we already have set a default image when we + ;; added the tag. + (put-text-property marker (+ marker region-length) + 'display image)) + ;; We are done with the marker; release it: + (set-marker marker nil))) + (kill-buffer url-buffer))))))) (defun mastodon-media--load-image-from-url (url media-type start region-length) "Takes a URL and MEDIA-TYPE and load the image asynchronously. diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index dbc815f..2f26b55 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -297,7 +297,7 @@ also render the html" preview-url) (concat "Media::" preview-url "\n")))) media-attachements ""))) - (if (not (and (not mastodon-tl--display-media-p) + (if (not (and mastodon-tl--display-media-p (equal media-string ""))) (concat "\n" media-string) ""))) -- cgit v1.2.3 From 62b9098a207c9b84e84a56c84ac173b7490c4765 Mon Sep 17 00:00:00 2001 From: Holger Durer Date: Fri, 2 Mar 2018 17:34:03 +0000 Subject: Stop url.el from spamming the user with "Connecting host: ..." messages in the minibuffer. These happen during async loads, i.e. when the user might be doing something else completely. Especially with auto-update that are coming this is becoming annoying. --- lisp/mastodon-media.el | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/mastodon-media.el b/lisp/mastodon-media.el index f010fee..fa5b8c3 100644 --- a/lisp/mastodon-media.el +++ b/lisp/mastodon-media.el @@ -32,6 +32,8 @@ ;; required by the server and client. ;;; Code: +(defvar url-show-status) + (defgroup mastodon-media nil "Inline Mastadon media." :prefix "mastodon-media-" @@ -172,7 +174,9 @@ MEDIA-TYPE is a symbol and either 'avatar or 'media-link." ((eq media-type 'media-link) `(:max-height ,mastodon-media--preview-max-height)))))) (let ((buffer (current-buffer)) - (marker (copy-marker start))) + (marker (copy-marker start)) + ;; Keep url.el from spamming us with messages about connecting to hosts: + (url-show-status nil)) (condition-case nil ;; catch any errors in url-retrieve so as to not abort ;; whatever called us -- cgit v1.2.3 From b774f9e5295341a68171d94765320114d0b5b407 Mon Sep 17 00:00:00 2001 From: Holger Dürer Date: Wed, 28 Feb 2018 20:48:24 +0000 Subject: Keep track of to which instance secrets in plstore belong. While testing out issue 149 (https://github.com/jdenen/mastodon.el/issues/149) I had problems due to stale client information being cached. With this change we store various pieces of information (the client information in the plstore and the auth tokens) in alists keyed by the instance url (and the plstore key contains the instance url as well to allow us to store data per instance). --- fixture/client.plstore | 3 +- lisp/mastodon-auth.el | 24 +++++++++------ lisp/mastodon-client.el | 30 ++++++++++-------- lisp/mastodon-http.el | 11 ++++--- test/mastodon-auth-tests.el | 15 +++++---- test/mastodon-client-tests.el | 72 ++++++++++++++++++++++++++++++------------- 6 files changed, 99 insertions(+), 56 deletions(-) (limited to 'lisp') diff --git a/fixture/client.plstore b/fixture/client.plstore index 3514ed9..e050018 100644 --- a/fixture/client.plstore +++ b/fixture/client.plstore @@ -1,2 +1,3 @@ ;;; public entries -*- mode: plstore -*- -(("mastodon" :client_id "id" :client_secret "secret")) +(("mastodon-http://other.example" :client_id "id1" :client_secret "secret1") + ("mastodon-http://mastodon.example" :client_id "id2" :client_secret "secret2")) diff --git a/lisp/mastodon-auth.el b/lisp/mastodon-auth.el index 83d7d04..b2399d2 100644 --- a/lisp/mastodon-auth.el +++ b/lisp/mastodon-auth.el @@ -40,8 +40,8 @@ :prefix "mastodon-auth-" :group 'mastodon) -(defvar mastodon-auth--token nil - "User access token.") +(defvar mastodon-auth--token-alist nil + "Alist of User access tokens keyed by instance url.") (defun mastodon-auth--generate-token () "Make POST to generate auth token." @@ -53,7 +53,8 @@ ("username" . ,(read-string "Email: ")) ("password" . ,(read-passwd "Password: ")) ("scope" . "read write follow")) - nil)) + nil + :unauthenticated)) (defun mastodon-auth--get-token () "Make auth token request and return JSON response." @@ -67,13 +68,16 @@ (json-read-from-string json-string)))) (defun mastodon-auth--access-token () - "Return `mastodon-auth--token'. - -Generate token and set `mastodon-auth--token' if nil." - (or mastodon-auth--token - (let* ((json (mastodon-auth--get-token)) - (token (plist-get json :access_token))) - (setq mastodon-auth--token token)))) + "Return the access token to use with the current `mastodon-instance-url'. + +Generate token and set if none known yet." + (let ((token + (cdr (assoc mastodon-instance-url mastodon-auth--token-alist)))) + (unless token + (let ((json (mastodon-auth--get-token))) + (setq token (plist-get json :access_token)) + (push (cons mastodon-instance-url token) mastodon-auth--token-alist))) + token)) (provide 'mastodon-auth) ;;; mastodon-auth.el ends here diff --git a/lisp/mastodon-client.el b/lisp/mastodon-client.el index b97197e..f8beb81 100644 --- a/lisp/mastodon-client.el +++ b/lisp/mastodon-client.el @@ -30,6 +30,7 @@ ;;; Code: (require 'plstore) +(defvar mastodon-instance-url) (autoload 'mastodon-http--api "mastodon-http") (autoload 'mastodon-http--post "mastodon-http") @@ -39,8 +40,8 @@ :group 'mastodon :type 'file) -(defvar mastodon-client--client-details nil - "Client id and secret.") +(defvar mastodon-client--client-details-alist nil + "An alist of Client id and secrets keyed by the instance url.") (defun mastodon-client--register () "POST client to Mastodon." @@ -50,7 +51,8 @@ ("redirect_uris" . "urn:ietf:wg:oauth:2.0:oob") ("scopes" . "read write follow") ("website" . "https://github.com/jdenen/mastodon.el")) - nil)) + nil + :unauthenticated)) (defun mastodon-client--fetch () "Return JSON from `mastodon-client--register' call." @@ -72,8 +74,8 @@ Make `mastodon-client--fetch' call to determine client values." (let ((plstore (plstore-open (mastodon-client--token-file))) - (client (mastodon-client--fetch))) - (plstore-put plstore "mastodon" client nil) + (client (mastodon-client--fetch))) + (plstore-put plstore (concat "mastodon-" mastodon-instance-url) client nil) (plstore-save plstore) (plstore-close plstore) client)) @@ -81,19 +83,23 @@ Make `mastodon-client--fetch' call to determine client values." (defun mastodon-client--read () "Retrieve client_id and client_secret from `mastodon-client--token-file'." (let* ((plstore (plstore-open (mastodon-client--token-file))) - (mastodon (plstore-get plstore "mastodon"))) - (when mastodon - (delete "mastodon" mastodon)))) + (mastodon (plstore-get plstore (concat "mastodon-" mastodon-instance-url)))) + (cdr mastodon))) (defun mastodon-client () - "Return variable `mastodon-client--client-details' plist. + "Return variable client secrets to use for the current `mastodon-instance-url'.. Read plist from `mastodon-client--token-file' if variable is nil. Fetch and store plist if `mastodon-client--read' returns nil." - (or mastodon-client--client-details - (setq mastodon-client--client-details + (let ((client-details (cdr (assoc mastodon-instance-url mastodon-client--client-details-alist)))) + (unless client-details + (setq client-details (or (mastodon-client--read) - (mastodon-client--store))))) + (mastodon-client--store))) + (push (cons mastodon-instance-url client-details) + mastodon-client--client-details-alist)) + client-details)) (provide 'mastodon-client) ;;; mastodon-client.el ends here + diff --git a/lisp/mastodon-http.el b/lisp/mastodon-http.el index f519e20..905a853 100644 --- a/lisp/mastodon-http.el +++ b/lisp/mastodon-http.el @@ -31,7 +31,6 @@ (require 'json) (defvar mastodon-instance-url) -(defvar mastodon-auth--token) (autoload 'mastodon-auth--access-token "mastodon-auth") (defvar mastodon-http--api-version "v1") @@ -68,10 +67,10 @@ Open RESPONSE buffer if unsuccessful." (funcall success) (switch-to-buffer response)))) -(defun mastodon-http--post (url args headers) +(defun mastodon-http--post (url args headers &optional unauthenticed-p) "POST synchronously to URL with ARGS and HEADERS. -Authorization header is included by default." +Authorization header is included by default unless UNAUTHENTICED-P is non-nil." (let ((url-request-method "POST") (url-request-data (when args @@ -82,8 +81,10 @@ Authorization header is included by default." args "&"))) (url-request-extra-headers - `(("Authorization" . ,(concat "Bearer " mastodon-auth--token)) - ,headers))) + (append + (unless unauthenticed-p + `(("Authorization" . (concat "Bearer " (mastodon-auth--access-token))))) + headers))) (with-temp-buffer (url-retrieve-synchronously url)))) diff --git a/test/mastodon-auth-tests.el b/test/mastodon-auth-tests.el index 70c63d8..719a56c 100644 --- a/test/mastodon-auth-tests.el +++ b/test/mastodon-auth-tests.el @@ -14,7 +14,8 @@ ("username" . "foo@bar.com") ("password" . "password") ("scope" . "read write follow")) - nil)) + nil + :unauthenticated)) (mastodon-auth--generate-token)))) (ert-deftest get-token () @@ -26,15 +27,17 @@ (current-buffer))) (should (equal (mastodon-auth--get-token) '(:access_token "abcdefg")))))) -(ert-deftest access-token-1 () - "Should return `mastodon-auth--token' if non-nil." - (let ((mastodon-auth--token "foobar")) +(ert-deftest access-token-found () + "Should return value in `mastodon-auth--token-alist' if found." + (let ((mastodon-instance-url "https://instance.url") + (mastodon-auth--token-alist '(("https://instance.url" . "foobar")) )) (should (string= (mastodon-auth--access-token) "foobar")))) (ert-deftest access-token-2 () "Should set and return `mastodon-auth--token' if nil." - (let ((mastodon-auth--token nil)) + (let ((mastodon-instance-url "https://instance.url") + (mastodon-auth--token nil)) (with-mock (mock (mastodon-auth--get-token) => '(:access_token "foobaz")) (should (string= (mastodon-auth--access-token) "foobaz")) - (should (string= mastodon-auth--token "foobaz"))))) + (should (equal mastodon-auth--token-alist '(("https://instance.url" . "foobaz"))))))) diff --git a/test/mastodon-client-tests.el b/test/mastodon-client-tests.el index c339efa..dfe175b 100644 --- a/test/mastodon-client-tests.el +++ b/test/mastodon-client-tests.el @@ -9,7 +9,8 @@ ("redirect_uris" . "urn:ietf:wg:oauth:2.0:oob") ("scopes" . "read write follow") ("website" . "https://github.com/jdenen/mastodon.el")) - nil)) + nil + :unauthenticated)) (mastodon-client--register))) (ert-deftest fetch () @@ -23,53 +24,80 @@ (ert-deftest store-1 () "Should return the client plist." - (let ((plist '(:client_id "id" :client_secret "secret"))) + (let ((mastodon-instance-url "http://mastodon.example") + (plist '(:client_id "id" :client_secret "secret"))) (with-mock (mock (mastodon-client--token-file) => "stubfile.plstore") (mock (mastodon-client--fetch) => '(:client_id "id" :client_secret "secret")) (let* ((plstore (plstore-open "stubfile.plstore")) - (client (delete "mastodon" (plstore-get plstore "mastodon")))) - (should (equal (mastodon-client--store) plist)) - )))) + (client (cdr (plstore-get plstore "mastodon-http://mastodon.example")))) + (should (equal (mastodon-client--store) plist)))))) (ert-deftest store-2 () "Should store client in `mastodon-client--token-file'." - (let* ((plstore (plstore-open "stubfile.plstore")) - (client (delete "mastodon" (plstore-get plstore "mastodon")))) + (let* ((mastodon-instance-url "http://mastodon.example") + (plstore (plstore-open "stubfile.plstore")) + (client (cdr (plstore-get plstore "mastodon-http://mastodon.example")))) (plstore-close plstore) (should (string= (plist-get client :client_id) "id")) (should (string= (plist-get client :client_secret) "secret")))) -(ert-deftest read-1 () +(ert-deftest read-finds-match () "Should return mastodon client from `mastodon-token-file' if it exists." - (with-mock - (mock (mastodon-client--token-file) => "fixture/client.plstore") - (should (equal (mastodon-client--read) '(:client_id "id" :client_secret "secret"))))) + (let ((mastodon-instance-url "http://mastodon.example")) + (with-mock + (mock (mastodon-client--token-file) => "fixture/client.plstore") + (should (equal (mastodon-client--read) + '(:client_id "id2" :client_secret "secret2")))))) + +(ert-deftest read-finds-no-match () + "Should return mastodon client from `mastodon-token-file' if it exists." + (let ((mastodon-instance-url "http://mastodon.social")) + (with-mock + (mock (mastodon-client--token-file) => "fixture/client.plstore") + (should (equal (mastodon-client--read) nil))))) -(ert-deftest read-2 () +(ert-deftest read-empty-store () "Should return nil if mastodon client is not present in the plstore." (with-mock (mock (mastodon-client--token-file) => "fixture/empty.plstore") (should (equal (mastodon-client--read) nil)))) -(ert-deftest client-1 () - "Should return `mastondon-client' if non-nil." - (let ((mastodon-client--client-details t)) - (should (eq (mastodon-client) t)))) +(ert-deftest client-set-and-matching () + "Should return `mastondon-client' if `mastodon-client--client-details-alist' is non-nil and instance url is included." + (let ((mastodon-instance-url "http://mastodon.example") + (mastodon-client--client-details-alist '(("https://other.example" . :no-match) + ("http://mastodon.example" . :matches)))) + (should (eq (mastodon-client) :matches)))) + +(ert-deftest client-set-but-not-matching () + "Should read from `mastodon-token-file' if wrong data is cached." + (let ((mastodon-instance-url "http://mastodon.example") + (mastodon-client--client-details-alist '(("http://other.example" :wrong)))) + (with-mock + (mock (mastodon-client--read) => '(:client_id "foo" :client_secret "bar")) + (should (equal (mastodon-client) '(:client_id "foo" :client_secret "bar"))) + (should (equal mastodon-client--client-details-alist + '(("http://mastodon.example" :client_id "foo" :client_secret "bar") + ("http://other.example" :wrong))))))) -(ert-deftest client-2 () +(ert-deftest client-unset () "Should read from `mastodon-token-file' if available." - (let ((mastodon-client--client-details nil)) + (let ((mastodon-instance-url "http://mastodon.example") + (mastodon-client--client-details-alist nil)) (with-mock (mock (mastodon-client--read) => '(:client_id "foo" :client_secret "bar")) (should (equal (mastodon-client) '(:client_id "foo" :client_secret "bar"))) - (should (equal mastodon-client--client-details '(:client_id "foo" :client_secret "bar")))))) + (should (equal mastodon-client--client-details-alist + '(("http://mastodon.example" :client_id "foo" :client_secret "bar"))))))) -(ert-deftest client-3 () +(ert-deftest client-unset-and-not-in-storage () "Should store client data in plstore if it can't be read." - (let ((mastodon-client--client-details nil)) + (let ((mastodon-instance-url "http://mastodon.example") + (mastodon-client--client-details-alist nil)) (with-mock (mock (mastodon-client--read)) (mock (mastodon-client--store) => '(:client_id "foo" :client_secret "baz")) (should (equal (mastodon-client) '(:client_id "foo" :client_secret "baz"))) - (should (equal mastodon-client--client-details '(:client_id "foo" :client_secret "baz")))))) + (should (equal mastodon-client--client-details-alist + '(("http://mastodon.example" :client_id "foo" :client_secret "baz"))))))) -- cgit v1.2.3 From b1f05c07c8f00e4546b1ff07be47537660a0b5f6 Mon Sep 17 00:00:00 2001 From: Holger Durer Date: Fri, 2 Mar 2018 17:57:44 +0000 Subject: Explicity set output variables to "unlimited" when saving plstore. Alex Griffith reported ellipses in the output which seems to indicate the printing was somehow truncated. I cannot see anywhere in the code path for plstore-save that these variables be set explictly. See https://www.gnu.org/software/emacs/manual/html_node/elisp/Output-Variables.html for an explanation of these variables. --- lisp/mastodon-client.el | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/mastodon-client.el b/lisp/mastodon-client.el index f8beb81..cceb70a 100644 --- a/lisp/mastodon-client.el +++ b/lisp/mastodon-client.el @@ -74,7 +74,12 @@ Make `mastodon-client--fetch' call to determine client values." (let ((plstore (plstore-open (mastodon-client--token-file))) - (client (mastodon-client--fetch))) + (client (mastodon-client--fetch)) + ;; alexgriffith reported seeing ellipses in the saved output + ;; which indicate some output truncating. Nothing in `plstore-save' + ;; seems to ensure this cannot happen so let's do that ourselves: + (print-length nil) + (print-level nil)) (plstore-put plstore (concat "mastodon-" mastodon-instance-url) client nil) (plstore-save plstore) (plstore-close plstore) -- cgit v1.2.3 From c7e0da711b433ccac1f2791c16047e1eb2ed2c75 Mon Sep 17 00:00:00 2001 From: Holger Dürer Date: Sat, 13 May 2017 18:45:51 +0100 Subject: Allow user to navigate interesting things in a buffer via tabbing (tab to go forward, M-tab and S-Tab to go back). This has always been possible while on a hyperlink but now works everywhere. Currently only hyperlinks are tab stops but in the future we will want to support other things and there are already TODO comments in the code to note where we may want to do this. --- lisp/mastodon-tl.el | 223 +++++++++++++++++++++++++++++++++------------- lisp/mastodon.el | 9 +- test/mastodon-tl-tests.el | 173 ++++++++++++++++++++++++++++++++--- 3 files changed, 329 insertions(+), 76 deletions(-) (limited to 'lisp') diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index 2f26b55..58b50ab 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -40,6 +40,7 @@ (autoload 'mastodon-media--inline-images "mastodon-media") (autoload 'mastodon-mode "mastodon") (defvar mastodon-toot-timestamp-format) +(defvar shr-use-fonts) ;; need to declare it since Emacs24 didn't have this (defgroup mastodon-tl nil "Timelines in Mastodon." @@ -73,6 +74,47 @@ keep the timestamps current as time progresses." "The timer that, when set will scan the buffer to update the timestamps.") (make-variable-buffer-local 'mastodon-tl--timestamp-update-timer) +(defvar mastodon-tl--shr-map-replacement + (let ((map (copy-keymap shr-map))) + ;; Replace the move to next/previous link bindings with our + ;; version that knows about more types of links. + (define-key map [remap shr-next-link] 'mastodon-tl--next-tab-item) + (define-key map [remap shr-previous-link] 'mastodon-tl--previous-tab-item) + (keymap-canonicalize map))) + +(defvar mastodon-tl--shr-image-map-replacement + (let ((map (copy-keymap (if (boundp 'shr-image-map) + shr-image-map + shr-map)))) + ;; Replace the move to next/previous link bindings with our + ;; version that knows about more types of links. + (define-key map [remap shr-next-link] 'mastodon-tl--next-tab-item) + (define-key map [remap shr-previous-link] 'mastodon-tl--previous-tab-item) + (keymap-canonicalize map))) + +(defun mastodon-tl--next-tab-item () + "Move to the next interesting item. + +This could be the next toot, link, or image; whichever comes first. +Don't move if nothing else to move to is found, i.e. near the end of the buffer." + (interactive) + (let ((next-range (mastodon-tl--find-next-or-previous-property-range 'mastodon-tab-stop (point) nil))) + (if (null next-range) + (message "Nothing else here.") + (goto-char (car next-range)) + (message "%s" (get-text-property (point) 'help-echo))))) + +(defun mastodon-tl--previous-tab-item () + "Move to the previous interesting item. + +This could be the previous toot, link, or image; whichever comes first. +Don't move if nothing else to move to is found, i.e. near the start of the buffer." + (interactive) + (let ((next-range (mastodon-tl--find-next-or-previous-property-range 'mastodon-tab-stop (point) t))) + (if (null next-range) + (message "Nothing else before this.") + (goto-char (car next-range)) + (message "%s" (get-text-property (point) 'help-echo))))) (defun mastodon-tl--get-federated-timeline () "Opens federated timeline." @@ -140,6 +182,8 @@ Optionally start from POS." (handle (cdr (assoc 'acct account))) (name (cdr (assoc 'display_name account))) (avatar-url (cdr (assoc 'avatar account)))) + ;; TODO: Once we have a view for a user (e.g. their posts + ;; timeline) make this a tab-stop and attach an action (concat (when (and mastodon-tl--show-avatars-p mastodon-tl--display-media-p) (mastodon-media--get-avatar-rendering avatar-url)) @@ -237,49 +281,74 @@ TIME-STAMP is assumed to be in the past." (parsed-time (date-to-time (mastodon-tl--field 'created_at toot))) (faved (equal 't (mastodon-tl--field 'favourited toot))) (boosted (equal 't (mastodon-tl--field 'reblogged toot)))) - (propertize - (concat (propertize "\n | " 'face 'default) - (when boosted - (format "(%s) " - (propertize "B" 'face 'mastodon-boost-fave-face))) - (when faved - (format "(%s) " - (propertize "F" 'face 'mastodon-boost-fave-face))) - (mastodon-tl--byline-author toot) - (mastodon-tl--byline-boosted toot) - " " - (propertize - (format-time-string mastodon-toot-timestamp-format parsed-time) - 'timestamp parsed-time - 'display (if mastodon-tl--enable-relative-timestamps - (mastodon-tl--relative-time-description parsed-time) - parsed-time)) - (propertize "\n ------------" 'face 'default)) - 'favourited-p faved - 'boosted-p boosted - 'toot-id id - 'toot-json toot))) - -(defun mastodon-tl--set-face (string face render) - "Set the face of a string. If `render' is not nil -also render the html" - (propertize - (with-temp-buffer - (insert string) - (when render - (let ((shr-use-fonts nil)) - (shr-render-region (point-min) (point-max)))) - (buffer-string)) - 'face face)) + (concat + (propertize "\n | " 'face 'default) + (propertize + (concat (when boosted + (format "(%s) " + (propertize "B" 'face 'mastodon-boost-fave-face))) + (when faved + (format "(%s) " + (propertize "F" 'face 'mastodon-boost-fave-face))) + (mastodon-tl--byline-author toot) + (mastodon-tl--byline-boosted toot) + " " + ;; TODO: Once we have a view for toot (responses etc.) make + ;; this a tab stop and attach an action. + (propertize + (format-time-string mastodon-toot-timestamp-format parsed-time) + 'timestamp parsed-time + 'display (if mastodon-tl--enable-relative-timestamps + (mastodon-tl--relative-time-description parsed-time) + parsed-time)) + (propertize "\n ------------" 'face 'default)) + 'favourited-p faved + 'boosted-p boosted + 'toot-id id + 'toot-json toot)))) + +(defun mastodon-tl--render-text (string) + "Returns a propertized text giving the rendering of the given HTML string." + (with-temp-buffer + (insert string) + (let ((shr-use-fonts nil)) + (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. + (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))))) + (buffer-string))) + +(defun mastodon-tl--set-face (string face) + "Returns the propertized STRING with the face property set to FACE." + (propertize string 'face face)) (defun mastodon-tl--spoiler (toot) "Retrieve spoiler message from TOOT." (let* ((spoiler (mastodon-tl--field 'spoiler_text toot)) - (string (mastodon-tl--set-face spoiler 'default t)) + (string (mastodon-tl--set-face + (mastodon-tl--render-text spoiler) + 'default)) + ;; TODO: Make this a tab stop and link; then hide the main + ;; text and make the link action a toggling of the + ;; visibility of that main body. (message (concat "\n ---------------" "\n Content Warning" "\n ---------------\n")) - (cw (mastodon-tl--set-face message 'mastodon-cw-face nil))) + (cw (mastodon-tl--set-face message 'mastodon-cw-face))) (if (> (length string) 0) (replace-regexp-in-string "\n\n\n ---------------" "\n ---------------" (concat string cw)) @@ -299,28 +368,23 @@ also render the html" media-attachements ""))) (if (not (and mastodon-tl--display-media-p (equal media-string ""))) - (concat "\n" media-string) ""))) + (concat "\n" media-string) + ""))) (defun mastodon-tl--content (toot) "Retrieve text content from TOOT." - (let ((content (mastodon-tl--field 'content toot)) - (shr-use-fonts nil)) - (propertize (with-temp-buffer - (insert content) - (shr-render-region (point-min) (point-max)) - (buffer-string)) - 'face 'default))) + (let ((content (mastodon-tl--field 'content toot))) + (mastodon-tl--render-text content))) (defun mastodon-tl--toot (toot) "Display TOOT content and byline." (insert (concat (mastodon-tl--spoiler toot) - ;; remove two trailing newlines - (substring (mastodon-tl--content toot) 0 -2) + ;; remove trailing whitespace + (replace-regexp-in-string "[\t\n ]*\\'" "" (mastodon-tl--content toot)) (mastodon-tl--media toot) - "\n\n" (mastodon-tl--byline toot) "\n\n"))) @@ -454,23 +518,60 @@ webapp" (funcall update-function json) (goto-char point-before))))) -(defun mastodon-tl--find-property-range (property start-point) - "Finds (start . end) range around or after START-POINT where PROPERTY is set to a consistent value. +(defun mastodon-tl--find-property-range (property start-point &optional search-backwards) + "Finds (start . end) range around or before/after START-POINT where PROPERTY is set to a consistent value. + +Returns `nil` if no such range is found. -If PROPERTY is set at START-POINT returns a range aroung -START-POINT otherwise after START-POINT." +If PROPERTY is set at START-POINT returns a range around +START-POINT otherwise before/after START-POINT. + +SEARCH-BACKWARDS determines whether we pick point +before (non-nil) or after (nil)" (if (get-text-property start-point property) ;; We are within a range, so look backwards for the start: - (cons (or (previous-single-property-change start-point property) - (point-min)) - (or (next-single-property-change start-point property) - (point-max))) - (let* ((start (next-single-property-change start-point property)) - (end (and start - (or (next-single-property-change start property) - (point-max))))) - (when start - (cons start end))))) + (cons (previous-single-property-change + (if (equal start-point (point-max)) start-point (1+ start-point)) + property nil (point-min)) + (next-single-property-change start-point property nil (point-max))) + (if search-backwards + (let* ((end (or (previous-single-property-change + (if (equal start-point (point-max)) start-point (1+ start-point)) + property) + ;; we may either be just before the range or there is nothing at all + (and (not (equal start-point (point-min))) + (get-text-property (1- start-point) property) + start-point))) + (start (and end + (previous-single-property-change end property nil (point-min))))) + (when end + (cons start end))) + (let* ((start (next-single-property-change start-point property)) + (end (and start + (next-single-property-change start property nil (point-max))))) + (when start + (cons start end)))))) + +(defun mastodon-tl--find-next-or-previous-property-range (property start-point search-backwards) + "Finds (start . end) range after/before START-POINT where PROPERTY is set to a consistent value (different from the value at START-POINT if that is set). + +Returns nil if no such range exists. + +If SEARCH-BACKWARDS is non-nil it find a region before +START-POINT otherwise after START-POINT. +" + (if (get-text-property start-point property) + ;; We are within a range, we need to start the search from + ;; before/after this range: + (let ((current-range (mastodon-tl--find-property-range property start-point))) + (if search-backwards + (unless (equal (car current-range) (point-min)) + (mastodon-tl--find-property-range property (1- (car current-range)) search-backwards)) + (unless (equal (cdr current-range) (point-max)) + (mastodon-tl--find-property-range property (1+ (cdr current-range)) search-backwards)))) + ;; If we are not within a range, we can just defer to + ;; mastodon-tl--find-property-range directly. + (mastodon-tl--find-property-range property start-point search-backwards))) (defun mastodon-tl--consider-timestamp-for-updates (timestamp) "Take note that TIMESTAMP is used in buffer and ajust timers as needed. diff --git a/lisp/mastodon.el b/lisp/mastodon.el index c031774..e04babe 100644 --- a/lisp/mastodon.el +++ b/lisp/mastodon.el @@ -38,6 +38,8 @@ (autoload 'mastodon-tl--get-tag-timeline "mastodon-tl") (autoload 'mastodon-tl--goto-next-toot "mastodon-tl") (autoload 'mastodon-tl--goto-prev-toot "mastodon-tl") +(autoload 'mastodon-tl--next-tab-item "mastodon-tl") +(autoload 'mastodon-tl--previous-tab-item "mastodon-tl") (autoload 'mastodon-tl--thread "mastodon-tl") (autoload 'mastodon-tl--update "mastodon-tl") (autoload 'mastodon-toot--compose-buffer "mastodon-toot") @@ -131,7 +133,12 @@ If REPLY-TO-ID is non-nil, attach new toot to a conversation." (define-key map (kbd "r") #'mastodon-toot--reply) (define-key map (kbd "t") #'mastodon-tl--thread) (define-key map (kbd "T") #'mastodon-tl--get-tag-timeline) - (define-key map (kbd "u") #'mastodon-tl--update))) + (define-key map (kbd "u") #'mastodon-tl--update) + (define-key map [?\t] #'mastodon-tl--next-tab-item) + (define-key map [backtab] #'mastodon-tl--previous-tab-item) + (define-key map [?\S-\t] #'mastodon-tl--previous-tab-item) + (define-key map [?\M-\t] #'mastodon-tl--previous-tab-item) + )) (with-eval-after-load 'mastodon (when (require 'discover nil :noerror) diff --git a/test/mastodon-tl-tests.el b/test/mastodon-tl-tests.el index 5d7699e..4e284a3 100644 --- a/test/mastodon-tl-tests.el +++ b/test/mastodon-tl-tests.el @@ -1,5 +1,6 @@ -(require 'el-mock) +(require 'cl-lib) (require 'cl-macs) +(require 'el-mock) (defconst mastodon-tl-test-base-toot '((id . 61208) @@ -478,7 +479,8 @@ a string or a numeric." (insert "Just some random text") (insert (propertize "More text with a different property" 'other-property 'set)) - (should (null (mastodon-tl--find-property-range 'test-property 2))))) + (should (null (mastodon-tl--find-property-range 'test-property 2 nil))) + (should (null (mastodon-tl--find-property-range 'test-property 2 t))))) (ert-deftest mastodon-tl--find-property-range--earlier-tag () "Should cope with a buffer completely lacking the tag." @@ -487,7 +489,9 @@ a string or a numeric." (let ((end-of-region (point))) (insert "More random text") - (should (null (mastodon-tl--find-property-range 'test-property end-of-region)))))) + (should (null (mastodon-tl--find-property-range 'test-property end-of-region nil))) + (should (equal (cons (point-min) end-of-region) + (mastodon-tl--find-property-range 'test-property end-of-region t)))))) (ert-deftest mastodon-tl--find-property-range--successful-finding () "Should find the sought tag in all expected circumstances." @@ -501,13 +505,47 @@ a string or a numeric." ;; before the region (should (equal (cons start-of-region end-of-region) - (mastodon-tl--find-property-range 'test-property 1))) + (mastodon-tl--find-property-range 'test-property 1 nil))) + (should (null (mastodon-tl--find-property-range 'test-property 1 t))) ;; in the region (should (equal (cons start-of-region end-of-region) - (mastodon-tl--find-property-range 'test-property (+ 2 start-of-region)))) + (mastodon-tl--find-property-range 'test-property (+ 2 start-of-region) nil))) + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property (+ 2 start-of-region) t))) ;; at end of region (should (equal (cons start-of-region end-of-region) - (mastodon-tl--find-property-range 'test-property (1- end-of-region))))))) + (mastodon-tl--find-property-range 'test-property (1- end-of-region) nil))) + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property (1- end-of-region) t)))))) + +(ert-deftest mastodon-tl--find-property-range--successful-finding-consecutive-ranges () + "Should find the sought tag even from in between consecutive ranges." + (with-temp-buffer + (insert "Previous text") + (let ((start-of-region-1 (point)) + between-regions + end-of-region-2) + (insert (propertize "region1" 'test-property 'region1)) + (setq between-regions (point)) + (insert (propertize "region2" 'test-property 'region2)) + (setq end-of-region-2 (point)) + (insert "More random text") + + + ;; before + (should (equal (cons start-of-region-1 between-regions) + (mastodon-tl--find-property-range 'test-property 1 nil))) + (should (null (mastodon-tl--find-property-range 'test-property 1 t))) + + ;; between the regions + (should (equal (cons between-regions end-of-region-2) + (mastodon-tl--find-property-range 'test-property between-regions nil))) + (should (equal (cons between-regions end-of-region-2) + (mastodon-tl--find-property-range 'test-property between-regions t))) + ;; after + (should (null (mastodon-tl--find-property-range 'test-property end-of-region-2 nil))) + (should (equal (cons between-regions end-of-region-2) + (mastodon-tl--find-property-range 'test-property end-of-region-2 t)))))) (ert-deftest mastodon-tl--find-property-range--successful-finding-at-start () "Should cope with a tag at start." @@ -518,13 +556,17 @@ a string or a numeric." ;; at start of the region (should (equal (cons 1 end-of-region) - (mastodon-tl--find-property-range 'test-property 1))) + (mastodon-tl--find-property-range 'test-property 1 nil))) + (should (equal (cons 1 end-of-region) + (mastodon-tl--find-property-range 'test-property 1 t))) ;; in the region (should (equal (cons 1 end-of-region) - (mastodon-tl--find-property-range 'test-property 3))) + (mastodon-tl--find-property-range 'test-property 3 nil))) + (should (equal (cons 1 end-of-region) + (mastodon-tl--find-property-range 'test-property 3 t))) ;; at end of region (should (equal (cons 1 end-of-region) - (mastodon-tl--find-property-range 'test-property (1- end-of-region))))))) + (mastodon-tl--find-property-range 'test-property (1- end-of-region) t)))))) (ert-deftest mastodon-tl--find-property-range--successful-finding-at-end () "Should cope with a tag at end." @@ -537,22 +579,28 @@ a string or a numeric." ;; before the region (should (equal (cons start-of-region end-of-region) - (mastodon-tl--find-property-range 'test-property 1))) + (mastodon-tl--find-property-range 'test-property 1 nil))) + (should (null (mastodon-tl--find-property-range 'test-property 1 t))) ;; in the region (should (equal (cons start-of-region end-of-region) - (mastodon-tl--find-property-range 'test-property (1+ start-of-region)))) + (mastodon-tl--find-property-range 'test-property (1+ start-of-region) nil))) + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property (1+ start-of-region) t))) ;; at end of region (should (equal (cons start-of-region end-of-region) - (mastodon-tl--find-property-range 'test-property (1- end-of-region))))))) + (mastodon-tl--find-property-range 'test-property (1- end-of-region) nil))) + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property (1- end-of-region) t)))))) (ert-deftest mastodon-tl--find-property-range--successful-finding-whole-buffer () "Should cope with a tag being set for the whole buffer." (with-temp-buffer (insert (propertize "Just some text with a the sought property" 'test-property 'set)) - ;; before the region (should (equal (cons (point-min) (point-max)) - (mastodon-tl--find-property-range 'test-property 2))))) + (mastodon-tl--find-property-range 'test-property 2 nil))) + (should (equal (cons (point-min) (point-max)) + (mastodon-tl--find-property-range 'test-property 2 t))))) (defun tl-tests--all-regions-with-property (property) "Returns a list with (start . end) regions where PROPERTY is set." @@ -565,6 +613,102 @@ a string or a numeric." (goto-char (min (point-max) (cdr region)))) (nreverse result))) + +(ert-deftest mastodon-tl--next-tab-item--with-spaces-at-ends () + "Should do the correct tab actions." + (with-temp-buffer + ;; We build a buffer with 3 tab stops: "...R1...R2R3..." (a dot + ;; represents text that is not part of a link, so R1 and R2 have a + ;; gap in between each other, R2 and R3 don't. + (insert "Random text at start") + (let ((start 2) + (r1 (point)) + r2 gap r3 + end) + (insert (propertize "R1 R1 R1" 'mastodon-tab-stop 'region1)) + (setq gap (+ (point) 2)) + (insert " a gap ") + (setq r2 (point)) + (insert (propertize "R2 R2 R2" 'mastodon-tab-stop 'region2)) + (setq r3 (point)) + (insert (propertize "R3 R3 R3" 'mastodon-tab-stop 'region3)) + (setq end (+ (point) 2)) + (insert " more text at end") + + (let ((test-cases + ;; a list 4-elemet lists of (test-name start-point + ;; expected-prev-stop expected-next-stop): + (list (list 'start start start r1) + (list 'r1 r1 r1 r2) + (list 'gap gap r1 r2) + (list 'r2 r2 r1 r3) + (list 'r3 r3 r2 r3) + (list 'end end r3 end)))) + (with-mock + (stub message => nil) ;; don't mess up our test output with the function's messages + (cl-dolist (test test-cases) + (let ((test-name (cl-first test)) + (test-start (cl-second test)) + (expected-prev (cl-third test)) + (expected-next (cl-fourth test))) + (goto-char test-start) + (mastodon-tl--previous-tab-item) + (should (equal (list 'prev test-name expected-prev) + (list 'prev test-name (point)))) + (goto-char test-start) + (mastodon-tl--next-tab-item) + (should (equal (list 'next test-name expected-next) + (list 'next test-name (point))))))))))) + +(ert-deftest mastodon-tl--next-tab-item--no-spaces-at-ends () + "Should do the correct tab actions even with regions right at buffer ends." + (with-temp-buffer + ;; We build a buffer with 3 tab stops: "R1...R2R3...R4" (a dot + ;; represents text that is not part of a link, so R1 and R2, and + ;; R3 and R4 have a gap in between each other, R2 and R3 don't. + (let ((r1 (point)) + gap1 + r2 r3 + gap2 + r4) + (insert (propertize "R1 R1 R1" 'mastodon-tab-stop 'region1)) + (setq gap1 (+ (point) 2)) + (insert " a gap ") + (setq r2 (point)) + (insert (propertize "R2 R2 R2" 'mastodon-tab-stop 'region2)) + (setq r3 (point)) + (insert (propertize "R3 R3 R3" 'mastodon-tab-stop 'region3)) + (setq gap2 (+ (point) 2)) + (insert " another gap ") + (setq r4 (point)) + (insert (propertize "R4 R4 R4" 'mastodon-tab-stop 'region4)) + + (let ((test-cases + ;; a list 4-elemet lists of (test-name start-point + ;; expected-prev-stop expected-next-stop): + (list (list 'r1 r1 r1 r2) + (list 'gap1 gap1 r1 r2) + (list 'r2 r2 r1 r3) + (list 'r3 r3 r2 r4) + (list 'gap2 gap2 r3 r4) + (list 'r4 r4 r3 r4)))) + (with-mock + (stub message => nil) ;; don't mess up our test output with the function's messages + (cl-dolist (test test-cases) + (let ((test-name (cl-first test)) + (test-start (cl-second test)) + (expected-prev (cl-third test)) + (expected-next (cl-fourth test))) + (goto-char test-start) + (mastodon-tl--previous-tab-item) + (should (equal (list 'prev test-name expected-prev) + (list 'prev test-name (point)))) + (goto-char test-start) + (mastodon-tl--next-tab-item) + (should (equal (list 'next test-name expected-next) + (list 'next test-name (point))))))))))) + + (defun tl-tests--property-values-at (property ranges) "Returns a list with property values at the given ranges. @@ -618,3 +762,4 @@ constant." (tl-tests--property-values-at 'display (tl-tests--all-regions-with-property 'timestamp)))) (should (null (marker-position (nth 9 markers))))))))) + -- cgit v1.2.3 From 1e6b9b0b84c52a7d7cc94173079251dad0c2abbd Mon Sep 17 00:00:00 2001 From: Holger Dürer Date: Mon, 5 Mar 2018 20:41:42 +0000 Subject: Add a new customization flag to switch between using fixed width or proportional fonts. The default stays as is now to use fixed width fonts. --- lisp/mastodon-tl.el | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index 58b50ab..c78211d 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -55,6 +55,11 @@ keep the timestamps current as time progresses." :group 'mastodon-tl :type '(boolean :tag "Enable relative timestamps and background updater task")) +(defcustom mastodon-tl--enable-proportional-fonts nil + "Nonnil to enable using proportional (rather than the default fixed width) fonts when rendering HTML." + :group 'mastodon-tl + :type '(boolean :tag "Enable using proportional rather than fixed width fonts when rendering HTML text")) + (defvar mastodon-tl--buffer-spec nil "A unique identifier and functions for each Mastodon buffer.") (make-variable-buffer-local 'mastodon-tl--buffer-spec) @@ -311,7 +316,9 @@ TIME-STAMP is assumed to be in the past." "Returns a propertized text giving the rendering of the given HTML string." (with-temp-buffer (insert string) - (let ((shr-use-fonts nil)) + (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. -- cgit v1.2.3 From 7331431cc4300b5792907d5d2bd945a8bdc33c84 Mon Sep 17 00:00:00 2001 From: H Durer Date: Tue, 6 Mar 2018 01:16:15 +0000 Subject: Make "Content warning" a tab stop and toggle to show/hide the main contents. (#170) * Allow user to navigate interesting things in a buffer via tabbing (tab to go forward, M-tab and S-Tab to go back). This has always been possible while on a hyperlink but now works everywhere. Currently only hyperlinks are tab stops but in the future we will want to support other things and there are already TODO comments in the code to note where we may want to do this. * Add a new tab stop and link type: spoiler toggling. This initially hides the spoiler in a toot and makes the "Content warning" a link and tab stop. The action taken is to toggle the visibility of the toot. --- lisp/mastodon-tl.el | 142 +++++++++++++++++++++++++++++++++++++--------- test/mastodon-tl-tests.el | 62 +++++++++++++++++++- 2 files changed, 175 insertions(+), 29 deletions(-) (limited to 'lisp') diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index c78211d..ad5105d 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -50,7 +50,7 @@ (defcustom mastodon-tl--enable-relative-timestamps t "Nonnil to enable showing relative (to the current time) timestamps. -This will require periodic updates of a timeline buffer to +This will require periodic updates of a timeline buffer to keep the timestamps current as time progresses." :group 'mastodon-tl :type '(boolean :tag "Enable relative timestamps and background updater task")) @@ -79,13 +79,33 @@ keep the timestamps current as time progresses." "The timer that, when set will scan the buffer to update the timestamps.") (make-variable-buffer-local 'mastodon-tl--timestamp-update-timer) +(defvar mastodon-tl--link-keymap + (let ((map (make-sparse-keymap))) + (define-key map [return] 'mastodon-tl--do-link-action-at-point) + (define-key map [mouse-2] 'mastodon-tl--do-link-action) + (define-key map [follow-link] 'mouse-face) + (define-key map [tab] 'mastodon-tl--next-tab-item) + (define-key map [M-tab] 'mastodon-tl--previous-tab-item) + (define-key map [S-tab] 'mastodon-tl--previous-tab-item) + (define-key map [backtab] 'mastodon-tl--previous-tab-item) + (keymap-canonicalize map)) + "The keymap set for things in the buffer that act like links (except for shr.el generate links). + +This will make the region of text act like like a link with mouse +highlighting, mouse click action tabbing to next/previous link +etc.") + (defvar mastodon-tl--shr-map-replacement (let ((map (copy-keymap shr-map))) ;; Replace the move to next/previous link bindings with our ;; version that knows about more types of links. (define-key map [remap shr-next-link] 'mastodon-tl--next-tab-item) (define-key map [remap shr-previous-link] 'mastodon-tl--previous-tab-item) - (keymap-canonicalize map))) + (keymap-canonicalize map)) + "The keymap to be set for shr.el generated links that are not images. + +We need to override the keymap so tabbing will navigate to all +types of mastodon links and not just shr.el-generated ones.") (defvar mastodon-tl--shr-image-map-replacement (let ((map (copy-keymap (if (boundp 'shr-image-map) @@ -95,15 +115,26 @@ keep the timestamps current as time progresses." ;; version that knows about more types of links. (define-key map [remap shr-next-link] 'mastodon-tl--next-tab-item) (define-key map [remap shr-previous-link] 'mastodon-tl--previous-tab-item) - (keymap-canonicalize map))) + (keymap-canonicalize map)) + "The keymap to be set for shr.el generated image links. + +We need to override the keymap so tabbing will navigate to all +types of mastodon links and not just shr.el-generated ones.") (defun mastodon-tl--next-tab-item () "Move to the next interesting item. This could be the next toot, link, or image; whichever comes first. -Don't move if nothing else to move to is found, i.e. near the end of the buffer." +Don't move if nothing else to move to is found, i.e. near the end of the buffer. +This also skips tab items in invisible text, i.e. hidden spoiler text." (interactive) - (let ((next-range (mastodon-tl--find-next-or-previous-property-range 'mastodon-tab-stop (point) nil))) + (let (next-range + (search-pos (point))) + (while (and (setq next-range (mastodon-tl--find-next-or-previous-property-range 'mastodon-tab-stop search-pos nil)) + (get-text-property (car next-range) 'invisible) + (setq search-pos (1+ (cdr next-range)))) + ;; do nothing, all the action in in the while condition + ) (if (null next-range) (message "Nothing else here.") (goto-char (car next-range)) @@ -113,9 +144,16 @@ Don't move if nothing else to move to is found, i.e. near the end of the buffer. "Move to the previous interesting item. This could be the previous toot, link, or image; whichever comes first. -Don't move if nothing else to move to is found, i.e. near the start of the buffer." +Don't move if nothing else to move to is found, i.e. near the start of the buffer. +This also skips tab items in invisible text, i.e. hidden spoiler text." (interactive) - (let ((next-range (mastodon-tl--find-next-or-previous-property-range 'mastodon-tab-stop (point) t))) + (let (next-range + (search-pos (point))) + (while (and (setq next-range (mastodon-tl--find-next-or-previous-property-range 'mastodon-tab-stop search-pos t)) + (get-text-property (car next-range) 'invisible) + (setq search-pos (1- (car next-range)))) + ;; do nothing, all the action in in the while condition + ) (if (null next-range) (message "Nothing else before this.") (goto-char (car next-range)) @@ -343,23 +381,72 @@ TIME-STAMP is assumed to be in the past." "Returns the propertized STRING with the face property set to FACE." (propertize string 'face face)) +(defun mastodon-tl--toggle-spoiler-text (position) + "Toggle the visibility of the spoiler text at/after POSITION." + (let ((inhibit-read-only t) + (spoiler-text-region (mastodon-tl--find-property-range 'mastodon-content-warning-body position nil))) + (if (not spoiler-text-region) + (message "No spoiler text here") + (add-text-properties (car spoiler-text-region) (cdr spoiler-text-region) + (list 'invisible (not (get-text-property (car spoiler-text-region) 'invisible))))))) + +(defun mastodon-tl--make-link (string link-type) + "Return a propertized version of STRING that will act like link. + +LINK-TYPE is the type of link to produce." + (let ((help-text (cond + ((eq link-type 'content-warning) + "Toggle hidden text") + (t + (error "unknown link type %s" link-type))))) + (propertize + string + 'mastodon-tab-stop link-type + 'mouse-face 'highlight + 'keymap mastodon-tl--link-keymap + 'help-echo help-text))) + +(defun mastodon-tl--do-link-action-at-point (position) + (interactive "d") + (let ((link-type (get-text-property position 'mastodon-tab-stop))) + (cond ((eq link-type 'content-warning) + (mastodon-tl--toggle-spoiler-text position)) + (t + (error "unknown link type %s" link-type))))) + +(defun mastodon-tl--do-link-action (event) + (interactive "e") + (mastodon-tl--do-link-action-at-point (posn-point (event-end event)))) + +(defun mastodon-tl--has-spoiler (toot) + "Check if the given TOOT has a spoiler text that should initially be shown only while the main content should be hidden." + (let ((spoiler (mastodon-tl--field 'spoiler_text toot))) + (and spoiler (> (length spoiler) 0)))) + (defun mastodon-tl--spoiler (toot) - "Retrieve spoiler message from TOOT." + "Render TOOT with spoiler message. + +This assumes TOOT is a toot with a spoiler message. +The main body gets hidden and only the spoiler text and the +content warning message are displayed. The content warning +message is a link which unhides/hides the main body." (let* ((spoiler (mastodon-tl--field 'spoiler_text toot)) (string (mastodon-tl--set-face - (mastodon-tl--render-text spoiler) + ;; remove trailing whitespace + (replace-regexp-in-string "[\t\n ]*\\'" "" + (mastodon-tl--render-text spoiler)) 'default)) - ;; TODO: Make this a tab stop and link; then hide the main - ;; text and make the link action a toggling of the - ;; visibility of that main body. - (message (concat "\n ---------------" - "\n Content Warning" - "\n ---------------\n")) + (message (concat "\n" + " ---------------\n" + " " (mastodon-tl--make-link "Content Warning" 'content-warning) "\n" + " ---------------\n")) (cw (mastodon-tl--set-face message 'mastodon-cw-face))) - (if (> (length string) 0) - (replace-regexp-in-string "\n\n\n ---------------" - "\n ---------------" (concat string cw)) - ""))) + (concat + string + cw + (propertize (mastodon-tl--content toot) + 'invisible t + 'mastodon-content-warning-body t)))) (defun mastodon-tl--media (toot) "Retrieve a media attachment link for TOOT if one exists." @@ -382,16 +469,19 @@ TIME-STAMP is assumed to be in the past." (defun mastodon-tl--content (toot) "Retrieve text content from TOOT." (let ((content (mastodon-tl--field 'content toot))) - (mastodon-tl--render-text content))) + (concat + (mastodon-tl--render-text content) + (mastodon-tl--media toot)))) (defun mastodon-tl--toot (toot) "Display TOOT content and byline." (insert (concat - (mastodon-tl--spoiler toot) ;; remove trailing whitespace - (replace-regexp-in-string "[\t\n ]*\\'" "" (mastodon-tl--content toot)) - (mastodon-tl--media toot) + (replace-regexp-in-string "[\t\n ]*\\'" "" (if (mastodon-tl--has-spoiler toot) + (mastodon-tl--spoiler toot) + (mastodon-tl--content toot))) + (mastodon-tl--byline toot) "\n\n"))) @@ -488,7 +578,7 @@ webapp" (let ((id (cdr (assoc 'id json))) (reblog (cdr (assoc 'reblog json)))) (if reblog (cdr (assoc 'id reblog)) id))) - + (defun mastodon-tl--thread () "Open thread buffer for toot under `point'." (interactive) @@ -526,9 +616,7 @@ webapp" (goto-char point-before))))) (defun mastodon-tl--find-property-range (property start-point &optional search-backwards) - "Finds (start . end) range around or before/after START-POINT where PROPERTY is set to a consistent value. - -Returns `nil` if no such range is found. +" Returns `nil` if no such range is found. If PROPERTY is set at START-POINT returns a range around START-POINT otherwise before/after START-POINT. diff --git a/test/mastodon-tl-tests.el b/test/mastodon-tl-tests.el index 4e284a3..189916d 100644 --- a/test/mastodon-tl-tests.el +++ b/test/mastodon-tl-tests.el @@ -8,7 +8,7 @@ (in_reply_to_id) (in_reply_to_account_id) (sensitive . :json-false) - (spoiler_text . "Spoiler text") + (spoiler_text . "") (visibility . "public") (account (id . 42) (username . "acct42") @@ -25,6 +25,7 @@ (tags . []) (uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status") (url . "https://example.space/users/acct42/updates/123456789") + (content . "

Just some text

") (reblogs_count . 0) (favourites_count . 0) (reblog)) @@ -36,7 +37,7 @@ (in_reply_to_id) (in_reply_to_account_id) (sensitive . :json-false) - (spoiler_text . "Spoiler text") + (spoiler_text . "") (visibility . "public") (account (id . 42) (username . "acct42") @@ -763,3 +764,60 @@ constant." (tl-tests--all-regions-with-property 'timestamp)))) (should (null (marker-position (nth 9 markers))))))))) +(ert-deftest mastodon-tl--has-spoiler () + "Should be able to detect toots with spoiler text as expected" + (let* ((normal-toot mastodon-tl-test-base-toot) + (normal-toot-with-spoiler (cons '(spoiler_text . "spoiler") normal-toot)) + (boosted-toot mastodon-tl-test-base-boosted-toot) + (boosted-toot-with-spoiler (cons (cons 'reblog normal-toot-with-spoiler) + boosted-toot))) + (should (null (mastodon-tl--has-spoiler normal-toot))) + (should-not (null (mastodon-tl--has-spoiler normal-toot-with-spoiler))) + (should (null (mastodon-tl--has-spoiler boosted-toot))) + (should-not (null (mastodon-tl--has-spoiler boosted-toot-with-spoiler))))) + +(ert-deftest mastodon-tl--spoiler () + "Should render a toot with spoiler properly, with link that toggles the body." + (let ((normal-toot-with-spoiler (cons '(spoiler_text . "This is the spoiler warning text") + mastodon-tl-test-base-toot)) + toot-start + toot-end + link-region + body-position) + (with-temp-buffer + (insert "some text before\n") + (setq toot-start (point)) + (with-mock + (stub create-image => '(image "fake data")) + (stub shr-render-region => nil) ;; Travis's Emacs doesn't have libxml + (insert + (mastodon-tl--spoiler normal-toot-with-spoiler))) + (setq toot-end (point)) + (insert "\nsome more text.") + + (goto-char toot-start) + (should (eq t (looking-at "This is the spoiler warning text"))) + + (setq link-region (mastodon-tl--find-next-or-previous-property-range + 'mastodon-tab-stop toot-start nil)) + ;; There should be a link following the text: + (should-not (null link-region)) + (goto-char (car link-region)) + (should (eq t (looking-at "Content Warning"))) + + (setq body-position (+ 25 (cdr link-region))) ;; 25 is enough to skip the "\n--------------...." + + ;; The text a bit after the link should be invisible: + (should (eq t (get-text-property body-position 'invisible))) + + ;; Click the link: + (mastodon-tl--do-link-action-at-point (car link-region)) + + ;; The body is now visible: + (should (eq nil (get-text-property body-position 'invisible))) + + ;; Click the link once more: + (mastodon-tl--do-link-action-at-point (car link-region)) + + ;; The body is invisible again: + (should (eq t (get-text-property body-position 'invisible)))))) -- cgit v1.2.3 From b277114d7b3be3447eeecaf3ba7ac0b282a339fe Mon Sep 17 00:00:00 2001 From: Alexander Griffith Date: Mon, 5 Mar 2018 21:39:12 -0500 Subject: Bump to 0.7.2 and shorten long code lines (#172) * Bump version numbers to 0.7.2 * Adjusted functions to bring line length below 90. --- lisp/mastodon-auth.el | 2 +- lisp/mastodon-client.el | 5 ++- lisp/mastodon-http.el | 2 +- lisp/mastodon-inspect.el | 2 +- lisp/mastodon-media.el | 16 +++++--- lisp/mastodon-tl.el | 97 +++++++++++++++++++++++++++++------------------- lisp/mastodon-toot.el | 2 +- lisp/mastodon.el | 2 +- 8 files changed, 78 insertions(+), 50 deletions(-) (limited to 'lisp') diff --git a/lisp/mastodon-auth.el b/lisp/mastodon-auth.el index b2399d2..28c14bc 100644 --- a/lisp/mastodon-auth.el +++ b/lisp/mastodon-auth.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.1 +;; Version: 0.7.2 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) diff --git a/lisp/mastodon-client.el b/lisp/mastodon-client.el index cceb70a..968cdf3 100644 --- a/lisp/mastodon-client.el +++ b/lisp/mastodon-client.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.1 +;; Version: 0.7.2 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) @@ -96,7 +96,8 @@ Make `mastodon-client--fetch' call to determine client values." Read plist from `mastodon-client--token-file' if variable is nil. Fetch and store plist if `mastodon-client--read' returns nil." - (let ((client-details (cdr (assoc mastodon-instance-url mastodon-client--client-details-alist)))) + (let ((client-details + (cdr (assoc mastodon-instance-url mastodon-client--client-details-alist)))) (unless client-details (setq client-details (or (mastodon-client--read) diff --git a/lisp/mastodon-http.el b/lisp/mastodon-http.el index 905a853..de9d464 100644 --- a/lisp/mastodon-http.el +++ b/lisp/mastodon-http.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.1 +;; Version: 0.7.2 ;; Package-Requires: ((emacs "24.4")) ;; Homepage: https://github.com/jdenen/mastodon.el diff --git a/lisp/mastodon-inspect.el b/lisp/mastodon-inspect.el index c5b2924..62a91b5 100644 --- a/lisp/mastodon-inspect.el +++ b/lisp/mastodon-inspect.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.1 +;; Version: 0.7.2 ;; Package-Requires: ((emacs "24.4")) ;; Homepage: https://github.com/jdenen/mastodon.el diff --git a/lisp/mastodon-media.el b/lisp/mastodon-media.el index fa5b8c3..2decce4 100644 --- a/lisp/mastodon-media.el +++ b/lisp/mastodon-media.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.1 +;; Version: 0.7.2 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) @@ -127,7 +127,8 @@ BAIQCEAgAIEABAIsJVH58WqHw8FIgjUIQCAACAQgEIBAAAIBCAQgEIBAAAIBCAQgEAAEAhAIQCBA fKRJkmVZjAQwh78A6vCRWJE8K+8AAAAASUVORK5CYII=") "The PNG data for a generic 200x200 'broken image' view") -(defun mastodon-media--process-image-response (status-plist marker image-options region-length) +(defun mastodon-media--process-image-response + (status-plist marker image-options region-length) "Callback function processing the url retrieve response for URL. STATUS-PLIST is the usual plist of status events as per `url-retrieve'. @@ -151,7 +152,8 @@ REGION-LENGTH is the length of the region that should be replaced with the image (let ((inhibit-read-only t)) (save-restriction (widen) - (put-text-property marker (+ marker region-length) 'media-state 'loaded) + (put-text-property marker + (+ marker region-length) 'media-state 'loaded) (when image ;; We only set the image to display if we could load ;; it; we already have set a default image when we @@ -185,7 +187,10 @@ MEDIA-TYPE is a symbol and either 'avatar or 'media-link." (list marker image-options region-length)) (error (with-current-buffer buffer ;; TODO: Consider adding retries - (put-text-property marker (+ marker region-length) 'media-state 'loading-failed) + (put-text-property marker + (+ marker region-length) + 'media-state + 'loading-failed) :loading-failed)))))) (defun mastodon-media--select-next-media-line () @@ -235,7 +240,8 @@ not been returned." (put-text-property start end 'media-state 'invalid-url) ;; proceed to load this image asynchronously (put-text-property start end 'media-state 'loading) - (mastodon-media--load-image-from-url image-url media-type start (- end start))))))) + (mastodon-media--load-image-from-url + image-url media-type start (- end start))))))) (defun mastodon-media--get-avatar-rendering (avatar-url) "Returns the string to be written that renders the avatar at AVATAR-URL." diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index ad5105d..d6f7d04 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.1 +;; Version: 0.7.2 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) @@ -56,9 +56,12 @@ keep the timestamps current as time progresses." :type '(boolean :tag "Enable relative timestamps and background updater task")) (defcustom mastodon-tl--enable-proportional-fonts nil - "Nonnil to enable using proportional (rather than the default fixed width) fonts when rendering HTML." + "Nonnil to enable using proportional fonts when rendering HTML. + +By default fixed width fonts are used." :group 'mastodon-tl - :type '(boolean :tag "Enable using proportional rather than fixed width fonts when rendering HTML text")) + :type '(boolean :tag "Enable using proportional rather than fixed \ +width fonts when rendering HTML text")) (defvar mastodon-tl--buffer-spec nil "A unique identifier and functions for each Mastodon buffer.") @@ -130,7 +133,8 @@ This also skips tab items in invisible text, i.e. hidden spoiler text." (interactive) (let (next-range (search-pos (point))) - (while (and (setq next-range (mastodon-tl--find-next-or-previous-property-range 'mastodon-tab-stop search-pos nil)) + (while (and (setq next-range (mastodon-tl--find-next-or-previous-property-range + 'mastodon-tab-stop search-pos nil)) (get-text-property (car next-range) 'invisible) (setq search-pos (1+ (cdr next-range)))) ;; do nothing, all the action in in the while condition @@ -149,7 +153,8 @@ This also skips tab items in invisible text, i.e. hidden spoiler text." (interactive) (let (next-range (search-pos (point))) - (while (and (setq next-range (mastodon-tl--find-next-or-previous-property-range 'mastodon-tab-stop search-pos t)) + (while (and (setq next-range (mastodon-tl--find-next-or-previous-property-range + 'mastodon-tab-stop search-pos t)) (get-text-property (car next-range) 'invisible) (setq search-pos (1- (car next-range)))) ;; do nothing, all the action in in the while condition @@ -373,8 +378,8 @@ TIME-STAMP is assumed to be in the past." mastodon-tl--shr-map-replacement mastodon-tl--shr-image-map-replacement))) (add-text-properties start end - (list 'mastodon-tab-stop 'shr-url - 'keymap keymap))))) + (list 'mastodon-tab-stop 'shr-url + 'keymap keymap))))) (buffer-string))) (defun mastodon-tl--set-face (string face) @@ -384,11 +389,14 @@ TIME-STAMP is assumed to be in the past." (defun mastodon-tl--toggle-spoiler-text (position) "Toggle the visibility of the spoiler text at/after POSITION." (let ((inhibit-read-only t) - (spoiler-text-region (mastodon-tl--find-property-range 'mastodon-content-warning-body position nil))) + (spoiler-text-region (mastodon-tl--find-property-range + 'mastodon-content-warning-body position nil))) (if (not spoiler-text-region) (message "No spoiler text here") (add-text-properties (car spoiler-text-region) (cdr spoiler-text-region) - (list 'invisible (not (get-text-property (car spoiler-text-region) 'invisible))))))) + (list 'invisible + (not (get-text-property (car spoiler-text-region) + 'invisible))))))) (defun mastodon-tl--make-link (string link-type) "Return a propertized version of STRING that will act like link. @@ -400,11 +408,11 @@ LINK-TYPE is the type of link to produce." (t (error "unknown link type %s" link-type))))) (propertize - string - 'mastodon-tab-stop link-type - 'mouse-face 'highlight - 'keymap mastodon-tl--link-keymap - 'help-echo help-text))) + string + 'mastodon-tab-stop link-type + 'mouse-face 'highlight + 'keymap mastodon-tl--link-keymap + 'help-echo help-text))) (defun mastodon-tl--do-link-action-at-point (position) (interactive "d") @@ -438,7 +446,9 @@ message is a link which unhides/hides the main body." 'default)) (message (concat "\n" " ---------------\n" - " " (mastodon-tl--make-link "Content Warning" 'content-warning) "\n" + " " (mastodon-tl--make-link "Content Warning" + 'content-warning) + "\n" " ---------------\n")) (cw (mastodon-tl--set-face message 'mastodon-cw-face))) (concat @@ -478,10 +488,11 @@ message is a link which unhides/hides the main body." (insert (concat ;; remove trailing whitespace - (replace-regexp-in-string "[\t\n ]*\\'" "" (if (mastodon-tl--has-spoiler toot) - (mastodon-tl--spoiler toot) - (mastodon-tl--content toot))) - + (replace-regexp-in-string + "[\t\n ]*\\'" "" + (if (mastodon-tl--has-spoiler toot) + (mastodon-tl--spoiler toot) + (mastodon-tl--content toot))) (mastodon-tl--byline toot) "\n\n"))) @@ -616,7 +627,7 @@ webapp" (goto-char point-before))))) (defun mastodon-tl--find-property-range (property start-point &optional search-backwards) -" Returns `nil` if no such range is found. + " Returns `nil` if no such range is found. If PROPERTY is set at START-POINT returns a range around START-POINT otherwise before/after START-POINT. @@ -631,14 +642,17 @@ before (non-nil) or after (nil)" (next-single-property-change start-point property nil (point-max))) (if search-backwards (let* ((end (or (previous-single-property-change - (if (equal start-point (point-max)) start-point (1+ start-point)) + (if (equal start-point (point-max)) + start-point (1+ start-point)) property) - ;; we may either be just before the range or there is nothing at all + ;; we may either be just before the range or there + ;; is nothing at all (and (not (equal start-point (point-min))) (get-text-property (1- start-point) property) start-point))) - (start (and end - (previous-single-property-change end property nil (point-min))))) + (start (and + end + (previous-single-property-change end property nil (point-min))))) (when end (cons start end))) (let* ((start (next-single-property-change start-point property)) @@ -647,7 +661,8 @@ before (non-nil) or after (nil)" (when start (cons start end)))))) -(defun mastodon-tl--find-next-or-previous-property-range (property start-point search-backwards) +(defun mastodon-tl--find-next-or-previous-property-range + (property start-point search-backwards) "Finds (start . end) range after/before START-POINT where PROPERTY is set to a consistent value (different from the value at START-POINT if that is set). Returns nil if no such range exists. @@ -661,9 +676,11 @@ START-POINT otherwise after START-POINT. (let ((current-range (mastodon-tl--find-property-range property start-point))) (if search-backwards (unless (equal (car current-range) (point-min)) - (mastodon-tl--find-property-range property (1- (car current-range)) search-backwards)) + (mastodon-tl--find-property-range + property (1- (car current-range)) search-backwards)) (unless (equal (cdr current-range) (point-max)) - (mastodon-tl--find-property-range property (1+ (cdr current-range)) search-backwards)))) + (mastodon-tl--find-property-range + property (1+ (cdr current-range)) search-backwards)))) ;; If we are not within a range, we can just defer to ;; mastodon-tl--find-property-range directly. (mastodon-tl--find-property-range property start-point search-backwards))) @@ -723,8 +740,9 @@ from the start if it is nil." (seconds-to-time 300)) mastodon-tl--timestamp-update-timer nil)) (while (and (< iteration 5) - (setq next-timestamp-range (mastodon-tl--find-property-range 'timestamp - previous-timestamp))) + (setq next-timestamp-range + (mastodon-tl--find-property-range 'timestamp + previous-timestamp))) (let* ((start (car next-timestamp-range)) (end (cdr next-timestamp-range)) (timestamp (get-text-property start 'timestamp)) @@ -732,15 +750,17 @@ from the start if it is nil." (new-display (mastodon-tl--relative-time-description timestamp))) (unless (string= current-display new-display) (let ((inhibit-read-only t)) - (add-text-properties start end - (list 'display (mastodon-tl--relative-time-description timestamp))))) + (add-text-properties + start end (list 'display + (mastodon-tl--relative-time-description timestamp))))) (mastodon-tl--consider-timestamp-for-updates timestamp) (setq iteration (1+ iteration) previous-timestamp (1+ (cdr next-timestamp-range))))) (if next-timestamp-range ;; schedule the next batch from the previous location to ;; start very soon in the future: - (run-at-time 0.1 nil #'mastodon-tl--update-timestamps-callback buffer (copy-marker previous-timestamp)) + (run-at-time 0.1 nil #'mastodon-tl--update-timestamps-callback buffer + (copy-marker previous-timestamp)) ;; otherwise we are done for now; schedule a new run for when needed (setq mastodon-tl--timestamp-update-timer (run-at-time mastodon-tl--timestamp-next-update @@ -781,12 +801,13 @@ UPDATE-FUNCTION is used to recieve more toots." `(buffer-name ,buffer-name endpoint ,endpoint update-function ,update-function) - mastodon-tl--timestamp-update-timer (when mastodon-tl--enable-relative-timestamps - (run-at-time mastodon-tl--timestamp-next-update - nil ;; don't repeat - #'mastodon-tl--update-timestamps-callback - (current-buffer) - nil)))) + mastodon-tl--timestamp-update-timer + (when mastodon-tl--enable-relative-timestamps + (run-at-time mastodon-tl--timestamp-next-update + nil ;; don't repeat + #'mastodon-tl--update-timestamps-callback + (current-buffer) + nil)))) buffer)) (provide 'mastodon-tl) diff --git a/lisp/mastodon-toot.el b/lisp/mastodon-toot.el index 7e2451e..bad9b3f 100644 --- a/lisp/mastodon-toot.el +++ b/lisp/mastodon-toot.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.1 +;; Version: 0.7.2 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) diff --git a/lisp/mastodon.el b/lisp/mastodon.el index e04babe..7f02295 100644 --- a/lisp/mastodon.el +++ b/lisp/mastodon.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen -;; Version: 0.7.1 +;; Version: 0.7.2 ;; Package-Requires: ((emacs "24.4")) ;; Homepage: https://github.com/jdenen/mastodon.el -- cgit v1.2.3 From e9920d64b5283fca6a34b2144a5a35c4c1d02938 Mon Sep 17 00:00:00 2001 From: Alexander Griffith Date: Mon, 5 Mar 2018 21:45:45 -0500 Subject: Retoot add accts closes #155 When responding to toots the full acct for both local and federated accounts are now added to the new toot buffer. Changes - Added a function in mastodon.el to return the current user acct - Added mastodon-toot--process-local, which takes an acct and appends the current server if it is local returns an empty string if the acct matches the current user and does only adds a prefix @ if the acct is federated - mastodon-toot--mentions will return a formatted string of mentions or an empty string - adds tests for mastodon-toot--mentions - adds a missing , in mastodon-http--post - `mastodon-toot--reply` now passes `mastodon-toot` a toot-id rather than the whole json - 'mastodon-toot--reply-to-id is now a local var in a new toot --- lisp/mastodon-auth.el | 18 ++++++++++++++++++ lisp/mastodon-http.el | 2 +- lisp/mastodon-tl.el | 3 ++- lisp/mastodon-toot.el | 34 ++++++++++++++++++++++++++++++---- test/mastodon-toot-tests.el | 39 +++++++++++++++++++++++++++++++++++++++ 5 files changed, 90 insertions(+), 6 deletions(-) (limited to 'lisp') diff --git a/lisp/mastodon-auth.el b/lisp/mastodon-auth.el index 28c14bc..e9889d9 100644 --- a/lisp/mastodon-auth.el +++ b/lisp/mastodon-auth.el @@ -43,6 +43,9 @@ (defvar mastodon-auth--token-alist nil "Alist of User access tokens keyed by instance url.") +(defvar mastodon-auth--acct-alist nil + "Alist of account accts (name@domain) keyed by instance url.") + (defun mastodon-auth--generate-token () "Make POST to generate auth token." (mastodon-http--post @@ -79,5 +82,20 @@ Generate token and set if none known yet." (push (cons mastodon-instance-url token) mastodon-auth--token-alist))) token)) +(defun mastodon-auth--get-account-name () + "Request user credentials and return an account name." + (cdr (assoc + 'acct + (mastodon-http--get-json + (mastodon-http--api + "accounts/verify_credentials"))))) + +(defun mastodon-auth--user-acct () + "Return a mastodon user acct name." + (or (cdr (assoc mastodon-instance-url mastodon-auth--acct-alist)) + (let ((acct (mastodon-auth--get-account-name))) + (push (cons mastodon-instance-url acct) mastodon-auth--acct-alist) + acct))) + (provide 'mastodon-auth) ;;; mastodon-auth.el ends here diff --git a/lisp/mastodon-http.el b/lisp/mastodon-http.el index de9d464..3240eef 100644 --- a/lisp/mastodon-http.el +++ b/lisp/mastodon-http.el @@ -83,7 +83,7 @@ Authorization header is included by default unless UNAUTHENTICED-P is non-nil." (url-request-extra-headers (append (unless unauthenticed-p - `(("Authorization" . (concat "Bearer " (mastodon-auth--access-token))))) + `(("Authorization" . ,(concat "Bearer " (mastodon-auth--access-token))))) headers))) (with-temp-buffer (url-retrieve-synchronously url)))) diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index d6f7d04..252cefd 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -135,6 +135,7 @@ This also skips tab items in invisible text, i.e. hidden spoiler text." (search-pos (point))) (while (and (setq next-range (mastodon-tl--find-next-or-previous-property-range 'mastodon-tab-stop search-pos nil)) + (get-text-property (car next-range) 'invisible) (setq search-pos (1+ (cdr next-range)))) ;; do nothing, all the action in in the while condition @@ -397,7 +398,6 @@ TIME-STAMP is assumed to be in the past." (list 'invisible (not (get-text-property (car spoiler-text-region) 'invisible))))))) - (defun mastodon-tl--make-link (string link-type) "Return a propertized version of STRING that will act like link. @@ -488,6 +488,7 @@ message is a link which unhides/hides the main body." (insert (concat ;; remove trailing whitespace + (replace-regexp-in-string "[\t\n ]*\\'" "" (if (mastodon-tl--has-spoiler toot) diff --git a/lisp/mastodon-toot.el b/lisp/mastodon-toot.el index bad9b3f..5db9d32 100644 --- a/lisp/mastodon-toot.el +++ b/lisp/mastodon-toot.el @@ -48,7 +48,6 @@ map) "Keymap for `mastodon-toot'.") - (defun mastodon-toot--action-success (marker &optional rm) "Insert MARKER with 'success face in byline. @@ -142,14 +141,40 @@ Set `mastodon-toot--content-warning' to nil." (mastodon-http--triage response (lambda () (message "Toot toot!")))))) +(defun mastodon-toot--process-local (acct) + "Adds domain to local ACCT and replaces the curent user name with \"\". + +Mastodon requires the full user@domain, even in the case of local accts. +eg. \"user\" -> \"user@local.social \" (when local.social is the domain of the +mastodon-instance-url). +eg. \"yourusername\" -> \"\" +eg. \"feduser@fed.social\" -> \"feduser@fed.social\" " + (cond ((string-match-p "@" acct) (concat "@" acct " ")) ; federated acct + ((string= (mastodon-auth--user-acct) acct) "") ; your acct + (t (concat "@" acct "@" ; local acct + (cadr (split-string mastodon-instance-url "/" t)) " ")))) + +(defun mastodon-toot--mentions (status) + "Extract mentions from STATUS and process them into a string." + (interactive) + (let ((mentions (cdr (assoc 'mentions status)))) + (mapconcat (lambda(x) (mastodon-toot--process-local + (cdr (assoc 'acct x)))) + ;; reverse does not work on vectors in 24.5 + (reverse (append mentions nil)) + ""))) + (defun mastodon-toot--reply () "Reply to toot at `point'." (interactive) (let* ((toot (mastodon-tl--property 'toot-json)) (id (mastodon-tl--as-string (mastodon-tl--field 'id toot))) (account (mastodon-tl--field 'account toot)) - (user (cdr (assoc 'username account)))) - (mastodon-toot user id))) + (user (cdr (assoc 'acct account))) + (mentions (mastodon-toot--mentions toot))) + (mastodon-toot (when user (concat (mastodon-toot--process-local user) + mentions)) + id))) (defun mastodon-toot--toggle-warning () "Toggle `mastodon-toot--content-warning'." @@ -211,7 +236,8 @@ e.g. mastodon-toot--send -> Send." "If REPLY-TO-USER is provided, inject their handle into the message. If REPLY-TO-ID is provided, set the MASTODON-TOOT--REPLY-TO-ID var." (when reply-to-user - (insert (format "@%s " reply-to-user)) + (insert (format "%s " reply-to-user)) + (make-variable-buffer-local 'mastodon-toot--reply-to-id) (setq mastodon-toot--reply-to-id reply-to-id))) (defun mastodon-toot--compose-buffer (reply-to-user reply-to-id) diff --git a/test/mastodon-toot-tests.el b/test/mastodon-toot-tests.el index e9d3b26..3e25536 100644 --- a/test/mastodon-toot-tests.el +++ b/test/mastodon-toot-tests.el @@ -1,5 +1,44 @@ (require 'el-mock) +(defconst mastodon-toot-multi-mention + '((mentions . + [((id . "1") + (username . "federated") + (url . "https://site.cafe/@federated") + (acct . "federated@federated.cafe")) + ((id . "1") + (username . "federated") + (url . "https://site.cafe/@federated") + (acct . "federated@federated.social")) + ((id . "1") + (username . "local") + (url . "") + (acct . "local"))]))) + +(defconst mastodon-toot-no-mention + '((mentions . []))) + +(ert-deftest toot-multi-mentions () + (let ((mastodon-auth--acct-alist '(("https://local.social". "null"))) + (mastodon-instance-url "https://local.social")) + (should (string= + (mastodon-toot--mentions mastodon-toot-multi-mention) + "@local@local.social @federated@federated.social @federated@federated.cafe ")))) + +(ert-deftest toot-multi-mentions-with-name () + (let ((mastodon-auth--acct-alist + '(("https://local.social". "local"))) + (mastodon-instance-url "https://local.social")) + (should (string= + (mastodon-toot--mentions mastodon-toot-multi-mention) + "@federated@federated.social @federated@federated.cafe ")))) + +(ert-deftest toot-no-mention () + (let ((mastodon-auth--acct-alist + '(("https://local.social". "null"))) + (mastodon-instance-url "https://local.social")) + (should (string= (mastodon-toot--mentions mastodon-toot-no-mention) "")))) + (ert-deftest cancel () (with-mock (mock (kill-buffer-and-window)) -- cgit v1.2.3