#!/usr/bin/perl -w
# Copyright 2012, 2013 Kevin Ryde
# This file is part of X11-Protocol-Other.
#
# X11-Protocol-Other is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 3, or (at your option) any
# later version.
#
# X11-Protocol-Other is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
# Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with X11-Protocol-Other. If not, see <http://www.gnu.org/licenses/>.
BEGIN { require 5 }
use strict;
use X11::Protocol;
use Test;
use lib 't';
use MyTestHelpers;
BEGIN { MyTestHelpers::nowarnings() }
END { MyTestHelpers::diag ("END"); }
# uncomment this to run the ### lines
#use Smart::Comments;
my $test_count = (tests => 26)[1];
plan tests => $test_count;
require X11::Protocol;
MyTestHelpers::diag ("X11::Protocol version ", X11::Protocol->VERSION);
my $display = $ENV{'DISPLAY'};
if (! defined $display) {
foreach (1 .. $test_count) {
skip ('No DISPLAY set', 1, 1);
}
exit 0;
}
# pass display arg so as not to get a "guess" warning
my $X;
if (! eval { $X = X11::Protocol->new ($display); }) {
MyTestHelpers::diag ('Cannot connect to X server -- ',$@);
foreach (1 .. $test_count) {
skip ('Cannot connect to X server', 1, 1);
}
exit 0;
}
$X->QueryPointer($X->{'root'}); # sync
my ($major_opcode, $first_event, $first_error)
= $X->QueryExtension('TOG-CUP');
{
if (! defined $major_opcode) {
foreach (1 .. $test_count) {
skip ('QueryExtension() no TOG-CUP on the server', 1, 1);
}
exit 0;
}
MyTestHelpers::diag ("TOG-CUP extension opcode=$major_opcode event=$first_event error=$first_error");
}
if (! $X->init_extension ('TOG-CUP')) {
die "QueryExtension says TOG-CUP avaiable, but init_extension() failed";
}
$X->QueryPointer($X->root); # sync
#------------------------------------------------------------------------------
# CupQueryVersion
{
my $client_major = 1;
my $client_minor = 0;
my @ret = $X->CupQueryVersion ($client_major, $client_minor);
MyTestHelpers::diag ("server TOG-CUP version ", join('.',@ret));
ok (scalar(@ret), 2);
}
$X->QueryPointer($X->root); # sync
#------------------------------------------------------------------------------
# CupGetReservedColormapEntries
{
my $screen_num = 0;
my @colours = $X->CupGetReservedColormapEntries ($screen_num);
my $bad = 0;
my $c;
foreach $c (@colours) {
if (scalar(@$c) != 5) {
MyTestHelpers::diag ("oops, bad colour length: ", scalar(@$c));
last if ++$bad > 10;
}
}
ok ($bad, 0);
}
#------------------------------------------------------------------------------
# find a writable visual, preferably a colour one
my $visual;
my $visual_is_colour;
{
my $v;
foreach $v (sort {$a<=>$b} keys %{$X->{'visuals'}}) {
my $info = $X->{'visuals'}->{$v};
my $class = $X->interp('VisualClass',$info->{'class'});
MyTestHelpers::diag ("visual $v $class depth=$info->{'depth'}");
if ($class eq 'GrayScale'
|| $class eq 'PseudoColor'
|| $class eq 'DirectColor') {
$visual = $v;
$visual_is_colour = ($class eq 'GrayScale' ? 0 : 1);
last if $visual_is_colour;
}
}
}
my $skip_no_writable_visual;
if (defined $visual) {
MyTestHelpers::diag ("using visual=$visual, visual_is_colour=$visual_is_colour");
} else {
$skip_no_writable_visual = 'due to no visual with a writable colormap';
MyTestHelpers::diag ("no writable visual available");
}
#------------------------------------------------------------------------------
# CupStoreColors -- black and white
{
my $colormap;
if (defined $visual) {
$colormap = $X->new_rsrc;
$X->CreateColormap ($colormap, $visual, $X->root, 'None');
$X->QueryPointer($X->{'root'}); # sync
}
{
my @colours = ([0,0,0,0,0]);
if (defined $colormap) {
# store white
@colours = $X->CupStoreColors ($colormap, [0, 65535,65535,65535]);
$X->QueryPointer($X->{'root'}); # sync
MyTestHelpers::diag ("white actual colour: ",join(', ',@{$colours[0]}));
}
skip ($skip_no_writable_visual, scalar(@colours), 1);
skip ($skip_no_writable_visual, $colours[0]->[0], 0);
skip ($skip_no_writable_visual, $colours[0]->[1] > 0, 1);
skip ($skip_no_writable_visual, $colours[0]->[2] > 0, 1);
skip ($skip_no_writable_visual, $colours[0]->[3] > 0, 1);
skip ($skip_no_writable_visual, $colours[0]->[4] & 8, 8); # succeed
}
{
my @colours = ([0,0,0,0,0]);
if (defined $colormap) {
# store black
@colours = $X->CupStoreColors ($colormap, [0, 0,0,0, 0]);
$X->QueryPointer($X->{'root'}); # sync
MyTestHelpers::diag ("black actual colour: ",join(', ',@{$colours[0]}));
}
skip ($skip_no_writable_visual, scalar(@colours), 1);
skip ($skip_no_writable_visual, $colours[0]->[0] != 0, 1);
skip ($skip_no_writable_visual, $colours[0]->[1], 0);
skip ($skip_no_writable_visual, $colours[0]->[2], 0);
skip ($skip_no_writable_visual, $colours[0]->[3], 0);
skip ($skip_no_writable_visual, $colours[0]->[4] & 8, 8); # at another pixel
}
if (defined $colormap) {
$X->FreeColormap($colormap);
}
}
#------------------------------------------------------------------------------
# CupStoreColors -- colour
my $skip_no_colour_visual;
if (! defined $visual) {
$skip_no_colour_visual = $skip_no_writable_visual;
} elsif (! $visual_is_colour) {
$skip_no_colour_visual = 'due to no writable colour visual';
MyTestHelpers::diag ("skip, visual is not colour");
}
{
my $colormap;
if ($visual_is_colour) {
$colormap = $X->new_rsrc;
$X->CreateColormap ($colormap, $visual, $X->root, 'None');
$X->QueryPointer($X->{'root'}); # sync
}
{
my @colours = ([0,0,0,0,0]);
if (defined $colormap) {
# store red
@colours = $X->CupStoreColors ($colormap, [0, 65535,0,0]);
$X->QueryPointer($X->{'root'}); # sync
MyTestHelpers::diag ("red actual colour: ",join(', ',@{$colours[0]}));
}
skip ($skip_no_colour_visual, scalar(@colours), 1);
skip ($skip_no_colour_visual, $colours[0]->[0], 0);
skip ($skip_no_colour_visual, $colours[0]->[1] > 0, 1);
skip ($skip_no_colour_visual, $colours[0]->[2], 0);
skip ($skip_no_colour_visual, $colours[0]->[3], 0);
skip ($skip_no_colour_visual, $colours[0]->[4] & 8, 8); # succeed
}
{
my @colours = ([0,0,0,0,0]);
if (defined $colormap) {
# store blue
@colours = $X->CupStoreColors ($colormap, [0, 0,0,65535, 0]);
$X->QueryPointer($X->{'root'}); # sync
MyTestHelpers::diag ("blue actual colour: ",join(', ',@{$colours[0]}));
}
skip ($skip_no_colour_visual, scalar(@colours), 1);
skip ($skip_no_colour_visual, $colours[0]->[0] != 0, 1);
skip ($skip_no_colour_visual, $colours[0]->[1], 0);
skip ($skip_no_colour_visual, $colours[0]->[2], 0);
skip ($skip_no_colour_visual, $colours[0]->[3] > 0, 1);
skip ($skip_no_colour_visual, $colours[0]->[4] & 8, 8); # at another pixel
}
if (defined $colormap) {
$X->FreeColormap($colormap);
}
}
#------------------------------------------------------------------------------
exit 0;