#!/usr/bin/perl -w

# Copyright 2011, 2012, 2013, 2014 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 Test;

use lib 't';
use MyTestHelpers;
BEGIN { MyTestHelpers::nowarnings() }

my $test_count = (tests => 250)[1];
plan tests => $test_count;

require X11::Protocol::WM;

require X11::Protocol;
MyTestHelpers::diag ("X11::Protocol version ", X11::Protocol->VERSION);

my $display = $ENV{'DISPLAY'};
if (! defined $display) {
  MyTestHelpers::diag ('No DISPLAY set');
  foreach (1 .. $test_count) {
    skip ('No DISPLAY set', 1, 1);
  }
  exit 0;
}
MyTestHelpers::diag ("DISPLAY $display");

# 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;
}
MyTestHelpers::X11_server_info($X);

my $window = $X->new_rsrc;
$X->CreateWindow ($window,
                  $X->{'root'},     # parent
                  'InputOutput',
                  0,                # depth, from parent
                  'CopyFromParent', # visual
                  0,0,              # x,y
                  1,1,              # width,height
                  0);               # border
$X->MapWindow ($window);
$X->QueryPointer($X->{'root'});  # sync

my $window2 = $X->new_rsrc;
$X->CreateWindow ($window2,
                  $window,          # parent, so sub-window
                  'InputOutput',
                  0,                # depth, from parent
                  'CopyFromParent', # visual
                  0,0,              # x,y
                  1,1,              # width,height
                  0);               # border

sub to_hex {
  my ($str) = @_;
  return join (' ',
               map {sprintf("%02X", ord(substr($str,$_,1)))}
               0 .. length($str)-1);
}

#------------------------------------------------------------------------------
# VERSION

my $want_version = 30;
ok ($X11::Protocol::WM::VERSION,
    $want_version,
    'VERSION variable');
ok (X11::Protocol::WM->VERSION,
    $want_version,
    'VERSION class method');

ok (eval { X11::Protocol::WM->VERSION($want_version); 1 },
    1,
    "VERSION class check $want_version");
my $check_version = $want_version + 1000;
ok (! eval { X11::Protocol::WM->VERSION($check_version); 1 },
    1,
    "VERSION class check $check_version");

#------------------------------------------------------------------------------
# get_wm_icon_size()

{
  X11::Protocol::WM::get_wm_icon_size($X);
  X11::Protocol::WM::get_wm_icon_size($X, $X->root);

  $X->ChangeProperty($window,
                     $X->atom('WM_ICON_SIZE'),  # property
                     $X->atom('WM_ICON_SIZE'),  # type
                     32,                        # format
                     'Replace',                 # mode
                     pack ('L6', 1,2,3,4,5,6));

  my @ret = X11::Protocol::WM::get_wm_icon_size($X, $window);
  ok (join(',',@ret), '1,2,3,4,5,6', "WM_ICON_SIZE");

  $X->DeleteProperty($window, $X->atom('WM_ICON_SIZE'));
}

#------------------------------------------------------------------------------
# aspect_to_num_den()

{
  my $elem;
  foreach $elem ([1, 1,1],
                 [2, 2,1],
                 ['0.5', 5,10],
                 ['0.33', 33,100],
                 ['.33', 33,100],
                 ['12.34', 1234,100],
                 ['7/17', 7,17],

                 # current code grows in decimal ...
                 ['7.5/17', 75,170],
                 ['7.5/1.0', 75,10],
                 ['1.23/4.5', 123,450],
                 ['12.3/4.56', 1230,456],

                 # chopped down to maximum
                 [0x8000_0000, 0x7FFF_FFFF,1],

                 # not sure about this one
                 ['4294967296/4', 0x7FFF_FFFF,2],
                ) {
    my ($aspect, $want_num, $want_den) = @$elem;
    my ($got_num, $got_den) = X11::Protocol::WM::aspect_to_num_den($aspect);

    ok ($got_num, $want_num);
    ok ($got_den, $want_den);
  }
}

#------------------------------------------------------------------------------
# pack_wm_size_hints()

X11::Protocol::WM::pack_wm_size_hints($X,
                                      user_position => 1);
X11::Protocol::WM::pack_wm_size_hints($X,
                                      user_size => 1);

X11::Protocol::WM::pack_wm_size_hints($X,
                                      program_position => 1);
X11::Protocol::WM::pack_wm_size_hints($X,
                                      program_size => 1);

X11::Protocol::WM::pack_wm_size_hints($X,
                                      min_width => 100,
                                      min_height => 200);

X11::Protocol::WM::pack_wm_size_hints($X,
                                      max_width => 100,
                                      max_height => 200);
X11::Protocol::WM::pack_wm_size_hints($X,
                                      width_inc => 10,
                                      height_inc => 11);
X11::Protocol::WM::pack_wm_size_hints($X,
                                      base_width => 50,
                                      base_height => 60);

{
  my $bytes1 = X11::Protocol::WM::pack_wm_size_hints($X,
                                                     min_aspect => '1/2',
                                                     max_aspect => '3/4');
  my $bytes2 = X11::Protocol::WM::pack_wm_size_hints($X,
                                                     min_aspect_num => 1,
                                                     min_aspect_den => 2,
                                                     max_aspect_num => 3,
                                                     max_aspect_den => 4);
  ok ($bytes1, $bytes2);
}

