Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 182 lines (139 sloc) 4.912 kb
d90ee1b @Blaizer Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
1 use strict;
2 use warnings;
3 use Test::More;
4 use SDL;
5 use SDL::Surface;
6 use SDL::Rect;
7 use SDLx::Surface;
8 use SDL::PixelFormat;
9 use SDL::Video;
10 use lib 't/lib';
11 use SDL::TestTool;
12
13 my $videodriver = $ENV{SDL_VIDEODRIVER};
14 $ENV{SDL_VIDEODRIVER} = 'dummy' unless $ENV{SDL_RELEASE_TESTING};
15
16 if ( !SDL::TestTool->init(SDL_INIT_VIDEO) ) {
4979eb1 @jtpalmer perltidy
jtpalmer authored
17 plan( skip_all => 'Failed to init video' );
d90ee1b @Blaizer Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
18 }
19
20 my $app = SDL::Video::set_video_mode( 400, 200, 32, SDL_SWSURFACE );
21
22 my $app_x = SDLx::Surface::display();
23
4979eb1 @jtpalmer perltidy
jtpalmer authored
24 is_deeply(
25 $app_x->surface->get_pixels_ptr,
26 $app->get_pixels_ptr, '[display] works'
27 );
d90ee1b @Blaizer Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
28
29 my $surface = SDL::Surface->new( SDL_SWSURFACE, 400, 200, 32 );
30 my @surfs = (
4979eb1 @jtpalmer perltidy
jtpalmer authored
31 SDLx::Surface->new( surface => $surface ),
32 SDLx::Surface->new( width => 400, height => 200 ),
33 SDLx::Surface->new(
34 width => 400,
35 height => 200,
36 flags => SDL_SWSURFACE,
37 depth => 32
38 ),
39 SDLx::Surface->new(
40 width => 400,
41 height => 200,
42 flags => SDL_SWSURFACE,
43 depth => 32,
44 greenmask => 0xFF000000
45 ),
d90ee1b @Blaizer Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
46 );
47
48 foreach my $a (@surfs) {
4979eb1 @jtpalmer perltidy
jtpalmer authored
49 isa_ok( $a, 'SDLx::Surface' );
d90ee1b @Blaizer Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
50
4979eb1 @jtpalmer perltidy
jtpalmer authored
51 isa_ok( $a->surface(), 'SDL::Surface' );
d90ee1b @Blaizer Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
52
4979eb1 @jtpalmer perltidy
jtpalmer authored
53 my $color = $a->[0][0];
54 is( $color, 0, 'Right color returned' );
d90ee1b @Blaizer Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
55
4979eb1 @jtpalmer perltidy
jtpalmer authored
56 $a->[0][0] = 0x00FF00FF;
57 is( $a->[0][0], 0x00FF00FF, 'Right color returned' );
d90ee1b @Blaizer Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
58
4979eb1 @jtpalmer perltidy
jtpalmer authored
59 is( @{$a}, 200, 'Correct Y value' );
d90ee1b @Blaizer Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
60
4979eb1 @jtpalmer perltidy
jtpalmer authored
61 is( @{ $a->[0] }, 400, 'Correct X value' );
d90ee1b @Blaizer Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
62
63 }
64
65 #my $source = SDLx::Surface->new( width=> 400, height=>200, flags=> SDL_SWSURFACE, depth=>32 ),
66
67 is( $surfs[0]->[1][2], 0, 'Checking source pixel is 0' );
68 is( $surfs[1]->[1][2], 0, 'Checking dest pixel is 0' );
69
70 $surfs[0]->[1][2] = 0x00FF00FF;
71
72 is( $surfs[0]->[1][2], 0x00FF00FF, 'Checking that source pixel got written' );
73
74 $surfs[0]->blit( $surfs[1] );
75
76 #SDL::Video::blit_surface( $surfs[0]->surface, SDL::Rect->new(0,0,400,200), $surfs[1]->surface, SDL::Rect->new(0,0,400,200));
77
78 isnt( $surfs[1]->[1][2], 0, 'Pixel blitted from one surface to another' );
79
80 $surfs[1]->blit_by( $surfs[0], undef, [ 1, 0, 0, 0 ] );
81
82 isnt( $surfs[1]->[2][2], 0, 'Pixel by_blitted to another surface with offset' );
83
91586c2 redid perltidy
Tobias Leich authored
84 push @surfs,
4979eb1 @jtpalmer perltidy
jtpalmer authored
85 SDLx::Surface->new(
86 w => 1,
87 h => 1,
88 color => 1,
89 );
d90ee1b @Blaizer Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
90
91 is( $surfs[-1]->[0][0], 1, 'Fill color worked' );
92
93 $surfs[1]->flip();
94
95 pass 'Fliped the surface';
96
97 $surfs[0]->update();
98 pass 'update all surface';
99 $surfs[0]->update( [ 0, 10, 30, 40 ] );
100 pass 'Single rect update';
4979eb1 @jtpalmer perltidy
jtpalmer authored
101 $surfs[0]->update( [ SDL::Rect->new( 0, 1, 2, 3 ), SDL::Rect->new( 2, 4, 5, 6 ) ] );
d90ee1b @Blaizer Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
102 pass 'SDL::Rect array update';
103
564c0a9 @jtpalmer SDLx::Surface::draw_rect tests
jtpalmer authored
104 my @colors = (
105 [ 255, 255, 255, 255 ],
106 [ 255, 255, 0, 255 ],
107 [ 255, 0, 255, 255 ],
108 [ 0, 255, 255, 255 ],
109 [ 255, 0, 0, 255 ],
110 [ 0, 255, 0, 255 ],
111 [ 0, 0, 255, 255 ],
112 [ 0, 0, 0, 255 ],
113 [ 32, 64, 128, 255 ],
114 [ 128, 32, 64, 255 ],
115 [ 64, 128, 32, 255 ],
116 );
117
118 foreach my $c (@colors) {
119 my $color = ( $c->[0] << 24 ) + ( $c->[1] << 16 ) + ( $c->[2] << 8 ) + $c->[3];
120 $surfs[0]->draw_rect( [ 0, 0, 10, 20 ], $color );
121
122 my $num = sprintf('0x%08x', $color);
123
124 my $rgba = SDL::Video::get_RGB( $app->format(), $surfs[0]->[0][0] );
125 is( $rgba->[0], $c->[0], "draw_rect uses correct red for $num" );
126 is( $rgba->[1], $c->[1], "draw_rect uses correct green for $num" );
127 is( $rgba->[2], $c->[2], "draw_rect uses correct blue for $num" );
128
129 #is($rgba->[3], $c->[3], "draw_rect uses correct alpha for $num");
130 }
d90ee1b @Blaizer Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
131
92b0bbc @kthakore Added draw_gfx_text to SDLx:;Surface
kthakore authored
132 SKIP:
133 {
36a0ca5 @kthakore Tidied the code
kthakore authored
134 skip( 'SDL_gfx_primitives needed', 2 ) unless SDL::Config->has('SDL_gfx_primitives');
135 $surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], 0xff00ff );
136 $surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], 0xff00ffff );
137 $surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], 0xff00ffff, 1 );
138 $surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], [ 255, 255, 0, 255 ] );
139 $surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], [ 255, 255, 0, 255 ], 1 );
140 pass 'draw_line works';
141
142 $surfs[1]->draw_gfx_text( [ 0, 0 ], 0xffffffff, "fooo" );
143 $surfs[1]->draw_gfx_text( [ 10, 10 ], [ 20, 20, 20, 20 ], "fooo" );
144 my $f = '';
145 open( my $FH, '<', 'test/data/5x7.fnt' );
146 binmode($FH);
147 read( $FH, $f, 4096 );
148 close($FH);
149 my $font = { data => $f, cw => 5, ch => 7 };
150 $surfs[1]->draw_gfx_text( [ 0, 0 ], 0xffffffff, "fooo", $font );
151 pass 'draw_gfx_text works';
c4cf5b1 @kthakore Added gfx guard for sdlx_surface.t
kthakore authored
152 my $cir_color = [ 255, 0, 0, 255 ];
153 $surfs[0]->draw_circle( [ 100, 10 ], 20, $cir_color ); #no fill
154 $surfs[0]->draw_circle_filled( [ 100, 10 ], 20, $cir_color ); #fill
92b0bbc @kthakore Added draw_gfx_text to SDLx:;Surface
kthakore authored
155
c4cf5b1 @kthakore Added gfx guard for sdlx_surface.t
kthakore authored
156 isnt( $surfs[0]->[100][10], 0 );
157 pass 'draw_circle works';
158 pass 'draw_circle_filled works';
a44ce7d @jtpalmer merge
jtpalmer authored
159
c4cf5b1 @kthakore Added gfx guard for sdlx_surface.t
kthakore authored
160 }
b4dbf65 @kthakore Fixed test for surface. Added tests for circle
kthakore authored
161
a44ce7d @jtpalmer merge
jtpalmer authored
162
d90ee1b @Blaizer Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
163 my $surf_dup = SDLx::Surface::duplicate( $surfs[1] );
164
165 is( $surf_dup->w, $surfs[1]->w, 'Duplicate surf has same width' );
166 is( $surf_dup->h, $surfs[1]->h, 'Duplicate surf has same flags' );
167 is( $surf_dup->flags, $surfs[1]->flags, 'Duplicate surf has same flags' );
4979eb1 @jtpalmer perltidy
jtpalmer authored
168 is( $surf_dup->format->BitsPerPixel,
169 $surfs[1]->format->BitsPerPixel,
170 'Duplicate surf has same bpp'
d90ee1b @Blaizer Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
171 );
172
173 if ($videodriver) {
4979eb1 @jtpalmer perltidy
jtpalmer authored
174 $ENV{SDL_VIDEODRIVER} = $videodriver;
175 } else {
176 delete $ENV{SDL_VIDEODRIVER};
d90ee1b @Blaizer Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
177 }
178
179 pass 'Final SegFault test';
180
181 done_testing;
Something went wrong with that request. Please try again.