/lib/SDLx/Surface.pm

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