{
  my $bytes1 = X11::Protocol::WM::pack_wm_size_hints($X,
                                                     win_gravity => 'NorthEast');
  my $bytes2 = X11::Protocol::WM::pack_wm_size_hints($X,
                                                     win_gravity => 4);
  ok ($bytes1, $bytes2);
}


#------------------------------------------------------------------------------
# pack_wm_size_hints()

{
  X11::Protocol::WM::set_wm_normal_hints($X, $window,
                                         user_position => 1,
                                         win_gravity => 'South');

  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window,
                       $X->atom('WM_NORMAL_HINTS'),
                       'AnyPropertyType',
                       0,   # offset
                       100, # length
                       0);  # delete
  ok ($format, 32);
  ok ($type, $X->atom('WM_SIZE_HINTS'));
  require X11::AtomConstants;
  ok ($type, X11::AtomConstants::WM_SIZE_HINTS());
  my $type_name = ($type ? $X->atom_name($type) : 'None');
  ok ($type_name, 'WM_SIZE_HINTS');
  # ok ($value, "...");
  ok ($bytes_after, 0);

  $X->DeleteProperty($window, $X->atom('WM_NORMAL_HINTS'));
}

#------------------------------------------------------------------------------
# unpack_wm_state()

{
  my @ret = X11::Protocol::WM::unpack_wm_state ($X, pack 'L2',0,0);
  ok (scalar(@ret), 2);
  ok ($ret[0], 'WithdrawnState');
  ok ($ret[1], 'None');
}
{
  my @ret = X11::Protocol::WM::unpack_wm_state ($X, pack 'L2',1,123);
  ok (scalar(@ret), 2);
  ok ($ret[0], 'NormalState');
  ok ($ret[1], 123);
}
{
  my @ret = X11::Protocol::WM::unpack_wm_state ($X, pack 'L2',3,123);
  ok (scalar(@ret), 2);
  ok ($ret[0], 'IconicState');
  ok ($ret[1], 123);
}

#------------------------------------------------------------------------------
# get_wm_state()

{
  my $target;
  foreach $target ($window, $X->{'root'}) {
    my @ret = X11::Protocol::WM::get_wm_state ($X, $target);
    ok (scalar(@ret) == 0 || scalar(@ret) == 2, 1,
        'get_wm_state() return 0 or 2 values');
    MyTestHelpers::diag ("WM_STATE: ",join(' ',@ret));
  }
}

{
  my $toplevel = $X->new_rsrc;
  $X->CreateWindow($toplevel,
                   $X->root,           # parent
                   'InputOutput',      # class
                   $X->root_depth,     # depth
                   'CopyFromParent',   # visual
                   0,0,                # x,y
                   100,100,            # width,height
                   10,                 # border
                   background_pixel => $X->{'white_pixel'},
                   override_redirect => 1,
                   colormap => 'CopyFromParent',
                  );

  my $subwin = $X->new_rsrc;
  $X->CreateWindow($subwin,
                   $toplevel,           # parent
                   'InputOutput',       # class
                   $X->root_depth,      # depth
                   'CopyFromParent',    # visual
                   0,0,                 # x,y
                   10,10,               # width,height
                   0,                   # border
                   background_pixel => $X->{'black_pixel'},
                   colormap => 'CopyFromParent',
                  );

  $X->ChangeProperty($subwin,
                     $X->atom('WM_STATE'),  # property
                     $X->atom('WM_STATE'),  # type
                     32,                    # format
                     'Replace',             # mode
                     pack ('L*', 1, 0));
  {
    my @ret = X11::Protocol::WM::get_wm_state ($X, $subwin);
    ok (scalar(@ret), 2);
    ok ($ret[0], 'NormalState');
    ok ($ret[1], 'None');
  }
  {
    local $X->{'do_interp'} = 0;
    my @ret = X11::Protocol::WM::get_wm_state ($X, $subwin);
    ok (scalar(@ret), 2);
    ok ($ret[0], 1);
    ok ($ret[1], 0);
  }

  $X->ChangeProperty($subwin,
                     $X->atom('WM_STATE'),  # property
                     $X->atom('WM_STATE'),  # type
                     32,                    # format
                     'Replace',             # mode
                     pack ('L*', 3, $toplevel));
  {
    my @ret = X11::Protocol::WM::get_wm_state ($X, $subwin);
    ok (scalar(@ret), 2);
    ok ($ret[0], 'IconicState');
    ok ($ret[1], $toplevel);
  }
  {
    local $X->{'do_interp'} = 0;
    my @ret = X11::Protocol::WM::get_wm_state ($X, $subwin);
    ok (scalar(@ret), 2);
    ok ($ret[0], 3);
    ok ($ret[1], $toplevel);
  }

  $X->ChangeProperty($subwin,
                     $X->atom('WM_STATE'),  # property
                     $X->atom('STRING'),    # type
                     8,                     # format
                     'Replace',             # mode
                     'Wrong data type');
  {
    my @ret = X11::Protocol::WM::get_wm_state ($X, $subwin);
    ok (scalar(@ret), 0);
  }

  $X->DeleteProperty($subwin, $X->atom('WM_STATE'));
  {
    my @ret = X11::Protocol::WM::get_wm_state ($X, $subwin);
    ok (scalar(@ret), 0);
  }

  $X->DestroyWindow($subwin);
  $X->DestroyWindow($toplevel);
}


