File Coverage

blib/lib/Image/Base/X11/Protocol/Window.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

# Copyright 2010, 2011, 2012, 2013 Kevin Ryde

# This file is part of Image-Base-X11-Protocol.
#
# Image-Base-X11-Protocol 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.
#
# Image-Base-X11-Protocol 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 Image-Base-X11-Protocol.  If not, see .


# X11::Protocol::Ext::SHAPE
# /usr/share/doc/x11proto-xext-dev/shape.txt.gz
# /usr/share/doc/x11proto-core-dev/x11protocol.txt.gz
#

package Image::Base::X11::Protocol::Window;
use 5.004;
use strict;
use Carp;
use vars '@ISA', '$VERSION';

use Image::Base::X11::Protocol::Drawable;
@ISA = ('Image::Base::X11::Protocol::Drawable');

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

$VERSION = 14;


sub new {
  my ($class, %params) = @_;
  ### X11-Protocol-Window new()

  # lookup -colormap from -window if not supplied
  if (! defined $params{'-colormap'}) {
    my %attrs = $params{'-X'}->GetWindowAttributes ($params{'-window'});
    $params{'-colormap'} = $attrs{'colormap'};
  }

  # alias -window to -drawable
  if (my $win = delete $params{'-window'}) {
    $params{'-drawable'} = $win;
  }

  return $class->SUPER::new (%params);
}

sub DESTROY {
  my ($self) = @_;
  ### X11-Protocol-Window DESTROY
  _free_bitmap_gc($self);
  shift->SUPER::DESTROY (@_);
}
sub _free_bitmap_gc {
  my ($self) = @_;
  if (my $bitmap_gc = delete $self->{'_bitmap_gc'}) {
    ### FreeGC bitmap_gc: $bitmap_gc
    $self->{'-X'}->FreeGC ($bitmap_gc);
  }
}

my %get_window_attributes = (-colormap => 1,
                             -visual   => 1);
sub _get {
  my ($self, $key) = @_;
  ### X11-Protocol-Window _get(): $key

  if (! exists $self->{$key}) {
    if ($get_window_attributes{$key}) {
      my $attr = ($self->{'_during_get'}->{'GetWindowAttributes'} ||= do {
        my %attr = $self->{'-X'}->GetWindowAttributes ($self->{'-drawable'});
        foreach my $field ('visual') {
          if (! exists $self->{"-$field"}) {  # unchanging
            $self->{"-$field"} = $attr{$field};
          }
        }
        \%attr
      });
      return $attr->{substr($key,1)};
    }
  }
  return $self->SUPER::_get($key);
}

sub set {
  my ($self, %params) = @_;

  if (exists $params{'-drawable'}) {
    _free_bitmap_gc ($self);
    delete $self->{'-visual'};  # must be refetched, or provided in %params
  }

  my $width  = delete $params{'-width'};
  my $height = delete $params{'-height'};

  # set -drawable before applying -width and -height
  $self->SUPER::set (%params);

  if (defined $width || defined $height) {
    $self->{'-X'}->ConfigureWindow
      ($self->{'-drawable'},
       (defined $width  ? (width => $width)   : ()),
       (defined $height ? (height => $height) : ()));
  }
}

#------------------------------------------------------------------------------
# drawing

sub xy {
  my ($self, $x, $y, $colour) = @_;
  ### Window xy(): "$x, $y".(@_>=4 && ", $colour")

  if ((my $X = $self->{'-X'})->{'ext'}->{'SHAPE'}) {

    # don't overflow INT16 in requests
    if ($x < 0 || $y < 0 || $x > 0x7FFF || $y > 0x7FFF) {
      ### entirely outside max possible drawable ...
      return undef; # fetch or store
    }

    if (@_ >= 4) {
      if ($colour eq 'None') {
        ### Window xy() subtract shape ...
        $X->ShapeRectangles ($self->{'-drawable'},
                             'Bounding',
                             'Subtract',
                             0,0, # offset
                             'YXBanded',
                             [ $x,$y, 1,1 ]);
        return;
      }
    } else {
      ### Window xy() fetch shape ...
      my ($ordering, @rects) = $X->ShapeGetRectangles ($self->{'-drawable'},
                                                       'Bounding');
      ### @rects
      if (! _rects_contain_xy($x,$y,@rects)) {
        return 'None';
      }
    }
  }
  shift->SUPER::xy (@_);
}

