#!/usr/bin/perl -w

# Copyright 2011, 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/>.

use strict;
use X11::Protocol;
use vars '%Keysyms';
use X11::Keysyms '%Keysyms', 'MISCELLANY';

use lib 'devel', '.';
use X11::Protocol::Ext::X_Resource;

# uncomment this to run the ### lines
use Smart::Comments;


{
  # various prints

  my $display = $ENV{'DISPLAY'} || ':0';
  $display = ':1';
  my $X0 = X11::Protocol->new ($display);
  ### resource_id_base: sprintf '%X', $X0->resource_id_base

  my $X = X11::Protocol->new ($display);
  ### resource_id_base: sprintf '%X', $X->resource_id_base

  { my @query = $X->QueryExtension('X-Resource');
    ### @query
  }
  $X->QueryPointer($X->root); # sync

  $X->init_extension('X-Resource') or die $@;
  $X->QueryPointer($X->root); # sync

  { my @version = $X->XResourceQueryVersion (99,99);
    ### @version
  }
  $X->QueryPointer($X->root); # sync

  my @clients = $X->XResourceQueryClients;
  ### @clients
  foreach (@clients) {
    printf "%X %X\n", @$_;
  }
  $X->QueryPointer($X->root); # sync

  {
    # = $Keysyms{'Zenkaku'};
    my $keycode = $X->max_keycode - 2;
    my $modifiers = 0;
    $X->GrabKey ($keycode, $modifiers, $X->root,
                 0, # owner
                 'Asynchronous', 'Asynchronous');
  }
  {
    # = $Keysyms{'Hankaku'};
    my $keycode = $X->max_keycode - 1;
    my $modifiers = 0;
    $X->GrabKey ($keycode, $modifiers, $X->root,
                 0, # owner
                 'Asynchronous', 'Asynchronous');
  }

  my $pixmap;
  foreach (1 .. 1) {
    $pixmap = $X->new_rsrc;
    $X->CreatePixmap ($pixmap,
                      $X->root,
                      $X->{'root_depth'},
                      1000,1000);  # width,height
    # 32767,32767);  # width,height
  }
  $X->QueryPointer($X->root); # sync

  { my @res = $X->XResourceQueryClientResources ($X->resource_id_base);
    ### @res
    { my %res = @res;
      atom_names ($X, values(%res)); }
    while (@res) {
      my $atom = shift @res;
      my $count = shift @res;
      printf "%s (atom %d)   %d\n", atom_name_maybe($X,$atom), $atom, $count;
    }
  }

  require Number::Format;
  my $nf = Number::Format->new;

  foreach my $client (@clients) {
    printf "\nclient %X %X\n", $client->[0], $client->[1];
    my $xid =  $client->[0] + $client->[1];
    my @res = $X->XResourceQueryClientResources ($xid);
    while (@res) {
      my $atom = shift @res;
      my $count = shift @res;
      printf "%s (atom %d)   %d\n", atom_name_maybe($X,$atom), $atom, $count;
    }
    my $bytes = $X->XResourceQueryClientPixmapBytes ($xid);
    my $nbytes = $nf->format_number($bytes);
    print "PixmapBytes $nbytes   $bytes\n";
  }

  exit 0;
}

{
  my $display = $ENV{'DISPLAY'} || ':0';
  my $X = X11::Protocol->new ($display);
  $X->init_extension('X-Resource') or die $@;

  my $pixmap;
  foreach (1 .. 1) {
    $pixmap = $X->new_rsrc;
    $X->CreatePixmap ($pixmap,
                      $X->root,
                      8,
                      1000,1000);  # width,height
  }

  my $bytes = $X->XResourceQueryClientPixmapBytes ($pixmap);
  print "PixmapBytes $bytes\n";
  exit 0;
}

{
  $ENV{'DISPLAY'} ||= ':0';
  my $X = X11::Protocol->new;
  $X->init_extension('X-Resource') or die $@;
  my $clients = [ $X->XResourceQueryClients ];
  ### $clients
  my $xid = $clients->[2]->[0] + 123;
  my $base = clients_xid_to_base ($clients, $xid);
  ### $xid
  ### $base

  sub clients_xid_to_base {
    my ($clients, $xid) = @_;
    my $elem;
    foreach $elem (@$clients) {
      if (($xid & ~ $elem->[1]) == $elem->[0]) {
        return $elem->[0];
      }
    }
    return undef;
  }
  exit 0;
}

{
  my $X = X11::Protocol->new (':0');
  require X11::AtomConstants;
  my @names = atom_names ($X,
                          X11::AtomConstants::WINDOW(),
                          X11::AtomConstants::PIXMAP(),
                         );
  ### @names

  @names = atom_names ($X,
                       X11::AtomConstants::WINDOW(),
                       X11::AtomConstants::COLORMAP(),
                       X11::AtomConstants::PIXMAP(),
                       X11::AtomConstants::FONT(),
                      );
  ### @names

  exit 0;
}

{
  my $data;
  my $result = unpack 'xL', $data;
  ### $data
  exit 0;
}

{
  my $X = X11::Protocol->new (':0');
  $X->{'error_handler'}  = sub {
    my ($X, $data) = @_;
    ### error handler: $data
    return;
  };
  $X->QueryPointer(999999);
  ### exit
  exit 0;
}

{
  my $v = ((0xFFFFFFFF * (2.0**32)) + 0xFFFFFFFF);
  require Devel::Peek;
  Devel::Peek::Dump ($v);
  ### sp: sprintf "%u", $v
  my $bit = ($v & 1);
  ### $bit
  my $test = ($v & 1) == 1;
  ### $test
  exit 0;
}

sub atom_names {
  my $X = shift;
  my @ret;
  my @atom;
  my @seq;
  my @data;
  for (;;) {
    while (@_ && @seq < 100) {  # max 100 sliding window
      my $atom = shift;
      push @atom, $atom;
      my $seq;
      my $name = $X->{'atom_names'}->[$atom];
      if (defined $name) {
        push @data, $name;
      } else {
        $seq = $X->send('GetAtomName',$atom);
        ### send: $seq
        push @data, undef;
        $X->add_reply ($seq, \($data[-1]));
      }
      push @seq, $seq;
    }

    @seq || last;
    my $seq = shift @seq;
    my $atom = shift @atom;
    my $name;
    if (defined $seq) {
      ### handle_input_for: $seq
      $X->handle_input_for ($seq);
      $X->delete_reply($seq);
      $name = $X->unpack_reply ('GetAtomName', shift @data);
      ### $name
      $X->{'atom_names'}->[$atom] = $name;
    } else {
      $name = shift @data;
    }
    push @ret, $name;
  }
  return @ret;
}

sub atom_name_maybe {
  my ($X, $atom) = @_;
  my $ret = $X->robust_req ('GetAtomName', $atom);
  if (ref $ret) {
    return @$ret;
  }
  return '[not-atom]';
}