#------------------------------------------------------------------------------
# get_net_frame_extents()

{
  my $target;
  foreach $target ($window, $X->{'root'}) {
    my @ret = X11::Protocol::WM::get_net_frame_extents ($X, $target);
    ok (scalar(@ret) == 0 || scalar(@ret) == 4, 1,
        'get_net_frame_extents() return 0 or 4 values');
    MyTestHelpers::diag ("_NET_FRAME_EXTENTS: ",join(' ',@ret));
  }
}

{
  my $toplevel = $X->new_rsrc;
  $X->CreateWindow($toplevel,
                   $X->root,           # parent
                   'InputOutput',      # class
                   $X->root_depth,     # depth
                   'CopyFromParent',   # visual
                   0,0,                # x,y
                   100,100,            # width,height
                   10,                 # border
                   background_pixel => $X->{'white_pixel'},
                   override_redirect => 1,
                   colormap => 'CopyFromParent',
                  );

  my $subwin = $X->new_rsrc;
  $X->CreateWindow($subwin,
                   $toplevel,           # parent
                   'InputOutput',       # class
                   $X->root_depth,      # depth
                   'CopyFromParent',    # visual
                   0,0,                 # x,y
                   10,10,               # width,height
                   0,                   # border
                   background_pixel => $X->{'black_pixel'},
                   colormap => 'CopyFromParent',
                  );

  $X->ChangeProperty($subwin,
                     $X->atom('_NET_FRAME_EXTENTS'),  # property
                     $X->atom('CARDINAL'),  # type
                     32,                    # format
                     'Replace',             # mode
                     pack ('L*', 11,22,33,44));
  {
    my @ret = X11::Protocol::WM::get_net_frame_extents ($X, $subwin);
    ok (scalar(@ret), 4);
    ok (join(',',@ret), '11,22,33,44');
  }

  $X->ChangeProperty($subwin,
                     $X->atom('_NET_FRAME_EXTENTS'),  # property
                     $X->atom('STRING'),    # type
                     8,                     # format
                     'Replace',             # mode
                     'Wrong data type');
  {
    my @ret = X11::Protocol::WM::get_net_frame_extents ($X, $subwin);
    ok (scalar(@ret), 0);
  }

  $X->DeleteProperty($subwin, $X->atom('_NET_FRAME_EXTENTS'));
  {
    my @ret = X11::Protocol::WM::get_net_frame_extents ($X, $subwin);
    ok (scalar(@ret), 0);
  }

  $X->DestroyWindow($subwin);
  $X->DestroyWindow($toplevel);
}


#------------------------------------------------------------------------------
# set_text_property()

{
  my $name = "hello world";
  X11::Protocol::WM::set_text_property ($X, $window2,
                                        $X->atom('WM_NAME'), $name);

  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window2,
                       $X->atom('WM_NAME'),
                       'AnyPropertyType',
                       0,   # offset
                       100, # length
                       0);  # delete
  ok ($format, 8);
  ok ($type, $X->atom('STRING'));
  my $type_name = ($type ? $X->atom_name($type) : 'None');
  ok ($type_name, 'STRING');
  ok ($value, $name);
  ok ($bytes_after, 0);
}

#------------------------------------------------------------------------------
# set_wm_class()

{
  X11::Protocol::WM::set_wm_class ($X, $window2, "foo", "Foo");

  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window2,
                       $X->atom('WM_CLASS'),
                       'AnyPropertyType',
                       0,   # offset
                       100, # length
                       0);  # delete
  ok ($format, 8);
  ok ($type, $X->atom('STRING'));
  my $type_name = ($type ? $X->atom_name($type) : 'None');
  ok ($type_name, 'STRING');
  ok ($value, "foo\0Foo\0");
  ok ($bytes_after, 0);
}


#------------------------------------------------------------------------------
# set_wm_client_machine()

{
  my $hostname = "mymachine";
  X11::Protocol::WM::set_wm_client_machine ($X, $window2, $hostname);

  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window2,
                       $X->atom('WM_CLIENT_MACHINE'),
                       'AnyPropertyType',
                       0,   # offset
                       100, # length
                       0);  # delete
  ok ($format, 8);
  ok ($type, $X->atom('STRING'));
  my $type_name = ($type ? $X->atom_name($type) : 'None');
  ok ($type_name, 'STRING');
  ok ($value, $hostname);
  ok ($bytes_after, 0);
}
{
  X11::Protocol::WM::set_wm_client_machine_from_syshostname ($X, $window2);

  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window2,
                       $X->atom('WM_CLIENT_MACHINE'),
                       'AnyPropertyType',
                       0,   # offset
                       100, # length
                       0);  # delete
  ok ($format, 8);
  ok ($type, $X->atom('STRING'));
  my $type_name = ($type ? $X->atom_name($type) : 'None');
  ok ($type_name, 'STRING');
  my $want_hostname = eval { Sys::Hostname::hostname() };
  ok ($value, $want_hostname);
  ok ($bytes_after, 0);
}


#------------------------------------------------------------------------------
# set_wm_command()