sub line {
  my ($self, $x1,$y1, $x2,$y2, $colour) = @_;
  ### X11-Protocol-Window line(): $x1,$y1, $x2,$y2, $colour

  if ($colour eq 'None'
      && (my $X = $self->{'-X'}) ->{'ext'}->{'SHAPE'}) {

    unless (Image::Base::X11::Protocol::Drawable::_line_any_positive($x1,$y1, $x2,$y2)) {
      ### nothing positive ...
      return;
    }
    my $bitmap_width = abs($x2-$x1)+1;
    my $bitmap_height = abs($y2-$y1)+1;
    if ($bitmap_width > 0x7FFF || $bitmap_height > 0x7FFF
        || $x1 < -0x8000 || $x2 < -0x8000
        || $x1 > 0x7FFF || $x2 > 0x7FFF
        || $y1 < -0x8000 || $y2 < -0x8000
        || $y1 > 0x7FFF || $y2 > 0x7FFF) {
      ### coordinates would overflow, use superclass ...
      shift->SUPER::line(@_);
      return;
    }

    my ($bitmap, $bitmap_gc) = _make_bitmap_and_gc
      ($self, $bitmap_width , $bitmap_height);

    my $xmin = ($x1 < $x2 ? $x1 : $x2);
    my $ymin = ($y1 < $y2 ? $y1 : $y2);
    $X->PolySegment ($bitmap, $bitmap_gc,
                     $x1-$xmin,$y1-$ymin, $x2-$xmin,$y2-$ymin);
    $X->ShapeMask ($self->{'-drawable'},
                   'Bounding',
                   'Subtract',
                   $xmin,$ymin, # offset
                   $bitmap);
    $X->FreePixmap ($bitmap);
  } else {
    shift->SUPER::line (@_);
  }
}

sub rectangle {
  my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
  ### Window rectangle: $x1, $y1, $x2, $y2, $colour, $fill
  if ($colour eq 'None'
      && (my $X = $self->{'-X'}) ->{'ext'}->{'SHAPE'}) {

    unless ($x2 >= 0 && $y2 >= 0 && $x1 <= 0x7FFF && $y1 <= 0x7FFF) {
      ### entirely outside max possible drawable ...
      return;
    }

    # don't underflow INT16 -0x8000 x,y in request
    # retain negativeness so as not to bring unfilled sides into view
    if ($x1 < -1) { $x1 = -1; }
    if ($y1 < -1) { $y1 = -1; }

    # don't overflow CARD16 width,height in request
    if ($x2 > 0x7FFF) { $x2 = 0x7FFF; }
    if ($y2 > 0x7FFF) { $y2 = 0x7FFF; }

    my @rects;
    my $width = $x2 - $x1 + 1;
    my $height = $y2 - $y1 + 1;
    if ($fill
        || $width <= 2
        || $height <= 2) {
      # filled, or unfilled 2xN or Nx2 as one rectangle
      @rects = ([ $x1, $y1, $width, $height ]);
    } else {
      # unfilled, line segments
      @rects = ([ $x1, $y1,   $width, 1    ],  # top
                [ $x1,$y1+1,  1, $height-2 ],  # left
                [ $x2,$y1+1,  1, $height-2 ],  # right
                [ $x1, $y2,   $width, 1    ]); # bottom
    }
    $X->ShapeRectangles ($self->{'-drawable'},
                         'Bounding',
                         'Subtract',
                         0,0, # offset
                         'YXBanded', @rects);

  } else {
    $self->SUPER::rectangle ($x1, $y1, $x2, $y2, $colour, $fill);
  }
}
sub Image_Base_Other_rectangles {
  ### X11-Protocol-Window rectangles() ...
  my $self = shift;
  my $colour = shift;
  my $fill = shift;

  # ENHANCE-ME: multiple rectangles at once to ShapeRectangles()
  ### rectangles: @_
  while (@_) {
    $self->rectangle (shift,shift,shift,shift, $colour, $fill);
  }
}

