File Coverage

blib/lib/X11/Protocol/Ext/DAMAGE.pm
Criterion Covered Total %
statement 16 52 30.7
branch 0 6 0.0
condition 0 3 0.0
subroutine 6 14 42.8
pod 0 1 0.0
total 22 76 28.9


line stmt bran cond sub pod time code
1             # Copyright 2011, 2012, 2013, 2014, 2017 Kevin Ryde
2              
3             # This file is part of X11-Protocol-Other.
4             #
5             # X11-Protocol-Other is free software; you can redistribute it and/or
6             # modify it under the terms of the GNU General Public License as published
7             # by the Free Software Foundation; either version 3, or (at your option) any
8             # later version.
9             #
10             # X11-Protocol-Other is distributed in the hope that it will be useful,
11             # but WITHOUT ANY WARRANTY; without even the implied warranty of
12             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
13             # Public License for more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with X11-Protocol-Other. If not, see .
17              
18              
19             # /usr/share/doc/x11proto-damage-dev/damageproto.txt.gz
20             # http://cgit.freedesktop.org/xorg/proto/damageproto/tree/damageproto.txt
21             #
22             # /usr/include/X11/extensions/Xdamage.h
23             # /usr/include/X11/extensions/damageproto.h
24             # /usr/include/X11/extensions/damagewire.h
25             #
26             # server side source:
27             # http://cgit.freedesktop.org/xorg/xserver/tree/damageext/damageext.c
28             #
29              
30              
31 1     1   360 BEGIN { require 5 }
32             package X11::Protocol::Ext::DAMAGE;
33 1     1   3 use strict;
  1         1  
  1         14  
34 1     1   557 use X11::Protocol;
  1         13919  
  1         50  
35              
36 1     1   6 use vars '$VERSION', '@CARP_NOT';
  1         1  
  1         53  
37             $VERSION = 30;
38             @CARP_NOT = ('X11::Protocol');
39              
40             # uncomment this to run the ### lines
41             #use Smart::Comments;
42              
43              
44             # these not documented yet ...
45 1     1   3 use constant CLIENT_MAJOR_VERSION => 1;
  1         2  
  1         63  
46 1     1   3 use constant CLIENT_MINOR_VERSION => 1;
  1         1  
  1         671  