{
  X11::Protocol::WM::set_wm_command ($X, $window2, "myprog", "myarg");

  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window2,
                       $X->atom('WM_COMMAND'),
                       'AnyPropertyType',
                       0,   # offset
                       100, # length
                       0);  # delete
  ok ($format, 8);
  ok ($type, $X->atom('STRING'));
  my $type_name = ($type ? $X->atom_name($type) : 'None');
  ok ($type_name, 'STRING');
  ok ($value, "myprog\0myarg\0");
  ok ($bytes_after, 0);
}

{
  # with some latin-1 chars
  my $command = "\xF7";
  X11::Protocol::WM::set_wm_command ($X, $window2, $command);

  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window2,
                       $X->atom('WM_COMMAND'),
                       'AnyPropertyType',
                       0,   # offset
                       100, # length
                       0);  # delete
  ok ($format, 8);
  ok ($type, $X->atom('STRING'));
  my $type_name = ($type ? $X->atom_name($type) : 'None');
  ok ($type_name, 'STRING');
  ok (to_hex($value), to_hex("$command\0"));
  ok ($bytes_after, 0);
}


#------------------------------------------------------------------------------
# set_wm_icon_name()

{
  my $icon_name = "hello world";
  X11::Protocol::WM::set_wm_icon_name ($X, $window2, $icon_name);

  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window2,
                       $X->atom('WM_ICON_NAME'),
                       'AnyPropertyType',
                       0,   # offset
                       100, # length
                       0);  # delete
  ok ($format, 8);
  ok ($type, $X->atom('STRING'));
  my $type_name = ($type ? $X->atom_name($type) : 'None');
  ok ($type_name, 'STRING');
  ok ($value, $icon_name);
  ok ($bytes_after, 0);
}


#------------------------------------------------------------------------------
# set_wm_name()

{
  my $name = "hello world";
  X11::Protocol::WM::set_wm_name ($X, $window2, $name);

  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window2,
                       $X->atom('WM_NAME'),
                       'AnyPropertyType',
                       0,   # offset
                       100, # length
                       0);  # delete
  ok ($format, 8);
  ok ($type, $X->atom('STRING'));
  my $type_name = ($type ? $X->atom_name($type) : 'None');
  ok ($type_name, 'STRING');
  ok ($value, $name);
  ok ($bytes_after, 0);
}


#------------------------------------------------------------------------------
# set_wm_protocols()

X11::Protocol::WM::set_wm_protocols ($X, $window2, 'WM_DELETE_WINDOW');
{
  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window2,
                       $X->atom('WM_PROTOCOLS'),
                       'AnyPropertyType',
                       0,  # offset
                       1,  # length, 1 x CARD32
                       0); # delete
  ok ($format, 32);
  ok ($type, $X->atom('ATOM'));
  ok ($X->atom_name($type), 'ATOM');
  ok (length($value), 4);
  my ($value_atom) = unpack 'L', $value;
  ok ($value_atom, $X->atom('WM_DELETE_WINDOW'));
  ok ($X->atom_name($value_atom), 'WM_DELETE_WINDOW');
  ok ($bytes_after, 0);
}

X11::Protocol::WM::set_wm_protocols ($X, $window2,
                                     $X->atom('WM_DELETE_WINDOW'),
                                     'MY_PRIVATE_SOMETHING');
{
  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window2,
                       $X->atom('WM_PROTOCOLS'),
                       'AnyPropertyType',
                       0,  # offset
                       2,  # length, 2 x CARD32
                       0); # delete
  ok ($format, 32);
  ok ($type, $X->atom('ATOM'));
  ok ($X->atom_name($type), 'ATOM');
  ok (length($value), 8);
  my ($value_atom1, $value_atom2) = unpack 'L*', $value;
  ok ($value_atom1, $X->atom('WM_DELETE_WINDOW'));
  ok ($X->atom_name($value_atom1), 'WM_DELETE_WINDOW');
  ok ($value_atom2, $X->atom('MY_PRIVATE_SOMETHING'));
  ok ($X->atom_name($value_atom2), 'MY_PRIVATE_SOMETHING');
  ok ($bytes_after, 0);
}

X11::Protocol::WM::set_wm_protocols ($X, $window2);
{
  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window2,
                       $X->atom('WM_PROTOCOLS'),
                       'AnyPropertyType',
                       0,  # offset
                       2,  # length, 2 x CARD32
                       0); # delete
  ok ($format, 0);
  ok ($type eq 'None' || $type == 0, 1);
}


#------------------------------------------------------------------------------
# set_wm_transient_for()

{
  my $elem;
  foreach $elem ([$window, $window], # a window
                 [0, 0],             # 0==None
                 ['None', 0],        # 0==None
                 [undef, undef],     # delete
                ) {
    my ($transient_for, $want) = @$elem;
    X11::Protocol::WM::set_wm_transient_for ($X, $window2, $transient_for);

    my ($value, $type, $format, $bytes_after)
      = $X->GetProperty ($window2,
                         $X->atom('WM_TRANSIENT_FOR'),
                         'AnyPropertyType',
                         0,  # offset
                         1,  # length, 1 x CARD32
                         0); # delete
    ok ($format, (defined $want ? 32 : 0));
    ok ($type, (defined $want ? $X->atom('WINDOW') : 0));
    my $type_name = ($type ? $X->atom_name($type) : 'None');
    ok ($type_name, (defined $want ? 'WINDOW' : 'None'));
    my ($got) = unpack 'L', $value;
    ok ($got, $want, $window);
    ok ($bytes_after, 0);
  }
}

