1# in progress 2 3 4 5# Copyright 2011, 2012, 2013, 2014, 2017 Kevin Ryde 6 7# This file is part of X11-Protocol-Other. 8# 9# X11-Protocol-Other is free software; you can redistribute it and/or 10# modify it under the terms of the GNU General Public License as published 11# by the Free Software Foundation; either version 3, or (at your option) any 12# later version. 13# 14# X11-Protocol-Other is distributed in the hope that it will be useful, 15# but WITHOUT ANY WARRANTY; without even the implied warranty of 16# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 17# Public License for more details. 18# 19# You should have received a copy of the GNU General Public License along 20# with X11-Protocol-Other. If not, see <http://www.gnu.org/licenses/>. 21 22BEGIN { require 5 } 23package X11::Protocol::Ext::XInputExtension; 24use strict; 25use Carp; 26use X11::Protocol; 27 28use vars '$VERSION', '@CARP_NOT'; 29$VERSION = 31; 30@CARP_NOT = ('X11::Protocol'); 31 32# uncomment this to run the ### lines 33use Smart::Comments; 34 35# /usr/share/doc/x11proto-input-dev/XIproto.txt.gz 36# /usr/share/doc/x11proto-input-dev/XI2proto.txt.gz 37# 38# /usr/include/X11/extensions/XIproto.h 39# /usr/include/X11/extensions/XI2proto.h 40# 41# /usr/include/X11/extensions/XInput2.h 42# 43# /usr/share/doc/x11proto-core-dev/x11protocol.txt.gz 44# 45# xinput dumper programs 46# 47 48# these not documented yet ... 49use constant CLIENT_MAJOR_VERSION => 2; 50use constant CLIENT_MINOR_VERSION => 0; 51 52#------------------------------------------------------------------------------ 53# symbolic constants 54 55my %const_arrays 56 = ( 57 XIDeviceUse => ['MasterPointer', 'MasterKeyboard', 58 'SlavePointer', 'SlaveKeyboard', 59 'FloatingSlave' ], 60 XIClass => ['Key', 'Button', 'Valuator'], 61 XIDeviceMode => ['Relative', 'Absolute'], 62 XIFeedbackClass => ['Kbd', # 0 63 'Ptr', # 1 64 'String', # 2 65 'Integer', # 3 66 'Led', # 4 67 'Bell', # 5 68 ], 69 XIUse => ['Pointer', # 0 70 'Keyboard', # 1 71 'ExtensionDevice', # 2 72 'ExtensionKeyboard', # 3 73 'ExtensionPointer', # 4 74 ], 75 XIEventMode => [ 'AsyncThisDevice', # 0 per XI.h 76 'SyncThisDevice', # 1 77 'ReplayThisdevice', # 2 78 'AsyncOtherDevices', # 3 79 'AsyncAll', # 4 80 'SyncAll', # 5 81 ] 82 ); 83 84my %const_hashes 85 = (map { $_ => { X11::Protocol::make_num_hash($const_arrays{$_}) } } 86 keys %const_arrays); 87 88#------------------------------------------------------------------------------ 89# requests 90 91my $reqs = 92 [ 93 undef, # 0 94 95 ['XIGetExtensionVersion', # 1 96 sub { 97 my ($X, $name) = @_; 98 ### XIGetExtensionVersion() ... 99 if (! defined $name) { $name = "XInputExtension"; } 100 # my $ret = pack ('Sxx' . X11::Protocol::padded($name), 101 # length($name), $name); 102 # ### $ret 103 # ### len: length($ret) 104 return pack ('Sxx' . X11::Protocol::padded($name), 105 length($name), $name); 106 }, 107 sub { 108 my ($X, $data) = @_; 109 return unpack 'x8SS', $data; 110 111 # Any interest in holding onto the version? 112 # my ($server_major, $server_minor) = unpack 'x8SS', $data; 113 # ### $server_major 114 # ### $server_minor 115 # my $self; 116 # if ($self = $self->{'ext'}{'XInputExtension'}->[3]) { 117 # $self->{'major'} = $server_major; 118 # $self->{'minor'} = $server_minor; 119 # } 120 # return ($server_major, $server_minor); 121 }], 122 123 ['XIListInputDevices', # 2 124 \&_request_empty, 125 sub { 126 my ($X, $data) = @_; 127 128 # use Data::HexDump::XXD; 129 # print scalar(Data::HexDump::XXD::xxd($data)); 130 # print "\n"; 131 132 my ($num_devices) = unpack 'x8C', $data; 133 my $pos = 32; 134 ### $num_devices 135 136 my @ret; 137 my @infos; 138 foreach (1 .. $num_devices) { 139 ### device: $_ 140 ### pos: sprintf '%d %#X', $pos, $pos 141 142 my ($type_atom, $deviceid, $num_classes, $use, $attached_deviceid) 143 = unpack 'LCCCC', substr ($data, $pos, 8); 144 $pos += 8; 145 my $info = { type => $type_atom, 146 use => $X->interp('XIUse',$use), 147 attached_deviceid => $attached_deviceid, 148 num_classes => $num_classes, 149 }; 150 push @infos, $info; 151 push @ret, $deviceid => $info; 152 } 153 154 my $info; 155 foreach $info (@infos) { 156 my $num_classes = $info->{'num_classes'}; 157 158 my @classes; 159 $info->{'classes'} = \@classes; 160 161 foreach (1 .. $num_classes) { 162 ### pos: sprintf '%d %#X', $pos, $pos 163 164 my ($class, $class_len) = unpack 'CC', substr ($data, $pos, 2); 165 my %class_info = (class => $X->interp('XIClass',$class)); 166 push @classes, \%class_info; 167 168 ### $class 169 ### class interp: $X->interp('XIClass',$class) 170 ### $class_len 171 ### assert: $class_len >= 2 172 173 if ($class == 0) { # Key 174 ($class_info{'min_keycode'}, 175 $class_info{'max_keycode'}, 176 $class_info{'num_keys'}) 177 = unpack 'xxCCS', substr ($data, $pos, 6); 178 } elsif ($class == 1) { # Button 179 ($class_info{'num_buttons'}) 180 = unpack 'xxS', substr ($data, $pos, 4); 181 } elsif ($class == 2) { # Valuator 182 my ($num_axes, $mode, $motion_buffer_size) 183 = unpack 'xxCCL', substr ($data, $pos, 8); 184 $class_info{'num_axes'} = $num_axes; 185 $class_info{'mode'} = $X->interp('XIDeviceMode',$mode); 186 $class_info{'motion_buffer_size'} = $motion_buffer_size; 187 $class_info{'axes'} 188 = [ map { 189 # FIXME: min/max signed or unsigned? Xlib is signed ... 190 my ($resolution, $min_value, $max_value) 191 = unpack 'Lll', substr ($data, $pos+12*$_-4, 12); 192 { resolution => $resolution, 193 min_value => $min_value, 194 max_value => $max_value 195 } 196 } 1 .. $num_axes ]; 197 } 198 $pos += $class_len; 199 } 200 } 201 202 ### names pos: sprintf '%d %#X', $pos, $pos 203 foreach my $i (1 .. $num_devices) { 204 my ($name_len) = unpack 'C', substr($data,$pos++,1); 205 ### $name_len 206 $ret[2*$i-1]->{'name'} = substr($data,$pos,$name_len); 207 $pos += $name_len; 208 } 209 return @ret; 210 }], 211 212 undef, # OpenDevice 3 213 214 ['XICloseDevice', # 4 215 sub { 216 my ($X, $deviceid) = @_; 217 return pack 'Cxxx', $deviceid; 218 }], 219 220 ['XISetDeviceMode', # 5 221 sub { 222 my ($X, $deviceid, $mode) = @_; 223 return pack 'CCxx', 224 $deviceid, $X->num('XIDeviceMode',$mode); 225 }, 226 sub { 227 my ($X, $data) = @_; 228 # FIXME: decode status value ... 229 return unpack 'x8C', $data; 230 }], 231 232 undef, # SelectExtensionEvent 6 233 undef, # GetSelectedExtensionEvents 7 234 undef, # ChangeDeviceDontPropagateList 8 235 undef, # GetDeviceDontPropagateList 9 236 undef, # GetDeviceMotionEvents 10 237 undef, # ChangeKeyboardDevice 11 238 undef, # ChangePointerDevice 12 239 240 ['XIGrabDevice', # 13 241 sub { 242 my ($X, $window, $deviceid, $owner_events, $event_class_list, 243 $this_device_mode, $other_device_mode, $time) = @_; 244 return pack('LLSCCCCxxC*', 245 $window, 246 _num_time($time), 247 scalar(@$event_class_list), # event_count 248 $X->num('SyncMode',$this_device_mode), 249 $X->num('SyncMode',$other_device_mode), 250 $owner_events, 251 $deviceid, 252 map {$X->num('XIEventClass',$_)} 253 @$event_class_list 254 ) 255 }, 256 sub { 257 my ($X, $data) = @_; 258 my ($status) = unpack 'x8C', $data; 259 return $X->interp('GrabStatus',$status); 260 } ], 261 262 ['XIUngrabDevice', # 14 263 sub { 264 my ($X, $deviceid, $time) = @_; 265 return pack 'LCxxx', _num_time($time), $deviceid; 266 } ], 267 268 undef, # GrabDeviceKey 15 269 undef, # UngrabDeviceKey 16 270 undef, # GrabDeviceButton 17 271 undef, # UngrabDeviceButton 18 272 273 ['XIAllowDeviceEvents', # 19 274 sub { 275 my ($X, $deviceid, $event_mode, $time) = @_; 276 return pack 'LCCxx', 277 _num_time($time), 278 $X->num('XIEventMode',$event_mode), 279 $deviceid; 280 } ], 281 282 undef, # GetDeviceFocus 20 283 undef, # SetDeviceFocus 21 284 undef, # GetFeedbackControl 22 285 undef, # ChangeFeedbackControl 23 286 undef, # GetDeviceKeyMapping 24 287 undef, # ChangeDeviceKeyMapping 25 288 undef, # GetDeviceModifierMapping 26 289 undef, # SetDeviceModifierMapping 27 290 undef, # GetDeviceButtonMapping 28 291 undef, # SetDeviceButtonMapping 29 292 undef, # QueryDeviceState 30 293 undef, # SendExtensionEvent 31 294 295 ['XIDeviceBell', # 32 296 sub { 297 my ($X, $deviceid, $feedbackclass, $feedbackid, $percent) = @_; 298 return pack 'CCCc', $deviceid, $feedbackclass, $feedbackid, $percent; 299 } ], # 300 301 undef, # SetDeviceValuators 33 302 undef, # GetDeviceControl 34 303 undef, # ChangeDeviceControl 35 304 305 # ------------------------------------------------------------------------- 306 # XInputExtension version 1.5 307 undef, # ListDeviceProperties 36 308 undef, # ChangeDeviceProperty 37 309 undef, # DeleteDeviceProperty 38 310 undef, # GetDeviceProperty 39 311 312 # ------------------------------------------------------------------------- 313 # XInputExtension version 2.0 314 315 undef, # XIQueryPointer 40 316 undef, # XIWarpPointer 41 317 undef, # XIChangeCursor 42 318 undef, # XIChangeHierarchy 43 319 undef, # XISetClientPointer 44 320 undef, # XIGetClientPointer 45 321 undef, # XISelectEvents 46 322 323 ['XIQueryVersion', # 47 324 sub { 325 shift; # ($X, $client_major, $client_minor) 326 ### XIQueryVersion() ... 327 return pack 'SS', @_; 328 }, 329 sub { 330 my ($X, $data) = @_; 331 return unpack 'x8SS', $data; 332 333 # Any interest in holding onto the version? 334 # my ($server_major, $server_minor) = unpack 'x8SS', $data; 335 # ### $server_major 336 # ### $server_minor 337 # my $self; 338 # if ($self = $self->{'ext'}{'XI'}->[3]) { 339 # $self->{'major'} = $server_major; 340 # $self->{'minor'} = $server_minor; 341 # } 342 # return ($server_major, $server_minor); 343 }], 344 345 ['XIQueryDevice', # 48 346 sub { 347 my ($X, $deviceid) = @_; 348 ### XIQueryDevice() ... 349 return pack 'Sxx', $deviceid; 350 }, 351 sub { 352 my ($X, $data) = @_; 353 ### XIQueryDevice reply ... 354 355 my ($num_devices) = unpack 'x8S', $data; 356 ### $num_devices 357 358 my $pos = 32; 359 my @ret; 360 foreach (1 .. $num_devices) { 361 ### $pos 362 ### data: substr($data,$pos) 363 364 my ($deviceid, $use, $attachment, $num_classes, $name_len, $enabled) 365 = unpack 'SSSSSC', substr ($data, $pos); 366 $pos += 12; 367 368 ### $deviceid 369 ### $use 370 ### $attachment 371 ### $num_classes 372 ### $name_len 373 ### $enabled 374 375 my $name = substr ($data, $pos, $name_len); 376 $pos += $name_len + X11::Protocol::padding($name_len); 377 ### $name 378 379 my @classes; 380 foreach (1 .. $num_classes) { 381 my ($type, $class_len, $sourceid, $num_whatever) 382 = unpack 'SSSS', substr($data,$pos); 383 $pos += $class_len*4; 384 ### $type 385 ### $class_len 386 ### $sourceid 387 ### $num_whatever 388 389 push @classes, [ $X->interp('XIClass', $type), 390 $sourceid ]; 391 } 392 393 push @ret, [ $deviceid, 394 $X->interp('XIDeviceUse',$use), 395 $attachment, 396 $enabled, 397 $name, 398 \@classes ]; 399 } 400 return @ret; 401 }], 402 403 ['XISetFocus', # 49 404 sub { 405 my ($X, $window, $deviceid, $time) = @_; 406 return pack 'LLSxx', _num_none($window), _num_time($time), $deviceid; 407 } ], 408 409 ['XIGetFocus', # 50 410 sub { 411 my ($X, $deviceid) = @_; 412 return pack 'Sxx', $deviceid; 413 }, 414 sub { 415 my ($X, $data) = @_; 416 return unpack 'L', $data; 417 } ], 418 419 undef, # XIGrabDevice 51 420 undef, # XIUngrabDevice 52 421 422 ['XIAllowEvents', # 53 423 sub { 424 my ($X, $deviceid, $mode, $time) = @_; # per $X->AllowEvents() arg order 425 return pack 'LSCx', 426 _num_time($time), 427 $deviceid, 428 $X->num('AllowEventsMode',$mode); 429 } ], 430 431 undef, # XIPassiveGrabDevice 54 432 undef, # XIPassiveUngrabDevice 55 433 undef, # XIListProperties 56 434 undef, # XIChangeProperty 57 435 undef, # XIDeleteProperty 58 436 undef, # XIGetProperty 59 437 438 ['XIGetSelectedEvents', # 60 439 \&_request_xids, 440 sub { 441 my ($X, $data) = @_; 442 # pairs of 443 # uint16_t deviceid; /**< Device id to select for */ 444 # uint16_t mask_len; /**< Length of mask in 4 byte units */ 445 446 my ($num_masks) = unpack 'x8S', $data; 447 my @ret; 448 my $pos = 12; 449 foreach (1 .. $num_masks) { 450 my ($deviceid, $mask_len) = unpack 'SS', substr ($data, $pos); 451 $pos += 4; 452 my $mask = substr ($data, $pos, $mask_len); # FIXME ... numize bytes 453 $pos += $mask_len; 454 push @ret, $deviceid, $mask; 455 } 456 return @ret; 457 }], 458 459 ]; 460 461sub _num_none { 462 my ($xid) = @_; 463 if (defined $xid && $xid eq "None") { 464 return 0; 465 } else { 466 return $xid; 467 } 468} 469sub _num_time { 470 my ($time) = @_; 471 if (defined $time && $time eq "CurrentTime") { 472 return 0; 473 } else { 474 return $time; 475 } 476} 477 478sub _request_empty { 479 # ($X) 480 if (@_ > 1) { 481 croak "No parameters in this request"; 482 } 483 return ''; 484} 485sub _request_xids { 486 my $X = shift; 487 ### _request_xids(): @_ 488 return _request_card32s ($X, map {_num_none($_)} @_); 489} 490sub _request_card32s { 491 shift; 492 ### _request_card32s(): @_ 493 return pack 'L*', @_; 494} 495 496sub new { 497 my ($class, $X, $request_num, $event_num, $error_num) = @_; 498 ### XInputExtension new() ... 499 500 # Constants 501 %{$X->{'ext_const'}} = (%{$X->{'ext_const'} ||= {}}, %const_arrays); 502 %{$X->{'ext_const_num'}} = (%{$X->{'ext_const_num'} ||= {}}, %const_hashes); 503 504 # Errors 505 _ext_const_error_install ($X, $error_num, 506 'Device', # 0 507 'Event', # 1 508 'XIMode', # 2 509 'DeviceBusy', # 3 510 'XIClass'); # 4 511 512 # Requests 513 _ext_requests_install ($X, $request_num, $reqs); 514 515 return bless { }, $class; 516} 517 518sub _ext_requests_install { 519 my ($X, $request_num, $reqs) = @_; 520 521 $X->{'ext_request'}->{$request_num} = $reqs; 522 my $href = $X->{'ext_request_num'}; 523 my $i; 524 foreach $i (0 .. $#$reqs) { 525 if (defined $reqs->[$i]) { 526 $href->{$reqs->[$i]->[0]} = [$request_num, $i]; 527 } 528 } 529} 530sub _ext_const_error_install { 531 my $X = shift; # ($X, $errname1,$errname2,...) 532 ### _ext_const_error_install: @_ 533 my $error_num = shift; 534 my $aref = $X->{'ext_const'}{'Error'} # copy 535 = [ @{$X->{'ext_const'}{'Error'} || []} ]; 536 my $href = $X->{'ext_const_num'}{'Error'} # copy 537 = { %{$X->{'ext_const_num'}{'Error'} || {}} }; 538 my $i; 539 foreach $i (0 .. $#_) { 540 $aref->[$error_num + $i] = $_[$i]; 541 $href->{$_[$i]} = $error_num + $i; 542 } 543} 544 545### XInputExtension loaded ... 546 5471; 548__END__ 549 550=for stopwords XID Ryde 551 552=head1 NAME 553 554X11::Protocol::Ext::XInputExtension - input devices beyond keyboard and pointer 555 556=head1 SYNOPSIS 557 558 use X11::Protocol; 559 my $X = X11::Protocol->new; 560 $X->init_extension('XInputExtension') 561 or print "XInputExtension not available"; 562 563=head1 DESCRIPTION 564 565The XInputExtension extension ... 566 567=head1 REQUESTS 568 569The following requests are made available with an C<init_extension()>, as 570per L<X11::Protocol/EXTENSIONS>. 571 572 my $is_available = $X->init_extension('XInputExtension'); 573 574=head1 XInputExtension 1.5 575 576=over 577 578=item C<$X-E<gt>XIAllowDeviceEvents ($deviceid, $event_mode, $time)> 579 580Release some events frozen by a grab on C<$deviceid>. C<$event_mode> can be 581 582 "AsyncThisDevice" 0 583 "SyncThisDevice" 1 584 "ReplayThisdevice" 2 585 "AsyncOtherDevices" 3 586 "AsyncAll" 4 587 "SyncAll" 5 588 589C<$time> is a server timestamp, or "CurrentTime". If C<$time> is before the 590last grab then C<XIAllowDeviceEvents()> is ignored. 591 592=item C<$X-E<gt>XIDeviceBell ($deviceid, $feedback_class, $feedback_id, $percent)> 593 594Sound the device bell, in a style similar to the core C<Bell()>. 595C<$feedback_class> and C<$feedback_id> identify which bell to ring. 596 597C<$percent> is -100 to +100 relative to the base volume of the bell. 598 599 -100 0 +100 $percent 600 |-----------base----| 601 0 100 volume used 602 603Percent 0 means the base volume. Positive percent 0 to 100 means a volume 604proportionally from base up to 100% volume. Negative percent -100 to 0 605means a volume proportionally from 0% (silent) up to the base volume. 606 607 percent <= 0 volume = base * (percent+100)/100 608 so percent=-100 to 0 is volume=0 to base 609 610 percent >= 0 volume = base + percent*(100 - base)/100 611 so percent=0 to +100 is volume=base to 100 612 613=cut 614 615# when percent>=0 616# volume = base - [(base * percent) / 100] + percent 617# = base + percent - (base*percent)/100 618# = base + percent*(1 - base/100) 619# = base + percent*(100 - base)/100 620 621=pod 622 623=back 624 625=head1 XInputExtension 2.0 626 627=over 628 629=item C<($server_major, $server_minor) = $X-E<gt>XIQueryVersion ($client_major, $client_minor)> 630 631Negotiate a protocol version with the server. C<$client_major> and 632C<$client_minor> is what the client would like. The returned 633C<$server_major> and C<$server_minor> is what the server will do. 634 635C<$client_major> must be 2 or more or a C<BadValue> error results. 636 637=back 638 639=head1 SEE ALSO 640 641L<X11::Protocol> 642 643F</usr/share/doc/x11proto-input-dev/XIproto.txt.gz>, 644F</usr/share/doc/x11proto-input-dev/XI2proto.txt.gz> 645 646=head1 HOME PAGE 647 648L<http://user42.tuxfamily.org/x11-protocol-other/index.html> 649 650=head1 LICENSE 651 652Copyright 2011, 2012, 2013, 2014, 2017 Kevin Ryde 653 654X11-Protocol-Other is free software; you can redistribute it and/or modify 655it under the terms of the GNU General Public License as published by the 656Free Software Foundation; either version 3, or (at your option) any later 657version. 658 659X11-Protocol-Other is distributed in the hope that it will be useful, but 660WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 661or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 662more details. 663 664You should have received a copy of the GNU General Public License along with 665X11-Protocol-Other. If not, see <http://www.gnu.org/licenses/>. 666 667=cut 668