File Coverage

blib/lib/SDLx/Surface.pm
Criterion Covered Total %
statement 182 237 76.7
branch 40 82 48.7
condition 33 86 38.3
subroutine 39 46 84.7
pod 0 24 0.0
total 294 475 61.8


line stmt bran cond sub pod time code
1             package SDLx::Surface;
2 10     10   875 use strict;
  10         10  
  10         263  
3 10     10   85 use warnings;
  10         10  
  10         229  
4 10     10   38 use vars qw(@ISA @EXPORT @EXPORT_OK);
  10         8  
  10         651  
5             require Exporter;
6             require DynaLoader;
7 10     10   41 use Carp ();
  10         9  
  10         113  
8 10     10   39 use SDL;
  10         10  
  10         550  
9 10     10   263 use SDL::Rect;
  10         13  
  10         1231  
10 10     10   518 use SDL::Video;
  10         14  
  10         2757  
11 10     10   1773 use SDL::Image;
  10         12  
  10         404  
12 10     10   1290 use SDL::Color;
  10         13  
  10         1839  
13 10     10   1039 use SDL::Config;
  10         11  
  10         166  
14 10     10   34 use SDL::Surface;
  10         8  
  10         1307  
15 10     10   39 use SDL::PixelFormat;
  10         9  
  10         1806  
16              
17 10     10   2351 use SDL::GFX::Primitives;
  10         15  
  10         528  
18              
19 10     10   3722 use Tie::Simple;
  10         75513  
  10         201  
20 10     10   2780 use SDLx::Validate;
  10         19  
  10         327  
21 10     10   2527 use SDLx::Surface::TiedMatrix;
  10         19  
  10         229  
22              
23             use overload (
24 10         68 '@{}' => '_array',
25             fallback => 1,
26 10     10   40 );
  10         13  
27 10     10   584 use SDL::Constants ':SDL::Video';
  10         11  
  10         3677  
28             our @ISA = qw(Exporter DynaLoader SDL::Surface);
29              
30 10     10   46 use SDL::Internal::Loader;
  10         13  
  10         16650  
