Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 197 lines (152 sloc) 5.624 kb
d90ee1b Blaise Roth 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;
7212404 Kartik Thakore Fixed problem with get_pixels
kthakore authored
10 use Data::Dumper;
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
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) ) {
4979eb1 Jeffrey T. Palmer perltidy
jtpalmer authored
18 plan( skip_all => 'Failed to init video' );
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
19 }
20
21 my $app = SDL::Video::set_video_mode( 400, 200, 32, SDL_SWSURFACE );
22
23 my $app_x = SDLx::Surface::display();
24
4979eb1 Jeffrey T. Palmer perltidy
jtpalmer authored
25 is_deeply(
26 $app_x->surface->get_pixels_ptr,
27 $app->get_pixels_ptr, '[display] works'
28 );
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
29
30 my $surface = SDL::Surface->new( SDL_SWSURFACE, 400, 200, 32 );
31 my @surfs = (
4979eb1 Jeffrey T. Palmer perltidy
jtpalmer authored
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 ),
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
47 );
48
49 foreach my $a (@surfs) {
4979eb1 Jeffrey T. Palmer perltidy
jtpalmer authored
50 isa_ok( $a, 'SDLx::Surface' );
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
51
4979eb1 Jeffrey T. Palmer perltidy
jtpalmer authored
52 isa_ok( $a->surface(), 'SDL::Surface' );
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
53
4979eb1 Jeffrey T. Palmer perltidy
jtpalmer authored
54 my $color = $a->[0][0];
55 is( $color, 0, 'Right color returned' );
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
56
4979eb1 Jeffrey T. Palmer perltidy
jtpalmer authored
57 $a->[0][0] = 0x00FF00FF;
58 is( $a->[0][0], 0x00FF00FF, 'Right color returned' );
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
59
4979eb1 Jeffrey T. Palmer perltidy
jtpalmer authored
60 is( @{$a}, 200, 'Correct Y value' );
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
61
4979eb1 Jeffrey T. Palmer perltidy
jtpalmer authored
62 is( @{ $a->[0] }, 400, 'Correct X value' );
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
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
36c3511 Kartik Thakore Test to see other values for pixels
kthakore authored
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
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
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
91586c2 redid perltidy
Tobias Leich authored
89 push @surfs,
4979eb1 Jeffrey T. Palmer perltidy
jtpalmer authored
90 SDLx::Surface->new(
91 w => 1,
92 h => 1,
1705105 Jeffrey T. Palmer Changed some numbers and changed some to hex
jtpalmer authored
93 color => 0x204080FF,
4979eb1 Jeffrey T. Palmer perltidy
jtpalmer authored
94 );
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
95
30533c9 Jeffrey T. Palmer SDLx::Validate::map_rgb[a] needs a pixel format
jtpalmer authored
96 my $fill = SDL::Video::get_RGBA( $surfs[-1]->surface()->format(), $surfs[-1]->[0][0] );
c69445b Jeffrey T. Palmer Fixed test to work with mapped colors
jtpalmer authored
97
1705105 Jeffrey T. Palmer Changed some numbers and changed some to hex
jtpalmer authored
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' );
c69445b Jeffrey T. Palmer Fixed test to work with mapped colors
jtpalmer authored
101 is( $fill->[3], 0xFF, 'Fill color alpha worked' );
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
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';
4979eb1 Jeffrey T. Palmer perltidy
jtpalmer authored
111 $surfs[0]->update( [ SDL::Rect->new( 0, 1, 2, 3 ), SDL::Rect->new( 2, 4, 5, 6 ) ] );
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
112 pass 'SDL::Rect array update';
113
564c0a9 Jeffrey T. Palmer SDLx::Surface::draw_rect tests
jtpalmer authored
114 my @colors = (
1705105 Jeffrey T. Palmer Changed some numbers and changed some to hex
jtpalmer authored
115 [ 0xFF, 0xFF, 0xFF, 0xFF ],
116 [ 0xFF, 0xFF, 0x00, 0xFF ],
117 [ 0xFF, 0x00, 0xFF, 0xFF ],
118 [ 0x00, 0xFF, 0xFF, 0xFF ],
119 [ 0xFF, 0x00, 0x00, 0xFF ],
120 [ 0x00, 0xFF, 0x00, 0xFF ],
121 [ 0x00, 0x00, 0xFF, 0xFF ],
122 [ 0x00, 0x00, 0x00, 0xFF ],
123 [ 0x20, 0x40, 0x80, 0xFF ],
124 [ 0x80, 0x20, 0x40, 0xFF ],
125 [ 0x40, 0x80, 0x20, 0xFF ],
564c0a9 Jeffrey T. Palmer SDLx::Surface::draw_rect tests
jtpalmer authored
126 );
127
128 foreach my $c (@colors) {
129 my $color = ( $c->[0] << 24 ) + ( $c->[1] << 16 ) + ( $c->[2] << 8 ) + $c->[3];
7212404 Kartik Thakore Fixed problem with get_pixels
kthakore authored
130 $surfs[0]->draw_rect( [ 0, 0, 10, 20 ], $c );
564c0a9 Jeffrey T. Palmer SDLx::Surface::draw_rect tests
jtpalmer authored
131
b2df9df Jeffrey T. Palmer perltidy
jtpalmer authored
132 my $num = sprintf( '0x%08x', $color );
564c0a9 Jeffrey T. Palmer SDLx::Surface::draw_rect tests
jtpalmer authored
133
30533c9 Jeffrey T. Palmer SDLx::Validate::map_rgb[a] needs a pixel format
jtpalmer authored
134 my $rgba = SDL::Video::get_RGBA( $surfs[0]->surface()->format(), $surfs[0]->[0][0] );
564c0a9 Jeffrey T. Palmer SDLx::Surface::draw_rect tests
jtpalmer authored
135
c69445b Jeffrey T. Palmer Fixed test to work with mapped colors
jtpalmer authored
136 is( $rgba->[0], $c->[0], "draw_rect uses correct red for $num" );
137 is( $rgba->[1], $c->[1], "draw_rect uses correct green for $num" );
138 is( $rgba->[2], $c->[2], "draw_rect uses correct blue for $num" );
139 is( $rgba->[3], $c->[3], "draw_rect uses correct alpha for $num" );
564c0a9 Jeffrey T. Palmer SDLx::Surface::draw_rect tests
jtpalmer authored
140 }
45e1ce5 Jeffrey T. Palmer Revert "SDLx::Surface::draw_rect tests"
jtpalmer authored
141 $surfs[0]->draw_rect( [ 0, 0, 10, 20 ], 0xFF00FFFF );
142 pass 'draw_rect works';
92b0bbc Kartik Thakore Added draw_gfx_text to SDLx:;Surface
kthakore authored
143 SKIP:
144 {
36a0ca5 Kartik Thakore Tidied the code
kthakore authored
145 skip( 'SDL_gfx_primitives needed', 2 ) unless SDL::Config->has('SDL_gfx_primitives');
146 $surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], 0xff00ff );
147 $surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], 0xff00ffff );
148 $surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], 0xff00ffff, 1 );
149 $surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], [ 255, 255, 0, 255 ] );
150 $surfs[1]->draw_line( [ 0, 10 ], [ 20, 10 ], [ 255, 255, 0, 255 ], 1 );
151 pass 'draw_line works';
152
153 $surfs[1]->draw_gfx_text( [ 0, 0 ], 0xffffffff, "fooo" );
154 $surfs[1]->draw_gfx_text( [ 10, 10 ], [ 20, 20, 20, 20 ], "fooo" );
155 my $f = '';
156 open( my $FH, '<', 'test/data/5x7.fnt' );
157 binmode($FH);
158 read( $FH, $f, 4096 );
159 close($FH);
160 my $font = { data => $f, cw => 5, ch => 7 };
161 $surfs[1]->draw_gfx_text( [ 0, 0 ], 0xffffffff, "fooo", $font );
162 pass 'draw_gfx_text works';
c33c981 Kartik Thakore Using cluck and confess now. Perltidied too
kthakore authored
163 my @colors_t = ( [ 255, 0, 0, 255 ], 0xFF0000FF, 0xFF00FF, [ 255, 0, 255 ] );
164
165 foreach my $cir_color (@colors_t) {
166 my $cir_color = [ 255, 0, 0, 255 ];
167 $surfs[0]->draw_circle( [ 100, 10 ], 20, $cir_color ); #no fill
81edab8 Kartik Thakore Added antialias for unfilled color circle in SDLx::Surface
kthakore authored
168 $surfs[0]->draw_circle( [ 102, 12 ], 22, $cir_color , 1 );
c33c981 Kartik Thakore Using cluck and confess now. Perltidied too
kthakore authored
169 $surfs[0]->draw_circle_filled( [ 100, 10 ], 20, $cir_color ); #fill
170 isnt( $surfs[0]->[100][10], 0 );
171 pass 'draw_circle works';
172 pass 'draw_circle_filled works';
e46cfcf Kartik Thakore Testing all types for circle. Fixed draw_line validate for color. Fixed ...
kthakore authored
173 }
a44ce7d Jeffrey T. Palmer merge
jtpalmer authored
174
c4cf5b1 Kartik Thakore Added gfx guard for sdlx_surface.t
kthakore authored
175 }
b4dbf65 Kartik Thakore Fixed test for surface. Added tests for circle
kthakore authored
176
a44ce7d Jeffrey T. Palmer merge
jtpalmer authored
177
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
178 my $surf_dup = SDLx::Surface::duplicate( $surfs[1] );
179
180 is( $surf_dup->w, $surfs[1]->w, 'Duplicate surf has same width' );
181 is( $surf_dup->h, $surfs[1]->h, 'Duplicate surf has same flags' );
182 is( $surf_dup->flags, $surfs[1]->flags, 'Duplicate surf has same flags' );
4979eb1 Jeffrey T. Palmer perltidy
jtpalmer authored
183 is( $surf_dup->format->BitsPerPixel,
184 $surfs[1]->format->BitsPerPixel,
185 'Duplicate surf has same bpp'
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
186 );
187
188 if ($videodriver) {
4979eb1 Jeffrey T. Palmer perltidy
jtpalmer authored
189 $ENV{SDL_VIDEODRIVER} = $videodriver;
190 } else {
191 delete $ENV{SDL_VIDEODRIVER};
d90ee1b Blaise Roth Misc stuff for SDLx::Surface. Pod and test too ^_^
Blaizer authored
192 }
193
194 pass 'Final SegFault test';
195
196 done_testing;
Something went wrong with that request. Please try again.