view release on metacpan or  search on metacpan

t/GD.t  view on Meta::CPAN

    );

  # Some TTFs
  $im->stringFT($black,FONT,12.0,0.0,20,20,"Hello world!") || warn $@;
  $im->stringFT($red,FONT,14.0,0.0,20,80,"Hello world!") || warn $@;
  $im->stringFT($blue,FONT,30.0,-0.5,60,100,"Goodbye cruel world!") || warn $@;
  return $im;
}

sub test8 {
    my $im = test4();
    $im = $im->copyRotate90();
    $im = $im->copyFlipHorizontal();
    $im = $im->copyTranspose();
    $im->rotate180();
    $im->flipVertical();
    $im = $im->copyReverseTranspose();
    $im = $im->copyFlipVertical();
    return $im;
}

sub run_image_regression_tests {
    my $suffix = $ENV{GDIMAGETYPE} || $image_types[0];
    print STDERR "# Testing gd ".GD::VERSION_STRING()." using $suffix support.\n";
    for my $t (1..REGRESSION_TESTS) {
	my $gd   = eval "test${t}('$suffix')";
	if (!$gd) {
	    fail("unable to generate comparison image for test $t with $suffix: $@");
	} else {
            my $ok = compare($gd,$t,$suffix);
            unless ($ok) {
                if (($suffix ne 'gd2') or ($t == 7)) {
                    ok(1, "TODO image comparison test $t $suffix failed (regen with --write)");
                } else {
                    ok($ok, "image comparison test $t $suffix");
                }
                diag("gd: ",GD::VERSION_STRING(),
                     ", files: ",join(" ",glob("$images/t${t}/*.$suffix")));
            } else {
                ok($ok, "image comparison test $t $suffix");
            }
	}
    }
}

sub run_round_trip_test {
    my $image = GD::Image->new(300,300);
    $image->colorAllocate(255,255,255);
    $image->colorAllocate(0,0,0);
    $image->colorAllocate(255,0,0);
    $image->rectangle(0,0,300,300,0);
    $image->filledRectangle(10,10,50,50,2);
    if (GD::Image->can("newFromGd") and GD::Image->can("newFromGd2")) {
        my $gd = $image->gd;
        my $image2 = GD::Image->newFromGdData($gd);
        ok(!$image->compare($image2) & GD_CMP_IMAGE(),'round trip gd');
        my $gd2 = $image->gd2;
        $image2 = GD::Image->newFromGd2Data($gd2);
        ok(!$image->compare($image2) & GD_CMP_IMAGE(),'round trip gd2');
    }
    elsif (GD::Image->can("newFromPng")) {
      SKIP: {
          skip "No GIF support", 2 unless defined &GD::Image::newFromGif;

          # GD 2.3.2 disabled the old GD and GD2 formats by default
          my $png = $image->png;
          my $image2 = GD::Image->newFromPngData($png);
          ok(!$image->compare($image2) & GD_CMP_IMAGE(),'round trip png');
          my $gif = $image->gif;
          $image2 = GD::Image->newFromGifData($gif);
          ok(!$image->compare($image2) & GD_CMP_IMAGE(),'round trip gif');
        }
    }
    else {
      SKIP: {
          skip "No GIF or TIFF support", 2
              unless defined &GD::Image::newFromGif
              and defined &GD::Image::newFromTiff;

          my $img = $image->tiff;
          my $image2 = GD::Image->newFromTiffData($img);
          ok(!$image->compare($image2) & GD_CMP_IMAGE(),'round trip tiff');
          my $gif = $image->gif;
          $image2 = GD::Image->newFromGifData($gif);
          ok(!$image->compare($image2) & GD_CMP_IMAGE(),'round trip gif');
        }
    }
}

sub catch_libgd_error {
  diag("ignore corrupt png error messages...");
  SKIP: {
    skip "No PNG support", 2 unless defined &GD::Image::newFromPng;
    my $image = eval { GD::Image->newFromPng("test_data/images/corrupt.png") };
    is($image, undef, "empty corrupt png data");
    ok($@, 'caught corrupt png');
  }
}

sub test_cve2019_6977 {
  my $img1 = GD::Image->new(0xfff, 0xfff, 1);
  my $img2 = GD::Image->new(0xfff, 0xfff, 0);
  $img2->colorAllocate(0, 0, 0);
  $img2->setPixel (0, 0, 255);
  if (GD::LIBGD_VERSION() >= 2.10) {
    $img1->colorMatch ($img2);
  }
  ok(1, 'survived CVE 2019-6977'); # fails only under valgrind or asan
}