Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

extensions: randr: fix RR-GET-SCREEN-INFO rates #174

Merged
merged 1 commit into from
Jul 13, 2020
Merged

extensions: randr: fix RR-GET-SCREEN-INFO rates #174

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
176 changes: 132 additions & 44 deletions extensions/randr.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -182,7 +182,7 @@
'(member :rotate-0 :rotate-90 :rotate-180 :rotate-270 :reflect-x :reflect-y))

(deftype rotation-mask ()
'(or mask16 (clx-list event-mask-class)))
'(or mask16 (clx-list rotation-mask-class)))

;; Select

Expand Down Expand Up @@ -435,18 +435,49 @@
(boolean state)
)

;; x-requests
;;; Helpers

(declaim (ftype (function (card32 card32) (values boolean &optional))
rr-has-rates))
(defun rr-has-rates (major minor)
(or (> major 1)
(and (= major 1) (>= minor 1))))

;;; Requests

(declaim (ftype (function (display) (values card32 card32 &optional))
rr-query-version))
(defun rr-query-version (display)
"Returns version MAJOR and MINOR from server."
(with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (32))
"Execute the RRQueryVersion request and return its result as multiple
values consisting of the server's major and minor protocol versions."
(with-buffer-request-and-reply (display (randr-opcode display) nil
:sizes (32))
((data +rr-QueryVersion+)
(card32 +rr-major+)
(card32 +rr-minor+))
(values
(card32-get 8)
(card32-get 12))))

;; Unexported
(declaim (ftype (function (display (or null card32) (or null card32))
(values card32 card32 &optional))
rr-maybe-query-version))
(defun rr-maybe-query-version (display major minor)
"Return MAJOR and MINOR as multiple values, substituting 0 for NIL,
unless they are both NIL, in which case call RR-QUERY-VERSION and return
its values.

Some requests (e.g., RRGetScreenInfo) behave differently after a version
query (only the first query has any effect on these requests).
In order that the functions executing such requests be able to skip
subsequent (redundant) queries, have them accept MAJOR and MINOR keyword
arguments and call this function with those arguments instead of calling
RR-QUERY-VERSION."
(if (or major minor)
(values (or major 0) (or minor 0))
(rr-query-version display)))

(defun rr-set-screen-config (window timestamp conf-timestamp size-id rotation refresh)
"Sets the current screen to which the given window belongs. Timestamps are obtained from rr-get-screen-info. Rotation can be a list of rotation keys or a rotation mask. Returns timestamp, config timestamp, the root window of the screen and sub-pixel order."
(let ((display (window-display window))
Expand Down Expand Up @@ -487,39 +518,96 @@
(card16 select-mask)
(pad16))))

