File Coverage

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

Criterion	Covered	Total	%
statement	19	40	47.5
branch	0	4	0.0
condition	0	3	0.0
subroutine	7	12	58.3
pod	0	1	0.0
total	26	60	43.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 .


# /usr/share/doc/x11proto-xext-dev/dbe.txt.gz
# /usr/share/doc/x11proto-core-dev/x11protocol.txt.gz
# /usr/include/X11/extensions/dbe.h
# /usr/include/X11/extensions/dbeproto.h
#    Protocol.
#
# /usr/share/doc/libxext-dev/dbelib.txt.gz
# /so/xfree/xfree86-3.3.2.3a/lib/Xext/Xdbe.c
#    Xlib.
#
# /so/xfree/xfree86-3.3.2.3a/programs/Xserver/dbe/dbe.c
# /so/xorg/xorg-server-1.10.0/dbe/dbe.c
#    Server.


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

use vars '$VERSION', '@CARP_NOT';
$VERSION = 30;
@CARP_NOT = ('X11::Protocol');

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


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

my $reqs =
  [
   [ 'DbeGetVersion',  # 0
     sub {
       my ($X, $client_major, $client_minor) = @_;
       ### DbeGetVersion request
       return pack 'CCxx', $client_major, $client_minor;
     },
     sub {
       my ($X, $data) = @_;
       return unpack 'x8CC', $data;
     }],

   [ 'DbeAllocateBackBufferName',  # 1
     sub {
       my ($X, $window, $buffer, $action_hint) = @_;
       ### DbeAllocateBackBufferName request
       return pack 'LLCxxx',
         $window, $buffer, $X->num('DbeSwapAction',$action_hint);
     } ],

   [ 'DbeDeallocateBackBufferName',  # 2
     \&_request_card32s ],  # ($X,$buffer)

   [ 'DbeSwapBuffers',  # 3
     sub {
       my $X = shift;   # ($X, $window,$action, $window,$action, ...)
       my $ret = pack 'L', scalar(@_)/2;  # number of pairs
       while (@_) {
         $ret .= pack 'LCxxx', shift, $X->num('DbeSwapAction',shift);
       }
       return $ret;
     }],

   [ 'DbeBeginIdiom',     # 4
     \&_request_empty ],
   [ 'DbeEndIdiom',       # 5
     \&_request_empty ],

   [ 'DbeGetVisualInfo',  # 6
     sub {
       ### DbeGetVisualInfo request ...
       my $X = shift;   # ($X, $window, $window, ...)
       ### num_windows: scalar(@_)
       ### windows: @_
       return pack 'L*', scalar(@_), @_; # (num_windows, window, window, ...)
     },
     sub {
       my ($X, $data) = @_;
       ### DbeGetVisualInfo reply ...

       my $num_screens = unpack 'x8L', $data;
       ### $num_screens

       my $pos = 32;
       # Maybe should return single aref in scalar context.
       # The map{} ends up giving a count in scalar context (or does it?).
       return map {
         my $num_visuals = unpack 'L', substr($data,$pos,4);
         $pos += 4;
         [ map { my ($visual_id, $depth, $performance)
                   =  unpack 'LCC', substr($data,($pos+=8)-8,6);
                 $visual_id => [ $depth, $performance ] }
           1 .. $num_visuals ]
       } 1 .. $num_screens;
     }],

   [ 'DbeGetBackBufferAttributes',  # 7
     \&_request_card32s,   # ($X,$buffer)
     sub {
       my ($X, $data) = @_;
       return _interp_none($X, unpack('x8L',$data));
     }],

  ];

my $DbeSwapAction_array = ['Undefined', 'Background', 'Untouched', 'Copied'];
my $DbeSwapAction_hash
  = { X11::Protocol::make_num_hash($DbeSwapAction_array) };

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

  # Constants
  $X->{'ext_const'}->{'DbeSwapAction'} = $DbeSwapAction_array;
  $X->{'ext_const_num'}->{'DbeSwapAction'} = $DbeSwapAction_hash;

  _ext_requests_install ($X, $request_num, $reqs);

  # Protocol spec says must negotiate version or the extension may or may
  # not work.
  my ($server_major, $server_minor) = $X->req('DbeGetVersion', 1, 0);
  ### $server_major
  ### $server_minor
  return bless { major => $server_major,
                 minor => $server_minor,
               }, $class;
}

sub _ext_requests_install {
  my ($X, $request_num, $reqs) = @_;

  $X->{'ext_request'}->{$request_num} = $reqs;
  my $href = $X->{'ext_request_num'};
  my $i;
  foreach $i (0 .. $#$reqs) {
    $href->{$reqs->[$i]->[0]} = [$request_num, $i];
  }
}

sub _request_empty {
  if (@_ > 1) {
    croak "No parameters in this request";
  }
  return '';
}

sub _request_card32s {
  shift;
  ### _request_card32s(): @_
  return pack 'L*', @_;
}

sub _interp_none {
  my ($X, $xid) = @_;
  if ($X->{'do_interp'} && $xid == 0) {
    return 'None';
  } else {
    return $xid;
  }
}

1;
__END__