31             internal_load_dlls(__PACKAGE__);
32              
33             bootstrap SDLx::Surface;
34              
35             # I won't use a module here for efficiency and simplification of the
36             # hierarchy.
37             # Inside out object
38             my %_tied_array;
39              
40             sub new {
41 40     40 0 2907 my ( $class, %options ) = @_;
42 40         40 my $self;
43              
44 40 100       101 if ( $options{surface} ) {
45 32         66 $self = bless $options{surface}, $class;
46             } else {
47 8   66     25 my $width = $options{width} || $options{w};
48 8   66     24 my $height = $options{height} || $options{h};
49 8 50 33     31 if ( $width and $height ) #atleast give a dimension
50             {
51 8   100     28 $options{flags} ||= SDL_ANYFORMAT;
52 8   100     35 $options{depth} ||= 32;
53              
54 8   50     28 $options{redmask} ||= 0xFF000000;
55 8   100     29 $options{greenmask} ||= 0x00FF0000;
56 8   50     26 $options{bluemask} ||= 0x0000FF00;
57 8   50     28 $options{alphamask} ||= 0x000000FF;
58              
59 8         614 $self = bless SDL::Surface->new(
60             $options{flags}, $width, $height,
61             $options{depth}, $options{redmask}, $options{greenmask},
62             $options{bluemask}, $options{alphamask}
63             ), $class;
64             } else {
65 0         0 Carp::confess 'Provide surface, or atleast width and height';
66             }
67             }
68 40 100       87 if ( exists $options{color} ) {
69 1         8 $self->draw_rect( undef, $options{color} );
70             }
71 40         166 return $self;
72             }
73              
74             sub display {
75 1     1 0 1965 my $disp = SDL::Video::get_video_surface;
76 1 50       16 return SDLx::Surface->new( surface => $disp ) if $disp;
77 0         0 my %options = @_;
78              
79 0   0     0 my $width = $options{width} || $options{w};
80 0   0     0 my $height = $options{height} || $options{h};
81 0 0 0     0 if ( $width and $height ) #atleast give a dimension
82             {
83 0   0     0 $options{depth} ||= 32;
84 0   0     0 $options{flags} ||= SDL_ANYFORMAT;
85              
86 0         0 my $surface = SDL::Video::set_video_mode(
87             $width, $height, $options{depth},
88             $options{flags},
89             );
90 0         0 return SDLx::Surface->new( surface => $surface );
91             } else {
92 0         0 Carp::confess 'set_video_mode externally or atleast provide width and height';
93             }
94              
95             }
96              
97             sub duplicate {
98 1     1 0 165 my $surface = shift;
99 1         5 SDLx::Validate::surface($surface);
100 1         25 return SDLx::Surface->new(
101             width => $surface->w,
102             height => $surface->h,
103             depth => $surface->format->BitsPerPixel,
104             flags => $surface->flags
105             );
106              
107             }
108              
109             ### Overloads
110              
111             sub _tied_array {
112 79     79   61 my ( $self, $array ) = @_;
113 79 100       120 if ($array) {
114 5 50       11 $_tied_array{$$self} = $array if $array;
115             }
116 79         94 return $_tied_array{$$self};
117             }
118              
119             sub get_pixel {
120 60     60 0 44 my ( $self, $y, $x ) = @_;
121 60         177 return SDLx::Surface::get_pixel_xs( $self, $x, $y );
122             }
123              
124             sub set_pixel {
125 6     6 0 6 my ( $self, $y, $x, $new_value ) = @_;
126              
127 6         18 $new_value = SDLx::Validate::num_rgba($new_value);
128              
129 6         17 SDLx::Surface::set_pixel_xs( $self, $x, $y, $new_value );
130             }
131              
132             sub _array {
133 74     74   1292 my $self = shift;
134              
135 74         98 my $array = $self->_tied_array;
136              
137 74 100       109 unless ($array) {
138 5         22 tie my @array, 'SDLx::Surface::TiedMatrix', $self;
139 5         6 $array = \@array;
140 5         6 $self->_tied_array($array);
141             }
142 74         199 return $array;
143             }
144              
145             #ATTRIBUTE
146              
147 47     47 0 32045 sub surface { $_[0] }
148              
149 0     0 0 0 sub width { $_[0]->w }
150 0     0 0 0 sub height { $_[0]->h }
151              
152             #WRAPPING
153              
154             sub clip_rect {
155              
156 0 0 0 0 0 0 SDL::Video::set_clip_rect( $_[1] ) if $_[1] && $_[1]->isa('SDL::Rect');
157 0         0 SDL::Video::get_clip_rect( $_[0] );
158              
159             }
160              
161             sub load {
162 11     11 0 23 my ( $self, $filename, $type ) = @_;
163 11         15 my $surface;
164              
165             # short-circuit if it's a bitmap
166 11 50 33     84 if ( ( $type and lc $type eq 'bmp' )
      33        
167             or lc substr( $filename, -4, 4 ) eq '.bmp' )
168             {
169 11 50       1715 $surface = SDL::Video::load_BMP($filename)
170             or Carp::confess "error loading image $filename: " . SDL::get_error;
171             } else {
172              
173             # otherwise, make sure we can load first
174             #eval { require SDL::Image; 1 }; This doesn't work. As you can still load SDL::Image but can't call any functions.
175             #
176 0 0       0 Carp::confess 'no SDL_image support found. Can only load bitmaps'
177             unless SDL::Config->has('SDL_image'); #this checks if we actually have that library. C Library != SDL::Image
178              
179 0         0 require SDL::Image;
180              
181 0 0       0 if ($type) { #I don't understand what you are doing here
182 0         0 require SDL::RWOps;
183 0 0       0 my $file = SDL::RWOps->new_file( $filename, "rb" )
184             or Carp::confess "error loading file $filename: " . SDL::get_error;
185 0 0       0 $surface = SDL::Image::load_typed_rw( $file, 1, $type )
186             or Carp::confess "error loading image $file: " . SDL::get_error;
187             } else {
188 0 0       0 $surface = SDL::Image::load($filename)
189             or Carp::confess "error loading image $filename: " . SDL::get_error;
190             }
191             }
192              
193 11         24 my $formated_surface = $surface;
194 11 50       53 if( SDL::Video::get_video_surface )
195             {
196             #Reduces memory usage for loaded images
197 11         1556 $formated_surface = SDL::Video::display_format_alpha($surface);
198             }
199 11         90 return SDLx::Surface->new( surface => $formated_surface );
200             }
201              
202             #EXTENSTIONS
203              
204             sub blit_by {
205 1     1 0 2 my ( $dest, $src, $src_rect, $dest_rect ) = @_;
206 1         1238 SDLx::Surface::blit( $src, $dest, $src_rect, $dest_rect );
207             }
208              
209             sub flip {
210 1 50   1 0 992 Carp::confess "surface is not defined" unless $_[0];
211 1 50       11 Carp::confess "Error flipping surface: " . SDL::get_error()
212             if ( SDL::Video::flip( $_[0] ) == -1 );
213 1         2 return $_[0];
214              
215             }
216              
217             sub update {
218 3     3 0 667 my ( $surface, $rects ) = @_;
219              
220 3 100 66     32 if ( !defined($rects) || ( ref($rects) eq 'ARRAY' && !ref( $rects->[0] ) ) ) {
      66        
221 2         3 my @rect;
222 2 100       3 @rect = @{$rects} if $rects;
  1         3  
223 2   50     9 $rect[0] ||= 0;
224 2   100     6 $rect[1] ||= 0;
225 2   66     6 $rect[2] ||= $surface->w;
226 2   66     7 $rect[3] ||= $surface->h;
227            
228 2         6 SDL::Video::update_rect( $surface, @rect );
229             } else {
230 1         2 SDL::Video::update_rects( $surface, map { SDLx::Validate::rect($_) } @{$rects} );
  2         10  
  1         3  
231             }
232              
233 3         5 return $surface;
234             }
235              
236             sub draw_line {
237 6     6 0 12 my ( $self, $start, $end, $color, $antialias ) = @_;
238              
239 6 50       11 Carp::confess "Error start needs an array ref [x,y]"
240             unless ref($start) eq 'ARRAY';
241 6 50       8 Carp::confess "Error end needs an array ref [x,y]"
242             unless ref($end) eq 'ARRAY';
243              
244 6 50       11 unless ( SDL::Config->has('SDL_gfx_primitives') ) {
245 0         0 Carp::cluck("SDL_gfx_primitives support has not been compiled");
246 0         0 return;
247             }
248              
249 6         11 $color = SDLx::Validate::num_rgba($color);
250              
251 6         4 my $result;
252 6 100       8 if ($antialias) {
253 2         11 $result = SDL::GFX::Primitives::aaline_color( $self, @$start, @$end, $color );
254             } else {
255 4         24 $result = SDL::GFX::Primitives::line_color( $self, @$start, @$end, $color );
256             }
257              
258 6 50       9 Carp::confess "Error drawing line: " . SDL::get_error() if ( $result == -1 );
259              
260 6         9 return $self;
261             }
262              
263             sub draw_circle {
264 9     9 0 476 my ( $self, $center, $radius, $color, $antialias ) = @_;
265              
266 9 50       13 unless ( SDL::Config->has('SDL_gfx_primitives') ) {
267 0         0 Carp::cluck("SDL_gfx_primitives support has not been compiled");
268 0         0 return;
269             }
270              
271 9 50 33     31 Carp::cluck "Center needs to be an array of format [x,y]" unless ( ref $center eq 'ARRAY' && scalar @$center == 2 );
272 9         22 $color = SDLx::Validate::num_rgba($color);
273              
274 9 100       11 unless( $antialias )
275             {
276 5         4 SDL::GFX::Primitives::circle_color( $self, @{$center}, $radius, $color );
  5         39  
277             }
278             else
279             {
280 4         4 SDL::GFX::Primitives::aacircle_color( $self, @{$center}, $radius, $color );
  4         147  
281             }
282 9         16 return $self;
283             }
284              
285             sub draw_circle_filled {
286 4     4 0 6 my ( $self, $center, $radius, $color) = @_;
287              
288 4 50       8 unless ( SDL::Config->has('SDL_gfx_primitives') ) {
289 0         0 Carp::cluck("SDL_gfx_primitives support has not been compiled");
290 0         0 return;
291             }
292              
293 4 50 33     21 Carp::cluck "Center needs to be an array of format [x,y]" unless ( ref $center eq 'ARRAY' && scalar @$center == 2 );
294 4         11 $color = SDLx::Validate::num_rgba($color);
295              
296 4         6 SDL::GFX::Primitives::filled_circle_color( $self, @{$center}, $radius, $color );
  4         31  
297              
298 4         6 return $self;
299             }
300              
301             sub draw_trigon {
302 9     9 0 666 my ( $self, $vertices, $color, $antialias ) = @_;
303              
304 9         24 $color = SDLx::Validate::num_rgba($color);
305              
306 9 100       11 if ($antialias) {
307 4         21 SDL::GFX::Primitives::aatrigon_color( $self, $vertices->[0][0], $vertices->[0][1], $vertices->[1][0], $vertices->[1][1], $vertices->[2][0], $vertices->[2][1], $color );
308             }
309             else
310             {
311 5         31 SDL::GFX::Primitives::trigon_color( $self, $vertices->[0][0], $vertices->[0][1], $vertices->[1][0], $vertices->[1][1], $vertices->[2][0], $vertices->[2][1], $color );
312             }
313              
314 9         13 return $self;
315             }
316              
317             sub draw_trigon_filled {
318 5     5 0 6 my ( $self, $vertices, $color ) = @_;
319              
320 5         11 $color = SDLx::Validate::num_rgba($color);
321              
322 5         32 SDL::GFX::Primitives::filled_trigon_color( $self, $vertices->[0][0], $vertices->[0][1], $vertices->[1][0], $vertices->[1][1], $vertices->[2][0], $vertices->[2][1], $color );
323              
324 5         7 return $self;
325             }
326              
327             sub draw_polygon_filled {
328 5     5 0 394 my ( $self, $vertices, $color ) = @_;
329              
330 5         15 $color = SDLx::Validate::num_rgba($color);
331              
332 5         9 my @vx = map { $_->[0] } @$vertices;
  3         4  
333 5         6 my @vy = map { $_->[1] } @$vertices;
  3         4  
334 5         21 SDL::GFX::Primitives::filled_polygon_color( $self, \@vx, \@vy, scalar @$vertices, $color );
335              
336 5         8 return $self;
337             }
338              
339             sub draw_arc {
340 0     0 0 0 my ( $self, $center, $radius, $start, $end, $color ) = @_;
341              
342 0 0 0     0 Carp::cluck "Center needs to be an array of format [x,y]" unless ( ref $center eq 'ARRAY' && scalar @$center == 2 );
343 0         0 $color = SDLx::Validate::num_rgba($color);
344              
345 0         0 SDL::GFX::Primitives::arc_color( $self, @$center, $radius, $start, $end, $color );
346              
347 0         0 return $self;
348             }
349              
350             sub draw_ellipse {
351 0     0 0 0 my ( $self, $center, $rx, $ry, $color, $antialias ) = @_;
352              
353 0 0 0     0 Carp::cluck "Center needs to be an array of format [x,y]" unless ( ref $center eq 'ARRAY' && scalar @$center == 2 );
354 0         0 $color = SDLx::Validate::num_rgba($color);
355              
356 0 0       0 if ($antialias)
357             {
358 0         0 SDL::GFX::Primitives::aaellipse_color( $self, @$center, $rx, $ry, $color );
359             }
360             else
361             {
362 0         0 SDL::GFX::Primitives::ellipse_color( $self, @$center, $rx, $ry, $color );
363             }
364              
365 0         0 return $self;
366             }
367              
368             sub draw_ellipse_filled {
369 0     0 0 0 my ( $self, $center, $rx, $ry, $color ) = @_;
370              
371 0 0 0     0 Carp::cluck "Center needs to be an array of format [x,y]" unless ( ref $center eq 'ARRAY' && scalar @$center == 2 );
372 0         0 $color = SDLx::Validate::num_rgba($color);
373              
374 0         0 SDL::GFX::Primitives::filled_ellipse_color( $self, @$center, $rx, $ry, $color );
375              
376 0         0 return $self;
377             }
378              
379             sub draw_bezier {
380 0     0 0 0 my ( $self, $vector, $smooth, $color ) = @_;
381              
382 0         0 $color = SDLx::Validate::num_rgba($color);
383              
384 0         0 my @vx = map { $_->[0] } @$vector;
  0         0  
385 0         0 my @vy = map { $_->[1] } @$vector;
  0         0  
386 0         0 SDL::GFX::Primitives::bezier_color( $self, \@vx, \@vy, scalar @$vector, $smooth, $color );
387              
388 0         0 return $self;
389             }
390              
391             sub draw_gfx_text {
392 3     3 0 5 my ( $self, $vector, $color, $text, $font ) = @_;
393              
394 3 50       8 unless ( SDL::Config->has('SDL_gfx_primitives') ) {
395 0         0 Carp::cluck("SDL_gfx_primitives support has not been compiled");
396 0         0 return;
397             }
398              
399 3 100       6 if ($font) {
400 1 50 33     11 if ( ref($font) eq 'HASH' && exists $font->{data} && exists $font->{cw} && exists $font->{ch} ) {
      33        
      33        
401 1         7 SDL::GFX::Primitives::set_font( $font->{data}, $font->{cw}, $font->{ch} );
402             } else {
403 0         0 Carp::cluck
404             "Set font data as a hash of type \n \$font = {data => \$data, cw => \$cw, ch => \$ch}. \n Refer to perldoc SDL::GFX::Primitives set_font for initializing this variables.";
405             }
406             }
407 3 50 33     13 Carp::confess "vector needs to be an array ref of size 2. [x,y] "
408             unless ( ref($vector) eq 'ARRAY' && scalar(@$vector) == 2 );
409              
410 3         7 $color = SDLx::Validate::num_rgba($color);
411              
412 3         59 my $result = SDL::GFX::Primitives::string_color( $self, $vector->[0], $vector->[1], $text, $color );
413              
414 3 50       5 Carp::confess "Error drawing text: " . SDL::get_error() if ( $result == -1 );
415              
416 3         4 return $self;
417             }
418              
419             sub DESTROY {
420 23     23   1475 my $self = shift;
421 23         122 delete $_tied_array{$$self};
422 23         332 SDL::Surface::DESTROY($self);
423             }
424              
425             1;