aboutsummaryrefslogtreecommitdiff
path: root/lisp/mastodon-tl.el
diff options
context:
space:
mode:
authormarty hiatt <martianhiatus [a t] riseup [d o t] net>2023-07-13 10:35:09 +0200
committermarty hiatt <martianhiatus [a t] riseup [d o t] net>2023-07-13 10:35:09 +0200
commit5123212fa191ce5215262367d1022fd1441dc19a (patch)
treedc45d5bdd162cef7db95bae93b0fe174080e992f /lisp/mastodon-tl.el
parenta8112e5c150fc2ace856cb442fee6b1dd5d25066 (diff)
parent5f095822e92872ddcb76fc9fe98c0cf985849f3b (diff)
Merge branch 'develop'
Diffstat (limited to 'lisp/mastodon-tl.el')
-rw-r--r--lisp/mastodon-tl.el916
1 files changed, 421 insertions, 495 deletions
diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el
index f9db25a..360aeaa 100644
--- a/lisp/mastodon-tl.el
+++ b/lisp/mastodon-tl.el
@@ -60,7 +60,6 @@
(autoload 'mastodon-media--inline-images "mastodon-media")
(autoload 'mastodon-notifications--filter-types-list "mastodon-notifications")
(autoload 'mastodon-notifications--get-mentions "mastodon-notifications")
-(autoload 'mastodon-profile--account-field "mastodon-profile")
(autoload 'mastodon-profile--account-from-id "mastodon-profile")
(autoload 'mastodon-profile--extract-users-handles "mastodon-profile")
(autoload 'mastodon-profile--get-preferences-pref "mastodon-profile")
@@ -128,7 +127,7 @@ nil."
(defcustom mastodon-tl--show-stats t
"Whether to show toot stats (faves, boosts, replies counts)."
- :type 'bool)
+ :type 'boolean)
(defcustom mastodon-tl--symbols
'((reply . ("💬" . "R"))
@@ -258,7 +257,7 @@ types of mastodon links and not just shr.el-generated ones.")
It is active where point is placed by `mastodon-tl--goto-next-toot.'")
-;;; BUFFER MACRO
+;;; MACROS
(defmacro with-mastodon-buffer (buffer mode-fun other-window &rest body)
"Evaluate BODY in a new or existing buffer called BUFFER.
@@ -276,6 +275,21 @@ than `switch-to-buffer'."
(switch-to-buffer ,buffer))
,@body)))
+(defmacro mastodon-tl--do-if-toot (&rest body)
+ "Execute BODY if we have a toot or user at point."
+ (declare (debug t))
+ `(if (and (not (mastodon-tl--profile-buffer-p))
+ (not (mastodon-tl--property 'toot-json))) ; includes user listings
+ (message "Looks like there's no toot or user at point?")
+ ,@body))
+
+(defmacro mastodon-tl--do-if-toot-strict (&rest body)
+ "Execute BODY if we have a toot, and only a toot, at point."
+ (declare (debug t))
+ `(if (not (mastodon-tl--property 'toot-id :no-move))
+ (message "Looks like there's no toot at point?")
+ ,@body))
+
;;; NAV
@@ -283,7 +297,8 @@ than `switch-to-buffer'."
"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."
+This also skips tab items in invisible text, i.e. hidden spoiler text.
+PREVIOUS means move to previous item."
(interactive)
(let (next-range
(search-pos (point)))
@@ -326,6 +341,15 @@ Optionally start from POS."
(mastodon-tl--message-help-echo))
(funcall refresh))))
+(defun mastodon-tl--scroll-up-command ()
+ "Call `scroll-up-command', loading more toots if necessary.
+If we hit `point-max', call `mastodon-tl--more' then `scroll-up-command'."
+ (interactive)
+ (if (not (equal (point) (point-max)))
+ (scroll-up-command)
+ (mastodon-tl--more)
+ (scroll-up-command)))
+
(defun mastodon-tl--goto-next-toot ()
"Jump to next toot header."
(interactive)
@@ -425,15 +449,12 @@ With a double PREFIX arg, limit results to your own instance."
(let ((list (mastodon-http--build-array-params-alist "any[]" (cdr tag))))
(while list
(push (pop list) params))))
- (mastodon-tl--init (if (listp tag)
- "tags-multiple"
- (concat "tag-" tag))
- (concat "timelines/tag/" (if (listp tag)
- ;; endpoint must be /tag/:sth
- (car tag) tag))
- 'mastodon-tl--timeline
- nil
- params)))
+ (mastodon-tl--init
+ (if (listp tag) "tags-multiple" (concat "tag-" tag))
+ (concat "timelines/tag/" (if (listp tag) (car tag) tag)) ; must be /tag/:sth
+ 'mastodon-tl--timeline
+ nil
+ params)))
;;; BYLINES, etc.
@@ -441,9 +462,8 @@ With a double PREFIX arg, limit results to your own instance."
(defun mastodon-tl--message-help-echo ()
"Call message on `help-echo' property at point.
Do so if type of status at poins is not follow_request/follow."
- (let ((type (alist-get
- 'type
- (mastodon-tl--property 'toot-json :no-move)))
+ (let ((type (alist-get 'type
+ (mastodon-tl--property 'toot-json :no-move)))
(echo (mastodon-tl--property 'help-echo :no-move)))
(when echo ; not for followers/following in profile
(unless (or (string= type "follow_request")
@@ -453,25 +473,20 @@ Do so if type of status at poins is not follow_request/follow."
(defun mastodon-tl--byline-author (toot &optional avatar)
"Propertize author of TOOT.
With arg AVATAR, include the account's avatar image."
- (let* ((account (alist-get 'account toot))
- (handle (alist-get 'acct account))
- (name (if (not (string-empty-p (alist-get 'display_name account)))
- (alist-get 'display_name account)
- (alist-get 'username account)))
- (profile-url (alist-get 'url account))
- (avatar-url (alist-get 'avatar account)))
+ (let-alist toot
(concat
- ;; avatar insertion moved up to `mastodon-tl--byline' by default in order
- ;; to be outside of text prop 'byline t. arg avatar is used by
- ;; `mastodon-profile--add-author-bylines'
- (when (and avatar
+ ;; avatar insertion moved up to `mastodon-tl--byline' by default to be
+ ;; outside 'byline propt.
+ (when (and avatar ; used by `mastodon-profile--format-user'
mastodon-tl--show-avatars
mastodon-tl--display-media-p
(if (version< emacs-version "27.1")
(image-type-available-p 'imagemagick)
(image-transforms-p)))
- (mastodon-media--get-avatar-rendering avatar-url))
- (propertize name
+ (mastodon-media--get-avatar-rendering .account.avatar))
+ (propertize (if (not (string-empty-p .account.display_name))
+ .account.display_name
+ .account.username)
'face 'mastodon-display-name-face
;; enable playing of videos when point is on byline:
'attachments (mastodon-tl--get-attachments-for-byline toot)
@@ -485,15 +500,15 @@ With arg AVATAR, include the account's avatar image."
(string-suffix-p "-following*" (buffer-name)))
(mastodon-tl--format-byline-help-echo toot)))
" ("
- (propertize (concat "@" handle)
+ (propertize (concat "@" .account.acct)
'face 'mastodon-handle-face
'mouse-face 'highlight
'mastodon-tab-stop 'user-handle
- 'account account
- 'shr-url profile-url
+ 'account .account
+ 'shr-url .account.url
'keymap mastodon-tl--link-keymap
- 'mastodon-handle (concat "@" handle)
- 'help-echo (concat "Browse user profile of @" handle))
+ 'mastodon-handle (concat "@" .account.acct)
+ 'help-echo (concat "Browse user profile of @" .account.acct))
")")))
(defun mastodon-tl--format-byline-help-echo (toot)
@@ -503,11 +518,10 @@ moving image media from the byline.
Used when point is at the start of a byline, i.e. where
`mastodon-tl--goto-next-toot' leaves point."
(let* ((toot-to-count
- (or
- ;; simply praying this order works
+ (or ; simply praying this order works
(alist-get 'status toot) ; notifications timeline
- ;; fol-req notif, has 'type
- ;; placed before boosts coz fol-reqs have a (useless) reblog entry:
+ ;; fol-req notif, has 'type placed before boosts coz fol-reqs have
+ ;; a (useless) reblog entry:
(when (and (or (mastodon-tl--buffer-type-eq 'notifications)
(mastodon-tl--buffer-type-eq 'mentions))
(alist-get 'type toot))
@@ -521,9 +535,8 @@ Used when point is at the start of a byline, i.e. where
(format-media (when media-types
(format "media: %s"
(mapconcat #'identity media-types " "))))
- (format-media-binding (when (and (or
- (member "video" media-types)
- (member "gifv" media-types))
+ (format-media-binding (when (and (or (member "video" media-types)
+ (member "gifv" media-types))
(require 'mpv nil :no-error))
(format " | C-RET to view with mpv"))))
(format "%s" (concat format-media format-media-binding))))))
@@ -537,25 +550,19 @@ Used when point is at the start of a byline, i.e. where
"Return a list of attachment URLs and types for TOOT.
The result is added as an attachments property to author-byline."
(let ((media-attachments (mastodon-tl--field 'media_attachments toot)))
- (mapcar
- (lambda (attachement)
- (let ((remote-url
- (or (alist-get 'remote_url attachement)
- ;; fallback b/c notifications don't have remote_url
- (alist-get 'url attachement)))
- (type (alist-get 'type attachement)))
- `(:url ,remote-url :type ,type)))
- media-attachments)))
+ (mapcar (lambda (attachment)
+ (let-alist attachment
+ (list :url (or .remote_url .url) ; fallback for notifications
+ :type .type)))
+ media-attachments)))
(defun mastodon-tl--byline-boosted (toot)
"Add byline for boosted data from TOOT."
(let ((reblog (alist-get 'reblog toot)))
(when reblog
(concat
- "\n "
- (propertize "Boosted" 'face 'mastodon-boosted-face)
- " "
- (mastodon-tl--byline-author reblog)))))
+ "\n " (propertize "Boosted" 'face 'mastodon-boosted-face)
+ " " (mastodon-tl--byline-author reblog)))))
(defun mastodon-tl--format-faved-or-boosted-byline (letter)
"Format the byline marker for a boosted or favourited status.
@@ -583,8 +590,7 @@ DETAILED-P means display more detailed info. For now
this just means displaying toot client."
(let* ((created-time
;; bosts and faves in notifs view
- ;; (makes timestamps be for the original toot
- ;; not the boost/fave):
+ ;; (makes timestamps be for the original toot not the boost/fave):
(or (mastodon-tl--field 'created_at
(mastodon-tl--field 'status toot))
;; all other toots, inc. boosts/faves in timelines:
@@ -597,6 +603,7 @@ this just means displaying toot client."
(visibility (mastodon-tl--field 'visibility toot))
(account (alist-get 'account toot))
(avatar-url (alist-get 'avatar account))
+ (type (alist-get 'type toot))
(edited-time (alist-get 'edited_at toot))
(edited-parsed (when edited-time (date-to-time edited-time))))
(concat
@@ -631,9 +638,11 @@ this just means displaying toot client."
(funcall author-byline toot)
;; visibility:
(cond ((equal visibility "direct")
- (concat " " (mastodon-tl--symbol 'direct)))
+ (propertize (concat " " (mastodon-tl--symbol 'direct))
+ 'help-echo visibility))
((equal visibility "private")
- (concat " " (mastodon-tl--symbol 'private))))
+ (propertize (concat " " (mastodon-tl--symbol 'private))
+ 'help-echo visibility)))
(funcall action-byline toot)
" "
(propertize
@@ -673,7 +682,8 @@ this just means displaying toot client."
"")
(propertize (concat "\n " mastodon-tl--horiz-bar)
'face 'default)
- (if mastodon-tl--show-stats
+ (if (and mastodon-tl--show-stats
+ (not (member type '("follow" "follow_request"))))
(mastodon-tl--toot-stats toot)
"")
"\n")
@@ -793,13 +803,10 @@ START and END are the boundaries of the link in the toot."
url toot-instance-url))
(maybe-userhandle
(if (proper-list-p toot) ; fails for profile buffers?
- (or (mastodon-tl--userhandle-from-mentions toot
- link-str)
+ (or (mastodon-tl--userhandle-from-mentions toot link-str)
;; FIXME: if prev always works, cut this:
- (mastodon-tl--extract-userhandle-from-url
- url link-str))
- (mastodon-tl--extract-userhandle-from-url
- url link-str))))
+ (mastodon-tl--extract-userhandle-from-url url link-str))
+ (mastodon-tl--extract-userhandle-from-url url link-str))))
(cond (;; Hashtags:
maybe-hashtag
(setq mastodon-tab-stop-type 'hashtag
@@ -820,9 +827,7 @@ START and END are the boundaries of the link in the toot."
(when maybe-userid
(list 'account-id maybe-userid))))))
;; Anything else:
- (t
- ;; Leave it as a url handled by shr.el.
- ;; (We still have to replace the keymap so that tabbing works.)
+ (t ; Leave it as a url handled by shr.el.
(setq keymap (if (eq shr-map (get-text-property start 'keymap))
mastodon-tl--shr-map-replacement
mastodon-tl--shr-image-map-replacement)
@@ -836,28 +841,26 @@ START and END are the boundaries of the link in the toot."
(defun mastodon-tl--userhandle-from-mentions (toot link)
"Extract a user handle from mentions in json TOOT.
-LINK is maybe the '@handle' to search for."
+LINK is maybe the `@handle' to search for."
(mastodon-tl--extract-el-from-mentions 'acct toot link))
(defun mastodon-tl--extract-userid-toot (toot link)
"Extract a user id for an ACCT from mentions in a TOOT.
-LINK is maybe the '@handle' to search for."
+LINK is maybe the `@handle' to search for."
(mastodon-tl--extract-el-from-mentions 'id toot link))
(defun mastodon-tl--extract-el-from-mentions (el toot link)
"Extract element EL from TOOT mentions that matches LINK.
-LINK should be a simple handle string with no domain, i.e. @user.
-Return nil if no matching element"
+LINK should be a simple handle string with no domain, i.e. \"@user\".
+Return nil if no matching element."
;; Must return nil if nothing found!
- ;; TODO: we should break the while loop as soon as we get sth
(let ((mentions (append (alist-get 'mentions toot) nil)))
(when mentions
(let* ((mention (pop mentions))
(name (substring-no-properties link 1 (length link))) ; cull @
return)
(while mention
- (when (string= (alist-get 'username mention)
- name)
+ (when (string= name (alist-get 'username mention))
(setq return (alist-get el mention)))
(setq mention (pop mentions)))
return))))
@@ -871,10 +874,12 @@ this should be of the form <at-sign><user id>, e.g. \"@Gargon\"."
(url-host (url-generic-parse-url mastodon-instance-url))
(url-host parsed-url))))
(when (and (string= "@" (substring buffer-text 0 1))
+ ;; don't error on domain only url (rare):
+ (not (string= "" (url-filename parsed-url)))
(string= (downcase buffer-text)
(downcase (substring (url-filename parsed-url) 1))))
(if local-p
- buffer-text ; no instance suffic for local mention
+ buffer-text ; no instance suffix for local mention
(concat buffer-text "@" (url-host parsed-url))))))
(defun mastodon-tl--extract-hashtag-from-url (url instance-url)
@@ -898,17 +903,15 @@ the toot)."
(defun mastodon-tl--make-link (string link-type)
"Return a propertized version of STRING that will act like link.
LINK-TYPE is the type of link to produce."
- (let ((help-text (cond
- ((eq link-type 'content-warning)
- "Toggle hidden text")
- (t
- (error "Unknown link type %s" link-type)))))
- (propertize
- string
- 'mastodon-tab-stop link-type
- 'mouse-face 'highlight
- 'keymap mastodon-tl--link-keymap
- 'help-echo help-text)))
+ (let ((help-text (cond ((eq link-type 'content-warning)
+ "Toggle hidden text")
+ (t
+ (error "Unknown link type %s" link-type)))))
+ (propertize string
+ 'mastodon-tab-stop link-type
+ 'mouse-face 'highlight
+ 'keymap mastodon-tl--link-keymap
+ 'help-echo help-text)))
(defun mastodon-tl--do-link-action-at-point (position)
"Do the action of the link at POSITION.
@@ -918,7 +921,8 @@ Used for hitting RET on a given link."
(cond ((eq link-type 'content-warning)
(mastodon-tl--toggle-spoiler-text position))
((eq link-type 'hashtag)
- (mastodon-tl--show-tag-timeline nil (get-text-property position 'mastodon-tag)))
+ (mastodon-tl--show-tag-timeline
+ nil (get-text-property position 'mastodon-tag)))
;; 'account / 'account-id is not set for mentions, only bylines
((eq link-type 'user-handle)
(let ((account-json (get-text-property position 'account))
@@ -994,8 +998,7 @@ content should be hidden."
(defun mastodon-tl--clean-tabs-and-nl (string)
"Remove tabs and newlines from STRING."
- (replace-regexp-in-string
- "[\t\n ]*\\'" "" string))
+ (replace-regexp-in-string "[\t\n ]*\\'" "" string))
(defun mastodon-tl--spoiler (toot)
"Render TOOT with spoiler message.
@@ -1005,17 +1008,15 @@ 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
- ;; remove trailing whitespace
(mastodon-tl--clean-tabs-and-nl
(mastodon-tl--render-text spoiler toot))
'default))
- (message (concat
- " " mastodon-tl--horiz-bar "\n "
- (mastodon-tl--make-link
- (concat "CW: " string)
- 'content-warning)
- "\n "
- mastodon-tl--horiz-bar "\n"))
+ (message (concat " " mastodon-tl--horiz-bar "\n "
+ (mastodon-tl--make-link
+ (concat "CW: " string)
+ 'content-warning)
+ "\n "
+ mastodon-tl--horiz-bar "\n"))
(cw (mastodon-tl--set-face message 'mastodon-cw-face)))
(concat
cw
@@ -1047,36 +1048,25 @@ message is a link which unhides/hides the main body."
(defun mastodon-tl--media-attachment (media-attachment)
"Return a propertized string for MEDIA-ATTACHMENT."
- (let* ((preview-url (alist-get 'preview_url media-attachment))
- (remote-url
- (or (alist-get 'remote_url media-attachment)
- ;; fallback b/c notifications don't have remote_url
- (alist-get 'url media-attachment)))
- (type (alist-get 'type media-attachment))
- (caption (alist-get 'description media-attachment))
- (display-str
- (if (and mastodon-tl--display-caption-not-url-when-no-media
- caption)
- (concat "Media:: " caption)
- (concat "Media:: " preview-url))))
- (if mastodon-tl--display-media-p
- ;; return placeholder [img]:
- (mastodon-media--get-media-link-rendering
- preview-url remote-url type caption) ; 2nd arg for shr-browse-url
- ;; return URL/caption:
- (concat (mastodon-tl--propertize-img-str-or-url
- (concat "Media:: " preview-url) ;; string
- preview-url remote-url type caption
- display-str ;; display
- ;; FIXME: shr-link underlining is awful for captions with
- ;; newlines, as the underlining runs to the edge of the
- ;; frame even if the text doesn'
- 'shr-link)
- "\n"))))
-
-(defun mastodon-tl--propertize-img-str-or-url (str media-url full-remote-url
- type help-echo
- &optional display face)
+ (let-alist media-attachment
+ (let ((display-str
+ (if (and mastodon-tl--display-caption-not-url-when-no-media
+ .description)
+ (concat "Media:: " .description)
+ (concat "Media:: " .preview_url))))
+ (if mastodon-tl--display-media-p
+ (mastodon-media--get-media-link-rendering ; placeholder: "[img]"
+ .preview_url (or .remote_url .url) .type .description) ; 2nd arg for shr-browse-url
+ ;; return URL/caption:
+ (concat (mastodon-tl--propertize-img-str-or-url
+ (concat "Media:: " .preview_url) ; string
+ .preview_url .remote_url .type .description
+ display-str ; display
+ 'shr-link)
+ "\n")))))
+
+(defun mastodon-tl--propertize-img-str-or-url
+ (str media-url full-remote-url type help-echo &optional display face)
"Propertize an media placeholder string \"[img]\" or media URL.
STR is the string to propertize, MEDIA-URL is the preview link,
FULL-REMOTE-URL is the link to the full resolution image on the
@@ -1095,62 +1085,61 @@ HELP-ECHO, DISPLAY, and FACE are the text properties to add."
'keymap mastodon-tl--shr-image-map-replacement
'help-echo (if (or (string= type "image")
(string= type nil)
- (string= type "unknown")) ;handle borked images
+ (string= type "unknown")) ; handle borked images
help-echo
(concat help-echo "\nC-RET: play " type " with mpv"))))
;; POLLS
+(defun mastodon-tl--format-poll-option (option option-counter longest-option)
+ "Format poll OPTION. OPTION-COUNTER is just a counter.
+LONGEST-OPTION is the option whose length determines the formatting."
+ (format "%s: %s%s%s\n"
+ option-counter
+ (propertize (alist-get 'title option)
+ 'face 'success)
+ (make-string (1+ (- (length longest-option)
+ (length (alist-get 'title option))))
+ ?\ )
+ ;; TODO: disambiguate no votes from hidden votes
+ (format "[%s votes]" (or (alist-get 'votes_count option)
+ "0"))))
+
(defun mastodon-tl--get-poll (toot)
"If TOOT includes a poll, return it as a formatted string."
- (let* ((poll (mastodon-tl--field 'poll toot))
- (expiry (mastodon-tl--field 'expires_at poll))
- (expired-p (if (eq (mastodon-tl--field 'expired poll) :json-false) nil t))
- ;; (multi (mastodon-tl--field 'multiple poll))
- (voters-count (mastodon-tl--field 'voters_count poll))
- (vote-count (mastodon-tl--field 'votes_count poll))
- (options (mastodon-tl--field 'options poll))
- (option-titles (mastodon-tl--map-alist 'title options))
- (longest-option (car (sort option-titles
- (lambda (x y)
- (> (length x)
- (length y))))))
- (option-counter 0))
- (concat "\nPoll: \n\n"
- (mapconcat (lambda (option)
- (progn
- (format "%s: %s%s%s\n"
- (setq option-counter (1+ option-counter))
- (propertize (alist-get 'title option)
- 'face 'success)
- (make-string
- (1+
- (- (length longest-option)
- (length (alist-get 'title
- option))))
- ?\ )
- ;; TODO: disambiguate no votes from hidden votes
- (format "[%s votes]" (or (alist-get 'votes_count option)
- "0")))))
- options
- "\n")
- "\n"
- (propertize
- (cond (voters-count ; sometimes it is nil
- (if (= voters-count 1)
- (format "%s person | " voters-count)
- (format "%s people | " voters-count)))
- (vote-count
- (format "%s votes | " vote-count))
- (t
- ""))
- 'face 'font-lock-comment-face)
- (let ((str (if expired-p
- "Poll expired."
- (mastodon-tl--format-poll-expiry expiry))))
- (propertize str 'face 'font-lock-comment-face))
- "\n")))
+ (let-alist (mastodon-tl--field 'poll toot) ; toot or reblog
+ (let* ((option-titles (mastodon-tl--map-alist 'title .options))
+ (longest-option (car (sort option-titles
+ (lambda (x y)
+ (> (length x)
+ (length y))))))
+ (option-counter 0))
+ (concat "\nPoll: \n\n"
+ (mapconcat (lambda (option)
+ (setq option-counter (1+ option-counter))
+ (mastodon-tl--format-poll-option
+ option option-counter longest-option))
+ .options
+ "\n")
+ "\n"
+ (propertize
+ (cond (.voters_count ; sometimes it is nil
+ (if (= .voters_count 1)
+ (format "%s person | " .voters_count)
+ (format "%s people | " .voters_count)))
+ (.vote_count
+ (format "%s votes | " .vote_count))
+ (t
+ ""))
+ 'face 'font-lock-comment-face)
+ (let ((str (if (eq .expired :json-false)
+ (if (eq .expires_at nil)
+ ""
+ (mastodon-tl--format-poll-expiry .expires_at))
+ "Poll expired.")))
+ (propertize str 'face 'font-lock-comment-face))
+ "\n"))))
(defun mastodon-tl--format-poll-expiry (timestamp)
"Convert poll expiry TIMESTAMP into a descriptive string."
@@ -1166,40 +1155,39 @@ HELP-ECHO, DISPLAY, and FACE are the text properties to add."
(plist-get parsed :minutes)))
((> (plist-get parsed :minutes) 0)
(format "%s minutes left" (plist-get parsed :minutes)))
- (t ;; we failed to guess:
+ (t ; we failed to guess:
(format "%s days, %s hours, %s minutes left"
(plist-get parsed :days)
(plist-get parsed :hours)
(plist-get parsed :minutes))))))
+(defun mastodon-tl--read-poll-option ()
+ "Read a poll option to vote on a poll."
+ (let* ((toot (mastodon-tl--property 'toot-json))
+ (poll (mastodon-tl--field 'poll toot))
+ (options (mastodon-tl--field 'options poll))
+ (options-titles (mastodon-tl--map-alist 'title options))
+ (options-number-seq (number-sequence 1 (length options)))
+ (options-numbers (mapcar #'number-to-string options-number-seq))
+ (options-alist (cl-mapcar #'cons options-numbers options-titles))
+ ;; we display both option number and the option title
+ ;; but also store both as cons cell as cdr, as we need it below
+ (candidates (mapcar (lambda (cell)
+ (cons (format "%s | %s" (car cell) (cdr cell))
+ cell))
+ options-alist)))
+ (if (null poll)
+ (message "No poll here.")
+ (list
+ ;; var "option" = just the cdr, a cons of option number and desc
+ (cdr (assoc (completing-read "Poll option to vote for: "
+ candidates
+ nil t) ; require match
+ candidates))))))
+
(defun mastodon-tl--poll-vote (option)
"If there is a poll at point, prompt user for OPTION to vote on it."
- (interactive
- (list
- (let* ((toot (mastodon-tl--property 'toot-json))
- (reblog (alist-get 'reblog toot))
- (poll (or (alist-get 'poll reblog)
- (mastodon-tl--field 'poll toot)))
- (options (mastodon-tl--field 'options poll))
- (options-titles (mastodon-tl--map-alist 'title options))
- (options-number-seq (number-sequence 1 (length options)))
- (options-numbers (mapcar #'number-to-string options-number-seq))
- (options-alist (cl-mapcar #'cons options-numbers options-titles))
- ;; we display both option number and the option title
- ;; but also store both as cons cell as cdr, as we need it below
- (candidates (mapcar (lambda (cell)
- (cons (format "%s | %s" (car cell) (cdr cell))
- cell))
- options-alist)))
- (if (null (mastodon-tl--field 'poll (mastodon-tl--property 'toot-json)))
- (message "No poll here.")
- ;; var "option" = just the cdr, a cons of option number and desc
- (cdr (assoc
- (completing-read "Poll option to vote for: "
- candidates
- nil ; (predicate)
- t) ; require match
- candidates))))))
+ (interactive (mastodon-tl--read-poll-option))
(if (null (mastodon-tl--field 'poll (mastodon-tl--property 'toot-json)))
(message "No poll here.")
(let* ((toot (mastodon-tl--property 'toot-json))
@@ -1243,15 +1231,11 @@ HELP-ECHO, DISPLAY, and FACE are the text properties to add."
URL and TYPE are provided when called while point is on byline,
in which case play first video or gif from current toot."
(interactive)
- (let ((url (or
- ;; point in byline:
- url
- ;; point in toot:
- (mastodon-tl--property 'image-url :no-move)))
- (type (or ;; in byline:
- type
- ;; point in toot:
- (mastodon-tl--property 'mastodon-media-type :no-move))))
+ (let ((url (or url ; point in byline:
+ (mastodon-tl--property 'image-url :no-move))) ; point in toot
+ (type (or type ; in byline
+ ;; point in toot:
+ (mastodon-tl--property 'mastodon-media-type :no-move))))
(if url
(if (or (equal type "gifv")
(equal type "video"))
@@ -1268,22 +1252,17 @@ in which case play first video or gif from current toot."
"Retrieve text content from TOOT.
Runs `mastodon-tl--render-text' and fetches poll or media."
(let* ((content (mastodon-tl--field 'content toot))
- (reblog (alist-get 'reblog toot))
- (poll-p (if reblog
- (alist-get 'poll reblog)
- (alist-get 'poll toot))))
- (concat
- (mastodon-tl--render-text content toot)
- (when poll-p
- (mastodon-tl--get-poll toot))
- (mastodon-tl--media toot))))
+ (poll-p (mastodon-tl--field 'poll toot)))
+ (concat (mastodon-tl--render-text content toot)
+ (when poll-p
+ (mastodon-tl--get-poll toot))
+ (mastodon-tl--media toot))))
(defun mastodon-tl--prev-toot-id ()
"Return the id of the last toot inserted into the buffer."
- (let ((prev-pos (1- (save-excursion
- (previous-single-property-change
- (point)
- 'base-toot-id)))))
+ (let ((prev-pos
+ (1- (save-excursion
+ (previous-single-property-change (point) 'base-toot-id)))))
(get-text-property prev-pos 'base-toot-id)))
(defun mastodon-tl--after-reply-status (reply-to-id)
@@ -1328,7 +1307,6 @@ THREAD means the status will be displayed in a thread view."
'line-prefix bar
'wrap-prefix bar))
body)
- ;; body
" \n"
(mastodon-tl--byline toot author-byline action-byline detailed-p))
'toot-id (or id ; notification's own id
@@ -1337,8 +1315,7 @@ THREAD means the status will be displayed in a thread view."
;; if status is a notif, get id from base-toot
;; (-tl--toot-id toot) will not work here:
(or base-toot
- ;; else normal toot with reblog check:
- toot))
+ toot)) ; else normal toot with reblog check
'toot-json toot
'base-toot base-toot)
"\n")
@@ -1366,38 +1343,31 @@ When the TOOT is a reblog (boost), statistics from reblogged
toots are returned.
To disable showing the stats, customize
`mastodon-tl--show-stats'."
- (when-let ((toot (mastodon-tl--toot-for-stats toot)))
- (let* ((favourites-count (alist-get 'favourites_count toot))
- (favourited (equal 't (alist-get 'favourited toot)))
- (faves-prop (propertize (format "%s" favourites-count)
- 'favourites-count favourites-count))
- (boosts-count (alist-get 'reblogs_count toot))
- (boosted (equal 't (alist-get 'reblogged toot)))
- (boosts-prop (propertize (format "%s" boosts-count)
- 'boosts-count boosts-count))
- (replies-count (alist-get 'replies_count toot))
- (favourites (format "%s %s" faves-prop ;favourites-count
- (mastodon-tl--symbol 'favourite)))
- (boosts (format "%s %s" boosts-prop ;boosts-count
- (mastodon-tl--symbol 'boost)))
- (replies (format "%s %s" replies-count (mastodon-tl--symbol 'reply)))
+ (let-alist (mastodon-tl--toot-for-stats toot)
+ (let* ((faves-prop (propertize (format "%s" .favourites_count)
+ 'favourites-count .favourites_count))
+ (boosts-prop (propertize (format "%s" .reblogs_count)
+ 'boosts-count .reblogs_count))
+ (faves (format "%s %s" faves-prop (mastodon-tl--symbol 'favourite)))
+ (boosts (format "%s %s" boosts-prop (mastodon-tl--symbol 'boost)))
+ (replies (format "%s %s" .replies_count (mastodon-tl--symbol 'reply)))
(status (concat
- (propertize favourites
- 'favourited-p favourited
+ (propertize faves
+ 'favourited-p (eq 't .favourited)
'favourites-field t
- 'help-echo (format "%s favourites" favourites-count)
+ 'help-echo (format "%s favourites" .favourites_count)
'face font-lock-comment-face)
(propertize " | " 'face font-lock-comment-face)
(propertize boosts
- 'boosted-p boosted
+ 'boosted-p (eq 't .reblogged)
'boosts-field t
- 'help-echo (format "%s boosts" boosts-count)
+ 'help-echo (format "%s boosts" .reblogs_count)
'face font-lock-comment-face)
(propertize " | " 'face font-lock-comment-face)
(propertize replies
'replies-field t
- 'replies-count replies-count
- 'help-echo (format "%s replies" replies-count)
+ 'replies-count .replies_count
+ 'help-echo (format "%s replies" .replies_count)
'face font-lock-comment-face)))
(status
(concat
@@ -1419,16 +1389,11 @@ this just means displaying toot client.
THREAD means the status will be displayed in a thread view."
(mastodon-tl--insert-status
toot
- (mastodon-tl--clean-tabs-and-nl
- (if (mastodon-tl--has-spoiler toot)
- (mastodon-tl--spoiler toot)
- (mastodon-tl--content toot)))
- 'mastodon-tl--byline-author
- 'mastodon-tl--byline-boosted
- nil
- nil
- detailed-p
- thread))
+ (mastodon-tl--clean-tabs-and-nl (if (mastodon-tl--has-spoiler toot)
+ (mastodon-tl--spoiler toot)
+ (mastodon-tl--content toot)))
+ 'mastodon-tl--byline-author 'mastodon-tl--byline-boosted
+ nil nil detailed-p thread))
(defun mastodon-tl--timeline (toots &optional thread)
"Display each toot in TOOTS.
@@ -1440,7 +1405,7 @@ THREAD means the status will be displayed in a thread view."
(if (eq (mastodon-tl--get-buffer-type) 'profile-statuses)
toots
(if (or ; we were called via --more*:
- (mastodon-tl--get-buffer-property 'hide-replies nil :no-error)
+ (mastodon-tl--buffer-property 'hide-replies nil :no-error)
;; loading a tl with a prefix arg:
(mastodon-tl--hide-replies-p current-prefix-arg))
(cl-remove-if-not #'mastodon-tl--is-reply toots)
@@ -1450,49 +1415,48 @@ THREAD means the status will be displayed in a thread view."
;;; BUFFER SPEC
-(defun mastodon-tl--get-update-function (&optional buffer)
+(defun mastodon-tl--update-function (&optional buffer)
"Get the UPDATE-FUNCTION stored in `mastodon-tl--buffer-spec'.
Optionally get it for BUFFER."
- (mastodon-tl--get-buffer-property 'update-function buffer))
+ (mastodon-tl--buffer-property 'update-function buffer))
-(defun mastodon-tl--get-endpoint (&optional buffer no-error)
+(defun mastodon-tl--endpoint (&optional buffer no-error)
"Get the ENDPOINT stored in `mastodon-tl--buffer-spec'.
Optionally set it for BUFFER.
NO-ERROR means to fail silently."
- (mastodon-tl--get-buffer-property 'endpoint buffer no-error))
+ (mastodon-tl--buffer-property 'endpoint buffer no-error))
(defun mastodon-tl--buffer-name (&optional buffer no-error)
"Get the BUFFER-NAME stored in `mastodon-tl--buffer-spec'.
Optionally get it for BUFFER.
NO-ERROR means to fail silently."
- (mastodon-tl--get-buffer-property 'buffer-name buffer no-error))
+ (mastodon-tl--buffer-property 'buffer-name buffer no-error))
(defun mastodon-tl--link-header (&optional buffer)
"Get the LINK HEADER stored in `mastodon-tl--buffer-spec'.
Optionally get it for BUFFER."
- (mastodon-tl--get-buffer-property 'link-header buffer :no-error))
+ (mastodon-tl--buffer-property 'link-header buffer :no-error))
(defun mastodon-tl--update-params (&optional buffer)
"Get the UPDATE PARAMS stored in `mastodon-tl--buffer-spec'.
Optionally get it for BUFFER."
- (mastodon-tl--get-buffer-property 'update-params buffer :no-error))
+ (mastodon-tl--buffer-property 'update-params buffer :no-error))
-(defun mastodon-tl--get-buffer-property (property &optional buffer no-error)
+(defun mastodon-tl--buffer-property (property &optional buffer no-error)
"Get PROPERTY from `mastodon-tl--buffer-spec' in BUFFER or `current-buffer'.
If NO-ERROR is non-nil, do not error when property is empty."
- (with-current-buffer (or buffer (current-buffer))
+ (with-current-buffer (or buffer (current-buffer))
(if no-error
(plist-get mastodon-tl--buffer-spec property)
(or (plist-get mastodon-tl--buffer-spec property)
(error "Mastodon-tl--buffer-spec is not defined for buffer %s"
(or buffer (current-buffer)))))))
-(defun mastodon-tl--set-buffer-spec (buffer endpoint update-function
- &optional link-header update-params
- hide-replies)
+(defun mastodon-tl--set-buffer-spec
+ (buffer endpoint update-fun &optional link-header update-params hide-replies)
"Set `mastodon-tl--buffer-spec' for the current buffer.
BUFFER is buffer name, ENDPOINT is buffer's enpoint,
-UPDATE-FUNCTION is its update function.
+UPDATE-FUN is its update function.
LINK-HEADER is the http Link header if present.
UPDATE-PARAMS is any http parameters needed for the update function.
HIDE-REPLIES is a flag indicating if replies are hidden in the current buffer."
@@ -1501,17 +1465,18 @@ HIDE-REPLIES is a flag indicating if replies are hidden in the current buffer."
mastodon-instance-url)
buffer-name ,buffer
endpoint ,endpoint
- update-function ,update-function
+ update-function ,update-fun
link-header ,link-header
update-params ,update-params
hide-replies ,hide-replies)))
;;; BUFFERS
+
(defun mastodon-tl--endpoint-str-= (str &optional type)
"Return T if STR is equal to the current buffer's endpoint.
TYPE may be :prefix or :suffix, in which case, T if STR is a prefix or suffix."
- (let ((endpoint-fun (mastodon-tl--get-endpoint nil :no-error)))
+ (let ((endpoint-fun (mastodon-tl--endpoint nil :no-error)))
(cond ((eq type :prefix)
(string-prefix-p str endpoint-fun))
((eq type :suffix)
@@ -1555,12 +1520,8 @@ call this function after it is set or use something else."
;; profiles:
((mastodon-tl--profile-buffer-p)
(cond
- ;; own profile:
- ;; perhaps not needed, and needlessly confusing,
- ;; e.g. for `mastodon-profile--account-view-cycle':
- ;; ((equal (mastodon-tl--buffer-name)
- ;; (concat "*mastodon-" (mastodon-auth--get-account-name) "-statuses*"))
- ;; 'own-profile-statuses)
+ ;; an own profile option is needlessly confusing e.g. for
+ ;; `mastodon-profile--account-view-cycle'
;; profile note:
((string-suffix-p "update-profile*" buffer-name)
'update-profile-note)
@@ -1615,12 +1576,12 @@ call this function after it is set or use something else."
(defun mastodon-tl--profile-buffer-p ()
"Return t if current buffer is a profile buffer of any kind.
This includes the update profile note buffer, but not the preferences one."
- (string-prefix-p "accounts" (mastodon-tl--get-endpoint nil :no-error)))
+ (string-prefix-p "accounts" (mastodon-tl--endpoint nil :no-error)))
(defun mastodon-tl--timeline-proper-p ()
"Return non-nil if the current buffer is a 'proper' timeline.
-A proper timeline excludes notifications, threads, and other toot
-buffers that aren't strictly mastodon timelines."
+A proper timeline excludes notifications, threads, profiles, and
+other toot buffers that aren't strictly mastodon timelines."
(let ((timeline-buffers
'(home federated local tag-timeline list-timeline profile-statuses)))
(member (mastodon-tl--get-buffer-type) timeline-buffers)))
@@ -1708,9 +1669,8 @@ BACKWARD means move backward (up) the timeline."
(cond ((numberp numeric)
(number-to-string numeric))
((stringp numeric) numeric)
- (t (error
- "Numeric:%s must be either a string or a number"
- 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.
@@ -1718,9 +1678,8 @@ 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 (alist-get 'id json))
- (reblog (alist-get 'reblog json)))
- (if reblog (alist-get 'id reblog) id)))
+ (let-alist json
+ (if .reblog .reblog.id .id)))
(defun mastodon-tl--toot-or-base (json)
"Return the base toot or just the toot from toot JSON."
@@ -1739,8 +1698,16 @@ ID is that of the toot to view."
(if (equal (caar toot) 'error)
(message "Error: %s" (cdar toot))
(with-mastodon-buffer buffer #'mastodon-mode nil
- (mastodon-tl--set-buffer-spec buffer (format "statuses/%s" id) nil)
- (mastodon-tl--toot toot :detailed-p)))))
+ (mastodon-tl--set-buffer-spec buffer (format "statuses/%s" id)
+ #'mastodon-tl--update-toot)
+ (mastodon-tl--toot toot :detailed-p)
+ (goto-char (point-min))
+ (mastodon-tl--goto-next-item)))))
+
+(defun mastodon-tl--update-toot (json)
+ ""
+ (let ((id (alist-get 'id json)))
+ (mastodon-tl--single-toot id)))
(defun mastodon-tl--view-whole-thread ()
"From a thread view, view entire thread.
@@ -1765,12 +1732,9 @@ view all branches of a thread."
(let* ((endpoint (format "statuses/%s/context" id))
(url (mastodon-http--api endpoint))
(buffer (format "*mastodon-thread-%s*" id))
- (toot
- ;; refetch current toot in case we just faved/boosted:
- (mastodon-http--get-json
- (mastodon-http--api (concat "statuses/" id))
- nil
- :silent))
+ (toot (mastodon-http--get-json ; refetch in case we just faved/boosted:
+ (mastodon-http--api (concat "statuses/" id))
+ nil :silent))
(context (mastodon-http--get-json url nil :silent)))
(if (equal (caar toot) 'error)
(message "Error: %s" (cdar toot))
@@ -1782,8 +1746,7 @@ view all branches of a thread."
;; if we have a thread:
(with-mastodon-buffer buffer #'mastodon-mode nil
(let ((marker (make-marker)))
- (mastodon-tl--set-buffer-spec buffer
- endpoint
+ (mastodon-tl--set-buffer-spec buffer endpoint
#'mastodon-tl--thread)
(mastodon-tl--timeline (alist-get 'ancestors context) :thread)
(goto-char (point-max))
@@ -1813,29 +1776,28 @@ Note that you can only (un)mute threads you have posted in."
(defun mastodon-tl--mute-or-unmute-thread (&optional unmute)
"Mute a thread.
If UNMUTE, unmute it."
- (let ((endpoint (mastodon-tl--get-endpoint)))
- (if (mastodon-tl--buffer-type-eq 'thread)
- (let* ((id
+ (let ((endpoint (mastodon-tl--endpoint))
+ (mute-str (if unmute "unmute" "mute")))
+ (when (or (mastodon-tl--buffer-type-eq 'thread)
+ (mastodon-tl--buffer-type-eq 'notifications))
+ (let* ((id
+ (if (mastodon-tl--buffer-type-eq 'notifications)
+ (get-text-property (point) 'base-toot-id)
(save-match-data
(string-match "statuses/\\(?2:[[:digit:]]+\\)/context"
endpoint)
- (match-string 2 endpoint)))
- (we-posted-p (mastodon-tl--user-in-thread-p id))
- (url (mastodon-http--api
- (if unmute
- (format "statuses/%s/unmute" id)
- (format "statuses/%s/mute" id)))))
- (if (not we-posted-p)
- (message "You can only (un)mute a thread you have posted in.")
- (when (if unmute
- (y-or-n-p "Unnute this thread? ")
- (y-or-n-p "Mute this thread? "))
- (let ((response (mastodon-http--post url)))
- (mastodon-http--triage response
- (lambda ()
- (if unmute
- (message "Thread unmuted!")
- (message "Thread muted!")))))))))))
+ (match-string 2 endpoint))))
+ (we-posted-p (mastodon-tl--user-in-thread-p id))
+ (url (mastodon-http--api (format "statuses/%s/%s" id mute-str))))
+ (if (not we-posted-p)
+ (message "You can only (un)mute a thread you have posted in.")
+ (when (y-or-n-p (format "%s this thread? " (capitalize mute-str)))
+ (let ((response (mastodon-http--post url)))
+ (mastodon-http--triage response
+ (lambda ()
+ (if unmute
+ (message "Thread unmuted!")
+ (message "Thread muted!")))))))))))
(defun mastodon-tl--map-account-id-from-toot (statuses)
"Return a list of the account IDs of the author of each toot in STATUSES."
@@ -1860,21 +1822,6 @@ ID is that of the post the context is currently displayed for."
;;; FOLLOW/BLOCK/MUTE, ETC
-(defmacro mastodon-tl--do-if-toot (&rest body)
- "Execute BODY if we have a toot or user at point."
- (declare (debug t))
- `(if (and (not (mastodon-tl--profile-buffer-p))
- (not (mastodon-tl--property 'toot-json))) ; includes user listings
- (message "Looks like there's no toot or user at point?")
- ,@body))
-
-(defmacro mastodon-tl--do-if-toot-strict (&rest body)
- "Execute BODY if we have a toot, and only a toot, at point."
- (declare (debug t))
- `(if (not (mastodon-tl--property 'toot-id :no-move))
- (message "Looks like there's no toot at point?")
- ,@body))
-
(defun mastodon-tl--follow-user (user-handle &optional notify langs)
"Query for USER-HANDLE from current status and follow that user.
If NOTIFY is \"true\", enable notifications when that user posts.
@@ -1882,8 +1829,7 @@ If NOTIFY is \"false\", disable notifications when that user posts.
Can be called to toggle NOTIFY on users already being followed.
LANGS is an array parameters alist of languages to filer user's posts by."
(interactive
- (list
- (mastodon-tl--interactive-user-handles-get "follow")))
+ (list (mastodon-tl--user-handles-get "follow")))
(mastodon-tl--do-if-toot
(mastodon-tl--do-user-action-and-response
user-handle "follow" nil notify langs)))
@@ -1891,16 +1837,14 @@ LANGS is an array parameters alist of languages to filer user's posts by."
(defun mastodon-tl--enable-notify-user-posts (user-handle)
"Query for USER-HANDLE and enable notifications when they post."
(interactive
- (list
- (mastodon-tl--interactive-user-handles-get "enable")))
+ (list (mastodon-tl--user-handles-get "enable")))
(mastodon-tl--do-if-toot
(mastodon-tl--follow-user user-handle "true")))
(defun mastodon-tl--disable-notify-user-posts (user-handle)
"Query for USER-HANDLE and disable notifications when they post."
(interactive
- (list
- (mastodon-tl--interactive-user-handles-get "disable")))
+ (list (mastodon-tl--user-handles-get "disable")))
(mastodon-tl--follow-user user-handle "false"))
(defun mastodon-tl--filter-user-user-posts-by-language (user-handle)
@@ -1908,8 +1852,7 @@ LANGS is an array parameters alist of languages to filer user's posts by."
This feature is experimental and for now not easily varified by
the instance API."
(interactive
- (list
- (mastodon-tl--interactive-user-handles-get "filter by language")))
+ (list (mastodon-tl--user-handles-get "filter by language")))
(let ((langs (mastodon-tl--read-filter-langs)))
(mastodon-tl--do-if-toot
(mastodon-tl--follow-user user-handle nil langs))))
@@ -1923,8 +1866,7 @@ LANGS is the accumulated array param alist if we re-run recursively."
(when choice
(setq langs-alist
(push `("languages[]" . ,(alist-get choice mastodon-iso-639-1
- nil nil
- #'string=))
+ nil nil #'string=))
langs-alist))
(if (y-or-n-p "Filter by another language? ")
(mastodon-tl--read-filter-langs langs-alist)
@@ -1933,24 +1875,21 @@ LANGS is the accumulated array param alist if we re-run recursively."
(defun mastodon-tl--unfollow-user (user-handle)
"Query for USER-HANDLE from current status and unfollow that user."
(interactive
- (list
- (mastodon-tl--interactive-user-handles-get "unfollow")))
+ (list (mastodon-tl--user-handles-get "unfollow")))
(mastodon-tl--do-if-toot
(mastodon-tl--do-user-action-and-response user-handle "unfollow" t)))
(defun mastodon-tl--block-user (user-handle)
"Query for USER-HANDLE from current status and block that user."
(interactive
- (list
- (mastodon-tl--interactive-user-handles-get "block")))
+ (list (mastodon-tl--user-handles-get "block")))
(mastodon-tl--do-if-toot
(mastodon-tl--do-user-action-and-response user-handle "block")))
(defun mastodon-tl--unblock-user (user-handle)
"Query for USER-HANDLE from list of blocked users and unblock that user."
(interactive
- (list
- (mastodon-tl--interactive-blocks-or-mutes-list-get "unblock")))
+ (list (mastodon-tl--get-blocks-or-mutes-list "unblock")))
(if (not user-handle)
(message "Looks like you have no blocks to unblock!")
(mastodon-tl--do-user-action-and-response user-handle "unblock" t)))
@@ -1958,16 +1897,14 @@ LANGS is the accumulated array param alist if we re-run recursively."
(defun mastodon-tl--mute-user (user-handle)
"Query for USER-HANDLE from current status and mute that user."
(interactive
- (list
- (mastodon-tl--interactive-user-handles-get "mute")))
+ (list (mastodon-tl--user-handles-get "mute")))
(mastodon-tl--do-if-toot
(mastodon-tl--do-user-action-and-response user-handle "mute")))
(defun mastodon-tl--unmute-user (user-handle)
"Query for USER-HANDLE from list of muted users and unmute that user."
(interactive
- (list
- (mastodon-tl--interactive-blocks-or-mutes-list-get "unmute")))
+ (list (mastodon-tl--get-blocks-or-mutes-list "unmute")))
(if (not user-handle)
(message "Looks like you have no mutes to unmute!")
(mastodon-tl--do-user-action-and-response user-handle "unmute" t)))
@@ -1975,31 +1912,30 @@ LANGS is the accumulated array param alist if we re-run recursively."
(defun mastodon-tl--dm-user (user-handle)
"Query for USER-HANDLE from current status and compose a message to that user."
(interactive
- (list
- (mastodon-tl--interactive-user-handles-get "message")))
+ (list (mastodon-tl--user-handles-get "message")))
(mastodon-tl--do-if-toot
(mastodon-toot--compose-buffer (concat "@" user-handle))
(setq mastodon-toot--visibility "direct")
(mastodon-toot--update-status-fields)))
-(defun mastodon-tl--interactive-user-handles-get (action)
+(defun mastodon-tl--user-handles-get (action)
"Get the list of user-handles for ACTION from the current toot."
(mastodon-tl--do-if-toot
(let ((user-handles
- (cond ((or (mastodon-tl--buffer-type-eq 'follow-suggestions)
- ;; follow suggests / search / foll requests compat:
- (mastodon-tl--buffer-type-eq 'search)
- (mastodon-tl--buffer-type-eq 'follow-requests)
- ;; profile view follows/followers compat:
- ;; but not for profile statuses:
- ;; fetch 'toot-json:
- (mastodon-tl--buffer-type-eq 'profile-followers)
- (mastodon-tl--buffer-type-eq 'profile-following))
+ (cond ((or ; follow suggests / search / foll requests compat:
+ (mastodon-tl--buffer-type-eq 'follow-suggestions)
+ (mastodon-tl--buffer-type-eq 'search)
+ (mastodon-tl--buffer-type-eq 'follow-requests)
+ ;; profile follows/followers but not statuses:
+ (mastodon-tl--buffer-type-eq 'profile-followers)
+ (mastodon-tl--buffer-type-eq 'profile-following))
+ ;; fetch 'toot-json:
(list (alist-get 'acct
(mastodon-tl--property 'toot-json :no-move))))
- ;; profile view, no toots
+ ;; profile view, point in profile details, poss no toots
;; needed for e.g. gup.pe groups which show no toots publically:
- ((mastodon-tl--profile-buffer-p)
+ ((and (mastodon-tl--profile-buffer-p)
+ (get-text-property (point) 'profile-json))
(list (alist-get 'acct
(mastodon-profile--profile-json))))
(t
@@ -2016,7 +1952,7 @@ LANGS is the accumulated array param alist if we re-run recursively."
nil ; predicate
'confirm)))))
-(defun mastodon-tl--interactive-blocks-or-mutes-list-get (action)
+(defun mastodon-tl--get-blocks-or-mutes-list (action)
"Fetch the list of accounts for ACTION from the server.
Action must be either \"unblock\" or \"unmute\"."
(let* ((endpoint (cond ((equal action "unblock")
@@ -2028,9 +1964,7 @@ Action must be either \"unblock\" or \"unmute\"."
(accts (mastodon-tl--map-alist 'acct json)))
(when accts
(completing-read (format "Handle of user to %s: " action)
- accts
- nil ; predicate
- t))))
+ accts nil t)))) ; require match
(defun mastodon-tl--do-user-action-and-response
(user-handle action &optional negp notify langs)
@@ -2041,23 +1975,20 @@ If NOTIFY is \"false\", disable notifications when that user posts.
NOTIFY is only non-nil when called by `mastodon-tl--follow-user'.
LANGS is an array parameters alist of languages to filer user's posts by."
(let* ((account (if negp
- ;; if unmuting/unblocking, we got handle from mute/block list
- (mastodon-profile--search-account-by-handle
- user-handle)
- ;; if profile view, use 'profile-json as status:
+ ;; unmuting/unblocking, handle from mute/block list
+ (mastodon-profile--search-account-by-handle user-handle)
+ ;; profile view, use 'profile-json as status:
(if (mastodon-tl--profile-buffer-p)
(mastodon-profile--lookup-account-in-status
user-handle (mastodon-profile--profile-json))
- ;; if muting/blocking, we select from handles in current status
+ ;; muting/blocking, select from handles in current status
(mastodon-profile--lookup-account-in-status
user-handle (mastodon-profile--toot-json)))))
- (user-id (mastodon-profile--account-field account 'id))
- (name (if (not (string-empty-p
- (mastodon-profile--account-field account 'display_name)))
- (mastodon-profile--account-field account 'display_name)
- (mastodon-profile--account-field account 'username)))
- (args (cond (notify
- `(("notify" . ,notify)))
+ (user-id (alist-get 'id account))
+ (name (if (string-empty-p (alist-get 'display_name account))
+ (alist-get 'username account)
+ (alist-get 'display_name account)))
+ (args (cond (notify `(("notify" . ,notify)))
(langs langs)
(t nil)))
(url (mastodon-http--api (format "accounts/%s/%s" user-id action))))
@@ -2096,11 +2027,27 @@ ARGS is an alist of any parameters to send with the request."
;; FOLLOW TAGS
+(defun mastodon-tl--get-tags-list ()
+ "Return the list of tags of the toot at point."
+ (let* ((toot (or (mastodon-tl--property 'base-toot :no-move) ; fave/boost notifs
+ (mastodon-tl--property 'toot-json :no-move)))
+ (tags (mastodon-tl--field 'tags toot)))
+ (mapcar (lambda (x)
+ (alist-get 'name x))
+ tags)))
+
(defun mastodon-tl--follow-tag (&optional tag)
"Prompt for a tag and follow it.
If TAG provided, follow it."
(interactive)
- (let* ((tag (or tag (read-string "Tag to follow: ")))
+ (let* ((tags (unless tag (mastodon-tl--get-tags-list)))
+ (tag-at-point
+ (unless tag
+ (when (eq 'hashtag (get-text-property (point) 'mastodon-tab-stop))
+ (get-text-property (point) 'mastodon-tag))))
+ (tag (or tag (completing-read
+ (format "Tag to follow [%s]: " tag-at-point)
+ tags nil nil nil nil tag-at-point)))
(url (mastodon-http--api (format "tags/%s/follow" tag)))
(response (mastodon-http--post url)))
(mastodon-http--triage response
@@ -2117,10 +2064,8 @@ If TAG provided, follow it."
If TAG is provided, unfollow it."
(interactive)
(let* ((followed-tags-json (unless tag (mastodon-tl--followed-tags)))
- (tags (unless tag
- (mastodon-tl--map-alist 'name followed-tags-json)))
- (tag (or tag (completing-read "Unfollow tag: "
- tags)))
+ (tags (unless tag (mastodon-tl--map-alist 'name followed-tags-json)))
+ (tag (or tag (completing-read "Unfollow tag: " tags)))
(url (mastodon-http--api (format "tags/%s/unfollow" tag)))
(response (mastodon-http--post url)))
(mastodon-http--triage response
@@ -2149,7 +2094,7 @@ PREFIX is sent to `mastodon-tl--show-tag-timeline', which see."
(defun mastodon-tl--some-followed-tags-timeline (&optional prefix)
"Prompt for some tags, and open a timeline for them.
The suggestions are from followed tags, but any other tags are also allowed.
-PREFIX us sent to `mastodon-tl--show-tag-timeline', which see."
+PREFIX is for `mastodon-tl--show-tag-timeline', which see."
(interactive "p")
(let* ((followed-tags-json (mastodon-tl--followed-tags))
(tags (mastodon-tl--map-alist 'name followed-tags-json))
@@ -2169,7 +2114,7 @@ PREFIX us sent to `mastodon-tl--show-tag-timeline', which see."
(defun mastodon-tl--report-params (account toot)
"Query user and return report params alist.
ACCOUNT and TOOT are the data to use."
- (let* ((account-id (mastodon-profile--account-field account 'id))
+ (let* ((account-id (alist-get 'id account))
(comment (read-string "Add comment [optional]: "))
(toot-id (when (y-or-n-p "Also report status at point? ")
(mastodon-tl--toot-id toot))) ; base toot if poss
@@ -2219,7 +2164,6 @@ report the account for spam."
(handle (alist-get 'acct account))
(params (mastodon-tl--report-params account toot))
(response (mastodon-http--post url params)))
- ;; (setq masto-report-response response)
(mastodon-http--triage response
(lambda ()
(message "User %s reported!" handle)))))))
@@ -2227,7 +2171,7 @@ report the account for spam."
(defvar crm-separator)
(defun mastodon-tl--map-rules-alist (rules)
- "Return an alist of the text and id fields of RULES."
+ "Convert RULES text and id fields into an alist."
(mapcar (lambda (x)
(let-alist x
(cons .text .id)))
@@ -2240,7 +2184,7 @@ report the account for spam."
(crm-separator (replace-regexp-in-string "," "|" crm-separator))
(choices (completing-read-multiple
"rules [TAB for options, | to separate]: "
- alist nil :match)))
+ alist nil t)))
(mapcar (lambda (x)
(alist-get x alist nil nil 'equal))
choices)))
@@ -2254,7 +2198,8 @@ report the account for spam."
(url (mastodon-http--api endpoint)))
(mastodon-http--get-json url args)))
-(defun mastodon-tl--more-json-async (endpoint id &optional params callback &rest cbargs)
+(defun mastodon-tl--more-json-async
+ (endpoint id &optional params callback &rest cbargs)
"Return JSON for timeline ENDPOINT before ID.
Then run CALLBACK with arguments CBARGS.
PARAMS is used to send any parameters needed to correctly update
@@ -2295,16 +2240,12 @@ POS is a number, where point will be placed."
(mastodon-profile--my-profile))
((eq type 'thread)
(save-match-data
- (let ((endpoint (mastodon-tl--get-endpoint)))
- (string-match
- "statuses/\\(?2:[[:digit:]]+\\)/context"
- endpoint)
- (mastodon-tl--thread
- (match-string 2 endpoint))))))
- ;; TODO: sends point to POS, which was where point was in buffer before
- ;; reload. This is very rough; we may have removed an item (deleted a
- ;; toot, cleared a notif), so the buffer will be smaller, point will end
- ;; up past where we were, etc.
+ (let ((endpoint (mastodon-tl--endpoint)))
+ (string-match "statuses/\\(?2:[[:digit:]]+\\)/context" endpoint)
+ (mastodon-tl--thread (match-string 2 endpoint))))))
+ ;; TODO: sends point to where point was in buffer. This is very rough; we
+ ;; may have removed an item , so the buffer will be smaller, point will
+ ;; end up past where we were, etc.
(when pos
(goto-char pos)
(mastodon-tl--goto-prev-item))))
@@ -2347,7 +2288,7 @@ when showing followers or accounts followed."
(mastodon-http--get-response-async url nil 'mastodon-tl--more* (current-buffer)
(point) :headers))))
(mastodon-tl--more-json-async
- (mastodon-tl--get-endpoint)
+ (mastodon-tl--endpoint)
(mastodon-tl--oldest-id)
(mastodon-tl--update-params)
'mastodon-tl--more* (current-buffer) (point))))
@@ -2368,20 +2309,21 @@ HEADERS is the http headers returned in the response, if any."
;; if thread view, call --thread with parent ID
(progn (goto-char (point-min))
(mastodon-tl--goto-next-toot)
- (funcall (mastodon-tl--get-update-function)))
- (funcall (mastodon-tl--get-update-function) json))
+ (funcall (mastodon-tl--update-function)))
+ (funcall (mastodon-tl--update-function) json))
(goto-char point-before)
;; update buffer spec to new link-header:
;; (other values should just remain as they were)
(when headers
(mastodon-tl--set-buffer-spec (mastodon-tl--buffer-name)
- (mastodon-tl--get-endpoint)
- (mastodon-tl--get-update-function)
+ (mastodon-tl--endpoint)
+ (mastodon-tl--update-function)
link-header))
(message "Loading older toots... done.")))))
-(defun mastodon-tl--find-property-range (property start-point &optional search-backwards)
- "Return `nil` if no such range is found.
+(defun mastodon-tl--find-property-range (property start-point
+ &optional search-backwards)
+ "Return 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
@@ -2402,14 +2344,13 @@ before (non-nil) or after (nil)"
(and (not (equal start-point (point-min)))
(get-text-property (1- start-point) property)
start-point)))
- (start (and
- end
- (previous-single-property-change end property nil (point-min)))))
+ (start (and end (previous-single-property-change
+ end property nil (point-min)))))
(when end
(cons start end)))
(let* ((start (next-single-property-change start-point property))
- (end (and start
- (next-single-property-change start property nil (point-max)))))
+ (end (and start (next-single-property-change
+ start property nil (point-max)))))
(when start
(cons start end))))))
@@ -2458,7 +2399,8 @@ no-op."
;; 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 (time-to-seconds (time-subtract this-update (current-time)))
+ (run-at-time (time-to-seconds (time-subtract this-update
+ (current-time)))
nil ;; don't repeat
#'mastodon-tl--update-timestamps-callback
(current-buffer) nil)))))))
@@ -2468,7 +2410,7 @@ no-op."
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...
+ (when (and mastodon-tl--enable-relative-timestamps ; just in case
(buffer-live-p buffer))
(save-excursion
(with-current-buffer buffer
@@ -2478,8 +2420,7 @@ from the start if it is nil."
(iteration 0)
next-timestamp-range)
(if previous-marker
- ;; This is a follow-up call to process the next batch of
- ;; timestamps.
+ ;; 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.
@@ -2498,8 +2439,9 @@ from the start if it is nil."
(unless (string= current-display new-display)
(let ((inhibit-read-only t))
(add-text-properties
- start end (list 'display
- (mastodon-tl--relative-time-description timestamp)))))
+ 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)))))
@@ -2521,29 +2463,29 @@ from the start if it is nil."
"Set `mastodon-tl--after-update-marker' to the after-update location.
This location is defined by a non-nil value of
`mastodon-tl-position-after-update'."
- (if mastodon-tl-position-after-update
- (let ((marker (make-marker)))
- (set-marker marker
- (cond
- ((eq 'keep-point mastodon-tl-position-after-update)
- (point))
- ((eq 'last-old-toot mastodon-tl-position-after-update)
- (next-single-property-change
- (or mastodon-tl--update-point (point-min))
- 'byline))
- (t
- (error "Unknown mastodon-tl-position-after-update value %S"
- mastodon-tl-position-after-update))))
- ;; Make the marker advance if text gets inserted there.
- (set-marker-insertion-type marker t)
- (setq mastodon-tl--after-update-marker marker))
- (setq mastodon-tl--after-update-marker nil)))
+ (if (not mastodon-tl-position-after-update)
+ (setq mastodon-tl--after-update-marker nil)
+ (let ((marker (make-marker)))
+ (set-marker marker
+ (cond
+ ((eq 'keep-point mastodon-tl-position-after-update)
+ (point))
+ ((eq 'last-old-toot mastodon-tl-position-after-update)
+ (next-single-property-change
+ (or mastodon-tl--update-point (point-min))
+ 'byline))
+ (t
+ (error "Unknown mastodon-tl-position-after-update value %S"
+ mastodon-tl-position-after-update))))
+ ;; Make the marker advance if text gets inserted there.
+ (set-marker-insertion-type marker t)
+ (setq mastodon-tl--after-update-marker marker))))
(defun mastodon-tl--update ()
"Update timeline with new toots."
(interactive)
- (let* ((endpoint (mastodon-tl--get-endpoint))
- (update-function (mastodon-tl--get-update-function))
+ (let* ((endpoint (mastodon-tl--endpoint))
+ (update-function (mastodon-tl--update-function))
(thread-id (mastodon-tl--property 'toot-id)))
;; update a thread, without calling `mastodon-tl--updated-json':
(if (mastodon-tl--buffer-type-eq 'thread)
@@ -2575,12 +2517,12 @@ HIDE-REPLIES is a flag indicating if replies are hidden in the current buffer."
(let ((url (mastodon-http--api endpoint))
(buffer (concat "*mastodon-" buffer-name "*")))
(if headers
- (mastodon-http--get-response-async url params
- 'mastodon-tl--init* buffer endpoint update-function
- headers params hide-replies)
- (mastodon-http--get-json-async url params
- 'mastodon-tl--init* buffer endpoint update-function nil
- params hide-replies))))
+ (mastodon-http--get-response-async
+ url params 'mastodon-tl--init*
+ buffer endpoint update-function headers params hide-replies)
+ (mastodon-http--get-json-async
+ url params 'mastodon-tl--init*
+ buffer endpoint update-function nil params hide-replies))))
(defun mastodon-tl--init* (response buffer endpoint update-function
&optional headers update-params hide-replies)
@@ -2595,31 +2537,12 @@ JSON and http headers, without it just the JSON."
(let* ((headers (if headers (cdr response) nil))
(link-header (mastodon-tl--get-link-header-from-response headers)))
(with-mastodon-buffer buffer #'mastodon-mode nil
- (mastodon-tl--set-buffer-spec buffer
- endpoint
- update-function
- link-header
- update-params
- hide-replies)
- (funcall update-function json)
- (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)))
- (setq mastodon-tl--timestamp-update-timer
- (when mastodon-tl--enable-relative-timestamps
- (run-at-time (time-to-seconds
- (time-subtract mastodon-tl--timestamp-next-update
- (current-time)))
- nil ;; don't repeat
- #'mastodon-tl--update-timestamps-callback
- (current-buffer)
- nil)))
- (unless (mastodon-tl--profile-buffer-p)
- (mastodon-tl--goto-first-item)))))))
+ (mastodon-tl--set-buffer-spec buffer endpoint update-function
+ link-header update-params hide-replies)
+ (mastodon-tl--do-init json update-function))))))
-(defun mastodon-tl--init-sync (buffer-name endpoint update-function &optional note-type)
+(defun mastodon-tl--init-sync (buffer-name endpoint update-function
+ &optional note-type)
"Initialize BUFFER-NAME with timeline targeted by ENDPOINT.
UPDATE-FUNCTION is used to receive more toots.
Runs synchronously.
@@ -2628,32 +2551,35 @@ Optional arg NOTE-TYPE means only get that type of note."
(mastodon-notifications--filter-types-list note-type)))
(args (when note-type (mastodon-http--build-array-params-alist
"exclude_types[]" exclude-types)))
- ;; NB: we now store 'update-params separately in `mastodon-tl--buffer-spec'
- ;; and -http.el handles all conversion of params alists into query strings.
(url (mastodon-http--api endpoint))
(buffer (concat "*mastodon-" buffer-name "*"))
(json (mastodon-http--get-json url args)))
(with-mastodon-buffer buffer #'mastodon-mode nil
- (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-tl--set-buffer-spec buffer endpoint update-function nil args)
- (setq mastodon-tl--timestamp-update-timer
- (when mastodon-tl--enable-relative-timestamps
- (run-at-time (time-to-seconds
- (time-subtract mastodon-tl--timestamp-next-update
- (current-time)))
- nil ;; don't repeat
- #'mastodon-tl--update-timestamps-callback
- (current-buffer)
- nil)))
- (unless (mastodon-tl--profile-buffer-p)
- ;; FIXME: this breaks test (because test has empty buffer)
- (mastodon-tl--goto-first-item)))
- buffer))
+ (mastodon-tl--do-init json update-function)
+ buffer)))
+
+(defun mastodon-tl--do-init (json update-fun)
+ "Utility function for `mastodon-tl--init*' and `mastodon-tl--init-sync'.
+JSON is the data to call UPDATE-FUN on."
+ (remove-overlays) ; video overlays
+ (funcall update-fun json)
+ (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)))
+ (setq mastodon-tl--timestamp-update-timer
+ (when mastodon-tl--enable-relative-timestamps
+ (run-at-time (time-to-seconds
+ (time-subtract mastodon-tl--timestamp-next-update
+ (current-time)))
+ nil ;; don't repeat
+ #'mastodon-tl--update-timestamps-callback
+ (current-buffer)
+ nil)))
+ (unless (mastodon-tl--profile-buffer-p)
+ (mastodon-tl--goto-first-item)))
(provide 'mastodon-tl)
;;; mastodon-tl.el ends here
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-26 15:14:22 +0000