view release on metacpan or  search on metacpan

t/MyTestImageBase.pm  view on Meta::CPAN

  is ($bad, 0,
      "all_hline x=$x1..$x2,y=$y  $colour  on $name");
  return $bad;
}

# demand that all pixels $y1 to $y2 inclusive have $colour
sub all_vline {
  my ($image, $x, $y1,$y2, $colour, $name) = @_;
  my $bad = 0;
  ($y1,$y2) = ($y2,$y1) if $y1 > $y2;
  my $y;
  foreach $y ($y1 .. $y2) {
    ### all_hline look at: "$x,$y"
    my $got = mung_colour($image->xy($x,$y));
    if ($got ne $colour) {
      $bad = 1;
    }
  }
  is ($bad, 0,
      "all_vline x=$x,y=$y1..$y2  $colour  on $name");
  return $bad;
}


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

my @sizes = ([0,0, 0,0],    # 1x1
             [5,7, 5,7],

             [3,2, 4,2],    # thin horiz
             [3,2, 13,2],
             [3,3, 4,3],
             [3,3, 13,3],

             [5,2, 5,3],    # thin vert
             [5,2, 5,9],
             [6,2, 6,3],
             [6,2, 6,9],

             [1,1, 2,2],    # 2x2
             [5,6, 7,8],

             [1,1, 18,8],   # big
            );

sub check_line {
  my ($image, %options) = @_;
  my ($width, $height) = $image->get('-width','-height');
  my $image_clear_func = $options{'image_clear_func'};

  my $elem;
  foreach $elem (@sizes) {
    my ($x1,$y1, $x2,$y2) = @$elem;

    {
      my $name = "line $x1,$y1 $x2,$y2";
      &$image_clear_func();
      $image->line ($x1,$y1, $x2,$y2, $white);

      my $bad = (
                 # endpoints
                 is_pixel ($image, $x1,$y1, $white, $name)
                 + is_pixel ($image, $x2,$y2, $white, $name)

                 # nothing in surrounding rectangle
                 + is_rect ($image, $x1-1,$y1-1, $x2+1,$y2+1, $black, $name));
      if ($bad) {
        dump_image ($image);
      }
    }
    {
      my $name = "line $x2,$y2 $x1,$y1, reversal";
      &$image_clear_func();
      $image->line ($x2,$y2, $x1,$y1, $white);

      my $bad = (
                 # endpoints
                 is_pixel ($image, $x1,$y1, $white, $name)
                 + is_pixel ($image, $x2,$y2, $white, $name)

                 # nothing in surrounding rectangle
                 + is_rect ($image, $x1-1,$y1-1, $x2+1,$y2+1, $black, $name));
      if ($bad) {
        dump_image ($image);
      }
    }
  }
}

sub rect_using_Other {
  my ($image, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
  $image->Image_Base_Other_rectangles ($colour, $fill, $x1, $y1, $x2, $y2);
}

sub check_rectangle {
  my ($image, %options) = @_;
  my ($width, $height) = $image->get('-width','-height');
  my $image_clear_func = $options{'image_clear_func'};

  my $method;
  foreach $method ('rectangle',
                   ($image->can('Image_Base_Other_rectangles')
                    ? ('MyTestImageBase::rect_using_Other')
                    : ())) {

    my $elem;
    foreach $elem (@sizes) {
      my ($x1,$y1, $x2,$y2) = @$elem;

      {
        my $name = "$method unfilled $x1,$y1, $x2,$y2";
        my $fill = undef;
        &$image_clear_func();

        my @args = ($x1,$y1, $x2,$y2, $white, $fill);
        if ($method eq 'Image_Base_Other_rectangles') {
          unshift @args, splice @args, -2, 2;
        }
        $image->$method (@args);

        my $bad
          = (is_rect ($image, $x1,$y1, $x2,$y2, $white_expect, $name)
             # outside
             + is_rect ($image, $x1-1,$y1-1, $x2+1,$y2+1, $black, $name)
             # inside
             + is_rect ($image, $x1+1,$y1+1, $x2-1,$y2-1, $black, $name));
        if ($bad) { dump_image($image); }
      }
      {
        my $name = "$method filled $x1,$y1, $x2,$y2";
        my $fill = 123;
        &$image_clear_func();

        my @args = ($x1,$y1, $x2,$y2, $white, $fill);
        if ($method eq 'Image_Base_Other_rectangles') {
          unshift @args, splice @args, -2, 2;
        }