#------------------------------------------------------------------------------
# get_wm_transient_for()
# ok ($window,
#     X11::Protocol::WM::get_wm_transient_for($X,$window2,$window),
#    'get_wm_transient_for()/set_wm_transient_for()');


#------------------------------------------------------------------------------
# _net_wm_state_num()

{
  my $atom = $X->atom('_NET_WM_STATE_FULLSCREEN');
  X11::Protocol::WM::_net_wm_state_num
      ('FULLSCREEN', $atom,
       '_net_wm_state_num() FULLSCREEN');
  X11::Protocol::WM::_net_wm_state_num
      ('_NET_WM_STATE_FULLSCREEN', $atom,
       '_net_wm_state_num() _NET_WM_STATE_FULLSCREEN');
  X11::Protocol::WM::_net_wm_state_num
      ($atom, $atom,
       '_net_wm_state_num() integer unchanged');

  ok (X11::Protocol::WM::_net_wm_state_interp($X,$atom), 'FULLSCREEN');
  $atom = $X->atom('SOME_BOGOSITY');
  ok (X11::Protocol::WM::_net_wm_state_interp($X,$atom), 'SOME_BOGOSITY');
}

ok (X11::Protocol::WM::_net_wm_state_action_num($X,0), 0);
ok (X11::Protocol::WM::_net_wm_state_action_num($X,1), 1);
ok (X11::Protocol::WM::_net_wm_state_action_num($X,2), 2);
ok (X11::Protocol::WM::_net_wm_state_action_num($X,'remove'), 0);
ok (X11::Protocol::WM::_net_wm_state_action_num($X,'add'),    1);
ok (X11::Protocol::WM::_net_wm_state_action_num($X,'toggle'), 2);

ok (X11::Protocol::WM::_net_wm_source_num($X,0), 0);
ok (X11::Protocol::WM::_net_wm_source_num($X,1), 1);
ok (X11::Protocol::WM::_net_wm_source_num($X,2), 2);
ok (X11::Protocol::WM::_net_wm_source_num($X,'none'),   0);
ok (X11::Protocol::WM::_net_wm_source_num($X,'normal'), 1);
ok (X11::Protocol::WM::_net_wm_source_num($X,'user'),   2);

#------------------------------------------------------------------------------
# set_net_wm_state()

{
  X11::Protocol::WM::set_net_wm_state ($X, $window2, '_NET_WM_STATE_SKIP_PAGER');
  {
    my ($value, $type, $format, $bytes_after)
      = $X->GetProperty ($window2,
                         $X->atom('_NET_WM_STATE'),
                         'AnyPropertyType',
                         0,  # offset
                         1,  # length, 1 x CARD32
                         0); # delete
    ok ($format, 32, 'set_net_wm_state');
    ok ($type, $X->atom('ATOM'));
    my ($got) = unpack 'L*', $value;
    ok ($got, $X->atom('_NET_WM_STATE_SKIP_PAGER'));
    ok ($bytes_after, 0);
  }
  {
    my @ret = X11::Protocol::WM::get_net_wm_state ($X, $window2);
    ok (scalar(@ret), 1);
    ok ($ret[0], 'SKIP_PAGER');
  }
  {
    my @ret = X11::Protocol::WM::get_net_wm_state_atoms ($X, $window2);
    ok (scalar(@ret), 1);
    ok ($ret[0], $X->atom('_NET_WM_STATE_SKIP_PAGER'));
  }
}

{
  X11::Protocol::WM::set_net_wm_state ($X, $window2,
                                       'SKIP_PAGER', 'SKIP_TASKBAR');
  {
    my ($value, $type, $format, $bytes_after)
      = $X->GetProperty ($window2,
                         $X->atom('_NET_WM_STATE'),
                         'AnyPropertyType',
                         0,  # offset
                         2,  # length, 2 x CARD32
                         0); # delete
    ok ($format, 32, 'set_net_wm_state');
    ok ($type, $X->atom('ATOM'));
    ok (length($value), 8);
    my ($got1, $got2) = unpack 'L*', $value;
    ok ($got1, $X->atom('_NET_WM_STATE_SKIP_PAGER'));
    ok ($got2, $X->atom('_NET_WM_STATE_SKIP_TASKBAR'));
    ok ($bytes_after, 0);
  }
  {
    my @ret = X11::Protocol::WM::get_net_wm_state ($X, $window2);
    ok (scalar(@ret), 2);
    ok ($ret[0], 'SKIP_PAGER');
    ok ($ret[1], 'SKIP_TASKBAR');
  }
  {
    my @ret = X11::Protocol::WM::get_net_wm_state_atoms ($X, $window2);
    ok (scalar(@ret), 2);
    ok ($ret[0], $X->atom('_NET_WM_STATE_SKIP_PAGER'));
    ok ($ret[1], $X->atom('_NET_WM_STATE_SKIP_TASKBAR'));
  }
}

#------------------------------------------------------------------------------
# pack_wm_hints()

