view release on metacpan or  search on metacpan

t/gd_oo_tests.t  view on Meta::CPAN

my $testfile_lut = "$tempdir/test.png";
my $testfile2 = "$tempdir/test2.png";
my $testfile_true = "$tempdir/test3.png";

# Write out the lutfile below, so we don't have to include it in the distro:
write_lut($lutfile);

my $pdl = sequence(byte, 30, 30);

my $lut = load_lut( $lutfile );
ok( ($lut->dim(0) == 3 && $lut->dim(1) == 256), 'Load a lut from an ASCII file' );

write_png( $pdl, $lut, $testfile_lut );

write_true_png(sequence(100, 100, 3), $testfile_true);

eval {PDL::IO::GD->new( { filename => "$tempdir/notthere.png" } )};
like $@, qr/Error/, 'exception not segfault on non-existent file';
my $gd = PDL::IO::GD->new( { filename => $testfile_lut } );
ok( defined( $gd ), 'Object created' );

is $gd->gdImageSX, 30, 'query X dim';
is $gd->gdImageSY, 30, 'query Y dim';

is_pdl $gd->to_pdl, $pdl->long, 'image matches original pdl';
is_pdl $gd->to_rpic->slice(',-1:0'), $pdl->long, 'rpic image matches original pdl';

undef $gd;

my $im = PDL::IO::GD->new( { x => 300, y => 300 } );
ok( defined( $im ), 'create new image from scratch' );

$im->apply_lut( $lut );

# Resolve some colors:
my $black = $im->ColorResolve( 0, 0, 0 );
ok( defined( $black ), 'resolve color black' );
my $red = $im->ColorResolve( 255, 0, 0 );
ok( defined( $red ), 'resolve color red' );
my $green = $im->ColorResolve( 0, 255, 0 );
ok( defined( $green ), 'resolve color green' );
my $blue = $im->ColorResolve( 0, 0, 255 );
ok( defined( $blue ), 'resolve color blue' );

# Draw a rectangle:
$im->Rectangle( 5, 5, 295, 295, $red );
ok( 1, 'draw a rectangle' );

# Add some text:
$im->String( gdFontGetLarge(), 10, 10, "Test Large Font!", $green );
ok( 1, 'add some text' );

# Generate a color bar:
my $x1 = zeroes( long, 256 ) + 50;
my $y1 = sequence( long, 256 ) + 30;
my $color = sequence(long, 256);
$im->Lines( $x1, $y1, $x1 + 100, $y1, $color );
ok( 1, 'generate a color bar' );

# Write the output file:
$im->write_Png( $testfile2 );
ok( 1, 'write the output file' );
undef $im;

my $pic = sequence(100, 100);
$im = PDL::IO::GD->new({ pdl => $pic });
ok( defined( $im ), 'create from 2d PDL without a LUT' );
undef $im;

$im = PDL::IO::GD->new({ pdl => $pic, lut => $lut });
ok( defined( $im ), 'create from 2d PDL and a LUT' );
undef $im;

my $pic3d = $pic->dummy(2,3);
$im = PDL::IO::GD->new({ pdl => $pic3d });
ok( defined( $im ), 'create from a RGB PDL' );
undef $im;

$im = PDL::IO::GD->new({ x => 100, y => 100, true_color => 1 });
ok( defined( $im ), 'create an RGB from scratch' );
undef $im;

# Create from a 2d PNG data glob:
my $blob = do { open my $fh, $testfile_lut or die "$testfile_lut: $!"; binmode $fh; local $/; <$fh> };
ok defined $blob, "read test file $testfile_lut";
$im = PDL::IO::GD->new({ data => $blob });
ok( defined( $im ), 'create from a 2d PNG data glob' );
undef $im;

# Create from a 2d PNG data glob, with the type given:
$im = PDL::IO::GD->new({ data => $blob, type => 'png' });
ok( defined( $im ), 'create from glob with type given' );
undef $im;

# Create from a 3d PNG data glob:
my $blob3d = do { open my $fh, $testfile_true or die "$testfile_true: $!"; binmode $fh; local $/; <$fh> };
ok defined $blob, "read test file $testfile_true";
$im = PDL::IO::GD->new({ data => $blob3d });
ok( defined( $im ), 'create from a 3d PNG data glob' );
# Get a PNG data glob from a created 
my $png_blob = $im->get_Png_data();
ok( $blob3d eq $png_blob, 'get a PNG data glob' );
undef $im;

# Try a nicer way to make an object. Just pass in a filename:
my $gd_new_just_filename = PDL::IO::GD->new( $testfile_lut );
ok( defined( $gd_new_just_filename ), 'initialize an object from JUST the filename' );

# Try another nicer way to make an object: Pass in an inline hash:
my $gd_new_inline_hash = PDL::IO::GD->new( filename => $testfile_lut );
ok( defined( $gd_new_inline_hash ), 'initialize an object from an inline hash' );

# Make sure bogus inline hashes generate complaints. First, give an odd
# number of args
my $gd_new_inline_hash_broken1;
eval { $gd_new_inline_hash_broken1 = PDL::IO::GD->new( filename => $testfile_lut, 34 ) };
ok( $@ && !defined( $gd_new_inline_hash_broken1 ), 'incorrectly initialize an object from an inline hash: odd Nargs' );
# TEST 32:
# Make sure bogus inline hashes generate complaints. Give a non-string key
my $gd_new_inline_hash_broken2;
eval { $gd_new_inline_hash_broken2 = PDL::IO::GD->new( filename => $testfile_lut, [34] => 12 ) };
ok( $@ && !defined( $gd_new_inline_hash_broken2 ), 'incorrectly initialize an object from an inline hash: non-string key' );

done_testing;

sub write_lut {
    my $filename = shift;
    open my $fh, ">", $filename or die "Can't write $filename: $!\n";
    print $fh <<'ENDLUT';
  2    0    4
  9    0    7
 22    0   19
 36    0   32
 50    0   48
 61    0   63
 69    0   77
 77    0   91
 82    0  104
 84    0  118
 88    0  132
 87    0  145
 84    0  159
 83    0  173
 77    0  186
 70    0  200
 60    0  214
 53    0  227
 40    0  241
 25    0  255
 12    0  255
  0    4  255
  0   21  255
  0   38  255
  0   55  255
  0   72  255
  0   89  255
  0  106  255
  0  119  255
  0  135  255
  0  152  255
  0  165  255