Skip to content
This repository
Newer
Older
100644 252 lines (203 sloc) 7.839 kb
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
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;
7212404f » kthakore
2010-09-02 Fixed problem with get_pixels
10 use Data::Dumper;
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
11 use lib 't/lib';
12 use SDL::TestTool;
13
14 my $videodriver = $ENV{SDL_VIDEODRIVER};
15 $ENV{SDL_VIDEODRIVER} = 'dummy' unless $ENV{SDL_RELEASE_TESTING};
16
17 if ( !SDL::TestTool->init(SDL_INIT_VIDEO) ) {
4979eb13 » jtpalmer
2010-07-30 perltidy
18 plan( skip_all => 'Failed to init video' );
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
19 }
20
21 my $app = SDL::Video::set_video_mode( 400, 200, 32, SDL_SWSURFACE );
22
23 my $app_x = SDLx::Surface::display();
24
4979eb13 » jtpalmer
2010-07-30 perltidy
25 is_deeply(
26 $app_x->surface->get_pixels_ptr,
27 $app->get_pixels_ptr, '[display] works'
28 );
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
29
30 my $surface = SDL::Surface->new( SDL_SWSURFACE, 400, 200, 32 );
31 my @surfs = (
4979eb13 » jtpalmer
2010-07-30 perltidy
32 SDLx::Surface->new( surface => $surface ),
33 SDLx::Surface->new( width => 400, height => 200 ),
34 SDLx::Surface->new(
35 width => 400,
36 height => 200,
37 flags => SDL_SWSURFACE,
38 depth => 32
39 ),
40 SDLx::Surface->new(
41 width => 400,
42 height => 200,
43 flags => SDL_SWSURFACE,
44 depth => 32,
45 greenmask => 0xFF000000
46 ),
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
47 );
48
49 foreach my $a (@surfs) {
4979eb13 » jtpalmer
2010-07-30 perltidy
50 isa_ok( $a, 'SDLx::Surface' );
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
51
4979eb13 » jtpalmer
2010-07-30 perltidy
52 isa_ok( $a->surface(), 'SDL::Surface' );
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
53
4979eb13 » jtpalmer
2010-07-30 perltidy
54 my $color = $a->[0][0];
55 is( $color, 0, 'Right color returned' );
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
56
4979eb13 » jtpalmer
2010-07-30 perltidy
57 $a->[0][0] = 0x00FF00FF;
58 is( $a->[0][0], 0x00FF00FF, 'Right color returned' );
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
59
4979eb13 » jtpalmer
2010-07-30 perltidy
60 is( @{$a}, 200, 'Correct Y value' );
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
61
4979eb13 » jtpalmer
2010-07-30 perltidy
62 is( @{ $a->[0] }, 400, 'Correct X value' );
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
63
64 }
65
66 #my $source = SDLx::Surface->new( width=> 400, height=>200, flags=> SDL_SWSURFACE, depth=>32 ),
67
68 is( $surfs[0]->[1][2], 0, 'Checking source pixel is 0' );
69 is( $surfs[1]->[1][2], 0, 'Checking dest pixel is 0' );
70
36c35116 » kthakore
2010-10-10 Test to see other values for pixels
71 $surfs[0]->[4][4] = [255,255,0,255];
72
73 is( $surfs[0]->[4][4] , 0xFFFF00FF, "Surface can set pixel with other color values");
74
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
75 $surfs[0]->[1][2] = 0x00FF00FF;
76
77 is( $surfs[0]->[1][2], 0x00FF00FF, 'Checking that source pixel got written' );
78
79 $surfs[0]->blit( $surfs[1] );
80
81 #SDL::Video::blit_surface( $surfs[0]->surface, SDL::Rect->new(0,0,400,200), $surfs[1]->surface, SDL::Rect->new(0,0,400,200));
82
83 isnt( $surfs[1]->[1][2], 0, 'Pixel blitted from one surface to another' );
84
85 $surfs[1]->blit_by( $surfs[0], undef, [ 1, 0, 0, 0 ] );
86
87 isnt( $surfs[1]->[2][2], 0, 'Pixel by_blitted to another surface with offset' );
88
91586c22 » Tobias Leich
2010-07-22 redid perltidy
89 push @surfs,
4979eb13 » jtpalmer
2010-07-30 perltidy
90 SDLx::Surface->new(
91 w => 1,
92 h => 1,
17051051 » jtpalmer
2010-09-05 Changed some numbers and changed some to hex
93 color => 0x204080FF,
4979eb13 » jtpalmer
2010-07-30 perltidy
94 );
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
95
30533c9d » jtpalmer
2010-09-08 SDLx::Validate::map_rgb[a] needs a pixel format
96 my $fill = SDL::Video::get_RGBA( $surfs[-1]->surface()->format(), $surfs[-1]->[0][0] );
c69445b9 » jtpalmer
2010-09-05 Fixed test to work with mapped colors
97
17051051 » jtpalmer
2010-09-05 Changed some numbers and changed some to hex
98 is( $fill->[0], 0x20, 'Fill color red worked' );
99 is( $fill->[1], 0x40, 'Fill color green worked' );
100 is( $fill->[2], 0x80, 'Fill color blue worked' );
c69445b9 » jtpalmer
2010-09-05 Fixed test to work with mapped colors
101 is( $fill->[3], 0xFF, 'Fill color alpha worked' );
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
102
103 $surfs[1]->flip();
104
105 pass 'Fliped the surface';
106
107 $surfs[0]->update();
108 pass 'update all surface';
109 $surfs[0]->update( [ 0, 10, 30, 40 ] );
110 pass 'Single rect update';
4979eb13 » jtpalmer
2010-07-30 perltidy
111 $surfs[0]->update( [ SDL::Rect->new( 0, 1, 2, 3 ), SDL::Rect->new( 2, 4, 5, 6 ) ] );
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
112 pass 'SDL::Rect array update';
113
564c0a9f » jtpalmer
2010-09-02 SDLx::Surface::draw_rect tests
114 my @colors = (
9d81f881 » garu
2011-03-15 pushing some failing tests for SDLx::Surface
115 # opaque
17051051 » jtpalmer
2010-09-05 Changed some numbers and changed some to hex
116 [ 0xFF, 0xFF, 0xFF, 0xFF ],
117 [ 0xFF, 0xFF, 0x00, 0xFF ],
118 [ 0xFF, 0x00, 0xFF, 0xFF ],
119 [ 0x00, 0xFF, 0xFF, 0xFF ],
120 [ 0xFF, 0x00, 0x00, 0xFF ],
121 [ 0x00, 0xFF, 0x00, 0xFF ],
122 [ 0x00, 0x00, 0xFF, 0xFF ],
123 [ 0x00, 0x00, 0x00, 0xFF ],
124 [ 0x20, 0x40, 0x80, 0xFF ],
125 [ 0x80, 0x20, 0x40, 0xFF ],
126 [ 0x40, 0x80, 0x20, 0xFF ],
9d81f881 » garu
2011-03-15 pushing some failing tests for SDLx::Surface
127
128 # translucent
129 [ 0xFF, 0xFF, 0xFF, 0xCC ],
130 [ 0xFF, 0xFF, 0x00, 0xCC ],
131 [ 0xFF, 0x00, 0xFF, 0xCC ],
132 [ 0x00, 0xFF, 0xFF, 0xCC ],
133 [ 0xFF, 0x00, 0x00, 0xCC ],
134 [ 0x00, 0xFF, 0x00, 0xCC ],
135 [ 0x00, 0x00, 0xFF, 0xCC ],
136 [ 0x00, 0x00, 0x00, 0xCC ],
137 [ 0x20, 0x40, 0x80, 0xCC ],
138 [ 0x80, 0x20, 0x40, 0xCC ],
139 [ 0x40, 0x80, 0x20, 0xCC ],
140
141 # transparent
142 [ 0xFF, 0xFF, 0xFF, 0x00 ],
143 [ 0xFF, 0xFF, 0x00, 0x00 ],
144 [ 0xFF, 0x00, 0xFF, 0x00 ],
145 [ 0x00, 0xFF, 0xFF, 0x00 ],
146 [ 0xFF, 0x00, 0x00, 0x00 ],
147 [ 0x00, 0xFF, 0x00, 0x00 ],
148 [ 0x00, 0x00, 0xFF, 0x00 ],
149 [ 0x00, 0x00, 0x00, 0x00 ],
150 [ 0x20, 0x40, 0x80, 0x00 ],
151 [ 0x80, 0x20, 0x40, 0x00 ],
152 [ 0x40, 0x80, 0x20, 0x00 ],
564c0a9f » jtpalmer
2010-09-02 SDLx::Surface::draw_rect tests
153 );
154
155 foreach my $c (@colors) {
156 my $color = ( $c->[0] << 24 ) + ( $c->[1] << 16 ) + ( $c->[2] << 8 ) + $c->[3];
7212404f » kthakore
2010-09-02 Fixed problem with get_pixels
157 $surfs[0]->draw_rect( [ 0, 0, 10, 20 ], $c );
564c0a9f » jtpalmer
2010-09-02 SDLx::Surface::draw_rect tests
158
b2df9dff » jtpalmer
2010-09-05 perltidy
159 my $num = sprintf( '0x%08x', $color );
564c0a9f » jtpalmer
2010-09-02 SDLx::Surface::draw_rect tests
160
30533c9d » jtpalmer
2010-09-08 SDLx::Validate::map_rgb[a] needs a pixel format
161 my $rgba = SDL::Video::get_RGBA( $surfs[0]->surface()->format(), $surfs[0]->[0][0] );
564c0a9f » jtpalmer
2010-09-02 SDLx::Surface::draw_rect tests
162
c69445b9 » jtpalmer
2010-09-05 Fixed test to work with mapped colors
163 is( $rgba->[0], $c->[0], "draw_rect uses correct red for $num" );
164 is( $rgba->[1], $c->[1], "draw_rect uses correct green for $num" );
165 is( $rgba->[2], $c->[2], "draw_rect uses correct blue for $num" );
166 is( $rgba->[3], $c->[3], "draw_rect uses correct alpha for $num" );
564c0a9f » jtpalmer
2010-09-02 SDLx::Surface::draw_rect tests
167 }
45e1ce5e » jtpalmer
2010-09-02 Revert "SDLx::Surface::draw_rect tests"
168 $surfs[0]->draw_rect( [ 0, 0, 10, 20 ], 0xFF00FFFF );
169 pass 'draw_rect works';
92b0bbc5 » kthakore
2010-08-18 Added draw_gfx_text to SDLx:;Surface
170 SKIP:
171 {
36a0ca5c » kthakore
2010-08-31 Tidied the code
172 skip( 'SDL_gfx_primitives needed', 2 ) unless SDL::Config->has('SDL_gfx_primitives');
7a03eba1 » jtpalmer
2011-06-30 SDLx::Surface::draw_polygon should return $self
173
174 is( $surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], 0xff00ffff ), $surfs[1], 'draw_line returns self' );
175
36a0ca5c » kthakore
2010-08-31 Tidied the code
176 $surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], 0xff00ff );
177 $surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], 0xff00ffff );
178 $surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], 0xff00ffff, 1 );
179 $surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], [ 255, 255, 0, 255 ] );
180 $surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], [ 255, 255, 0, 255 ], 1 );
181 pass 'draw_line works';
182
183 $surfs[1]->draw_gfx_text( [ 0, 0 ], 0xffffffff, "fooo" );
184 $surfs[1]->draw_gfx_text( [ 10, 10 ], [ 20, 20, 20, 20 ], "fooo" );
185 my $f = '';
186 open( my $FH, '<', 'test/data/5x7.fnt' );
187 binmode($FH);
188 read( $FH, $f, 4096 );
189 close($FH);
190 my $font = { data => $f, cw => 5, ch => 7 };
191 $surfs[1]->draw_gfx_text( [ 0, 0 ], 0xffffffff, "fooo", $font );
192 pass 'draw_gfx_text works';
c33c9811 » kthakore
2010-09-10 Using cluck and confess now. Perltidied too
193 my @colors_t = ( [ 255, 0, 0, 255 ], 0xFF0000FF, 0xFF00FF, [ 255, 0, 255 ] );
194
7a03eba1 » jtpalmer
2011-06-30 SDLx::Surface::draw_polygon should return $self
195 is( $surfs[0]->draw_circle( [ 100, 10 ], 20, [ 0, 0, 0, 0] ), $surfs[0], 'draw_circle returns self' );
c33c9811 » kthakore
2010-09-10 Using cluck and confess now. Perltidied too
196 foreach my $cir_color (@colors_t) {
197 my $cir_color = [ 255, 0, 0, 255 ];
198 $surfs[0]->draw_circle( [ 100, 10 ], 20, $cir_color ); #no fill
81edab8c » kthakore
2010-10-26 Added antialias for unfilled color circle in SDLx::Surface
199 $surfs[0]->draw_circle( [ 102, 12 ], 22, $cir_color , 1 );
c33c9811 » kthakore
2010-09-10 Using cluck and confess now. Perltidied too
200 $surfs[0]->draw_circle_filled( [ 100, 10 ], 20, $cir_color ); #fill
201 isnt( $surfs[0]->[100][10], 0 );
202 pass 'draw_circle works';
203 pass 'draw_circle_filled works';
e46cfcf9 » kthakore
2010-09-09 Testing all types for circle. Fixed draw_line validate for color. Fix…
204 }
a44ce7da » jtpalmer
2010-07-30 merge
205
7a03eba1 » jtpalmer
2011-06-30 SDLx::Surface::draw_polygon should return $self
206 is( $surfs[0]->draw_trigon( [ [100, 10], [110, 10], [110, 20] ], [ 255, 0, 0, 255 ] ), $surfs[0], 'draw_trigon returns self' );
207 is( $surfs[0]->draw_trigon_filled( [ [100, 10], [110, 10], [110, 20] ], [ 255, 0, 0, 255 ] ), $surfs[0], 'draw_trigon_filled returns self' );
ed234399 » jtpalmer
2011-06-30 Added draw_trigon, made changes to draw_polygon
208 foreach my $color (@colors_t) {
209 my $color = [ 255, 0, 0, 255 ];
210 my $verts = [ [100, 10], [110, 10], [110, 20] ];
211 $surfs[0]->draw_trigon( $verts, $color ); #no fill
212 $surfs[0]->draw_trigon( $verts, $color, 1 );
213 $surfs[0]->draw_trigon_filled( $verts, $color ); #fill
214 isnt( $surfs[0]->[100][10], 0 );
215 pass 'draw_trigon works';
216 pass 'draw_trigon_filled works';
217 }
218
7a03eba1 » jtpalmer
2011-06-30 SDLx::Surface::draw_polygon should return $self
219 is( $surfs[0]->draw_polygon( [ [100, 10], [110, 10], [110, 20] ], [ 255, 0, 0, 255 ] ), $surfs[0], 'draw_polygon returns self' );
220 is( $surfs[0]->draw_polygon_filled( [ [100, 10], [110, 10], [110, 20] ], [ 255, 0, 0, 255 ] ), $surfs[0], 'draw_polygon_filled returns self' );
ed234399 » jtpalmer
2011-06-30 Added draw_trigon, made changes to draw_polygon
221 foreach my $color (@colors_t) {
222 my $color = [ 255, 0, 0, 255 ];
223 my $verts = [ [100, 10], [110, 10], [110, 20], [100, 20] ];
224 $surfs[0]->draw_polygon( $verts, $color ); #no fill
225 $surfs[0]->draw_polygon( $verts, $color, 1 );
226 $surfs[0]->draw_polygon_filled( $verts, $color ); #fill
227 isnt( $surfs[0]->[100][10], 0 );
228 pass 'draw_polygon works';
229 pass 'draw_polygon_filled works';
230 }
c4cf5b19 » kthakore
2010-09-01 Added gfx guard for sdlx_surface.t
231 }
b4dbf65c » kthakore
2010-08-30 Fixed test for surface. Added tests for circle
232
a44ce7da » jtpalmer
2010-07-30 merge
233
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
234 my $surf_dup = SDLx::Surface::duplicate( $surfs[1] );
235
236 is( $surf_dup->w, $surfs[1]->w, 'Duplicate surf has same width' );
237 is( $surf_dup->h, $surfs[1]->h, 'Duplicate surf has same flags' );
238 is( $surf_dup->flags, $surfs[1]->flags, 'Duplicate surf has same flags' );
4979eb13 » jtpalmer
2010-07-30 perltidy
239 is( $surf_dup->format->BitsPerPixel,
240 $surfs[1]->format->BitsPerPixel,
241 'Duplicate surf has same bpp'
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
242 );
243
244 if ($videodriver) {
4979eb13 » jtpalmer
2010-07-30 perltidy
245 $ENV{SDL_VIDEODRIVER} = $videodriver;
246 } else {
247 delete $ENV{SDL_VIDEODRIVER};
d90ee1be » Blaizer
2010-07-22 Misc stuff for SDLx::Surface. Pod and test too ^_^
248 }
249
250 pass 'Final SegFault test';
251
252 done_testing;
Something went wrong with that request. Please try again.