{
  my $format = 'LLLLLllLL';
  ok (X11::Protocol::WM::pack_wm_hints($X),
      pack($format));

  ok (X11::Protocol::WM::pack_wm_hints ($X,
                                        input => 1),
      pack($format,1,1));

  ok (X11::Protocol::WM::pack_wm_hints ($X,
                                        input => 1,
                                        initial_state => 'IconicState'),
      pack($format,1|2,1,3));

  ok (X11::Protocol::WM::pack_wm_hints ($X,
                                        icon_pixmap => 123,
                                        icon_mask => 456),
      pack($format,4|32,0,0,123,0,0,0,456));

  ok (X11::Protocol::WM::pack_wm_hints ($X,
                                        icon_x  => 123,
                                        icon_y  => 456),
      pack($format,16,0,0,0,0,123,456));

  ok (X11::Protocol::WM::pack_wm_hints ($X,
                                        urgency => 1),
      pack($format,256));
}
{
  my $bytes1 = X11::Protocol::WM::pack_wm_hints
    ($X, initial_state => 'NormalState');
  my $bytes2 = X11::Protocol::WM::pack_wm_hints
    ($X, initial_state => 1);
  ok ($bytes1, $bytes2);
}


#------------------------------------------------------------------------------
# unpack_wm_hints()

{
  my $format = 'LLLLLllLL';
  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,0))),
      '');

  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,1,0))),
      'input,0');
  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,1,123))),
      'input,123');

  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,2,0,1))),
      'initial_state,NormalState');
  { local $X->{'do_interp'} = 0;
    ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,2,0,1))),
        'initial_state,1');
  }

  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,4,0,0,123))),
      'icon_pixmap,123');
  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,4))),
      'icon_pixmap,None');
  { local $X->{'do_interp'} = 0;
    ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,4))),
        'icon_pixmap,0');
  }

  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,8,0,0,0,123))),
      'icon_window,123');
  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,8))),
      'icon_window,None');
  { local $X->{'do_interp'} = 0;
    ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,8))),
        'icon_window,0');
  }

  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,16,0,0,0,0,123,456))),
      'icon_x,123,icon_y,456');

  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,32,0,0,0,0,0,0,123))),
      'icon_mask,123');
  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,32))),
      'icon_mask,None');
  { local $X->{'do_interp'} = 0;
    ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,32))),
        'icon_mask,0');
  }

  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,64,0,0,0,0,0,0,0,123))),
      'window_group,123');
  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,64))),
      'window_group,None');
  { local $X->{'do_interp'} = 0;
    ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,64))),
        'window_group,0');
  }

  # hints from X11R2 only 8 cards with window_group flag but field chopped off
  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack('LLLLLllL',
                                                          64,0,0,0,0,0,0,0))),
      '');

  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,128))),
      'message,1');

  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,256))),
      'urgency,1');

  ok (join(',',X11::Protocol::WM::unpack_wm_hints($X,pack($format,64|256,0,0,0,0,0,0,0,123))),
      'window_group,123,urgency,1');
}

#------------------------------------------------------------------------------
# set_wm_hints() / get_wm_hints() / change_wm_hints()

{
  my $pixmap = $X->new_rsrc;
  $X->CreatePixmap ($pixmap,
                    $X->root,
                    $X->{'root_depth'},
                    16,16);  # width,height

  my $bitmap = $X->new_rsrc;
  $X->CreatePixmap ($bitmap,
                    $X->root,
                    1,       # depth 1 bitmap
                    16,16);  # width,height

  my $icon_window = $X->new_rsrc;
  $X->CreateWindow($icon_window,
                   $X->root,           # parent
                   'InputOutput',      # class
                   $X->root_depth,     # depth
                   'CopyFromParent',   # visual
                   0,0,                # x,y
                   32,32,              # width,height
                   1,                  # border
                   background_pixel => $X->{'black_pixel'},
                   colormap => 'CopyFromParent');
  $X->QueryPointer($X->root);  # sync

  X11::Protocol::WM::set_wm_hints ($X, $window,
                                   input => 1,
                                   initial_state => 'NormalState',
                                   icon_x  => 123,
                                   icon_y  => 456,
                                   urgency => 1);
  ok (join(',',X11::Protocol::WM::get_wm_hints($X,$window)),
      'input,1,initial_state,NormalState,icon_x,123,icon_y,456,urgency,1');

  # individual fields to see others default ...
  X11::Protocol::WM::set_wm_hints ($X, $window, input => 1);
  ok (join(',',X11::Protocol::WM::get_wm_hints($X,$window)),
      'input,1');
  X11::Protocol::WM::set_wm_hints ($X, $window, initial_state => 'IconicState');
  X11::Protocol::WM::set_wm_hints ($X, $window, icon_pixmap => 'None');
  X11::Protocol::WM::set_wm_hints ($X, $window, icon_pixmap => 0);
  ok (join(',',X11::Protocol::WM::get_wm_hints($X,$window)),
      'icon_pixmap,None');
  X11::Protocol::WM::set_wm_hints ($X, $window, icon_pixmap => $pixmap);
  X11::Protocol::WM::set_wm_hints ($X, $window, icon_window => 'None');
  X11::Protocol::WM::set_wm_hints ($X, $window, icon_window => 0);
  X11::Protocol::WM::set_wm_hints ($X, $window, icon_window => $icon_window);
  X11::Protocol::WM::set_wm_hints ($X, $window,
                                   icon_x => 123,
                                   icon_y => 456);
  X11::Protocol::WM::set_wm_hints ($X, $window, icon_mask => 'None');
  X11::Protocol::WM::set_wm_hints ($X, $window, icon_mask => 0);
  X11::Protocol::WM::set_wm_hints ($X, $window, icon_mask => $bitmap);
  X11::Protocol::WM::set_wm_hints ($X, $window, urgency => 1);

  X11::Protocol::WM::set_wm_hints ($X, $icon_window, window_group => 'None');
  X11::Protocol::WM::set_wm_hints ($X, $icon_window, window_group => 0);
  X11::Protocol::WM::set_wm_hints ($X, $icon_window, window_group => $window);

  # change to already set
  X11::Protocol::WM::set_wm_hints    ($X, $window, urgency => 1);
  X11::Protocol::WM::change_wm_hints ($X, $window, urgency => 1);
  ok (join(',',X11::Protocol::WM::get_wm_hints($X,$window)),
      'urgency,1');

  X11::Protocol::WM::change_wm_hints ($X, $window, window_group => $window);
  ok (join(',',X11::Protocol::WM::get_wm_hints($X,$window)),
      "window_group,$window,urgency,1");

  X11::Protocol::WM::change_wm_hints ($X, $window, window_group => undef);
  ok (join(',',X11::Protocol::WM::get_wm_hints($X,$window)),
      'urgency,1');

  X11::Protocol::WM::change_wm_hints ($X, $window,
                                      initial_state => 'IconicState');
  ok (join(',',X11::Protocol::WM::get_wm_hints($X,$window)),
      'initial_state,IconicState,urgency,1');

  X11::Protocol::WM::change_wm_hints ($X, $window,
                                      initial_state => 'NormalState');
  ok (join(',',X11::Protocol::WM::get_wm_hints($X,$window)),
      'initial_state,NormalState,urgency,1');

  $X->FreePixmap($pixmap);
  $X->FreePixmap($bitmap);
  $X->DestroyWindow($icon_window);
  $X->QueryPointer($X->root);  # sync
}


