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