aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJohnson Denen <johnson.denen@gmail.com>2018-03-05 22:09:37 -0500
committerGitHub <noreply@github.com>2018-03-05 22:09:37 -0500
commitae8dabda04e377a6ac22cb854e4844f68073f533 (patch)
treeb6c875c5e88e72966440d3641ef37d320ee2d9fd
parente08bb5794762d22f90e85fd65cef7c143e6b9318 (diff)
parente9920d64b5283fca6a34b2144a5a35c4c1d02938 (diff)
Merge pull request #173 from jdenen/develop
Merge 0.7.2 into master
Diffstat
-rw-r--r--README.org39
-rw-r--r--fixture/client.plstore3
-rw-r--r--lisp/mastodon-auth.el44
-rw-r--r--lisp/mastodon-client.el38
-rw-r--r--lisp/mastodon-http.el14
-rw-r--r--lisp/mastodon-inspect.el4
-rw-r--r--lisp/mastodon-media.el71
-rw-r--r--lisp/mastodon-tl.el581
-rw-r--r--lisp/mastodon-toot.el50
-rw-r--r--lisp/mastodon.el11
-rw-r--r--test/mastodon-auth-tests.el15
-rw-r--r--test/mastodon-client-tests.el72
-rw-r--r--test/mastodon-tl-tests.el589
-rw-r--r--test/mastodon-toot-tests.el39
14 files changed, 1378 insertions, 192 deletions
diff --git a/README.org b/README.org
index 2994bcd..95416a7 100644
--- a/README.org
+++ b/README.org
@@ -73,24 +73,27 @@ Opens a =*mastodon-home*= buffer in the major mode so you can see toots. You wil
**** Keybindings
-|-----+------------------------------------------------|
-| Key | Action |
-|-----+------------------------------------------------|
-| =?= | Open context menu (if =discover= is available) |
-| =b= | Boost toot under =point= |
-| =f= | Favourite toot under =point= |
-| =F= | Open federated timeline |
-| =H= | Open home timeline |
-| =j= | Go to next toot |
-| =k= | Go to previous toot |
-| =L= | Open local timeline |
-| =n= | Switch to =mastodon-toot= buffer |
-| =q= | Quit mastodon buffer. Leave window open. |
-| =Q= | Quit mastodon buffer and kill window. |
-| =r= | Reply to toot under =point=. |
-| =t= | Open thread buffer for toot under =point=. |
-| =T= | Prompt for tag and open its timeline |
-|-----+------------------------------------------------|
+|--------------------------+-----------------------------------------------------------------------------------|
+| Key | Action |
+|--------------------------+-----------------------------------------------------------------------------------|
+| =?= | Open context menu (if =discover= is available) |
+| =b= | Boost toot under =point= |
+| =f= | Favourite toot under =point= |
+| =F= | Open federated timeline |
+| =H= | Open home timeline |
+| =j= | Go to next toot |
+| =k= | Go to previous toot |
+| =L= | Open local timeline |
+| =n= | Switch to =mastodon-toot= buffer |
+| =q= | Quit mastodon buffer. Leave window open. |
+| =Q= | Quit mastodon buffer and kill window. |
+| =r= | Reply to toot under =point=. |
+| =t= | Open thread buffer for toot under =point=. |
+| =T= | Prompt for tag and open its timeline |
+| =<tab>= | Go to the next interesting thing that has an action. |
+| =<S-tab>= | Go to the previous interesting thing that has an action. |
+| =<return>= / =<mouse-2>= | Perform action for the thing under point (or under mouse for =<mouse-2>=) if any. |
+|--------------------------+-----------------------------------------------------------------------------------|
**** Legend
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..e9889d9 100644
--- a/lisp/mastodon-auth.el
+++ b/lisp/mastodon-auth.el
@@ -2,7 +2,7 @@
;; Copyright (C) 2017 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.7.1
+;; Version: 0.7.2
;; Homepage: https://github.com/jdenen/mastodon.el
;; Package-Requires: ((emacs "24.4"))
@@ -40,8 +40,11 @@
: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.")
+
+(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."
@@ -53,7 +56,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 +71,31 @@
(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))
+
+(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-client.el b/lisp/mastodon-client.el
index b97197e..968cdf3 100644
--- a/lisp/mastodon-client.el
+++ b/lisp/mastodon-client.el
@@ -2,7 +2,7 @@
;; Copyright (C) 2017 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.7.1
+;; Version: 0.7.2
;; Homepage: https://github.com/jdenen/mastodon.el
;; Package-Requires: ((emacs "24.4"))
@@ -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,13 @@
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))
+ ;; 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)
client))
@@ -81,19 +88,24 @@ 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 75cca2f..3240eef 100644
--- a/lisp/mastodon-http.el
+++ b/lisp/mastodon-http.el
@@ -2,7 +2,7 @@
;; Copyright (C) 2017 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.7.1
+;; Version: 0.7.2
;; Package-Requires: ((emacs "24.4"))
;; Homepage: https://github.com/jdenen/mastodon.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))))
@@ -107,6 +108,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..62a91b5 100644
--- a/lisp/mastodon-inspect.el
+++ b/lisp/mastodon-inspect.el
@@ -2,7 +2,7 @@
;; Copyright (C) 2017 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.7.1
+;; Version: 0.7.2
;; Package-Requires: ((emacs "24.4"))
;; Homepage: https://github.com/jdenen/mastodon.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-media.el b/lisp/mastodon-media.el
index 612fad5..2decce4 100644
--- a/lisp/mastodon-media.el
+++ b/lisp/mastodon-media.el
@@ -2,7 +2,7 @@
;; Copyright (C) 2017 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.7.1
+;; Version: 0.7.2
;; Homepage: https://github.com/jdenen/mastodon.el
;; Package-Requires: ((emacs "24.4"))
@@ -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-"
@@ -125,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'.
@@ -133,31 +136,33 @@ 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))))
+ (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.
@@ -171,7 +176,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
@@ -180,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 ()
@@ -230,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 66452dd..252cefd 100644
--- a/lisp/mastodon-tl.el
+++ b/lisp/mastodon-tl.el
@@ -2,7 +2,7 @@
;; Copyright (C) 2017 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.7.1
+;; Version: 0.7.2
;; Homepage: https://github.com/jdenen/mastodon.el
;; Package-Requires: ((emacs "24.4"))
@@ -40,19 +40,130 @@
(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."
: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"))
+
+(defcustom mastodon-tl--enable-proportional-fonts nil
+ "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"))
+
(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--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)
+
+(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)
+
+(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))
+ "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)
+ 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))
+ "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.
+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))
+
+ (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))
+ (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.
+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))
+ (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))
+ (message "%s" (get-text-property (point) 'help-echo)))))
(defun mastodon-tl--get-federated-timeline ()
"Opens federated timeline."
@@ -120,8 +231,10 @@ 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 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 " (@"
@@ -146,54 +259,204 @@ Return value from boosted content if available."
(or (cdr (assoc field (cdr (assoc 'reblog toot))))
(cdr (assoc field toot))))
+(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."
+ (car (mastodon-tl--relative-time-details timestamp current-time)))
+
(defun mastodon-tl--byline (toot)
"Generate byline for TOOT."
(let ((id (cdr (assoc 'id toot)))
- (timestamp (mastodon-tl--field 'created_at toot))
- (faved (mastodon-tl--field 'favourited toot))
- (boosted (mastodon-tl--field 'reblogged toot)))
+ (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))))
+ (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 mastodon-tl--enable-proportional-fonts)
+ (shr-width (when mastodon-tl--enable-proportional-fonts
+ (window-width))))
+ (shr-render-region (point-min) (point-max)))
+ ;; Make all links a tab stop recognized by our own logic and
+ ;; update keymaps where needed.
+ ;;
+ ;; TODO: Once we have views for users and tags we need to
+ ;; recognize these links and turn them into links to our own
+ ;; views.
+ (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--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
- (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)
- " "
- (format-time-string mastodon-toot-timestamp-format (date-to-time timestamp))
- (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))
+ 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 spoiler 'default t))
- (message (concat "\n ---------------"
- "\n Content Warning"
- "\n ---------------\n"))
- (cw (mastodon-tl--set-face message 'mastodon-cw-face nil)))
- (if (> (length string) 0)
- (replace-regexp-in-string "\n\n\n ---------------"
- "\n ---------------" (concat string cw))
- "")))
+ (string (mastodon-tl--set-face
+ ;; remove trailing whitespace
+ (replace-regexp-in-string "[\t\n ]*\\'" ""
+ (mastodon-tl--render-text spoiler))
+ 'default))
+ (message (concat "\n"
+ " ---------------\n"
+ " " (mastodon-tl--make-link "Content Warning"
+ 'content-warning)
+ "\n"
+ " ---------------\n"))
+ (cw (mastodon-tl--set-face message 'mastodon-cw-face)))
+ (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."
@@ -202,32 +465,35 @@ 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 mastodon-tl--display-media-p
+ (equal 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)))
+ (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 two trailing newlines
- (substring (mastodon-tl--content toot) 0 -2)
- (mastodon-tl--media toot)
- "\n\n"
+ ;; remove trailing whitespace
+
+ (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")))
@@ -237,7 +503,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'"
@@ -267,7 +534,7 @@ also render the html"
"&"
"?")
"max_id="
- (number-to-string id)))))
+ (mastodon-tl--as-string id)))))
(mastodon-http--get-json url)))
;; TODO
@@ -280,7 +547,7 @@ also render the html"
"&"
"?")
"since_id="
- (number-to-string id)))))
+ (mastodon-tl--as-string id)))))
(mastodon-http--get-json url)))
(defun mastodon-tl--property (prop &optional backward)
@@ -304,21 +571,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."
@@ -334,6 +627,148 @@ 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 &optional search-backwards)
+ " 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.
+
+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 (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.
+
+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.
+
+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.
+
+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 (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
+ (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)
@@ -346,7 +781,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.
@@ -356,14 +790,25 @@ 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
+ (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 6ec3174..5db9d32 100644
--- a/lisp/mastodon-toot.el
+++ b/lisp/mastodon-toot.el
@@ -2,7 +2,7 @@
;; Copyright (C) 2017 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.7.1
+;; Version: 0.7.2
;; Homepage: https://github.com/jdenen/mastodon.el
;; Package-Requires: ((emacs "24.4"))
@@ -48,7 +48,6 @@
map)
"Keymap for `mastodon-toot'.")
-
(defun mastodon-toot--action-success (marker &optional rm)
"Insert MARKER with 'success face in byline.
@@ -70,7 +69,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 +78,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 +87,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.
@@ -140,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 (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)))
+ (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'."
@@ -209,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/lisp/mastodon.el b/lisp/mastodon.el
index c031774..7f02295 100644
--- a/lisp/mastodon.el
+++ b/lisp/mastodon.el
@@ -2,7 +2,7 @@
;; Copyright (C) 2017 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.7.1
+;; Version: 0.7.2
;; Package-Requires: ((emacs "24.4"))
;; Homepage: https://github.com/jdenen/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-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")))))))
diff --git a/test/mastodon-tl-tests.el b/test/mastodon-tl-tests.el
index 8c706f5..189916d 100644
--- a/test/mastodon-tl-tests.el
+++ b/test/mastodon-tl-tests.el
@@ -1,3 +1,5 @@
+(require 'cl-lib)
+(require 'cl-macs)
(require 'el-mock)
(defconst mastodon-tl-test-base-toot
@@ -6,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")
@@ -23,6 +25,7 @@
(tags . [])
(uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status")
(url . "https://example.space/users/acct42/updates/123456789")
+ (content . "<p>Just some text</p>")
(reblogs_count . 0)
(favourites_count . 0)
(reblog))
@@ -34,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")
@@ -96,6 +99,28 @@
(let ((input "foobar</p>"))
(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"))
@@ -103,6 +128,126 @@
(mock (mastodon-http--get-json "https://instance.url/api/v1/timelines/foo?max_id=12345"))
(mastodon-tl--more-json "timelines/foo" 12345))))
+(ert-deftest more-json-id-string ()
+ "Should request toots older than max_id.
+
+`mastodon-tl--more-json' should accept and id that is either
+a string or a numeric."
+ (let ((mastodon-instance-url "https://instance.url"))
+ (with-mock
+ (mock (mastodon-http--get-json "https://instance.url/api/v1/timelines/foo?max_id=12345"))
+ (mastodon-tl--more-json "timelines/foo" "12345"))))
+
+(ert-deftest update-json-id-string ()
+ "Should request toots more recent than since_id.
+
+`mastodon-tl--updated-json' should accept and id that is either
+a string or a numeric."
+ (let ((mastodon-instance-url "https://instance.url"))
+ (with-mock
+ (mock (mastodon-http--get-json "https://instance.url/api/v1/timelines/foo?since_id=12345"))
+ (mastodon-tl--updated-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 ((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")
+ (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 (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)
@@ -236,3 +381,443 @@
| (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)))))))
+
+(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 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."
+ (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 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."
+ (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 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) 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) 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."
+ (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 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 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) t))))))
+
+(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 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) 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) 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))
+
+ (should (equal (cons (point-min) (point-max))
+ (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."
+ (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)))
+
+
+(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.
+
+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)))))))))
+
+(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))))))
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))
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-24 17:25:42 +0000