sub ellipse {
  my ($self, $x1,$y1, $x2,$y2, $colour, $fill) = @_;
  ### Window ellipse(): $x1,$y1, $x2,$y2, $colour
  if ($colour eq 'None'
      && (my $X = $self->{'-X'}) ->{'ext'}->{'SHAPE'}) {
    ### use shape ...

    unless ($x2 >= 0 && $y2 >= 0 && $x1 <= 0x7FFF && $y1 <= 0x7FFF) {
      ### entirely outside max possible drawable ...
      return;
    }
    if ($x1 < -0x8000 || $x2 > 0x7FFF || $y1 < -0x8000 || $y2 > 0x7FFF) {
      ### coordinates would overflow, use superclass ...
      shift->SUPER::ellipse(@_);
      return;
    }

    my $win = $self->{'-drawable'};
    my $w = $x2 - $x1;
    my $h = $y2 - $y1;
    if ($w <= 1 || $h <= 1) {
      $X->ShapeRectangles ($win,
                           'Bounding',
                           'Subtract',
                           0,0, # offset
                           'YXBanded',
                           [ $x1, $y1, $w+1, $h+1 ]);
    } else {
      my ($bitmap, $bitmap_gc) = _make_bitmap_and_gc ($self, $w+1, $h+1);

      # fill+outline per comments in Drawable.pm
      my @args = ($bitmap, $bitmap_gc, [ 0, 0, $w, $h, 0, 365*64 ]);
      if ($fill) {
        $X->PolyFillArc (@args);
      }
      $X->PolyArc (@args);

      $X->ShapeMask ($self->{'-drawable'},
                     'Bounding',
                     'Subtract',
                     $x1,$y1, # offset
                     $bitmap);
      $X->FreePixmap ($bitmap);
    }
  } else {
    shift->SUPER::ellipse (@_);
  }
}

sub diamond {
  my ($self, $x1,$y1, $x2,$y2, $colour, $fill) = @_;
  ### Window diamond(): $x1,$y1, $x2,$y2, $colour

  if ($colour eq 'None'
      && (my $X = $self->{'-X'}) ->{'ext'}->{'SHAPE'}) {
    ### use shape ...

    if ($x1==$x2 && $y1==$y2) {
      # 1x1 polygon draws nothing, do it as a point instead
      $self->xy ($x1,$y1, $colour);
      return;
    }

    unless ($x2 >= 0 && $y2 >= 0 && $x1 <= 0x7FFF && $y1 <= 0x7FFF) {
      ### entirely outside max possible drawable ...
      return;
    }
    if ($x1 < -0x8000 || $x2 > 0x7FFF || $y1 < -0x8000 || $y2 > 0x7FFF) {
      ### coordinates would overflow, use superclass ...
      shift->SUPER::diamond(@_);
      return;
    }

    my $drawable = $self->{'-drawable'};

    $x2 -= $x1;   # offset so 0,0 to x2,y2
    $y2 -= $y1;
    my ($bitmap, $bitmap_gc)
      = _make_bitmap_and_gc ($self, $x2+1, $y2+1);  # width,height
    Image::Base::X11::Protocol::Drawable::_diamond_drawable
        ($X, $bitmap, $bitmap_gc, 0,0, $x2,$y2, $fill);
    $X->ShapeMask ($drawable,
                   'Bounding',
                   'Subtract',
                   $x1,$y1,     # offset
                   $bitmap);
    $X->FreePixmap ($bitmap);

  } else {
    shift->SUPER::diamond (@_);
  }
}

#------------------------------------------------------------------------------
sub _make_bitmap_and_gc {
  my ($self, $width, $height) = @_;
  ### _make_bitmap_and_gc(): "$width,$height"
  my $X = $self->{'-X'};

  my $bitmap = $X->new_rsrc;
  ### CreatePixmap of bitmap: $bitmap
  $X->CreatePixmap ($bitmap, $self->{'-drawable'}, 1, $width, $height);

  my $bitmap_gc = $self->{'_bitmap_gc'};
  if ($bitmap_gc) {
    $X->ChangeGC ($bitmap_gc, foreground => 0);
  } else {
    $bitmap_gc = $X->new_rsrc;
    $X->CreateGC ($bitmap_gc, $bitmap, foreground => 0);
  }
  $X->PolyFillRectangle ($bitmap, $bitmap_gc, [0,0, $width,$height]);
  $X->ChangeGC ($bitmap_gc, foreground => 1);
  return ($bitmap, $bitmap_gc);
}

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

# _rects_contain_xy($x,$y, [$rx,$ry,$rw,$rh],...) returns true if pixel
# $x,$y is within any of the given rectangle arrayrefs.
#
# For any order except Unsorted could stop searching when $ry > $y, if that
# was worth the extra code.
#
sub _rects_contain_xy {
  ### _rects_contain_xy() ...
  my $x = shift;
  my $y = shift;
  while (@_) {
    my ($rx,$ry,$width,$height) = @{(shift)};
    if ($rx <= $x && $rx+$width > $x
        && $ry <= $y && $ry+$height > $y) {
      ### found: "$x,$y  in  $rx,$ry, $width,$height"
      return 1;
    }
  }
  ### not found ...
  return 0;
}


1;
__END__