File Coverage

blib/lib/X11/Protocol/Ext/X_Resource.pm

Criterion	Covered	Total	%
statement	16	29	55.1
branch	0	2	0.0
condition			n/a
subroutine	6	10	60.0
pod	0	1	0.0
total	22	42	52.3

# Copyright 2011, 2012, 2013, 2014, 2017 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 .

BEGIN { require 5 }
package X11::Protocol::Ext::X_Resource;
use strict;
use Carp;

use vars '$VERSION';
$VERSION = 30;

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

# /usr/include/X11/extensions/XResproto.h
#     protocol
#
# http://cgit.freedesktop.org/xorg/xserver/tree/Xext/xres.c
# http://cgit.freedesktop.org/xorg/xserver/plain/Xext/xres.c
#     server side source
#
# /usr/include/X11/extensions/XRes.h
#     Xlib.
#

### X_Resource.pm loads

# these not documented yet ...
use constant CLIENT_MAJOR_VERSION => 1;
use constant CLIENT_MINOR_VERSION => 0;

#------------------------------------------------------------------------------

my $reqs =
  [
   ["XResourceQueryVersion",  # 0
    sub {
      ### XResourceQueryVersion request
      shift;  # $X
      return pack 'CCxx', @_;   # ($client_major, $client_minor)
    },
    sub {
      my ($X, $data) = @_;
      return unpack 'x8SS', $data;   # ($server_major, $server_minor)
    }],

   ["XResourceQueryClients",  # 1
    \&_request_empty,
    sub {
      my ($X, $data) = @_;
      ### XResourceQueryClients reply
      my $num = unpack 'x8L', $data;
      ### $num
      # obey $num rather than the reply length
      # Other way to do it: List::Pairwise::pair(unpack 'x32L'.(2*$num))
      return map {[ unpack 'LL', substr($data,32+$_*8,8) ]} 0 .. $num-1;
    } ],

   ["XResourceQueryClientResources",  # 2
    \&_request_card32s,  # ($X, $client_xid)
    sub {
      my ($X, $data) = @_;
      ### XResourceQueryClientResources reply
      my ($num) = unpack 'x8L', $data;
      ### $num
      # obey $num rather than the reply length
      return unpack 'x32L'.(2*$num), $data;
    }],

   ["XResourceQueryClientPixmapBytes",  # 3
    \&_request_card32s,  # ($X, $client_xid)
    do {
      # see if 2^64-1 survives an sprintf %d, if so then 64-bit UV integers
      my $v = ((0xFFFFFFFF * (2.0**32)) + 0xFFFFFFFF);
      ($v == sprintf("%u",$v))
    }
    ? sub {
      my ($X, $data) = @_;
      ### XResourceQueryClientPixmapBytes reply, 64-bit system
      my ($lo, $hi) = unpack('x8LL', $data);
      return $lo + ($hi << 32);
    }
    : do {
      # probe for where floating point loses precision
      # if $hi<$hi_limit then $hi*2**32 + $lo is exact
      my $hi_limit = 1;
      foreach (1 .. 32) {
        my $float = $hi_limit * (2.0**32);
        my $plus1 = $float+1;
        my $plus2 = $float+2;
        if (! ($plus1 > $float && $plus1 < $plus2)) {
          last;
        }
        $hi_limit *= 2.0;
      }
      ### $hi_limit
      ### hex: sprintf "%X", $hi_limit
      sub {
        my ($X, $data) = @_;
        ### XResourceQueryClientPixmapBytes reply, 32-bit system
        my ($lo, $hi) = unpack('x8LL', $data);
        ### $lo
        ### $hi
        ### hex lo: sprintf "%X", $lo
        ### hex hi: sprintf "%X", $hi
        if ($hi == 0) {
          return $lo;
        } elsif ($hi < $hi_limit) {
          return $lo + $hi * (2 ** 32);
        } else {
          require Math::BigInt;
          return (Math::BigInt->new($hi) << 32) + $lo;
        }
      }
    } ],


   # #----------------------
   # # protocol 1.2
   #
   # # mask bits ...
   # # ClientXIDMask      0x01
   # # LocalClientPIDMask 0x02
   # # xid_or_pid 'None'
   # ["XResourceQueryClientIds",  # 4
   #  sub {
   #    my $X = shift;  # ($X, $xid_or_pid, $mask, ...)
   #    return pack 'L*',
   #      scalar(@_)/2, # num specs
   #        @_;
   #  },
   #  sub {
   #    my ($X, $data) = @_;
   #    ### XResourceQueryClientResources reply
   #    my ($num) = unpack 'x8L', $data;
   #    ### $num
   #    my $pos = 32;
   #    my @ret;
   #    # obey $num rather than the reply length
   #    for (1 .. $num) {
   #      my @elem = unpack 'L3', substr($data,$pos,12);
   #      my ($client_xid, $mask, $length) = unpack 'L3', substr($data,$pos,12);
   #      $pos += 12;
   #      my $length = 4 * pop @elem;
   #      push @elem, unpack 'L*', substr($data,$pos,$length);
   #      $pos += $length;
   #      push @ret, \@elem;
   #    }
   #    return @ret;
   #  }],
   #
   # ["XResourceQueryResourceBytes",  # 5
   #  sub {
   #    my $X = shift;  # ($X, $client_xid, $resource,$type, ...)
   #    my $client_xid = shift;
   #    return pack 'L*',
   #      $client_xid,
   #        scalar(@_)/2, # num specs
   #          @_;
   #  },
   #  sub {
   #    my ($X, $data) = @_;
   #    ### XResourceQueryClientResources reply
   #    my ($num) = unpack 'x8L', $data;
   #    ### $num
   #    my $pos = 32;
   #    my @ret;
   #    # obey $num rather than the reply length
   #    for (1 .. $num) {
   #      my @elem = unpack 'L6', # $resource,$type,$bytes,$refcount,$usecount
   #        substr($data,$pos,24);
   #      $pos += 24;
   #      my $length = 20 * pop @elem;
   #      push @elem, unpack 'L*', substr($data,$pos,$length);
   #      $pos += $length;
   #      push @ret, \@elem;
   #    }
   #    return @ret;
   #  }],

  ];

sub _request_empty {
  if (@_ > 1) {
    croak "No parameters in this request";
  }
  return '';
}
sub _request_card32s {
  shift;
  ### _request_card32s(): @_
  return pack 'L*', @_;
}


#------------------------------------------------------------------------------

sub new {
  my ($class, $X, $request_num, $event_num, $error_num) = @_;
  ### X_Resource new()

  $X->{'ext_request'}{$request_num} = $reqs;
  _ext_request_num_fill ($X, $request_num, $reqs);

  # Any need to query/negotiate the protocol version first?
  # Xlib XRes.c doesn't seem to.
  # my ($server_major, $server_minor) = $X->req('XResourceQueryVersion',
  #                                              CLIENT_MAJOR_VERSION,
  #                                              CLIENT_MINOR_VERSION);
  return bless {
                # major => $server_major,
                # minor => $server_minor,
               }, $class;
}

sub _ext_request_num_fill {
  my ($X, $request_num, $reqs) = @_;
  my $i;
  foreach $i (0 .. $#$reqs) {
    $X->{'ext_request_num'}{$reqs->[$i]->[0]} = [$request_num, $i];
  }
}

1;
__END__