view release on metacpan or  search on metacpan

t/OpenGL-Image.t  view on Meta::CPAN

#!/usr/bin/perl -w
use strict;
use OpenGL(':all');

# Images used for testing
my $src_image = 'test.png';
my $dst_image = 'test.jpg';
my $tga_image = 'test.tga';
my $width = 128;
my $height = 128;
my $deviation = 0.15;


# Init tests
my $t = new MyTests(26,'Testing OpenGL::Image');


# Get OpenGL version
my $pogl_ver = $OpenGL::VERSION;
my $has_pogl5503 = $pogl_ver ge '0.5503';
$t->status("Using OpenGL v$pogl_ver");
$t->status("Recommend OpenGL 0.55_03 or newer to use") if (!$has_pogl5503);


#1 Get module version
my $ogi_ver;
my $exec = qq
{
  use OpenGL\::Image;
  \$ogi_ver = \$OpenGL::Image::VERSION;
};
eval($exec);
$t->bail("OpenGL::Image failed to load: $@") if ($@ || !$ogi_ver);
$t->ok("OpenGL::Image module loaded: v$ogi_ver");


#2 Get ImageMagick version
my $im_ver = 0;
$exec = qq
{
  use Image\::Magick;
  \$im_ver = \$Image::Magick::VERSION;
};
eval($exec);
if ($@ || !$im_ver)
{
  $t->skip("Image::Magick module not installed: $@") 
}
elsif ($im_ver lt '6.3.5' )
{
  $t->skip("Image::Magick module installed: v$im_ver - recommend 6.3.5 or newer");
}
else
{
  $t->ok("Image::Magick module installed: v$im_ver");
}


#3 Enumerate installed engines
$t->status("Testing OpenGL::Image::GetEngines():");
my $engines = OpenGL::Image::GetEngines();
my @engines = keys(%$engines);
$t->bail("No imaging engines installed!") if (!@engines);
my $has_TGA = 0;
my $has_IM = 0;
my $has_IM635 = 0;
foreach my $engine (sort @engines)
{
  $t->status("  $engine: ".$engines->{$engine}->{version});
  if ($engine eq 'Targa')
  {
    $has_TGA = 1;
  }
  elsif ($engine eq 'Magick')
  {
    $has_IM = 1;
    $has_IM635 = $engines->{'Magick'}->{version} ge '6.3.5';
  }
}
$t->status('Targa is ' . ($has_TGA ? '' : 'NOT ') . "installed");
$t->status('Magick is ' . ($has_IM ? '' : 'NOT ') . "installed");
$t->ok("At least one imaging engine is installed");


#4 Test HasEngine()
my $engine_ver = OpenGL::Image::HasEngine($engines[0])->{version};
$t->bail("HasEngine('$engines[0]') failed to return a version") if (!$engine_ver);
$t->ok("HasEngine('$engines[0]') returned '$engine_ver'");


#5 Test OpenGL::Array
my $oga = OpenGL::Array->new_list(OpenGL::GL_UNSIGNED_BYTE,1,2,3,4);
$t->bail("Unable to instantiate OpenGL::Array") if (!$oga);
$t->bail("OpenGL::Array returned invalid element count") if (4 != $oga->elements());
$t->ok("Instantiated OpenGL::Array");


#6 Test image object instantiation
my $tga = new OpenGL::Image(width=>$width,height=>$height);
$t->bail("Unable to instantiate OpenGL::Image") if (!$tga);
$t->ok("Instantiated OpenGL::Image(width\=>$width,height\=>$height)");


#7 Test Get/Set Pixel
$tga->SetPixel(0,0, 0.1, 0.2, 0.3, 0.4);
my($v0,$v1,$v2,$v3) = $tga->GetPixel(0,0);

# Normalized values introduce rounding errors
my $dev = (abs($v0 - 0.1) + abs($v1 - 0.2) + abs($v2 - 0.3) + abs($v3 - 0.4)) / 4;
#$t->status("Get/SetPixel deviation: $dev");
if ($dev > $deviation)
{
  $t->bail("GetPixel failed to return values used with SetPixel");
}
$t->ok("GetPixel returns valid values used with SetPixel");

t/OpenGL-Image.t  view on Meta::CPAN

unlink($dst_image);


#21 Test destination image size
my($wd,$hd,$pd,$cd,$sd) = $dst->Get('width','height','pixels','components','size');
if ($wd != $ws || $hd != $hs)
{
  $t->fail("Get('width','height') returned invalid dimensions: $wd x $hd");
}
elsif($pd != $wd * $hd)
{
  $t->fail("Get('pixels') failed to return $wd x $hd: $pd");
}
else
{
  $t->ok("Get('width','height','pixels') returned: $wd x $hd = $pd");
}


#22 Test RGB deviation
$d = 0;
for (my $y=0; $y<$height; $y++)
{
  for (my $x=0; $x<$width; $x++)
  {
     my($rs,$gs,$bs,$as) = $src->GetPixel($x,$y);
     my($rd,$gd,$bd,$ad) = $dst->GetPixel($x,$y);
     $d += abs($rs-$rd) + abs($gs-$gd) + abs($bs-$bd);
  }
}

$d /= ($ps * 3);
if ($d > $deviation)
{
  $t->fail("Set/Get Pixels deviation out of range: $d")
}
elsif ($d)
{
  $t->ok("Set/Get Pixels within acceptable deviation: $d");
}
else
{
  $t->ok("Set/Get Pixels resulted in no deviation");
}


#23 Test Native()
$t->bail("Native() returned invalid PerlMagick object") if (!$src->Native());
my($x,$y) = $src->Native->Get('width','height');
if ($x != $w || $y != $h)
{
  $t->bail("Native->Get('width','height') returned invalid dimensions");
}
$t->ok("Native->Get('width','height') returned: $x x $y");


#24 Test GetBlob()
$blob = $src->GetBlob(magick=>'jpg');
$t->bail("GetBlob(type=>'jpg') failed to return a blob") if (!$blob);

my $im = Image::Magick->new(magick=>'jpg');
$im->BlobToImage($blob);
my($w0,$h0) = $im->Get('width','height');
if (!$w0 || !$h0)
{
  $t->bail("GetBlob(type=>'jpg') failed");
}
elsif ($w != $w0 || $h != $h0)
{
  $t->bail("GetBlob(type=>'jpg') returns invalid dimensions: $w0 x $h0");
}
$t->ok("GetBlob(type=>'jpg') returned a blob of length: ".length($blob));


#25 Test GetArray()
$oga = $src->GetArray();
$t->bail("GetArray() failed to return an OpenGL::Array object") if (!$oga);
$elements = $oga->elements();
if ($elements != $p * $c)
{
  $t->bail("GetArray() contains invalid number of elements: $elements");
}
$t->ok("GetArray() contains $elements elements");


#26 Test Ptr()
if ($oga->ptr() && $oga->ptr() != $src->Ptr())
{
  $t->bail("Ptr() returned invalid pointer: ".$oga->ptr().', '.$src->Ptr()."\n");
}
$t->ok("Ptr() returned a valid pointer");


$t->done();
exit 0;






package MyTests;
sub new
{
  my $this = shift;
  my $class = ref($this) || $this;
  my $self = {count=>0};
  bless($self,$class);

  my($tests,$title) = @_;
  $self->{tests} = $tests;
  print "1..$tests\n";
  $self->status("\n________________________________________");
  $self->status($title);
  $self->status("----------------------------------------");

  return $self;
}
sub status
{
  my($self,$msg) = @_;