;;; video-runtime.el --- Playback runtime for Canvas media -*- lexical-binding: t; -*-

;; Copyright (C) 2026 0WD0

;; Author: 0WD0 <me@0wd0.com>

;; Version: 0.1.0

;; Package-Requires: ((emacs "32.0"))

;; Keywords: multimedia, video, extensions

;; This file is free software: you can redistribute it and/or modify it

;; under the terms of the GNU General Public License as published by the

;; Free Software Foundation, either version 3 of the License, or (at your

;; option) any later version.

;;; Commentary:

;; Players, sessions, presentation leases, render targets, and shared Canvas

;; controls. Hosts supply per-target lifecycle callbacks; native playback and

;; target resources remain owned here.

;;; Code:

(require 'video-source)

(require 'video-module)

(defcustom video-pause-when-hidden t

"Whether playback pauses when none of a player's targets are visible.

After its first target is created, a player with no targets is hidden too.

Players that have never had a target still support headless playback."

:type 'boolean

:group 'video)

(defcustom video-network-cache-size (* 64 1024 1024)

"Maximum bytes retained for progressive network video downloads.

Buffered time ranges drive live mouse-seek previews. GStreamer keeps this

temporary ring buffer only for formats supporting progressive download. A

value of zero disables progressive download caching."

:type 'natnum

:group 'video)

(defcustom video-controls-hide-delay 1.5

"Seconds before transport controls fade while playback continues."

:type 'number

:group 'video)

(defcustom video-mouse-seek-seconds-per-pixel 0.05

"Seconds sought per horizontal pixel while dragging mouse button 1.

At the default value, dragging 100 pixels seeks five seconds."

:type 'number

:group 'video)

(defvar video-player-state-change-hook nil

"Hook run with one PLAYER argument after playback state changes.")

(defvar video-player-error-hook nil

"Hook run with PLAYER and error message after playback fails.")

(defvar video--player-status-change-hook nil

"Hook run with PLAYER when displayed metadata or whole seconds change.")

(defconst video--cache-poll-delay 0.1

"Seconds between bounded cache-completion retry polls.")

(defconst video--cache-poll-limit 20

"Maximum cache-completion retry polls after a native event burst.")

(defvar video--players nil

"Live `video-player' objects.")

(defvar video--sessions nil

"Live `video-session' objects.")

(cl-defstruct (video-player (:constructor video--make-player))

"One GStreamer playback session."

source

(kind 'video)

animated-p

animation-loop-count

(animation-loop-policy 'file)

(animation-iterations 0)

animation-ended

handle

process

(desired-state 'paused)

(state 'stopped)

(position 0.0)

duration

seekable

stream-live

live-hint

(buffering 100)

(width 0)

(height 0)

(volume 1.0)

muted

(rate 1.0)

error

request-headers

cache-file

cache-complete-function

cache-error

cache-poll-timer

(cache-poll-remaining 0)

buffered-time-ranges

(buffered-range-vector [])

(buffered-ranges-updated-at 0.0)

session

targets

dispatch-timer

buffering-timer

suspended

controls-timer

closed

;; Append slots: downstream bytecode inlines existing field offsets.

;; Explicit looping overrides the initial animation file policy.

loop-p

loop-explicit-p

subtitles-p

(subtitles-visible t)

;; Losing every viewport must not turn a presented player into a headless one.

visibility-managed)

(cl-defstruct (video-session (:constructor video--make-session))

"One player and all presentation leases sharing its exact state."

player

presentations

auto-close

closed)

(cl-defstruct (video--session-lease (:constructor video--make-session-lease))

"One inline or dedicated presentation retaining a `video-session'."

session

owner

close-function

closed)

(cl-defstruct (video-target (:constructor video--make-target))

"One Canvas viewport backed by a native render target."

player

handle

canvas

width

height

canvas-width

canvas-height

(destination-x 0)

(destination-y 0)

canvas-follows-target

(fit 'contain)

scale

(x 0.0)

(y 0.0)

last-sequence

presented-frame

visible-function

prepare-function

present-function

close-function

(controls-until 0.0)

closed

anchor

window

last-background)

(declare-function video-native-create

"video-module"

(uri process cache-size cache-template request-headers source-format))

(declare-function video-native-close "video-module" (player))

(declare-function video-native-play "video-module" (player))

(declare-function video-native-pause "video-module" (player))

(declare-function video-native-stop "video-module" (player))

(declare-function video-native-seek "video-module" (player seconds))

(declare-function video-native-buffered-ranges "video-module" (player))

(declare-function video-native-set-volume "video-module" (player volume))

(declare-function video-native-set-muted "video-module" (player muted))

(declare-function video-native-set-rate "video-module" (player rate))

(declare-function video-native-set-subtitles "video-module" (player ass-text))

(declare-function video-native-set-subtitles-visible "video-module"

(player visible))

(declare-function video-native-poll "video-module" (player))

(declare-function video-native-target-create

"video-module" (player width height fit scale x y))

(declare-function video-native-target-close "video-module" (target))

(declare-function video-native-target-set-view

"video-module" (target width height fit scale x y))

(declare-function video-native-canvas-draw-uri

"video-module"

(canvas canvas-width canvas-height uri x y width height fit

background source-format))

(declare-function video-native-lottie-metadata "video-module" (uri))

(declare-function video-native-target-copy

"video-module"

(target canvas canvas-width canvas-height x y background))

(declare-function video-native-canvas-fill

"video-module"

(canvas canvas-width canvas-height x y width height background))

(declare-function video-native-canvas-copy "video-module" (source destination))

(declare-function video-native-control-layout

"video-module" (x y width height))

(declare-function video-native-canvas-draw-controls

"video-module"

(canvas canvas-width canvas-height x y width height

playing position duration muted volume opacity waiting

buffering has-frame seekable buffered-ranges))

(declare-function read--potential-mouse-event "mouse" ())

(defun video--network-uri-p (uri)

"Return non-nil when URI is not a local file URI."

(and (stringp uri) (not (string-prefix-p "file:" uri t))))

(defun video--cache-pending-p (player)

"Return non-nil when PLAYER may still produce a persistent cache."

(and (video-player-live-p player)

(video-player-cache-file player)

(not (video-player-cache-error player))

(not (file-regular-p (video-player-cache-file player)))))

(defun video--cancel-cache-poll (player)

"Cancel PLAYER's pending cache-completion retry."

(when-let* ((timer (video-player-cache-poll-timer player))

((timerp timer)))

(cancel-timer timer))

(setf (video-player-cache-poll-timer player) nil

(video-player-cache-poll-remaining player) 0))

(defun video--schedule-cache-poll (player)

"Schedule PLAYER's next bounded cache-completion retry."

(when (and (video--cache-pending-p player)

(> (video-player-cache-poll-remaining player) 0)

(not (timerp (video-player-cache-poll-timer player))))

(setf (video-player-cache-poll-timer player)

(run-at-time video--cache-poll-delay nil

#'video--run-cache-poll player))))

(defun video--run-cache-poll (player)

"Retry native cache-completion detection for PLAYER once."

(when (video-player-p player)

(setf (video-player-cache-poll-timer player) nil)

(if (not (video--cache-pending-p player))

(video--cancel-cache-poll player)

(cl-decf (video-player-cache-poll-remaining player))

(video--dispatch player)

(video--schedule-cache-poll player))))

(defun video--arm-cache-poll (player)

"Start a bounded cache-completion retry burst for PLAYER."

(when (video--cache-pending-p player)

(setf (video-player-cache-poll-remaining player)

video--cache-poll-limit)

(video--schedule-cache-poll player)))

(defun video--commit-network-cache (player location)

"Atomically promote PLAYER's complete temporary cache at LOCATION."

(when-let* ((target (video-player-cache-file player))

((file-regular-p location)))

(condition-case error-data

(progn

(unless (file-regular-p target)

(condition-case rename-error

(rename-file location target)

(file-already-exists

(unless (file-regular-p target)

(signal (car rename-error) (cdr rename-error))))))

(video--cancel-cache-poll player)

(setf (video-player-cache-error player) nil)

(when-let* ((callback (video-player-cache-complete-function player)))

(setf (video-player-cache-complete-function player) nil)

(funcall callback player target))

target)

(error

(setf (video-player-cache-error player)

(error-message-string error-data))

(video--cancel-cache-poll player)

(display-warning

'video

(format "Could not retain completed video cache: %s"

(video-player-cache-error player))

:warning)

nil))))

(defun video--event-filter (process output)

"Schedule dispatch for PROCESS, retrying cache detection after event OUTPUT."

(when-let* ((player (process-get process 'video-player))

((not (video-player-closed player))))

(when (string-match-p "e" output)

(video--arm-cache-poll player))

(unless (timerp (video-player-dispatch-timer player))

(setf (video-player-dispatch-timer player)

(run-at-time 0 nil #'video--dispatch player)))))

(defcustom video-animation-loop-policy 'file

"How animated images repeat.

`file' honors animation loop metadata: absent means once, zero means forever,

and a positive count is the number of repetitions after the first pass.

`forever' repeats without limit; `once' disables repetition.

The value is captured when a player is created. Remote image animation

is discovered from native duration information, not the filename; its

loop metadata is unavailable, so `file' plays it once."

:type '(choice (const file) (const forever) (const once))

:group 'video)

(defun video--animation-repeat-p (player)

"Whether PLAYER may begin another animation iteration."

(if (video-player-loop-explicit-p player)

(and (video-player-loop-p player)

(video-player-seekable player)

(not (video-player-stream-live player)))

(pcase (video-player-animation-loop-policy player)

('forever t)

('file

(let ((count (video-player-animation-loop-count player)))

(and (integerp count)

(or (zerop count)

(<= (video-player-animation-iterations player) count)))))

(_ nil))))

(defun video--restart-player (player)

"Rewind PLAYER without resetting its animation repeat budget.

Only the original animation policy may restart nonseekable media."

(if (video-player-seekable player)

(video-native-seek (video-player-handle player) 0.0)

(video-native-stop (video-player-handle player)))

(setf (video-player-position player) 0.0

(video-player-animation-ended player) nil

(video-player-suspended player) t))

(defun video--player-eos (player)

"Handle PLAYER's EOS and return non-nil if repeating.

Count each completed animation iteration once, including an EOS observed

while paused. Repetition belongs to the player, never a render target."

(when (and (video-player-animated-p player)

(not (video-player-animation-ended player)))

(cl-incf (video-player-animation-iterations player))

(setf (video-player-animation-ended player) t))

(when (and (eq (video-player-desired-state player) 'playing)

(if (video-player-animated-p player)

(video--animation-repeat-p player)

(and (video-player-loop-p player)

(video-player-seekable player)

(not (video-player-stream-live player)))))

(video--restart-player player)

t))

(cl-defun video-player-create

(source &key kind (volume 1.0) muted (rate 1.0) live

cache-file cache-complete-function request-headers

(animation-loop-policy video-animation-loop-policy))

"Create and return a media player for SOURCE.

Local APNG, animated WebP, Lottie JSON and dotLottie are recognized

automatically. Omitted KIND is inferred from SOURCE.

KIND is `video' or `image'. VOLUME is between zero and one. MUTED controls

initial audio output and RATE is the positive playback rate. LIVE forces

live-stream semantics when protocol discovery cannot identify a live source.

For a network video, CACHE-FILE names an optional persistent destination

promoted only after GStreamer's sparse progressive cache becomes complete.

CACHE-COMPLETE-FUNCTION is then called with the player and local file.

REQUEST-HEADERS is an alist of HTTP field names and values applied to every

HTTP resource created for SOURCE. ANIMATION-LOOP-POLICY overrides

`video-animation-loop-policy' for this player.

GIF, APNG, animated WebP and Lottie capability is independent of KIND.

Local animation metadata is read before playback; remote image animation

is discovered from native duration, with no file loop metadata.

The player starts paused."

(unless (display-graphic-p)

(error "Video.el requires a graphical Emacs display"))

(unless (image-type-available-p 'canvas)

(error "This Emacs build does not provide Canvas images"))

(let* ((source-format (video-source-format source))

(kind (or kind (if source-format 'image (video--source-media-kind source)))))

(unless (memq kind '(video image))

(error "Unsupported media kind: %S" kind))

(unless (memq animation-loop-policy '(file forever once))

(error "Unsupported animation loop policy: %S" animation-loop-policy))

(when (and live (not (eq kind 'video)))

(error "Only video sources can be marked live"))

(when (and cache-complete-function

(not (functionp cache-complete-function)))

(error "Video cache completion callback is not callable"))

(let* ((uri (video-source-uri source))

(animation

(pcase source-format

('lottie (video-source-lottie-metadata source))

('apng (video-source-apng-metadata source))

('webp (video-source-webp-metadata source))

(_ (and (eq kind 'image)

(video-source-gif-metadata (video-source-file source))))))

(request-headers (video-source-header-vector request-headers))

(cache-file

(when cache-file

(unless (and (eq kind 'video) (video--network-uri-p uri))

(error "Persistent video cache requires a network video source"))

(unless (and (stringp cache-file)

(not (string-empty-p cache-file)))

(error "Video cache file must be a non-empty filename"))

(when (zerop video-network-cache-size)

(error "Persistent video cache requires progressive caching"))

(expand-file-name cache-file)))

(cache-template

(when cache-file

(make-directory (file-name-directory cache-file) t)

(concat cache-file ".part-XXXXXX")))

(process (make-pipe-process

:name (generate-new-buffer-name " video-events")

:buffer nil

:coding 'no-conversion

:noquery t

:filter #'video--event-filter

:sentinel #'ignore))

(player (video--make-player

:source uri

:kind kind

:process process

:animated-p (and animation (> (plist-get animation :frames) 1))

:animation-loop-count (plist-get animation :loop-count)

:animation-loop-policy animation-loop-policy

:volume (max 0.0 (min 1.0 (float volume)))

:muted (and muted t)

:rate (max 0.01 (float rate))

:stream-live (and live t)

:live-hint (and live t)

:request-headers request-headers

:cache-file cache-file

:cache-complete-function cache-complete-function)))

(process-put process 'video-player player)

(condition-case error-data

(setf (video-player-handle player)

(video-native-create

uri process (if (eq kind 'video) video-network-cache-size 0)

cache-template request-headers source-format))

(error

(delete-process process)

(signal (car error-data) (cdr error-data))))

(video-native-set-volume (video-player-handle player)

(video-player-volume player))

(video-native-set-muted (video-player-handle player)

(video-player-muted player))

(video-native-set-rate (video-player-handle player)

(video-player-rate player))

(push player video--players)

;; Setting the URI alone leaves GstPlay stopped, with no dimensions or

;; first frame. Preroll asynchronously even when a viewer preserves the

;; initial paused state (notably a cold-opened still image).

(video-native-pause (video-player-handle player))

(video--dispatch player)

player)))

(defun video-player-live-p (player)

"Return non-nil when PLAYER owns a live native session."

(and (video-player-p player)

(not (video-player-closed player))

(video-player-handle player)))

(cl-defun video-session-create

(source &key kind (volume 1.0) muted (rate 1.0) live

cache-file cache-complete-function request-headers (auto-close t)

(animation-loop-policy video-animation-loop-policy))

"Create a reusable presentation session for SOURCE.

KIND, VOLUME, MUTED, RATE, LIVE, CACHE-FILE,

CACHE-COMPLETE-FUNCTION, REQUEST-HEADERS, and ANIMATION-LOOP-POLICY are

forwarded to `video-player-create'. When AUTO-CLOSE is

non-nil, closing the last presentation closes the session after it has

presented at least once. The player starts paused."

(let* ((player

(video-player-create

source

:kind kind

:animation-loop-policy animation-loop-policy

:volume volume

:muted muted

:rate rate

:live live

:cache-file cache-file

:cache-complete-function cache-complete-function

:request-headers request-headers))

(session

(video--make-session

:player player

:auto-close (and auto-close t))))

(setf (video-player-session player) session)

(push session video--sessions)

session))

(defun video-session-live-p (session)

"Return non-nil when SESSION owns a live player."

(and (video-session-p session)

(not (video-session-closed session))

(video-player-live-p (video-session-player session))))

(defun video-session-presentation-count (session)

"Return the number of live presentations retaining SESSION."

(if (video-session-p session)

(length (video-session-presentations session))

0))

(defun video--session-acquire (session owner close-function)

"Retain SESSION for presentation OWNER closed by CLOSE-FUNCTION."

(unless (video-session-live-p session)

(error "Cannot present a closed video session"))

(unless (functionp close-function)

(error "Video session presentation close function is not callable"))

(let ((lease

(video--make-session-lease

:session session

:owner owner

:close-function close-function)))

(push lease (video-session-presentations session))

lease))

(defun video--session-release (lease)

"Release one presentation LEASE and auto-close its session if empty."

(when (and (video--session-lease-p lease)

(not (video--session-lease-closed lease)))

(setf (video--session-lease-closed lease) t)

(let ((session (video--session-lease-session lease)))

(setf (video--session-lease-owner lease) nil

(video--session-lease-close-function lease) nil)

(when (video-session-p session)

(setf (video-session-presentations session)

(delq lease (video-session-presentations session)))

(when (and (video-session-auto-close session)

(null (video-session-presentations session))

(not (video-session-closed session)))

(video-session-close session)))))

nil)

(defun video-player-play (player)

"Play PLAYER, respecting target visibility policy.

Starting playback does not reveal transport controls."

(unless (video-player-live-p player)

(error "Video player is closed"))

(if (video-player-animated-p player)

(when (video-player-animation-ended player)

(unless (video--animation-repeat-p player)

(setf (video-player-animation-iterations player) 0))

(video--restart-player player))

(when-let* (((video-player-seekable player))

(duration (video-player-duration player))

(position (video-player-position player))

((>= position (max 0.0 (- duration 0.05)))))

(video-native-seek (video-player-handle player) 0.0)

(setf (video-player-position player) 0.0)))

(setf (video-player-error player) nil

(video-player-desired-state player) 'playing

(video-player-suspended player) t)

(video--reconcile-player-visibility player)

(video--resume-player-controls player)

(video--update-player-buffering-animation player)

player)

(defun video-player-pause (player)

"Pause PLAYER."

(unless (video-player-live-p player)

(error "Video player is closed"))

(setf (video-player-desired-state player) 'paused

(video-player-suspended player) nil)

(video-native-pause (video-player-handle player))

(video--show-player-controls player)

(video--update-player-buffering-animation player)

player)

(defun video-player-toggle (player)

"Toggle PLAYER between playing and paused, revealing its controls."

(if (eq (video-player-desired-state player) 'playing)

(video-player-pause player)

(video-player-play player)

(video--show-player-controls player))

player)

(defun video-player-set-loop (player loop)

"Set PLAYER's explicit LOOP state and return PLAYER.

Non-nil LOOP repeats seekable, non-live video, audio, or animation at EOS.

Nil disables repetition, including an animation's file loop policy.

Until this function is called, animations retain their original policy.

Changing LOOP does not start playback, seek, or interrupt the current pass.

Still images cannot loop. Enabling looping requires known seekability;

disabling it remains possible if media has become live or nonseekable."

(unless (video-player-live-p player)

(error "Video player is closed"))

(unless (video--player-transport-p player)

(user-error "Current media is a still image"))

(when loop

(when (video-player-stream-live player)

(user-error "Live streams cannot loop"))

(unless (video-player-seekable player)

(user-error "Current media is not seekable")))

(setf (video-player-loop-p player) (and loop t)

(video-player-loop-explicit-p player) t)

(force-mode-line-update t)

player)

(defun video-player-toggle-loop (player)

"Toggle PLAYER's effective repetition policy and return PLAYER.

The first toggle of an animation overrides its original loop policy."

(unless (video-player-live-p player)

(error "Video player is closed"))

(video-player-set-loop

player

(not (if (and (video-player-animated-p player)

(not (video-player-loop-explicit-p player)))

(video--animation-repeat-p player)

(video-player-loop-p player)))))

(defun video-player-stop (player)

"Stop PLAYER and reset its desired state."

(unless (video-player-live-p player)

(error "Video player is closed"))

(setf (video-player-desired-state player) 'stopped

(video-player-suspended player) nil

(video-player-animation-iterations player) 0

(video-player-animation-ended player) nil)

(video-native-stop (video-player-handle player))

(video--show-player-controls player)

(video--update-player-buffering-animation player)

player)

(defun video-player-seek (player seconds)

"Seek PLAYER to absolute position SECONDS."

(unless (video-player-live-p player)

(error "Video player is closed"))

(unless (video-player-seekable player)

(user-error "Current media is not seekable"))

(let* ((limit (video-player-duration player))

(position

(max 0.0

(if (numberp limit)

(min (float seconds) limit)

(float seconds)))))

(setf (video-player-position player) position)

(video-native-seek (video-player-handle player) position))

(video--show-player-controls player)

(force-mode-line-update t)

player)

(defun video-player-seek-relative (player delta)

"Seek PLAYER by DELTA seconds."

(video-player-seek player (+ (or (video-player-position player) 0.0) delta)))

(defun video--store-player-buffered-ranges (player ranges)

"Store native RANGES and transport fractions on PLAYER."

(let ((duration (video-player-duration player))

fractions)

(when (and (numberp duration) (> duration 0.0))

(dolist (range ranges)

(when (and (consp range)

(numberp (car range))

(numberp (cdr range))

(< (car range) (cdr range)))

(push (/ (float (car range)) duration) fractions)

(push (/ (float (cdr range)) duration) fractions))))

(setf (video-player-buffered-time-ranges player) ranges

(video-player-buffered-range-vector player) (vconcat (nreverse fractions))

(video-player-buffered-ranges-updated-at player) (float-time))

ranges))

(defun video-player-buffered-ranges (player)

"Return locally available time ranges for PLAYER.

Each range is a cons cell of start and end seconds. Return nil when the

native pipeline cannot report buffering ranges."

(unless (video-player-live-p player)

(error "Video player is closed"))

(video--store-player-buffered-ranges

player (video-native-buffered-ranges (video-player-handle player))))

(defun video--player-buffered-range-vector (player)

"Return PLAYER buffered range fractions for transport drawing."

(when (and (video--network-uri-p (video-player-source player))

(> (- (float-time)

(video-player-buffered-ranges-updated-at player))

0.25))

(video-player-buffered-ranges player))

(video-player-buffered-range-vector player))

(defun video-player-set-volume (player volume)

"Set PLAYER audio VOLUME between zero and one."

(unless (video-player-live-p player)

(error "Video player is closed"))

(setf (video-player-volume player)

(max 0.0 (min 1.0 (float volume))))

(video-native-set-volume (video-player-handle player)

(video-player-volume player))

(video--show-player-controls player)

player)

(defun video-player-set-muted (player muted)

"Set PLAYER audio MUTED state."

(unless (video-player-live-p player)

(error "Video player is closed"))

(setf (video-player-muted player) (and muted t))

(video-native-set-muted (video-player-handle player)

(video-player-muted player))

(video--show-player-controls player)

player)

(defun video-player-set-subtitles (player ass-text)

"Load in-memory ASS-TEXT subtitles for PLAYER and return PLAYER.

ASS-TEXT must be a complete UTF-8-compatible ASS string, or nil to clear

the track. Loading is synchronous; malformed text signals an error and

leaves the previous track and playback unchanged. The native player

owns the parsed track, so callers need not retain ASS-TEXT.

Subtitles follow decoded frame timestamps, including while paused or

seeking, and share the same image across all player presentations."

(unless (video-player-live-p player)

(error "Video player is closed"))

(video-native-set-subtitles (video-player-handle player) ass-text)

(setf (video-player-subtitles-p player) (and ass-text t))

player)

(defun video-player-set-subtitles-visible (player visible)

"Set PLAYER subtitle visibility to VISIBLE and return PLAYER.

Non-nil VISIBLE displays the loaded track; nil hides it without unloading.

Changing visibility redraws the latest frame even while playback is paused."

(unless (video-player-live-p player)

(error "Video player is closed"))

(video-native-set-subtitles-visible (video-player-handle player) visible)

(setf (video-player-subtitles-visible player) (and visible t))

player)

(defun video-session-close (session)

"Close SESSION, every presentation retaining it, and its player.

This operation is idempotent."

(when (and (video-session-p session)

(not (video-session-closed session)))

(setf (video-session-closed session) t)

(setq video--sessions (delq session video--sessions))

(let ((presentations (video-session-presentations session))

(player (video-session-player session)))

(setf (video-session-presentations session) nil)

(dolist (lease presentations)

(unless (video--session-lease-closed lease)

(setf (video--session-lease-closed lease) t)

(let ((owner (video--session-lease-owner lease))

(close-function

(video--session-lease-close-function lease)))

(setf (video--session-lease-owner lease) nil

(video--session-lease-close-function lease) nil)

(condition-case error-data

(funcall close-function owner)

(error

(message "Video session presentation close failed: %s"

(error-message-string error-data)))))))

(when (video-player-p player)

(setf (video-player-session player) nil)

(video-player-close player))))

nil)

(defun video-player-close (player)

"Close PLAYER and every render target it owns.

This operation is idempotent."

(when-let* ((session (and (video-player-p player)

(video-player-session player)))

((not (video-session-closed session))))

(video-session-close session))

(when (and (video-player-p player) (not (video-player-closed player)))

(setf (video-player-closed player) t)

(when-let* ((timer (video-player-dispatch-timer player))

((timerp timer)))

(cancel-timer timer))

(setf (video-player-dispatch-timer player) nil)

(video--cancel-cache-poll player)

(when-let* ((timer (video-player-controls-timer player))

((timerp timer)))

(cancel-timer timer))

(setf (video-player-controls-timer player) nil)

(when-let* ((timer (video-player-buffering-timer player))

((timerp timer)))

(cancel-timer timer))

(setf (video-player-buffering-timer player) nil)

(dolist (target (copy-sequence (video-player-targets player)))

(video-target-close target))

(when (video-player-handle player)

(condition-case error-data

(video-native-close (video-player-handle player))

(error

(message "Video player close failed: %s"

(error-message-string error-data)))))

(setf (video-player-handle player) nil)

(when-let* ((process (video-player-process player))

((process-live-p process)))

(delete-process process))

(setf (video-player-process player) nil)

(setq video--players (delq player video--players)))

nil)

(defun video--color-to-rgb24 (color)

"Convert Emacs COLOR to the renderer's packed 24-bit RGB value."

(let ((rgb (color-values color)))

(logior (ash (round (/ (nth 0 rgb) 257.0)) 16)

(ash (round (/ (nth 1 rgb) 257.0)) 8)

(round (/ (nth 2 rgb) 257.0)))))

(defun video--face-background (face frame window &optional remapped inherited)

"Resolve FACE's background on FRAME for WINDOW without default merging.

REMAPPED and INHERITED prevent recursive remapping and inheritance loops."

(cond

((null face) nil)

((and (symbolp face) (facep face))

(let ((remap (assq face face-remapping-alist)))

(if (and remap (not (memq face remapped)))

(video--face-background (cdr remap) frame window

(cons face remapped) inherited)

(unless (memq face inherited)

(or (face-background face frame)

(video--face-background

(face-attribute face :inherit frame) frame window

remapped (cons face inherited)))))))

((eq (car-safe face) :filtered)

(let ((filter (cadr face)))

(when (and (eq (car-safe filter) :window)

(window-live-p window)

(equal (window-parameter window (cadr filter)) (caddr filter)))

(video--face-background (caddr face) frame window remapped inherited))))

((keywordp (car-safe face))

(or (face-attribute-specified-or (plist-get face :background) nil)

(video--face-background (plist-get face :inherit) frame window

remapped inherited)))

((eq (car-safe face) 'background-color)

(cdr face))

((and (consp face) (not (stringp (cdr face))))

(cl-some (lambda (entry)

(video--face-background entry frame window remapped inherited))

face))))

(defun video-background-color (&optional buffer position window)

"Return the display background color at POSITION in BUFFER.

The result is an Emacs color string.

BUFFER and POSITION default to the current buffer and point. WINDOW defaults

to a window displaying BUFFER. Overlay priority, text faces, inheritance and

buffer-local `face-remapping-alist' precede the actual frame default."

(setq buffer (or buffer (current-buffer))

window (or window

(and (eq (window-buffer (selected-window)) buffer)

(selected-window))

(get-buffer-window buffer t)))

(let ((frame (if (window-live-p window) (window-frame window) (selected-frame))))

(with-current-buffer buffer

(save-restriction

(widen)

(let*

((position

(max (point-min) (min (or position (point)) (point-max))))

(background

(or

(cl-some

(lambda (overlay)

(when

(or (null (overlay-get overlay 'window))

(eq (overlay-get overlay 'window) window))

(video--face-background (overlay-get overlay 'face) frame

window)))

(overlays-at position t))

(video--face-background

(or (get-text-property position 'face)

(get-text-property position 'font-lock-face))

frame window)

(video--face-background 'default frame window)

(face-background 'default frame t)

(frame-parameter frame 'background-color))))

(if

(or (display-graphic-p frame) (color-defined-p background frame))

background

(if (eq (frame-parameter frame 'background-mode) 'dark) "#000000"

"#ffffff")))))))

(defun video--anchor-buffer (anchor)

"Return the buffer containing the marker or overlay ANCHOR."

(cond ((markerp anchor) (marker-buffer anchor))

((overlayp anchor) (overlay-buffer anchor))))

(defun video--copy-anchor (anchor)

"Retain an overlay ANCHOR or copy a marker, defaulting to point."

(if (overlayp anchor)

anchor

(copy-marker (or anchor (point))

(and (markerp anchor) (marker-insertion-type anchor)))))

(defun video--target-background (target)

"Return TARGET's background at its display anchor as a color string."

(let* ((anchor (video-target-anchor target))

(buffer (video--anchor-buffer anchor))

(position (if (overlayp anchor)

(overlay-start anchor)

(and (markerp anchor) (marker-position anchor))))

(window

(or (video-target-window target)

(and position

(cl-find-if

(lambda (window)

(pos-visible-in-window-p position window t))

(get-buffer-window-list buffer nil t))))))

(video-background-color buffer position window)))

(defun video--fill-target-background (target background)

"Initialize TARGET's own blank Canvas to opaque BACKGROUND."

(video-native-canvas-fill

(video-target-canvas target)

(video-target-canvas-width target) (video-target-canvas-height target)

(video-target-destination-x target) (video-target-destination-y target)

(video-target-width target) (video-target-height target) (video--color-to-rgb24 background)))

(defun video-canvas-create (width height &optional background)

"Return an opaque Canvas image of WIDTH by HEIGHT pixels.

BACKGROUND is an Emacs color string (a name or an RGB specification).

It defaults to `video-background-color'."

(let ((canvas (list 'image

:type 'canvas

:id (gensym "video-canvas-")

:data-width width

:data-height height

:scale 1.0

:ascent 'center)))

(video-native-canvas-fill canvas width height 0 0 width height

(video--color-to-rgb24 (or background (video-background-color))))

canvas))

(defun video-canvas-copy (image)

"Snapshot Canvas IMAGE, copying its drawn pixels and display properties.

The returned static image owns a distinct Emacs Canvas backing store.

A Lisp descriptor copy alone does not retain native pixels."

(let ((copy

(cons 'image

(cl-loop for (key value) on (cdr image) by #'cddr

unless (memq key '(:data :file))

append (list key value)))))

(plist-put (cdr copy) :id (gensym "video-canvas-"))

(plist-put (cdr copy) :video-static-poster t)

(video-native-canvas-copy image copy)

(canvas-refresh copy)

copy))

(cl-defun video-canvas-draw-source

(canvas canvas-width canvas-height source x y width height

&key fit background)

"Draw one frame from SOURCE into CANVAS.

CANVAS-WIDTH and CANVAS-HEIGHT describe the complete Canvas. X, Y, WIDTH, and

HEIGHT describe the destination rectangle and may be clipped at its edges.

FIT defaults to `contain'. BACKGROUND is an Emacs color string; omitted,

it uses the effective display background at point in the calling buffer.

The source format is inferred from local contents.

Return non-nil when a frame was drawn. This function does not call

`canvas-refresh', so scene hosts can batch several regions before one refresh."

(video-native-canvas-draw-uri

canvas canvas-width canvas-height (video-source-uri source)

(round x) (round y) (round width) (round height)

(video--fit-name (or fit 'contain))

(video--color-to-rgb24 (or background (video-background-color)))

(video-source-format source)))

(cl-defun video-source-poster (source width height &key fit background)

"Render an immutable first-frame Canvas poster for SOURCE.

WIDTH and HEIGHT are positive pixel dimensions. The Canvas is fully drawn

before return and is never attached as a mutable playback target.

FIT and BACKGROUND have the meanings in `video-canvas-draw-source'."

(let ((canvas (video-canvas-create width height background)))

(unless (video-canvas-draw-source

canvas width height source 0 0 width height

:fit fit :background background)

(error "Media source has no drawable first frame: %s" source))

(plist-put (cdr canvas) :video-static-poster t)

(canvas-refresh canvas)

canvas))

(defun video--fit-name (fit)

"Return native string name for FIT."

(pcase fit

((or 'contain 'shrink 'cover 'width 'height 'actual) (symbol-name fit))

(_ "contain")))

(cl-defun video-target-create

(player width height &key (fit 'contain) scale

(x 0.0) (y 0.0)

canvas canvas-width canvas-height

(destination-x 0) (destination-y 0)

anchor window

visible-function prepare-function present-function close-function)

"Create a viewport render target for PLAYER with WIDTH and HEIGHT.

SCALE is the absolute source-pixel to display-pixel ratio. X and Y locate the

viewport in the resulting virtual media plane. When SCALE is nil, FIT chooses

an automatic scale; this mode is intended for fixed inline targets. CANVAS may

supply a larger host-owned scene. CANVAS-WIDTH, CANVAS-HEIGHT, DESTINATION-X,

and DESTINATION-Y place this target inside that scene.

ANCHOR is the display overlay or marker; by default capture point. Markers

are copied, while overlays remain host-owned and may move. WINDOW identifies

a window-specific presentation. Backgrounds follow the effective face at

this location without host color policy.

Host callbacks receive TARGET. VISIBLE-FUNCTION decides whether to render;

without it a target is visible. It may return the displaying window, which

also supplies the background's window context without another visibility

search. PREPARE-FUNCTION runs before copying a frame with current media

state. PRESENT-FUNCTION runs after a valid frame is copied

and its Canvas refreshed. CLOSE-FUNCTION runs once on close. These three

callbacks do nothing when omitted."