Skip to content
This repository
Fetching contributors…

Cannot retrieve contributors at this time

file 196 lines (152 sloc) 5.624 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196
use strict;
use warnings;
use Test::More;
use SDL;
use SDL::Surface;
use SDL::Rect;
use SDLx::Surface;
use SDL::PixelFormat;
use SDL::Video;
use Data::Dumper;
use lib 't/lib';
use SDL::TestTool;

my $videodriver = $ENV{SDL_VIDEODRIVER};
$ENV{SDL_VIDEODRIVER} = 'dummy' unless $ENV{SDL_RELEASE_TESTING};

if ( !SDL::TestTool->init(SDL_INIT_VIDEO) ) {
plan( skip_all => 'Failed to init video' );
}

my $app = SDL::Video::set_video_mode( 400, 200, 32, SDL_SWSURFACE );

my $app_x = SDLx::Surface::display();

is_deeply(
$app_x->surface->get_pixels_ptr,
$app->get_pixels_ptr, '[display] works'
);

my $surface = SDL::Surface->new( SDL_SWSURFACE, 400, 200, 32 );
my @surfs = (
SDLx::Surface->new( surface => $surface ),
SDLx::Surface->new( width => 400, height => 200 ),
SDLx::Surface->new(
width => 400,
height => 200,
flags => SDL_SWSURFACE,
depth => 32
),
SDLx::Surface->new(
width => 400,
height => 200,
flags => SDL_SWSURFACE,
depth => 32,
greenmask => 0xFF000000
),
);

foreach my $a (@surfs) {
isa_ok( $a, 'SDLx::Surface' );

isa_ok( $a->surface(), 'SDL::Surface' );

my $color = $a->[0][0];
is( $color, 0, 'Right color returned' );

$a->[0][0] = 0x00FF00FF;
is( $a->[0][0], 0x00FF00FF, 'Right color returned' );

is( @{$a}, 200, 'Correct Y value' );

is( @{ $a->[0] }, 400, 'Correct X value' );

}

#my $source = SDLx::Surface->new( width=> 400, height=>200, flags=> SDL_SWSURFACE, depth=>32 ),

is( $surfs[0]->[1][2], 0, 'Checking source pixel is 0' );
is( $surfs[1]->[1][2], 0, 'Checking dest pixel is 0' );

$surfs[0]->[4][4] = [255,255,0,255];

is( $surfs[0]->[4][4] , 0xFFFF00FF, "Surface can set pixel with other color values");

$surfs[0]->[1][2] = 0x00FF00FF;

is( $surfs[0]->[1][2], 0x00FF00FF, 'Checking that source pixel got written' );

$surfs[0]->blit( $surfs[1] );

#SDL::Video::blit_surface( $surfs[0]->surface, SDL::Rect->new(0,0,400,200), $surfs[1]->surface, SDL::Rect->new(0,0,400,200));

isnt( $surfs[1]->[1][2], 0, 'Pixel blitted from one surface to another' );

$surfs[1]->blit_by( $surfs[0], undef, [ 1, 0, 0, 0 ] );

isnt( $surfs[1]->[2][2], 0, 'Pixel by_blitted to another surface with offset' );

push @surfs,
SDLx::Surface->new(
w => 1,
h => 1,
color => 0x204080FF,
);

my $fill = SDL::Video::get_RGBA( $surfs[-1]->surface()->format(), $surfs[-1]->[0][0] );

is( $fill->[0], 0x20, 'Fill color red worked' );
is( $fill->[1], 0x40, 'Fill color green worked' );
is( $fill->[2], 0x80, 'Fill color blue worked' );
is( $fill->[3], 0xFF, 'Fill color alpha worked' );

$surfs[1]->flip();

pass 'Fliped the surface';

$surfs[0]->update();
pass 'update all surface';
$surfs[0]->update( [ 0, 10, 30, 40 ] );
pass 'Single rect update';
$surfs[0]->update( [ SDL::Rect->new( 0, 1, 2, 3 ), SDL::Rect->new( 2, 4, 5, 6 ) ] );
pass 'SDL::Rect array update';

