1#!/usr/bin/perl -w
2
3# Copyright 2011, 2012, 2013, 2014, 2017, 2019 Kevin Ryde
4
5# This file is part of X11-Protocol-Other.
6#
7# X11-Protocol-Other is free software; you can redistribute it and/or modify it
8# under the terms of the GNU General Public License as published by the Free
9# Software Foundation; either version 3, or (at your option) any later
10# version.
11#
12# X11-Protocol-Other is distributed in the hope that it will be useful, but
13# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
14# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
15# for more details.
16#
17# You should have received a copy of the GNU General Public License along
18# with X11-Protocol-Other.  If not, see <http://www.gnu.org/licenses/>.
19
20BEGIN { require 5 }
21use strict;
22use Test;
23
24use lib 't';
25use MyTestHelpers;
26BEGIN { MyTestHelpers::nowarnings() }
27
28my $test_count = (tests => 113)[1];
29plan tests => $test_count;
30
31require X11::Protocol::Other;
32
33require X11::Protocol;
34MyTestHelpers::diag ("X11::Protocol version ", X11::Protocol->VERSION);
35
36my $display = $ENV{'DISPLAY'};
37if (! defined $display) {
38  MyTestHelpers::diag ('No DISPLAY set');
39  foreach (1 .. $test_count) {
40    skip ('No DISPLAY set', 1, 1);
41  }
42  exit 0;
43}
44MyTestHelpers::diag ("DISPLAY $display");
45
46# pass display arg so as not to get a "guess" warning
47my $X;
48if (! eval { $X = X11::Protocol->new ($display); }) {
49  MyTestHelpers::diag ("Cannot connect to X server -- $@");
50  foreach (1 .. $test_count) {
51    skip ("Cannot connect to X server", 1, 1);
52  }
53  exit 0;
54}
55MyTestHelpers::X11_server_info($X);
56
57$X->QueryPointer($X->{'root'});  # sync
58
59#------------------------------------------------------------------------------
60# VERSION
61
62my $want_version = 31;
63ok ($X11::Protocol::Other::VERSION,
64    $want_version,
65    'VERSION variable');
66ok (X11::Protocol::Other->VERSION,
67    $want_version,
68    'VERSION class method');
69
70ok (eval { X11::Protocol::Other->VERSION($want_version); 1 },
71    1,
72    "VERSION class check $want_version");
73my $check_version = $want_version + 1000;
74ok (! eval { X11::Protocol::Other->VERSION($check_version); 1 },
75    1,
76    "VERSION class check $check_version");
77
78
79#------------------------------------------------------------------------------
80# get_property_atoms()
81
82my $test_window = $X->new_rsrc;
83$X->CreateWindow ($test_window,
84                  $X->root,         # parent
85                  'InputOutput',    # class
86                  0,                # depth, from parent
87                  'CopyFromParent', # visual
88                  0,0,              # x,y
89                  1,1,              # width,height
90                  0,                # border
91                  # event_mask => $X->pack_event_mask('PropertyChange'),
92                 );
93
94{
95  my $property = $X->atom('X11_PROTOCOL_OTHER__TEST');
96  my $property2 = $X->atom('X11_PROTOCOL_OTHER__TEST_2');
97  my $root = $X->root;
98  my @want_atoms_one = ($X->atom('ONE'),
99                        $X->atom('TWO'));
100  $X->ChangeProperty($root,
101                     $property,                   # property
102                     X11::AtomConstants::ATOM(),  # type
103                     32,                          # format
104                     'Replace',
105                     pack('L*', @want_atoms_one));
106
107  my @want_atoms_two = ($X->atom('TWO'),
108                        $X->atom('THREE'));
109  ok (join(',',@want_atoms_one) ne join(',',@want_atoms_two),
110      1);
111  $X->ChangeProperty($test_window,
112                     $property2,                  # property
113                     X11::AtomConstants::ATOM(),  # type
114                     32,                          # format
115                     'Replace',
116                     pack('L*', @want_atoms_two));
117
118  {
119    my @got_atoms
120      = X11::Protocol::Other::get_property_atoms ($X, $root, $property);
121    ok (scalar(@got_atoms), 2);
122    ok (join(',',@got_atoms), join(',',@want_atoms_one));
123  }
124  {
125    my @got_atoms
126      = X11::Protocol::Other::get_property_atoms ($X, $test_window, $property2);
127    ok (scalar(@got_atoms), 2);
128    ok (join(',',@got_atoms), join(',',@want_atoms_two));
129  }
130
131  $X->DeleteProperty ($root, $property);
132  {
133    my @got_atoms
134      = X11::Protocol::Other::get_property_atoms ($X, $root, $property);
135    ok (scalar(@got_atoms), 0);
136    ok (join(',',@got_atoms), '');
137  }
138}
139
140#------------------------------------------------------------------------------
141# root_to_screen()
142
143{
144  my $screens_aref = $X->{'screens'};
145  my $good = 1;
146  my $screen_number;
147  foreach $screen_number (0 .. $#$screens_aref) {
148    my $rootwin = $screens_aref->[$screen_number]->{'root'}
149      || die "oops, no 'root' under screen $screen_number";
150    my $got = X11::Protocol::Other::root_to_screen($X,$rootwin);
151    if (! defined $got || $got != $screen_number) {
152      $good = 0;
153      MyTestHelpers::diag ("root_to_screen() wrong on rootwin $rootwin screen $screen_number");
154      MyTestHelpers::diag ("got ", (defined $got ? $got : 'undef'));
155    }
156  }
157  ok ($good, 1, "root_to_screen()");
158}
159
160#------------------------------------------------------------------------------
161# visual_class_is_dynamic()
162
163{
164  my $visual_class = 'PseudoColor';
165  ok (X11::Protocol::Other::visual_class_is_dynamic($X,$visual_class),
166      1,
167      "visual_class_is_dynamic() $visual_class");
168}
169{
170  my $visual_class = 3;
171  ok (X11::Protocol::Other::visual_class_is_dynamic($X,$visual_class),
172      1,
173      "visual_class_is_dynamic() $visual_class");
174}
175{
176  my $visual_class = 'TrueColor';
177  ok (X11::Protocol::Other::visual_class_is_dynamic($X,$visual_class),
178      0,
179      "visual_class_is_dynamic() $visual_class");
180}
181{
182  my $visual_class = 4;
183  ok (X11::Protocol::Other::visual_class_is_dynamic($X,$visual_class),
184      0,
185      "visual_class_is_dynamic() $visual_class");
186}
187
188#------------------------------------------------------------------------------
189# visual_is_dynamic()
190
191{
192  my $good = 1;
193  foreach (keys %{$X->{'visuals'}}) {
194    my $visual_id = $_;
195    my $visual_class = $X->{'visuals'}->{$visual_id}->{'class'};
196    my $got = X11::Protocol::Other::visual_is_dynamic($X,$visual_id);
197    my $want = X11::Protocol::Other::visual_class_is_dynamic($X,$visual_class);
198    if ($got != $want) {
199      MyTestHelpers::diag ("wrong: visual_id $visual_id visual_class $visual_class got $got want $want");
200      $good = 0;
201    }
202  }
203  ok ($good, 1,
204      'visual_is_dynamic() ');
205}
206
207#------------------------------------------------------------------------------
208# hexstr_to_rgb()
209
210{
211  my $elem;
212  foreach $elem ([ 'bogosity' ],
213                 [ '#' ],
214                 [ '#1' ],
215                 [ '#12' ],
216
217                 [ '#def', 0xDDDD, 0xEEEE, 0xFFFF ],
218
219                 [ '#1234' ],
220                 [ '#12345' ],
221
222                 [ '#123456', 0x1212, 0x3434, 0x5656 ],
223                 [ '#abcdef', 0xABAB, 0xCDCD, 0xEFEF ],
224                 [ '#ABCDEF', 0xABAB, 0xCDCD, 0xEFEF ],
225
226                 [ '#1234567' ],
227                 [ '#12345678' ],
228
229                 [ '#123456789', 0x1231, 0x4564, 0x7897 ],
230                 [ '#abcbcdcde', 0xABCA, 0xBCDB, 0xCDEC ],
231
232                 [ '#1234567890' ],
233                 [ '#12345678901' ],
234
235                 [ '#123456789ABC', 0x1234, 0x5678, 0x9ABC ],
236                 [ '#abcdfedcdcba', 0xABCD, 0xFEDC, 0xDCBA ],
237
238                 [ '#1234567890123' ],
239                 [ '#12345678901234' ],
240                 [ '#123456789012345' ],
241                 [ '#1234567890123456' ],
242                 [ '#12345678901234567' ],
243                 [ '#123456789012345678' ],
244
245                ) {
246    my ($hexstr, @want_rgb) = @$elem;
247    my @got_rgb = X11::Protocol::Other::hexstr_to_rgb($hexstr);
248    ok (scalar(@got_rgb), scalar(@want_rgb),
249        "hexstr_to_rgb($hexstr) return 3 values");
250    ok ($got_rgb[0], $want_rgb[0],
251        "hexstr_to_rgb($hexstr) red[0]");
252    ok ($got_rgb[1], $want_rgb[1],
253        "hexstr_to_rgb($hexstr) green[1]");
254    ok ($got_rgb[2], $want_rgb[2],
255        "hexstr_to_rgb($hexstr) blue[2]");
256  }
257}
258
259#------------------------------------------------------------------------------
260$X->QueryPointer($X->{'root'});  # sync
261
262exit 0;
263