(defun rr-get-screen-info (window &optional (result-type 'list))
"Returns rotations, root-window, timestamp, config-timestamp, current-size-id, current rotation, current rate, a list of screen-size structures, and last a sequence of refresh-rates"
(declaim (ftype (function (window &key
(:major (or null card32))
(:minor (or null card32))
(:result-type t))
(values (clx-list rotation-mask-class)
window
timestamp
timestamp
size-id
(clx-list rotation-mask-class)
(clx-list screen-size)
(or null card16)
(clx-sequence card16)
&optional))
rr-get-screen-info))
(defun rr-get-screen-info (window &key major minor (result-type 'list))
"Execute the RRGetScreenInfo request and return its result as multiple
values consisting of:

1. List of possible rotations and reflections
2. Root window
3. Timestamp
4. Configuration timestamp
5. Current screen size index (in the list of possible screen sizes)
6. Current rotation and reflection
7. List of possible screen sizes
8. Current refresh rate (non-NIL only if server's protocol version is
1.1 or later)
9. Sequence of refresh rate information (non-NIL only if server's
protocol version is 1.1 or later)

Each screen size has in the refresh rate information sequence a
corresponding refresh rate count followed by that number of possible
refresh rates.
For example, '(2 120 60 1 60) means that the first screen size has the
two refresh rates 120 and 60, and that the second screen size has the
single refresh rate 60.

If MAJOR and MINOR, which comprise the server's protocol version, are
missing, this function executes the RRQueryVersion request before
RRGetScreenInfo in order to, first, potentially ask the server to
include, if it can, the current refresh rate and the refresh rate
information sequence in its reply to the latter request, and second,
determine whether this information is forthcoming.
Otherwise, this function assumes MAJOR and MINOR are the result of
RR-QUERY-VERSION -- failing which it will behave unreliably -- and it
skips executing the RRQueryVersion request."
(let ((display (window-display window)))
(declare (type display display)
(type window window))
(with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
((data +rr-GetScreenInfo+ )
(window window))
(let ((num-screens (card16-get 20))
(num-rates (card16-get 28))
(rates-location 0))
(declare (type fixnum rates-location num-rates))
(declare (type display display))
(multiple-value-bind (major minor)
(rr-maybe-query-version display major minor)
(with-buffer-request-and-reply (display (randr-opcode display) nil
:sizes (8 16 32))
((data +rr-GetScreenInfo+)
(window window))
(let* ((num-screens (card16-get 20))
(rate-info-length (card16-get 28))
(screen-start +replysize+)
(rate-info-start (index+ screen-start (index* num-screens 8)))
(has-rates (rr-has-rates major minor)))
(values
(make-rotation-keys (card16-get 1)) ; possible rotations, using card16, not card8 from spec.
(window-get 8) ;root window
(card32-get 12) ;timestamp
(card32-get 16) ;config-timestamp
(card16-get 22) ;size-id
(make-rotation-keys (card16-get 24)) ;current rotation
(card16-get 26) ; current rate
(loop :for x fixnum :from 1 :to num-screens
:for offset fixnum := 32 :then (+ offset 8)
:collect (make-screen-size (card16-get offset)
(card16-get (index+ offset 2))
(card16-get (index+ offset 4))
(card16-get (index+ offset 6)))
:finally (setf rates-location (+ offset 8 2)))
(sequence-get :format card16 :length num-rates :index rates-location :result-type result-type))))))

;; Possible rotations and reflections
(make-rotation-keys (card16-get 1))
(window-get 8) ; Root window
(card32-get 12) ; Timestamp
(card32-get 16) ; Configuration timestamp
(card16-get 22) ; Current screen size index
;; Current rotation and reflection
(make-rotation-keys (card16-get 24))
(loop for i fixnum from 1 to num-screens
for offset fixnum = screen-start then (+ offset 8)
collect (make-screen-size (card16-get offset)
(card16-get (index+ offset 2))
(card16-get (index+ offset 4))
(card16-get (index+ offset 6))))
;; Some servers (e.g., X.Org) always reply with the current
;; refresh rate if they support it, even before receiving any
;; version query.
;; However, the refresh rate information is available only
;; after querying the version (when providing an appropriate
;; client version).
(when has-rates (card16-get 26)) ; Current refresh rate
(when has-rates (sequence-get :result-type result-type
:format card16
:length rate-info-length
:index rate-info-start))))))))

;; Version 1.2

(defun rr-get-screen-size-range (window &optional (result-type 'list))
(defun rr-get-screen-size-range (window &key (result-type 'list))
"Returns a sequence of minimum width, minimum height, max width, max height."
(let ((display (window-display window)))
(with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (16))
Expand All @@ -546,7 +634,7 @@
(card32 width-mm)
(card32 height-mm))))

(defun rr-get-screen-resources (window &optional (result-type 'list))
(defun rr-get-screen-resources (window &key (result-type 'list))
""
(let ((display (window-display window)))
(declare (type display display)
Expand Down Expand Up @@ -574,7 +662,7 @@



(defun rr-get-output-info (display output config-timestamp &optional (result-type 'list))
(defun rr-get-output-info (display output config-timestamp &key (result-type 'list))
"FIXME: indexes might be off, name not decoded properly"
(with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
((data +rr-getoutputinfo+)
Expand Down Expand Up @@ -604,7 +692,7 @@
(sequence-get :result-type 'string :format card16 :length name-length :index name-start :transform #'code-char))
)))

(defun rr-list-output-properties (display output &optional (result-type 'list))
(defun rr-list-output-properties (display output &key (result-type 'list))
"Returns a list of atom properties for given display. ?keep it simple and return id's or atom-names?"
(declare (type display display)
(type card32 output))
Expand All @@ -615,7 +703,7 @@
(values
(sequence-get :format card32 :result-type result-type :length num-atoms :index +replysize+ :transform #'(lambda (id) (atom-name display id)))))))

(defun rr-query-output-property (display output atom &optional (result-type 'list))
(defun rr-query-output-property (display output atom &key (result-type 'list))
"Querys the current properties of an atom. Atom may be referenced by either id or keyword"
(let ((atom (if (typep atom 'keyword) (find-atom display atom) atom)))
(declare (type display display)
Expand All @@ -630,7 +718,7 @@
(boolean-get 10) ; immutable
(sequence-get :result-type result-type :index +replysize+ :length (card32-get 4))))))

(defun rr-configure-output-property (display output atom value-list &optional (pending nil) (range nil))
(defun rr-configure-output-property (display output atom value-list &key pending range)
"Atom can be specified by either id or keyword"
(let ((atom (if (typep atom 'keyword) (find-atom display atom) atom))
(seq (coerce value-list 'vector)))
Expand All @@ -647,7 +735,7 @@
;; Spec says type is not interpreted, what use? shit, are certain property types tied to certain formats? change if necessary after get-output-property

;; FIXME asynchronous match error
(defun rr-change-output-property (display output atom mode data &optional (atom-type 0) )
(defun rr-change-output-property (display output atom mode data &key (atom-type 0))
"Mode may be 0-replace 1-prepend 2-append. atom-type is obtained by calling rr-get-output-property "
(let ((atom (if (typep atom 'keyword) (find-atom display atom) atom))
(data-length (length data))
Expand All @@ -672,7 +760,7 @@
(card32 output)
(card32 atom))))

(defun rr-get-output-property (display output property &optional (type 0) (delete 0) (pending 0) (result-type 'list))
(defun rr-get-output-property (display output property &key (type 0) (delete 0) (pending 0) (result-type 'list))
""
(let ((atom (if (typep property 'keyword) (find-atom display property) property)))
(with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
Expand Down Expand Up @@ -744,7 +832,7 @@
(card32 output)
(card32 mode)))

(defun rr-get-crtc-info (display crtc config-timestamp &optional (result-type 'list))
(defun rr-get-crtc-info (display crtc config-timestamp &key (result-type 'list))
""
(with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
((data +rr-getcrtcinfo+)
Expand Down Expand Up @@ -794,7 +882,7 @@
(values
(card16-get 8))))

(defun rr-get-crtc-gamma (display crtc &optional (result-type 'list))
(defun rr-get-crtc-gamma (display crtc &key (result-type 'list))
"Get current gamma ramps, returns 3 sequences for red, green, blue."
(with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
((data +rr-getcrtcgamma+)
Expand Down Expand Up @@ -825,7 +913,7 @@
;; version 1.3


(defun rr-get-screen-resources-current (window &optional (result-type 'list ))
(defun rr-get-screen-resources-current (window &key (result-type 'list))
"Unlike RRGetScreenResources, this merely returns the current configuration, and does not poll for hardware changes."
(let ((display (window-display window)))
(with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
Expand All @@ -849,7 +937,7 @@
(string-get name-bytes name-start))))))


;; (defun rr-set-crtc-transform (display crtc transform &optional ( filter-name nil) ( filter-parameters nil))
;; (defun rr-set-crtc-transform (display crtc transform &key filter-name filter-parameters)
;; "FIXME:Transfrom may be a list or vector of length 9. ?perhaps allow length 6?"
;; (let ((seq (if filter-parameters (coerce filter-parameters 'vector) nil ))
;; (param-length (length filter-parameters))
Expand All @@ -874,7 +962,7 @@
;; )))


(defun rr-get-crtc-transform (display crtc &optional (result-type 'list))
(defun rr-get-crtc-transform (display crtc &key (result-type 'list))
""
(with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
((data +rr-getcrtctransform+)
Expand Down