X11::Protocol::Ext::SHAPE - Perl module for the X11 Protocol Nonrectangular Window Shape Extension

  use X11::Protocol;
  $x = X11::Protocol->new($ENV{'DISPLAY'});
  $x->init_extension('SHAPE') or die;

  $x->ShapeQueryVersion
  =>
  ($major, $minor)

  $x->ShapeRectangles($dest, $destKind, $op, $xOff, $yOff,
		      $ordering, @rectangles) 

  $x->ShapeMask($dest, $destKind, $op, $xOff, $yOff, $source)

  $x->ShapeCombine($dest, $destKind, $op, $xOff, $yOff, $source,
		   $sourceKind)

  $x->ShapeOffset($dest, $destKind, $xOff, $yOff)

  $x->ShapeQueryExtents($dest)
  =>
  ($boundingShaped, $clipShaped,
   ($xBoundingShape, $yBoundingShape,
    $widthBoundingShape, $heightBoundingShape)  
   ($xClipShape, $yClipShape, $widthClipShape, $heightClipShape))

  $x->ShapeSelectInput($window, $enable)  

  $x->ShapeInputSelected($window)
  =>
  $enable

  $x->ShapeGetRectangles($window, $kind)
  =>
  ($ordering, [$x, $y, $width, $height], ...)

#!/usr/bin/perl

# The `X11 Nonrectangular Window Shape Extension'
package X11::Protocol::Ext::SHAPE; 

# Copyright (C) 1997 Stephen McCamant. All rights reserved. This program
# is free software; you can redistribute and/or modify it under the same
# terms as Perl itself.

use X11::Protocol qw(pad padding padded make_num_hash);
use Carp;

use strict;
use vars '$VERSION';

$VERSION = 0.01;

sub new
{
    my($pkg, $x, $request_num, $event_num, $error_num) = @_;
    my($self) = {};

    # Constants

    $x->{'ext_const'}{'ShapeKind'} = ['Bounding', 'Clip'];
    $x->{'ext_const_num'}{'ShapeKind'} =
      {make_num_hash($x->{'ext_const'}{'ShapeKind'})};

    $x->{'ext_const'}{'ShapeOp'} = ['Set', 'Union', 'Intersect', 'Subtract',
				    'Invert'];
    $x->{'ext_const_num'}{'ShapeOp'} =
      {make_num_hash($x->{'ext_const'}{'ShapeOp'})};

    # Events
    $x->{'ext_const'}{'Events'}[$event_num] = "ShapeNotify";
    $x->{'ext_events'}[$event_num] =
      ["xCxxLssSSLCxxxxxxxxxxx", ['shape_kind', 'ShapeKind'], 'x', 'y',
       'width', 'height', 'time', 'shaped'];

    # Requests
    $x->{'ext_request'}{$request_num} = 
      [
       ["ShapeQueryVersion", sub {
	    my($self) = shift;
	    return "";
	}, sub {
	    my($self) = shift;
	    my($data) = @_;
	    my($major, $minor) = unpack("xxxxxxxxSSxxxxxxxxxxxxxxxxxxxx",
					$data);
	    return ($major, $minor);
	}],
       ["ShapeRectangles", sub {
	    my($self) = shift;
	    my($dest, $kind, $op, $x, $y, $ordering, @rects) = @_;
	    $op = $self->num('ShapeOp', $op);
	    $kind = $self->num('ShapeKind', $kind);
	    $ordering = $self->num('ClipRectangleOrdering', $ordering);
	    my($r);
	    for $r (@rects) {
		$r = pack("ssSS", @$r);
	    }
	    return pack("CCCxLss", $op, $kind, $ordering, $dest, $x, $y)
	      . join("", @rects);
	}],
       ["ShapeMask", sub {
	    my($self) = shift;
	    my($win, $kind, $op, $x, $y, $pixmap) = @_;
	    $op = $self->num('ShapeOp', $op);
	    $kind = $self->num('ShapeKind', $kind);
	    $pixmap = 0 if $pixmap eq "None";
	    return pack("CCxxLssL", $op, $kind, $win, $x, $y, $pixmap);
	}],
       ["ShapeCombine", sub {
	    my($self) = shift;
	    my($dst, $d_kind, $op, $x, $y, $src, $s_kind) = @_;
	    $op = $self->num('ShapeOp', $op);
	    $d_kind = $self->num('ShapeKind', $d_kind);
	    $s_kind = $self->num('ShapeKind', $s_kind);
	    return pack("CCCxLssL", $op, $d_kind, $s_kind, $dst, $x, $y, $src);
	}],
       ["ShapeOffset", sub {
	    my($self) = shift;
	    my($win, $kind, $x, $y) = @_;
	    $kind = $self->num('ShapeKind', $kind);
	    return pack("CxxxLss", $kind, $win, $x, $y);
	}],
       ["ShapeQueryExtents", sub {
	    my($self) = shift;
	    my($win) = @_;
	    return pack("L", $win);
	}, sub {
	    my($self) = shift;
	    my($data) = @_;
	    my($b, $c, $b_x, $b_y, $b_w, $b_h, $c_x, $c_y, $c_w, $c_h)
	      = unpack("xxxxxxxxCCxxssSSssSSxxxx", $data);
	    return ($b, $c, $b_x, $b_y, $b_w, $b_h, $c_x, $c_y, $c_w, $c_h);
	}],
       ["ShapeSelectInput", sub {
	    my($self) = shift;
	    my($win, $enable) = @_;
	    return pack("LCxxx", $win, $enable);
	}],
       # The R6 documentation gets the next two minor opcodes wrong;
       # this usage follows <X11/extensions/shape.h>.
       ["ShapeInputSelected", sub {
	    my($self) = shift;
	    my($win) = @_;
	    return pack("L", $win);
	}, sub {
	    my($self) = shift;
	    my($data) = @_;
	    return unpack("xCxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx", $data);
	}],
       ["ShapeGetRectangles", sub {
	    my($self) = shift;
	    my($win, $kind) = @_;
	    $kind = $self->num('ShapeKind', $kind);
	    return pack("LCxxx", $win, $kind);
	}, sub {
	    my($self) = shift;
	    my($data) = @_;
	    my($ordering, $nrects) =
	      unpack("xCxxxxxxLxxxxxxxxxxxxxxxxxxxx", substr($data, 0, 32));
	    my($i, @rects);
	    for $i (0 .. $nrects - 1) {
		push @rects, [unpack("ssSS", substr($data, 32 + 8 * $i, 8))];
	    }
	    return ($self->interp('ClipRectangleOrdering', $ordering), @rects);
	}]
      ];
    my($i);
    for $i (0 .. $#{$x->{'ext_request'}{$request_num}}) {
	$x->{'ext_request_num'}{$x->{'ext_request'}{$request_num}[$i][0]} =
	  [$request_num, $i];
    }
    ($self->{'major'}, $self->{'minor'}) = $x->req('ShapeQueryVersion');
    if ($self->{'major'} != 1) {
	carp "Wrong SHAPE version ($self->{'major'} != 1)";
	return 0;
    }
    return bless $self, $pkg;
}

1;
__END__