my @colors = (
[ 0xFF, 0xFF, 0xFF, 0xFF ],
[ 0xFF, 0xFF, 0x00, 0xFF ],
[ 0xFF, 0x00, 0xFF, 0xFF ],
[ 0x00, 0xFF, 0xFF, 0xFF ],
[ 0xFF, 0x00, 0x00, 0xFF ],
[ 0x00, 0xFF, 0x00, 0xFF ],
[ 0x00, 0x00, 0xFF, 0xFF ],
[ 0x00, 0x00, 0x00, 0xFF ],
[ 0x20, 0x40, 0x80, 0xFF ],
[ 0x80, 0x20, 0x40, 0xFF ],
[ 0x40, 0x80, 0x20, 0xFF ],
);

foreach my $c (@colors) {
my $color = ( $c->[0] << 24 ) + ( $c->[1] << 16 ) + ( $c->[2] << 8 ) + $c->[3];
$surfs[0]->draw_rect( [ 0, 0, 10, 20 ], $c );

my $num = sprintf( '0x%08x', $color );

my $rgba = SDL::Video::get_RGBA( $surfs[0]->surface()->format(), $surfs[0]->[0][0] );

is( $rgba->[0], $c->[0], "draw_rect uses correct red for $num" );
is( $rgba->[1], $c->[1], "draw_rect uses correct green for $num" );
is( $rgba->[2], $c->[2], "draw_rect uses correct blue for $num" );
is( $rgba->[3], $c->[3], "draw_rect uses correct alpha for $num" );
}
$surfs[0]->draw_rect( [ 0, 0, 10, 20 ], 0xFF00FFFF );
pass 'draw_rect works';
SKIP:
{
skip( 'SDL_gfx_primitives needed', 2 ) unless SDL::Config->has('SDL_gfx_primitives');
$surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], 0xff00ff );
$surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], 0xff00ffff );
$surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], 0xff00ffff, 1 );
$surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], [ 255, 255, 0, 255 ] );
$surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], [ 255, 255, 0, 255 ], 1 );
pass 'draw_line works';

$surfs[1]->draw_gfx_text( [ 0, 0 ], 0xffffffff, "fooo" );
$surfs[1]->draw_gfx_text( [ 10, 10 ], [ 20, 20, 20, 20 ], "fooo" );
my $f = '';
open( my $FH, '<', 'test/data/5x7.fnt' );
binmode($FH);
read( $FH, $f, 4096 );
close($FH);
my $font = { data => $f, cw => 5, ch => 7 };
$surfs[1]->draw_gfx_text( [ 0, 0 ], 0xffffffff, "fooo", $font );
pass 'draw_gfx_text works';
my @colors_t = ( [ 255, 0, 0, 255 ], 0xFF0000FF, 0xFF00FF, [ 255, 0, 255 ] );

foreach my $cir_color (@colors_t) {
my $cir_color = [ 255, 0, 0, 255 ];
$surfs[0]->draw_circle( [ 100, 10 ], 20, $cir_color ); #no fill
$surfs[0]->draw_circle( [ 102, 12 ], 22, $cir_color , 1 );
$surfs[0]->draw_circle_filled( [ 100, 10 ], 20, $cir_color ); #fill
isnt( $surfs[0]->[100][10], 0 );
pass 'draw_circle works';
pass 'draw_circle_filled works';
}

}


my $surf_dup = SDLx::Surface::duplicate( $surfs[1] );

is( $surf_dup->w, $surfs[1]->w, 'Duplicate surf has same width' );
is( $surf_dup->h, $surfs[1]->h, 'Duplicate surf has same flags' );
is( $surf_dup->flags, $surfs[1]->flags, 'Duplicate surf has same flags' );
is( $surf_dup->format->BitsPerPixel,
$surfs[1]->format->BitsPerPixel,
'Duplicate surf has same bpp'
);

if ($videodriver) {
$ENV{SDL_VIDEODRIVER} = $videodriver;
} else {
delete $ENV{SDL_VIDEODRIVER};
}

pass 'Final SegFault test';

done_testing;
Something went wrong with that request. Please try again.