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