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(-) 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(-) 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(-) 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(-) 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(-) 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(-) 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 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(-) 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