diff options
| -rw-r--r-- | lisp/mastodon-media.el | 232 | ||||
| -rw-r--r-- | lisp/mastodon-tl.el | 19 | ||||
| -rw-r--r-- | lisp/mastodon.el | 10 | ||||
| -rw-r--r-- | test/mastodon-media-tests.el | 179 | ||||
| -rw-r--r-- | test/mastodon-tl-tests.el | 54 |
5 files changed, 439 insertions, 55 deletions
diff --git a/lisp/mastodon-media.el b/lisp/mastodon-media.el index 23fbc79..d1ec871 100644 --- a/lisp/mastodon-media.el +++ b/lisp/mastodon-media.el @@ -38,60 +38,212 @@ :prefix "mastodon-media-" :group 'mastodon) -(defun mastodon-media--image-from-url (url) - "Takes a URL and return an image." - (let ((buffer (url-retrieve-synchronously url))) +(defvar mastodon-media-show-avatars-p + (image-type-available-p 'imagemagick) + "A boolean value stating whether to show avatars in timelines.") + +(defvar mastodon-media--generic-avatar-data + (base64-decode-string + "iVBORw0KGgoAAAANSUhEUgAAAGQAAABkCAIAAAD/gAIDAAAACXBIWXMAAAsTAAALEwEAmpwYAAAA +B3RJTUUH4QUIFCg2lVD1hwAAABZ0RVh0Q29tbWVudABHZW5lcmljIGF2YXRhcsyCnMsAAAcGSURB +VHja7dzdT1J/HAfwcw7EQzMKW0pGRMK4qdRZbdrs6aIRbt506V1b/AV1U2td9l9UXnmhW6vgwuko +SbcOD/a0RB4CCRCRg0AIR4Hz8LvgN2cKCMI5wOH7uXBuugO+eH8+fM/3HIFpmoZAVVYIIABYAAtg +ASyABbAAAcACWAALYAEsgAUIABbAAlgAC2ABLEAAsAAWwAJYAAtgAQKAxUjxm+R50DRN0zRFUf+8 +kggCwzAMwwDrfyOSJGmattlsdrvd5XLlcrndnyoUir6+vpGRkZMnT/J4vIarwY26MaTAZLVap6en +fT7f9vY2QRA7Ozv/vJJ8vkgk4vP5XV1dWq1Wq9VKpdIGkjUGi6IoFEWnp6ddLlcymSRJsvzv83g8 +kUikUCi0Wq1Opzt16lS7YBEE8ebNG6PRiGHYoUwHyW7cuPHo0SOlUsl9LIIgXrx4Ybfb//79e7Qj +CIXC3t7ex48fX7lyhctYBSkURTOZTC3H4fF4SqXy6dOnLHuxh0VR1PPnz2uX2uv17Nmzy5cvc21R +StP0q1ev7HZ7XaQgCCJJ0u/3T0xMBINBrmGhKGo0Go88p0p5Wa1Wg8GQSqW4g0XT9NTUFIZhdT9y +Npudn59nLVwIO7FyuVxVrRIqr1AoZDab2QkXG1hTU1PJZJKhg5MkOT8/HwqFuIBF07TP52MoVrvh +YqLHG4BlsVi2t7cZfQiSJB0OBwudyDiWzWYjCILpR1lZWeECltPp3LeXwEQFg8FoNNryWPl8noVp +ws6jgG1lgAWwuI914cIFPp/xnX6ZTCYSiVoeq7+/n4U/Q61Wy+Xylse6desWC8kaGBiQSCQtjyWR +SGQyGY/HY+4hpFJpV1cXRwa8TqdjtBOHh4fVajVHsLRarVKpZChcUqn07t27LPQgS1gSiUSn04nF +4rofGYbh4eHhgYEBTq2ztFrtyMhI3ZtRo9GMjY2xEyv2sCQSiV6vV6lUdWzGzs7O8fHxwcFBDq7g +5XL5kydPent76+LV2dmp1+vv37/P5gqe7SvSDofj5cuXteydwjAslUr1ev2DBw9YPt1pwL0ODodj +YmLCYrEcYZ8LhmGNRjM+Ps5yphqGBUFQKBQyGo0mk2l1dTWfz5MkSVFUPp8/+GSEQiEMw8eOHYNh +uLu7e2hoaGxsjM05tbfYvpkNx/FQKBSJRCAI6unpwTBsbW0tmUwWbtc6mCMEQSAIOn78+Llz586f +P9/T05PL5QKBgEKh4GyyCkZfvnwJhULhcHhzczOTyRRuYMtms/l8PpPJZDKZnZ2dvc9HIBCIxeIT +J04Uvil87ejoOH36tEwm02g0V69evXjxIkewCkZer/fr16+/f/+OxWKlrvQQBEEQxL7dYQRBhEJh +0fNwBEHEYrFMJlOpVP39/RqNhgU1prAKTDMzMy6XKxqNJhIJptY+CHLmzBmZTHbp0qXbt2+rVKpW +wtplWl5eDofDTF803Bs0tVrNKFmdsXAcn52dnZ2dDQaD7DAVJRsdHb1z507dT93rhoXj+MrKytzc +3NLSEnNNVyHZ2bNnr127NjQ0NDg4WEey+mDhOP7u3bu5ubkyI5z9iMnl8nv37o2OjgoEgmbBisVi +r1+/ttlsjQ1UmYg9fPiwo6OjwVg4jn///v3Dhw/Ly8vNEKiiXhKJpK+vT6fT1d6S/FqkUBSdnJz0 ++/1QsxZFUclkEkXReDxOkuT169dr8TpisnAcN5lMb9++ZfP+11pKIBAUdgpv3rx55BGGtIMUBEG5 +XM7tdhsMhoWFhb3/S8UsVitK1curaqzV1dX379+3nNQ+r42NjSPsPlaH5fP5mnyiV+Ll9XonJyfD +4XC1XkhVDTgzM/Pz50+oxSubzX779u3z58/VLneQyqUMBsOnT5+acz1V7XoiHo9//PjRZDKl0+n6 +Y3k8HrPZ3Gxr9Fq81tfXl5aWAoFA5cO+IqxIJFLYSIA4VARBuN3uxcXFyoc9v5IGNJvNVquVAw14 +sBktFkt3d7dUKq3k5BGpJFYLCwucacCizZhIJCoJF3JorBYXF//8+QNxtAiCKFwiqKRvkEPnOoqi +HGvAfeFKJBIVTnqkfKx+/PjBsbleKlwej6cmLI/H43A4OByr3XClUimn03louMphra2teb1eqA0q +m836fL6tra0jYkUiEb/fz8k3waLhikQiXq+3/NtiSayNjY1fv35BbVP5fN7pdG5tbR0Fy+12c360 +Hxzz5a8KI6V6EMMwzo/2fZ2YTqej0WgqlSoVLqRUDwYCAajNiqKoYDBYphOLY8ViscItVG1VJEmu +r6+XeU8sjhWPxzc3N9sNiyAIDMOqS1YbDqwKx1YRrFQqxc7HJDRnpdPpUuEqgoVhWL0+i6hFz6tL +ja3iM4u1zw1qwhlfJihI0bfCNhxYe4NSqg3/A862hQAbrdtHAAAAAElFTkSuQmCC") + "The PNG data for a generic 100x100 avatar") + +(defvar mastodon-media--generic-broken-image-data + (base64-decode-string + "iVBORw0KGgoAAAANSUhEUgAAAMgAAADICAYAAACtWK6eAAAACXBIWXMAAAsTAAALEwEAmpwYAAAA +B3RJTUUH4QUIFQUVFt+0LQAAABZ0RVh0Q29tbWVudABHZW5lcmljIGF2YXRhcsyCnMsAAAdoSURB +VHja7d1NSFRrAIfx//iB6ZDSMJYVkWEk0ceYFUkkhhQlEUhEg0FlC1eBoRTUwlbRok0TgRQURZAE +FgpjJmFajpK4kggxpXHRQEGWUJZizpy7uPfC5eKiV+dD5zw/mN05jrxnnjnfcxyWZVkCMKc0SXI4 +HIwEMIcUhgAgEIBAAAIBCAQgEIBAAAIBCAQgEAAEAhAIQCAAgQAEAhAIQCAAgQA2kBaNP8Jt7ViM +onErOWsQgEAAAgEIBCAQgEAAAgEIBCAQgEAAEAhAIACBAAQCEAhAIACBAAQCEAhAIAAIBCAQgEAA +AgEIBCAQgEAAAgEIBACBAAQCEAhAIACBAAQCEAhAIACBAAQCgEAAAgEIBCAQgECAxSyNIYitz58/ +a3BwUIODgxoZGVEoFFIoFNK3b980NTWlX79+SZIyMzOVlZWlVatWae3atSooKJDH49HOnTvl8XiU +ksJ3WSI4LMuyHA7Hgv6IZVmM5D8mJyf1/PlzdXZ2qrOzU8FgcMF/0+126+DBg6qqqlJFRYXS0vhe ++6MP9wI/1wQSJeFwWH6/X01NTWpra9PU1FTM3isvL0/nz5/XuXPntHz5ciqIcSCy/v50L+hlV+Pj +49a1a9esdevWLXgMTV8ul8u6c+eOFYlELMwtKmNNIOa+fv1qXbp0yXI6nXEP4/+v0tJS6+PHj9RA +IIk3PT1tXb161crOzk54GP995ebmWt3d3RRBIInj9/utgoKCRRXGf18ZGRmW3++niigHwk56PHf4 +Yiw9PV0dHR0qLy9nD52jWAQylxUrVmhgYEAbN24kkCgsM84+JZmJiQmdPn1akUiEweBE4eL/NsrN +zVVZWZlKSkpUWFioTZs2yeVyKTs7W7Ozs5qYmNDExITev3+v/v5+9fX1qb+/f8FjevPmTdXW1rIG +IZDFN9gbNmyQ1+uV1+uVx+MxXlAjIyNqbGzU3bt39fPnz3n9vytXrlQwGJTT6SQQThQm/ohIamqq +VVlZaXV1dUXtPT98+GCVlZXNe7n4fD6OYnGYN7GDnZ6ebtXU1FhjY2Mxed9IJGLV19fPa7kUFRUR +CIEkZrAdDod15syZmIXxf7W1tfNaNqOjowSygBdHseZh7969GhgY0IMHD5Sfnx+X97xx44Z2795t +PF93dzcLjMO88TvHcP/+ffX19WnXrl3xXVApKbp9+7bxfSFv3rxhwRFI7B07dkxDQ0Oqrq5O2P9Q +XFysffv2Gc0zOjrKwiOQ2Hv69Kny8vIS/n8cP37caPqxsTEWHoHYa//HxPfv3xk0ArGP1atXG03/ +7z3vIBBbyM3NNZo+KyuLQSMQ+5icnDSaPicnh0EjEPsYHh42mp7L3gnEVnp6eoymLyoqYtAIxD4e +PXpkNP3+/fsZtAXgcvclpL29XUeOHPnj6Z1Op8bHx7Vs2TJ7fri5o9A+ZmZmdPHiRaN5vF6vbeNg +E8tmGhoaNDQ0ZPTteeHCBQaOQJLfkydPdP36daN5Tp48qc2bNzN47IMkt9evX+vw4cOanp7+43ly +cnI0PDy8KK4dYx8EMRMIBHT06FGjOCTJ5/PZPg42sZJce3u7Dh06pB8/fhjNV11dndBL8tnEYhMr +5lpaWuT1evX792+j+YqLixUIBLj+ik2s5NXc3KwTJ04Yx5Gfn69nz54RB5tYyaupqUlVVVWanZ01 +ms/tdqujo4P9DgJJXg8fPtSpU6cUDoeN43j58qUKCwsZRAJJTvfu3dPZs2eNf0/X7Xarq6tL27dv +ZxAJJDn5fD7V1NQYx7FmzRq9evVK27ZtYxAJJDk1NDSorq7O+ChgQUGBent7tWXLFgYxxniecILU +1dXJ5/MZz7d161a9ePHC+N50sAZZMq5cuTKvOEpKStTT00McccSJwji7devWvJ7bceDAAbW2ttr6 +cQbGH26eD7K0BAIBlZeXG5/nqKioUEtLizIyMhhEAklOX758kcfj0adPn4zXHG1tbcSRoEDYB4mT +y5cvG8exZ88etba2Egf7IMnt7du32rFjh9G5jvz8fA0MDBj/UBxYgyw5jY2NRnGkpqaqubmZOBYB +AomxmZkZPX782Gie+vr6uD9/BGxiJURvb69KS0v/ePrMzEyFQiG5XC4Gj02s5BcIBIymr6ysJA42 +sezj3bt3RtObPv8DBLKkBYNBo+m5r4NAbCUUChlNv379egaNQOzD9FdJ2P8gEFsxfQQaFyMuLhzm +jfUAG45tOBw2fhY6ojP2rEGWwiqdONjEAggEIBCAQAACAUAgAIEA0cIPx8UYJ1FZgwAEAhAIAAIB +CAQgEIBAAAIBFiNOFMaY6V1tnFhkDQIQCEAgAIEABAKAQAACAQgEIBCAQAACAQgEIBCAQABIXO4e +c1y+zhoEIBCAQAAQCEAgAIEABAIQCEAgAIEABAIQCEAgAAgEIBCAQAACAQgEIBCAQAACAQgEAIEA +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 image-url) + "Callback function processing the url retrieve response for URL. + +STATUS-PLIST is the usual plist of status events as per `url-retrieve'. +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. +IMAGE-URL is the URL that was retrieved. +" + (let ((url-buffer (current-buffer)) + (is-error-response-p (eq :error (car status-plist)))) (unwind-protect - (let ((data (with-current-buffer buffer - (goto-char (point-min)) - (search-forward "\n\n") - (buffer-substring (point) (point-max))))) - (insert "\n") - (insert-image (create-image data nil t))) - (kill-buffer buffer)))) + (let* ((data (unless is-error-response-p + (goto-char (point-min)) + (search-forward "\n\n") + (buffer-substring (point) (point-max)))) + (image (when data + (apply #'create-image data (when image-options 'imagemagick) + t image-options)))) + (switch-to-buffer (marker-buffer marker)) + ;; Save narrowing in our buffer + (let ((inhibit-read-only t)) + (save-restriction + (widen) + (put-text-property marker (+ marker region-length) 'media-state 'loaded) + (when image + ;; We only set the image to display if we could load + ;; it; we already have set a default image when we + ;; added the tag. + (put-text-property marker (+ marker region-length) + 'display image)) + ;; We are done with the marker; release it: + (set-marker marker nil))) + (kill-buffer url-buffer))))) + +(defun mastodon-media--load-image-from-url (url media-type start region-length) + "Takes a URL and MEDIA-TYPE and load the image asynchronously. + +MEDIA-TYPE is a symbol and either 'avatar or 'media-link." + ;; TODO: Cache the avatars + (let ((image-options (when (image-type-available-p 'imagemagick) + (cond + ((eq media-type 'avatar) + `(:height ,mastodon-avatar-height)) + ((eq media-type 'media-link) + `(:max-height ,mastodon-preview-max-height)))))) + (url-retrieve url + #'mastodon-media--process-image-response + (list (copy-marker start) image-options region-length url)))) (defun mastodon-media--select-next-media-line () - "Find coordinates of a line that contains `Media_Links::' - -Returns the cons of (`start' . `end') points of that line or nil no -more media links were found." - (let ((foundp (search-forward-regexp "Media_Link::" nil t))) - (when foundp - (let ((start (progn (move-beginning-of-line nil) (point))) - (end (progn (move-end-of-line nil) (point)))) - (cons start end))))) + "Find coordinates of the next media to load. + +Returns the list of (`start' . `end', `media-symbol') points of +that line and string found or nil no more media links were +found." + (let ((next-pos (point))) + (while (and (setq next-pos (next-single-property-change next-pos 'media-state)) + (or (not (eq 'needs-loading (get-text-property next-pos 'media-state))) + (null (get-text-property next-pos 'media-url)) + (null (get-text-property next-pos 'media-type)))) + ;; do nothing - the loop will proceed + ) + (when next-pos + (let ((media-type (get-text-property next-pos 'media-type))) + (cond + ;; Avatars are just one character in the buffer + ((eq media-type 'avatar) + (list next-pos (+ next-pos 1) 'avatar)) + ;; Media links are 5 character ("[img]") + ((eq media-type 'media-link) + (list next-pos (+ next-pos 5) 'media-link))))))) (defun mastodon-media--valid-link-p (link) "Checks to make sure that the missing string has not been returned." (let ((missing "/files/small/missing.png")) - (not (equal link missing)))) - -(defun mastodon-media--line-to-link (line-points) - "Returns the url of the media link given at the given point. - -`LINE-POINTS' is a cons of (`start' . `end') positions of the line with -the `Media_Link:: <url>' text." - (replace-regexp-in-string "Media_Link:: " "" - (buffer-substring - (car line-points) - (cdr line-points)))) - -(defun mastodon-media--delete-line (line) - "Deletes the current media line" - (delete-region (car line) (cdr line))) + (and link + (not (equal link missing))))) (defun mastodon-media--inline-images () "Find all `Media_Links:' in the buffer replacing them with the referenced image." (interactive) (goto-char (point-min)) - (let (line-coordinates) - (while (setq line-coordinates (mastodon-media--select-next-media-line)) - (let ((link (mastodon-media--line-to-link line-coordinates))) - (when (mastodon-media--valid-link-p link) - (mastodon-media--image-from-url link) - (mastodon-media--delete-line line-coordinates)))))) + (let (line-details) + (while (setq line-details (mastodon-media--select-next-media-line)) + (let* ((start (car line-details)) + (end (cadr line-details)) + (media-type (cadr (cdr line-details))) + (image-url (get-text-property start 'media-url))) + (if (not (mastodon-media--valid-link-p image-url)) + ;; mark it at least as not needing loading any more + (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))))))) + +(defun mastodon-media--get-avatar-rendering (avatar-url) + "Returns the string to be written that renders the avatar at AVATAR-URL." + ;; We use just an empty space as the textual representation. + ;; This is what a user will see on a non-graphical display + ;; where not showing an avatar at all is preferable. + (let ((image-options (when (image-type-available-p 'imagemagick) + `(:height ,mastodon-avatar-height)))) + (concat + (propertize " " + 'media-url avatar-url + 'media-state 'needs-loading + 'media-type 'avatar + 'display (apply #'create-image mastodon-media--generic-avatar-data + (when image-options 'imagemagick) + t image-options)) + " "))) + +(defun mastodon-media--get-media-link-rendering (media-url) + "Returns the string to be written that renders the image at MEDIA-URL." + (concat + (propertize "[img]" + 'media-url media-url + 'media-state 'needs-loading + 'media-type 'media-link + 'display (create-image mastodon-media--generic-broken-image-data nil t)) + " ")) (provide 'mastodon-media) ;;; mastodon-media.el ends here diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index e025a6e..b3550c6 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -104,8 +104,11 @@ Optionally start from POS." "Propertize author of TOOT." (let* ((account (cdr (assoc 'account toot))) (handle (cdr (assoc 'acct account))) - (name (cdr (assoc 'display_name account)))) + (name (cdr (assoc 'display_name account))) + (avatar-url (cdr (assoc 'avatar account)))) (concat + (when mastodon-media-show-avatars-p + (mastodon-media--get-avatar-rendering avatar-url)) (propertize name 'face 'warning) " (@" handle @@ -177,14 +180,12 @@ also render the html" (defun mastodon-tl--media (toot) "Retrieve a media attachment link for TOOT if one exists." - (let ((media (mastodon-tl--field 'media_attachments toot))) - (mapconcat - (lambda (media-preview) - (concat "Media_Link:: " - (mastodon-tl--set-face - (cdr (assoc 'preview_url media-preview)) - 'mouse-face nil))) - media "\n"))) + (let ((media-attachements (mastodon-tl--field 'media_attachments toot))) + (mapconcat + (lambda (media-attachement) + (let ((preview-url (cdr (assoc 'preview_url media-attachement)))) + (mastodon-media--get-media-link-rendering preview-url))) + media-attachements ""))) (defun mastodon-tl--content (toot) "Retrieve text content from TOOT." diff --git a/lisp/mastodon.el b/lisp/mastodon.el index 947cc6a..0dd7f10 100644 --- a/lisp/mastodon.el +++ b/lisp/mastodon.el @@ -60,6 +60,16 @@ Use. e.g. \"%c\" for your locale's date and time format." :group 'mastodon :type 'string) +(defcustom mastodon-avatar-height 30 + "Height of the user avatar images (if shown)." + :group 'mastodon + :type 'integer) + +(defcustom mastodon-preview-max-height 250 + "Max height of any media attachment preview to be shown." + :group 'mastodon + :type 'integer) + (defvar mastodon-mode-map (make-sparse-keymap) "Keymap for `mastodon-mode'.") diff --git a/test/mastodon-media-tests.el b/test/mastodon-media-tests.el new file mode 100644 index 0000000..9cd06b7 --- /dev/null +++ b/test/mastodon-media-tests.el @@ -0,0 +1,179 @@ +(require 'el-mock) + +(ert-deftest mastodon-media:get-avatar-rendering () + "Should return text with all expected properties." + (with-mock + (mock (image-type-available-p 'imagemagick) => t) + (mock (create-image * 'imagemagick t :height 123) => :mock-image) + + (let* ((mastodon-avatar-height 123) + (result (mastodon-media--get-avatar-rendering "http://example.org/img.png")) + (result-no-properties (substring-no-properties result)) + (properties (text-properties-at 0 result))) + (should (string= " " result-no-properties)) + (should (string= "http://example.org/img.png" (plist-get properties 'media-url))) + (should (eq 'needs-loading (plist-get properties 'media-state))) + (should (eq 'avatar (plist-get properties 'media-type))) + (should (eq :mock-image (plist-get properties 'display)))))) + +(ert-deftest mastodon-media:get-media-link-rendering () + "Should return text with all expected properties." + (with-mock + (mock (create-image * nil t) => :mock-image) + + (let* ((mastodon-preview-max-height 123) + (result (mastodon-media--get-media-link-rendering "http://example.org/img.png")) + (result-no-properties (substring-no-properties result)) + (properties (text-properties-at 0 result))) + (should (string= "[img] " result-no-properties)) + (should (string= "http://example.org/img.png" (plist-get properties 'media-url))) + (should (eq 'needs-loading (plist-get properties 'media-state))) + (should (eq 'media-link (plist-get properties 'media-type))) + (should (eq :mock-image (plist-get properties 'display)))))) + +(ert-deftest mastodon-media:load-image-from-url:avatar-with-imagemagic () + "Should make the right call to url-retrieve." + (let ((url "http://example.org/image.png") + (mastodon-avatar-height 123)) + (with-mock + (mock (image-type-available-p 'imagemagick) => t) + (mock (create-image * 'imagemagick t :height 123) => '(image foo)) + (mock (copy-marker 7) => :my-marker ) + (mock (url-retrieve + url + #'mastodon-media--process-image-response + '(:my-marker (:height 123) 1 "http://example.org/image.png")) + => :called-as-expected) + + (with-temp-buffer + (insert (concat "Start:" + (mastodon-media--get-avatar-rendering "http://example.org/img.png") + ":rest")) + + (should (eq :called-as-expected (mastodon-media--load-image-from-url url 'avatar 7 1))))))) + +(ert-deftest mastodon-media:load-image-from-url:avatar-without-imagemagic () + "Should make the right call to url-retrieve." + (let ((url "http://example.org/image.png")) + (with-mock + (mock (image-type-available-p 'imagemagick) => nil) + (mock (create-image * nil t) => '(image foo)) + (mock (copy-marker 7) => :my-marker ) + (mock (url-retrieve + url + #'mastodon-media--process-image-response + '(:my-marker () 1 "http://example.org/image.png")) + => :called-as-expected) + + (with-temp-buffer + (insert (concat "Start:" + (mastodon-media--get-avatar-rendering "http://example.org/img.png") + ":rest")) + + (should (eq :called-as-expected (mastodon-media--load-image-from-url url 'avatar 7 1))))))) + +(ert-deftest mastodon-media:load-image-from-url:media-link-with-imagemagic () + "Should make the right call to url-retrieve." + (let ((url "http://example.org/image.png")) + (with-mock + (mock (image-type-available-p 'imagemagick) => t) + (mock (create-image * nil t) => '(image foo)) + (mock (copy-marker 7) => :my-marker ) + (mock (url-retrieve + "http://example.org/image.png" + #'mastodon-media--process-image-response + '(:my-marker (:max-height 321) 5 "http://example.org/image.png")) + => :called-as-expected) + (with-temp-buffer + (insert (concat "Start:" + (mastodon-media--get-media-link-rendering url) + ":rest")) + (let ((mastodon-preview-max-height 321)) + (should (eq :called-as-expected (mastodon-media--load-image-from-url url 'media-link 7 5)))))))) + +(ert-deftest mastodon-media:load-image-from-url:media-link-without-imagemagic () + "Should make the right call to url-retrieve." + (let ((url "http://example.org/image.png")) + (with-mock + (mock (image-type-available-p 'imagemagick) => nil) + (mock (create-image * nil t) => '(image foo)) + (mock (copy-marker 7) => :my-marker ) + (mock (url-retrieve + "http://example.org/image.png" + #'mastodon-media--process-image-response + '(:my-marker () 5 "http://example.org/image.png")) + => :called-as-expected) + + (with-temp-buffer + (insert (concat "Start:" + (mastodon-media--get-avatar-rendering url) + ":rest")) + (let ((mastodon-preview-max-height 321)) + (should (eq :called-as-expected (mastodon-media--load-image-from-url url 'media-link 7 5)))))))) + +(ert-deftest mastodon-media:process-image-response () + "Should process the HTTP response and adjust the source buffer." + (with-temp-buffer + (with-mock + (let ((source-buffer (current-buffer)) + used-marker + saved-marker) + (insert "start:") + (setq used-marker (copy-marker (point)) + saved-marker (copy-marker (point))) + ;; Mock needed for the preliminary image created in mastodon-media--get-avatar-rendering + (stub create-image => :fake-image) + (insert (mastodon-media--get-avatar-rendering "http://example.org/image.png") + ":end") + (with-temp-buffer + (insert "some irrelevant\n" + "http headers\n" + "which will be ignored\n\n" + "fake\nimage\ndata") + (goto-char (point-min)) + + (mock (create-image "fake\nimage\ndata" 'imagemagick t ':image :option) => :fake-image) + + (mastodon-media--process-image-response () used-marker '(:image :option) 1 "the-url") + + ;; the used marker has been unset: + (should (null (marker-position used-marker))) + ;; the media-state has been set to loaded and the image is being displayed + (should (eq 'loaded (get-text-property saved-marker 'media-state source-buffer))) + (should (eq ':fake-image (get-text-property saved-marker 'display source-buffer)))))))) + +(ert-deftest mastodon-media:inline-images () + "Should process all media in buffer." + (with-mock + ;; Stub needed for the test setup: + (stub create-image => '(image ignored)) + + (let (marker-media-link marker-media-link-bad-url marker-false-media marker-avatar) + (with-temp-buffer + (insert "Some text before\n") + (setq marker-media-link (copy-marker (point))) + (insert (mastodon-media--get-media-link-rendering "http://example.org/i.jpg") + " some more text ") + (setq marker-media-link-bad-url (copy-marker (point))) + (insert (mastodon-media--get-media-link-rendering "/files/small/missing.png") + " some more text ") + (setq marker-false-media (copy-marker (point))) + (insert + ;; text that looks almost like an avatar but lacks the media-url property + (propertize "this won't be processed" + 'media-state 'needs-loading + 'media-type 'avatar) + "even more text ") + (setq marker-avatar (copy-marker (point))) + (insert (mastodon-media--get-avatar-rendering "http://example.org/avatar.png") + " end of text") + (goto-char (point-min)) + + ;; stub for the actual test: + (stub mastodon-media--load-image-from-url) + (mastodon-media--inline-images) + + (should (eq 'loading (get-text-property marker-media-link 'media-state))) + (should (eq 'invalid-url (get-text-property marker-media-link-bad-url 'media-state))) + (should (eq 'loading (get-text-property marker-avatar 'media-state))) + (should (eq 'needs-loading (get-text-property marker-false-media 'media-state))))))) diff --git a/test/mastodon-tl-tests.el b/test/mastodon-tl-tests.el index e89d313..a91d6d5 100644 --- a/test/mastodon-tl-tests.el +++ b/test/mastodon-tl-tests.el @@ -105,7 +105,8 @@ (ert-deftest mastodon-tl--byline-regular () "Should format the regular toot correctly." - (let ((timestamp (cdr (assoc 'created_at mastodon-tl-test-base-toot)))) + (let ((mastodon-media-show-avatars-p nil) + (timestamp (cdr (assoc 'created_at mastodon-tl-test-base-toot)))) (with-mock (mock (date-to-time timestamp) => '(22782 21551)) (mock (format-time-string mastodon-toot-timestamp-format '(22782 21551)) => "2999-99-99 00:11:22") @@ -116,9 +117,25 @@ | Account 42 (@acct42@example.space) 2999-99-99 00:11:22 ------------"))))) +(ert-deftest mastodon-tl--byline-regular-with-avatar () + "Should format the regular toot correctly." + (let ((mastodon-media-show-avatars-p t) + (timestamp (cdr (assoc 'created_at mastodon-tl-test-base-toot)))) + (with-mock + (stub create-image => '(image "fake data")) + (mock (date-to-time timestamp) => '(22782 21551)) + (mock (format-time-string mastodon-toot-timestamp-format '(22782 21551)) => "2999-99-99 00:11:22") + + (should (string= (substring-no-properties + (mastodon-tl--byline mastodon-tl-test-base-toot)) + " + | Account 42 (@acct42@example.space) 2999-99-99 00:11:22 + ------------"))))) + (ert-deftest mastodon-tl--byline-boosted () "Should format the boosted toot correctly." - (let* ((toot (cons '(reblogged . t) mastodon-tl-test-base-toot)) + (let* ((mastodon-media-show-avatars-p nil) + (toot (cons '(reblogged . t) mastodon-tl-test-base-toot)) (timestamp (cdr (assoc 'created_at toot)))) (with-mock (mock (date-to-time timestamp) => '(22782 21551)) @@ -131,7 +148,8 @@ (ert-deftest mastodon-tl--byline-favorited () "Should format the favourited toot correctly." - (let* ((toot (cons '(favourited . t) mastodon-tl-test-base-toot)) + (let* ((mastodon-media-show-avatars-p nil) + (toot (cons '(favourited . t) mastodon-tl-test-base-toot)) (timestamp (cdr (assoc 'created_at toot)))) (with-mock (mock (date-to-time timestamp) => '(22782 21551)) @@ -145,7 +163,8 @@ (ert-deftest mastodon-tl--byline-boosted/favorited () "Should format the boosted & favourited toot correctly." - (let* ((toot `((favourited . t) (reblogged . t) ,@mastodon-tl-test-base-toot)) + (let* ((mastodon-media-show-avatars-p nil) + (toot `((favourited . t) (reblogged . t) ,@mastodon-tl-test-base-toot)) (timestamp (cdr (assoc 'created_at toot)))) (with-mock (mock (date-to-time timestamp) => '(22782 21551)) @@ -158,7 +177,8 @@ (ert-deftest mastodon-tl--byline-reblogged () "Should format the reblogged toot correctly." - (let* ((toot mastodon-tl-test-base-boosted-toot) + (let* ((mastodon-media-show-avatars-p nil) + (toot mastodon-tl-test-base-boosted-toot) (original-toot (cdr (assoc 'reblog mastodon-tl-test-base-boosted-toot))) (timestamp (cdr (assoc 'created_at toot))) (original-timestamp (cdr (assoc 'created_at original-toot)))) @@ -175,9 +195,31 @@ | Account 42 (@acct42@example.space) Boosted Account 43 (@acct43@example.space) original time ------------"))))) +(ert-deftest mastodon-tl--byline-reblogged-with-avatars () + "Should format the reblogged toot correctly." + (let* ((mastodon-media-show-avatars-p t) + (toot mastodon-tl-test-base-boosted-toot) + (original-toot (cdr (assoc 'reblog mastodon-tl-test-base-boosted-toot))) + (timestamp (cdr (assoc 'created_at toot))) + (original-timestamp (cdr (assoc 'created_at original-toot)))) + (with-mock + ;; We don't expect to use the toot's timestamp but the timestamp of the + ;; reblogged toot: + (stub create-image => '(image "fake data")) + (mock (date-to-time timestamp) => '(1 2)) + (mock (format-time-string mastodon-toot-timestamp-format '(1 2)) => "reblogging time") + (mock (date-to-time original-timestamp) => '(3 4)) + (mock (format-time-string mastodon-toot-timestamp-format '(3 4)) => "original time") + + (should (string= (substring-no-properties (mastodon-tl--byline toot)) + " + | Account 42 (@acct42@example.space) Boosted Account 43 (@acct43@example.space) original time + ------------"))))) + (ert-deftest mastodon-tl--byline-reblogged-boosted/favorited () "Should format the reblogged toot that was also boosted & favoritedcorrectly." - (let* ((toot `((favourited . t) (reblogged . t) ,@mastodon-tl-test-base-boosted-toot)) + (let* ((mastodon-media-show-avatars-p nil) + (toot `((favourited . t) (reblogged . t) ,@mastodon-tl-test-base-boosted-toot)) (original-toot (cdr (assoc 'reblog mastodon-tl-test-base-boosted-toot))) (timestamp (cdr (assoc 'created_at toot))) (original-timestamp (cdr (assoc 'created_at original-toot)))) |