File Coverage

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

Criterion	Covered	Total	%
statement	16	52	30.7
branch	0	6	0.0
condition	0	3	0.0
subroutine	6	14	42.8
pod	0	1	0.0
total	22	76	28.9

# 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-damage-dev/damageproto.txt.gz
#     http://cgit.freedesktop.org/xorg/proto/damageproto/tree/damageproto.txt
#
# /usr/include/X11/extensions/Xdamage.h
# /usr/include/X11/extensions/damageproto.h
# /usr/include/X11/extensions/damagewire.h
#
# server side source:
#     http://cgit.freedesktop.org/xorg/xserver/tree/damageext/damageext.c
#


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

use vars '$VERSION', '@CARP_NOT';
$VERSION = 31;
@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 => 1;

my $reqs
  = [
     #------------
     # version 1.0

     ["DamageQueryVersion",  # 0
      sub {
        my ($X, $major, $minor) = @_;
        ### DamageQueryVersion request
        return pack 'LL', $major, $minor;
      },
      sub {
        my ($X, $data) = @_;
        ### DamageQueryVersion reply
        my @ret = unpack 'x8LL', $data;

        # Any interest in holding onto the version?
        # Remove DamageAdd if downgrading?
        my $self;
        if ($self = $X->{'ext'}->{'DAMAGE'}->[3]) {
          ($self->{'major'}, $self->{'minor'}) = @ret;
        }
        return @ret;
      }],

     ["DamageCreate",  # 1
      sub {
        my ($X, $damage, $drawable, $level) = @_;
        ### DamageCreate
        return pack ('LLCxxx',
                     $damage,
                     $drawable,
                     $X->num('DamageReportLevel',$level));
      }],

     ["DamageDestroy",   # 2
      \&_request_xids ], # ($damage)

     ["DamageSubtract",  # 3
      \&_request_xids ], # ($damage, $repair_region, $parts_region)

     #------------
     # version 1.1

     ["DamageAdd",       # 4
      \&_request_xids ], # ($damage, $region)
    ];

my $DamageNotify_event
  = [ sub {
        my $X = shift;
        my $data = shift;
        ### DamageNotify unpack: @_[1..$#_]
        my ($level, $drawable, $damage, $time, $area, $geometry)
          = unpack 'xCxxL3a8a8', $data;
        ### fields: $level, $drawable, $damage, $time, $area, $geometry
        ### area: _unpack_rectangle($area)
        ### geometry: _unpack_rectangle($geometry)
        my $more = ($level >> 7) & 1;  # bit 0x80
        $level &= 0x7F;
        return (@_,  # base fields
                drawable => $drawable,
                damage   => $damage,
                level    => $X->interp('DamageReportLevel',$level),
                more     => $more,
                time     => _interp_time($time),
                area     => _unpack_rectangle($area),
                geometry => _unpack_rectangle($geometry),
               );
      }, sub {
        my ($X, %h) = @_;
        my $level = ($X->num('DamageReportLevel', $h{'level'})
                     + ($h{'more'} ? 0x80 : 0));
        return (pack('xCxxL3ssSSssSS',
                     $level,
                     $h{'drawable'},
                     $h{'damage'},
                     _num_time($h{'time'}),
                     @{$h{'area'}},      # [$x,$y,$w,$h]
                     @{$h{'geometry'}}), # [$x,$y,$w,$h]
                1); # "do_seq" put in sequence number
      } ];

my $DamageReportLevel_array = [ 'RawRectangles',
                                'DeltaRectangles',
                                'BoundingBox',
                                'NonEmpty' ];
my $DamageReportLevel_hash
  = { X11::Protocol::make_num_hash($DamageReportLevel_array) };

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

  # Constants
  $X->{'ext_const'}->{'DamageReportLevel'} = $DamageReportLevel_array;
  $X->{'ext_const_num'}->{'DamageReportLevel'} = $DamageReportLevel_hash;

  # Errors
  $X->{'ext_const'}->{'Error'}->[$error_num] = 'Damage';
  $X->{'ext_const_num'}->{'Error'}->{'Damage'} = $error_num;
  $X->{'ext_error_type'}->[$error_num] = 1; # bad resource

  # Events
  $X->{'ext_const'}->{'Events'}->[$event_num] = 'DamageNotify';
  $X->{'ext_events'}->[$event_num] = $DamageNotify_event;

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

  # Must DamageQueryVersion to negotiate desired version, or at least X.org
  # server 1.9.x gives "Opcode" errors to all other requests if not.
  my ($major, $minor) = $X->req ('DamageQueryVersion',
                                 CLIENT_MAJOR_VERSION,
                                 CLIENT_MINOR_VERSION);
  return bless { major => $major,
                 minor => $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_xids {
  my $X = shift;
  ### _request_xids(): @_
  return _request_card32s ($X, map {_num_none($_)} @_);
}
sub _request_card32s {
  shift;
  ### _request_card32s(): @_
  return pack 'L*', @_;
}
sub _num_none {
  my ($xid) = @_;
  if (defined $xid && $xid eq 'None') {
    return 0;
  } else {
    return $xid;
  }
}

sub _unpack_rectangle {
  my ($data) = @_;
  return [ unpack 'ssSS', $data ];
}

sub _interp_time {
  my ($time) = @_;
  if ($time == 0) {
    return 'CurrentTime';
  } else {
    return $time;
  }
}
sub _num_time {
  my ($time) = @_;
  if ($time eq 'CurrentTime') {
    return 0;
  } else {
    return $time;
  }
}

1;
__END__