47              
48             my $reqs
49             = [
50             #------------
51             # version 1.0
52              
53             ["DamageQueryVersion", # 0
54             sub {
55             my ($X, $major, $minor) = @_;
56             ### DamageQueryVersion request
57             return pack 'LL', $major, $minor;
58             },
59             sub {
60             my ($X, $data) = @_;
61             ### DamageQueryVersion reply
62             my @ret = unpack 'x8LL', $data;
63              
64             # Any interest in holding onto the version?
65             # Remove DamageAdd if downgrading?
66             my $self;
67             if ($self = $X->{'ext'}->{'DAMAGE'}->[3]) {
68             ($self->{'major'}, $self->{'minor'}) = @ret;
69             }
70             return @ret;
71             }],
72              
73             ["DamageCreate", # 1
74             sub {
75             my ($X, $damage, $drawable, $level) = @_;
76             ### DamageCreate
77             return pack ('LLCxxx',
78             $damage,
79             $drawable,
80             $X->num('DamageReportLevel',$level));
81             }],
82              
83             ["DamageDestroy", # 2
84             \&_request_xids ], # ($damage)
85              
86             ["DamageSubtract", # 3
87             \&_request_xids ], # ($damage, $repair_region, $parts_region)
88              
89             #------------
90             # version 1.1
91              
92             ["DamageAdd", # 4
93             \&_request_xids ], # ($damage, $region)
94             ];
95              
96             my $DamageNotify_event
97             = [ sub {
98             my $X = shift;
99             my $data = shift;
100             ### DamageNotify unpack: @_[1..$#_]
101             my ($level, $drawable, $damage, $time, $area, $geometry)
102             = unpack 'xCxxL3a8a8', $data;
103             ### fields: $level, $drawable, $damage, $time, $area, $geometry
104             ### area: _unpack_rectangle($area)
105             ### geometry: _unpack_rectangle($geometry)
106             my $more = ($level >> 7) & 1; # bit 0x80
107             $level &= 0x7F;
108             return (@_, # base fields
109             drawable => $drawable,
110             damage => $damage,
111             level => $X->interp('DamageReportLevel',$level),
112             more => $more,
113             time => _interp_time($time),
114             area => _unpack_rectangle($area),
115             geometry => _unpack_rectangle($geometry),
116             );
117             }, sub {
118             my ($X, %h) = @_;
119             my $level = ($X->num('DamageReportLevel', $h{'level'})
120             + ($h{'more'} ? 0x80 : 0));
121             return (pack('xCxxL3ssSSssSS',
122             $level,
123             $h{'drawable'},
124             $h{'damage'},
125             _num_time($h{'time'}),
126             @{$h{'area'}}, # [$x,$y,$w,$h]
127             @{$h{'geometry'}}), # [$x,$y,$w,$h]
128             1); # "do_seq" put in sequence number
129             } ];
130              
131             my $DamageReportLevel_array = [ 'RawRectangles',
132             'DeltaRectangles',
133             'BoundingBox',
134             'NonEmpty' ];
135             my $DamageReportLevel_hash
136             = { X11::Protocol::make_num_hash($DamageReportLevel_array) };
137              
138             sub new {
139 0     0 0   my ($class, $X, $request_num, $event_num, $error_num) = @_;
140             ### DAMAGE new()
141              
142             # Constants
143 0           $X->{'ext_const'}->{'DamageReportLevel'} = $DamageReportLevel_array;
144 0           $X->{'ext_const_num'}->{'DamageReportLevel'} = $DamageReportLevel_hash;
145              
146             # Errors
147 0           $X->{'ext_const'}->{'Error'}->[$error_num] = 'Damage';
148 0           $X->{'ext_const_num'}->{'Error'}->{'Damage'} = $error_num;
149 0           $X->{'ext_error_type'}->[$error_num] = 1; # bad resource
150              
151             # Events
152 0           $X->{'ext_const'}->{'Events'}->[$event_num] = 'DamageNotify';
153 0           $X->{'ext_events'}->[$event_num] = $DamageNotify_event;
154              
155             # Requests
156 0           _ext_requests_install ($X, $request_num, $reqs);
157              
158             # Must DamageQueryVersion to negotiate desired version, or at least X.org
159             # server 1.9.x gives "Opcode" errors to all other requests if not.
160 0           my ($major, $minor) = $X->req ('DamageQueryVersion',
161             CLIENT_MAJOR_VERSION,
162             CLIENT_MINOR_VERSION);
163 0           return bless { major => $major,
164             minor => $minor,
165             }, $class;
166             }
167              
168             sub _ext_requests_install {
169 0     0     my ($X, $request_num, $reqs) = @_;
170              
171 0           $X->{'ext_request'}->{$request_num} = $reqs;
172 0           my $href = $X->{'ext_request_num'};
173 0           my $i;
174 0           foreach $i (0 .. $#$reqs) {
175 0           $href->{$reqs->[$i]->[0]} = [$request_num, $i];
176             }
177             }
178              
179             sub _request_xids {
180 0     0     my $X = shift;
181             ### _request_xids(): @_
182 0           return _request_card32s ($X, map {_num_none($_)} @_);
  0            
183             }
184             sub _request_card32s {
185 0     0     shift;
186             ### _request_card32s(): @_
187 0           return pack 'L*', @_;
188             }
189             sub _num_none {
190 0     0     my ($xid) = @_;
191 0 0 0       if (defined $xid && $xid eq 'None') {
192 0           return 0;
193             } else {
194 0           return $xid;
195             }
196             }
197              
198             sub _unpack_rectangle {
199 0     0     my ($data) = @_;
200 0           return [ unpack 'ssSS', $data ];
201             }
202              
203             sub _interp_time {
204 0     0     my ($time) = @_;
205 0 0         if ($time == 0) {
206 0           return 'CurrentTime';
207             } else {
208 0           return $time;
209             }
210             }
211             sub _num_time {
212 0     0     my ($time) = @_;
213 0 0         if ($time eq 'CurrentTime') {
214 0           return 0;
215             } else {
216 0           return $time;
217             }
218             }
219              
220             1;
221             __END__