#------------------------------------------------------------------------------
# set_net_wm_pid()

X11::Protocol::WM::set_net_wm_pid ($X, $window2);
{
  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window2,
                       $X->atom('_NET_WM_PID'),
                       'AnyPropertyType',
                       0,  # offset
                       1,  # length, 1 x CARD32
                       0); # delete
  ok ($format, 32);
  ok ($type, $X->atom('CARDINAL'));
  ok ($X->atom_name($type), 'CARDINAL');
  ok (length($value), 4);
  my ($pid) = unpack 'L', $value;
  ok ($pid, $$);
  ok ($bytes_after, 0);
}

X11::Protocol::WM::set_net_wm_pid ($X, $window2, 123);
{
  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window2,
                       $X->atom('_NET_WM_PID'),
                       'AnyPropertyType',
                       0,  # offset
                       1,  # length, 1 x CARD32
                       0); # delete
  ok ($format, 32);
  ok ($type, $X->atom('CARDINAL'));
  ok ($X->atom_name($type), 'CARDINAL');
  ok (length($value), 4);
  my ($pid) = unpack 'L', $value;
  ok ($pid, 123);
  ok ($bytes_after, 0);
}

X11::Protocol::WM::set_net_wm_pid ($X, $window2, undef);
{
  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window2,
                       $X->atom('_NET_WM_PID'),
                       'AnyPropertyType',
                       0,  # offset
                       1,  # length, 1 x CARD32
                       0); # delete
  ok ($format, 0);
  ok ($type eq 'None' || $type == 0, 1);
}

#------------------------------------------------------------------------------
# set_net_wm_user_time()

X11::Protocol::WM::set_net_wm_user_time ($X, $window, 123);
{
  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window,
                       $X->atom('_NET_WM_USER_TIME'),
                       'AnyPropertyType',
                       0,  # offset
                       1,  # length, 1 x CARD32
                       0); # delete
  ok ($format, 32);
  ok ($type, $X->atom('CARDINAL'));
  ok ($X->atom_name($type), 'CARDINAL');
  ok (length($value), 4);
  my ($time) = unpack 'L', $value;
  ok ($time, 123);
  ok ($bytes_after, 0);
}

#------------------------------------------------------------------------------
# set_net_wm_window_type()

X11::Protocol::WM::set_net_wm_window_type ($X, $window, 'NORMAL');
{
  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window,
                       $X->atom('_NET_WM_WINDOW_TYPE'),
                       'AnyPropertyType',
                       0,  # offset
                       1,  # length, 1 x CARD32
                       0); # delete
  ok ($format, 32);
  ok ($type, $X->atom('ATOM'));
  ok ($X->atom_name($type), 'ATOM');
  ok (length($value), 4);
  my ($value_atom) = unpack 'L', $value;
  ok ($value_atom, $X->atom('_NET_WM_WINDOW_TYPE_NORMAL'));
  ok ($X->atom_name($value_atom), '_NET_WM_WINDOW_TYPE_NORMAL');
  ok ($bytes_after, 0);
}

#------------------------------------------------------------------------------
# get_net_wm_window_type()
# {
#   my $atom_name = $X->atom_name($atom);
#   ok ($atom_name, '_NET_WM_WINDOW_TYPE_NORMAL', 'set_net_wm_window_type');
# 
#   # my $atom = X11::Protocol::WM::_get_net_wm_window_type_atom ($X, $window);
# }

#------------------------------------------------------------------------------
# frame_window_to_client()

{
  my ($root_root, $root_parent, @toplevels) = $X->QueryTree ($X->root);
  my $window;
  my $count_found = 0;
  foreach $window (@toplevels) {
    my $client_window = X11::Protocol::WM::frame_window_to_client($X,$window);
    $count_found += (defined $client_window);
  }
  MyTestHelpers::diag ("frame_window_to_client() found $count_found clients out of ",scalar(@toplevels)," toplevels");
}


#------------------------------------------------------------------------------
# iconify() and withdraw() transitions

{
  my $toplevel = $X->new_rsrc;
  $X->CreateWindow($toplevel,
                   $X->root,           # parent
                   'InputOutput',      # class
                   $X->root_depth,     # depth
                   'CopyFromParent',   # visual
                   0,0,                # x,y
                   100,100,            # width,height
                   10,                 # border
                   background_pixel => $X->{'white_pixel'},
                   event_mask       => $X->pack_event_mask('PropertyChange'));
  $X->MapWindow($toplevel);
  $X->atom_name($X->atom('WM_STATE'));

  my $skip;

  # The tests hare are all skipped because don't want to rely on window
  # manager behaviour.  Some wms don't seem to have a proper withdraw, and
  # several by design don't have an IconicState.
  #
  # Window managers without IconicState include: dwm, evilwm, i3, sapphire,
  # subtle, wmii, xmonad.
  #
  # tritium uses python-plwm and python-plwm (as of its cvs circa 2008) may
  # have some dodginess too in its deiconify() where it leaves WM_STATE
  # saying IconicState even though it has in fact restored the window to
  # normal.
  #
  $skip = 'due to not rely on window manager behaviour';

  my $wm_state;
  unless ($skip) {
    $wm_state = wait_for_wm_state($X,$toplevel);
    if (! $wm_state) {
      $skip = 'due to no window manager running, it seems';
    }
  }
  skip ($skip, $wm_state, 'NormalState');

  {
    X11::Protocol::WM::iconify($X,$toplevel);
    unless ($skip) { $wm_state = wait_for_wm_state($X,$toplevel); }
    skip ($skip, $wm_state, 'IconicState');
  }
  {
    X11::Protocol::WM::withdraw($X,$toplevel);
    unless ($skip) { $wm_state = wait_for_wm_state($X,$toplevel); }
    my $is_withdrawn = (! defined $wm_state || $wm_state eq 'WithdrawnState');
    skip ($skip, $is_withdrawn, 1, 'withdrawn');
    if (! $is_withdrawn) {
      MyTestHelpers::diag ("after withdraw() wm_state is: ", $wm_state);
    }
  }
  {
    $X->MapWindow($toplevel);
    unless ($skip) { $wm_state = wait_for_wm_state($X,$toplevel); }
    skip ($skip, $wm_state, 'NormalState');
  }
  { X11::Protocol::WM::withdraw($X,$toplevel);
    unless ($skip) { $wm_state = wait_for_wm_state($X,$toplevel); }
    my $is_withdrawn = (! defined $wm_state || $wm_state eq 'WithdrawnState');
    skip ($skip, $is_withdrawn, 1, 'withdrawn again');
  }

  $X->DestroyWindow($toplevel);
  $X->QueryPointer($X->root);  # sync
}

sub wait_for_wm_state {
  my ($X, $window) = @_;
  $X->flush;
  my $WM_STATE = $X->atom('WM_STATE');
  my $found = 0;
  local $X->{'event_handler'} = sub {
    my (%h) = @_;
    ### event_handler: \%h
    # MyTestHelpers::diag ("event ", $h{'name'},
    #                      ' ',$h{'window'},
    #                      ' ',$h{'atom'},
    #                      '=', $h{'atom'} && $X->{'atom_names'}->[$h{'atom'}]);
    if ($h{'name'} eq 'PropertyNotify'
        && $h{'window'} == $window
        && $h{'atom'} == $WM_STATE) {
      $found = 1;
    }
  };
  foreach (1 .. 4) {  # attempts
    if (wait_for_readable ($X->{'connection'}->fh)) {
      ### X handle_input ...
      while (fh_readable ($X->{'connection'}->fh)) {
        $X->handle_input;
      }
    }
    if ($found) {
      my ($wm_state, $icon_window)
        = X11::Protocol::WM::get_wm_state ($X, $window);
      return $wm_state;
    }
  }
  return 'timeout waiting for WM_STATE change';
}

sub wait_for_readable {
  my ($fh) = @_;
  my $read_bits = '';
  vec($read_bits,fileno($fh),1) = 1;
  my $err_bits = $read_bits;

  my ($nfound, $timeleft) = select($read_bits, '', $err_bits,
                                   1); # 1 second timeout
  return $nfound;
}

sub fh_readable {
  my ($fh) = @_;
  require IO::Select;
  my $s = IO::Select->new;
  $s->add($fh);
  my @ready = $s->can_read(1);
  return scalar(@ready);
}

#------------------------------------------------------------------------------
$X->QueryPointer($X->{'root'});  # sync

exit 0;
