/lib/SDLx/Sprite.pm

  1package SDLx::Sprite;
  2use strict;
  3use warnings;
  4
  5use SDL;
  6use SDL::Video;
  7use SDL::Image;
  8use SDLx::Rect;
  9use SDL::Surface;
 10use SDLx::Surface;
 11use SDLx::Validate;
 12
 13use Carp ();
 14
 15our $VERSION = 2.548;
 16
 17sub new {
 18	my ( $class, %options ) = @_;
 19
 20	my $self = bless {}, $class;
 21	if ( exists $options{surface} ) {
 22		$self->{surface} = SDLx::Surface->new( surface => $options{surface} );
 23		$self->{orig_surface} = $options{surface};
 24		$self->_init_rects(%options);
 25		$self->handle_surface( $self->surface );
 26	} elsif ( exists $options{image} ) {
 27		my $surf = SDLx::Surface->load( $options{image} );
 28		$self->{surface} = SDLx::Surface->new( surface => $surf );
 29		$self->_init_rects(%options);
 30		$self->handle_surface($surf);
 31		$self->{orig_surface} = $self->{surface};
 32	} elsif ( exists $options{width} && $options{height} ) {
 33		$self->{surface}      = SDLx::Surface->new(%options);
 34		$self->{orig_surface} = $self->surface;
 35		$self->_init_rects(%options);
 36		$self->handle_surface( $self->surface );
 37	} else {
 38		Carp::confess "Need a surface => SDL::Surface, an image => name, or ( width => ... , height => ...)";
 39	}
 40
 41	# short-circuit
 42	return $self unless %options;
 43
 44	Carp::confess 'rect cannot be instantiated together with x or y'
 45		if exists $options{rect} and ( exists $options{x} or exists $options{y} );
 46
 47	Carp::confess 'image and surface cannot be instantiated together'
 48		if exists $options{image} and exists $options{surface};
 49
 50	# note: ordering here is somewhat important. If you change anything,
 51	# please rerun the test suite to make sure everything still works :)
 52
 53	$self->x( $options{x} )                 if exists $options{x};
 54	$self->y( $options{y} )                 if exists $options{y};
 55	$self->rotation( $options{rotation} )   if exists $options{rotation};
 56	$self->alpha_key( $options{alpha_key} ) if exists $options{alpha_key};
 57	$self->alpha( $options{alpha} )         if exists $options{alpha};
 58
 59	return $self;
 60}
 61
 62sub _init_rects {
 63	my ( $self, %options ) = @_;
 64
 65	# create our two initial rects
 66	$self->rect(
 67		exists $options{rect}
 68		? $options{rect}
 69		: SDLx::Rect->new( 0, 0, 0, 0 )
 70	);
 71	$self->clip(
 72		exists $options{clip}
 73		? $options{clip}
 74		: SDLx::Rect->new( 0, 0, 0, 0 )
 75	);
 76
 77}
 78
 79sub load {
 80	my ( $self, $filename ) = @_;
 81
 82	my $surface = SDLx::Surface->load($filename);
 83	$self->{orig_surface} = $surface unless $self->{orig_surface};
 84	$self->handle_surface($surface);
 85	return $self;
 86}
 87
 88sub handle_surface {
 89	my ( $self, $surface ) = @_;
 90
 91	# short-circuit
 92	return $self->surface unless $surface;
 93
 94	my $old_surface = $self->surface();
 95	$self->surface($surface);
 96
 97	# update our source and destination rects
 98	$self->rect->w( $surface->w );
 99	$self->rect->h( $surface->h );
100	$self->clip->w( $surface->w );
101	$self->clip->h( $surface->h );
102
103	return $old_surface;
104}
105
106sub rect {
107	my ( $self, $rect ) = @_;
108
109	# short-circuit
110	return $self->{rect} unless $rect;
111
112	return $self->{rect} = SDLx::Validate::rect($rect);
113}
114
115sub clip {
116	my ( $self, $clip ) = @_;
117
118	# short-circuit
119	return $self->{clip} unless $clip;
120
121	return $self->{clip} = SDLx::Validate::rect($clip);
122}
123
124sub x {
125	my ( $self, $x ) = @_;
126
127	if ( defined $x ) {
128		$self->rect->x($x);
129	}
130
131	return $self->rect->x;
132}
133
134sub y {
135	my ( $self, $y ) = @_;
136
137	if ( defined $y ) {
138		$self->rect->y($y);
139	}
140
141	return $self->rect->y;
142}
143
144sub draw {
145	my ( $self, $surface ) = @_;
146	SDLx::Validate::surface($surface);
147	$self->{surface}->blit( $surface, $self->clip, $self->rect );
148	return $self;
149}
150
151sub draw_xy {
152	my ( $self, $surface, $x, $y ) = @_;
153	SDLx::Validate::surface($surface);
154	$self->x($x);
155	$self->y($y);
156	return $self->draw($surface);
157}
158
159sub alpha_key {
160	my ( $self, $color ) = @_;
161
162	$color = SDLx::Validate::color($color);
163	Carp::confess 'SDL::Video::set_video_mode must be called first'
164		unless ref SDL::Video::get_video_surface();
165	$self->{alpha_key} = $color
166		unless $self->{alpha_key}; # keep a copy just in case
167	$self->surface( SDL::Video::display_format( $self->surface ) );
168
169	if ( SDL::Video::set_color_key( $self->surface, SDL_SRCCOLORKEY, $color ) < 0 ) {
170		Carp::confess ' alpha_key died :' . SDL::get_error;
171	}
172
173	return $self;
174}
175
176sub alpha {
177	my ( $self, $value ) = @_;
178
179	$value = int( $value * 0xff ) if $value < 1 and $value > 0;
180
181	$value = 0    if $value < 0;
182	$value = 0xff if $value > 0xff;
183	$self->{alpha} = $value; # keep a copy just in case
184	$self->surface( SDL::Video::display_format( $self->surface ) );
185	my $flags = SDL_SRCALPHA | SDL_RLEACCEL; #this should be predictive
186	if ( SDL::Video::set_alpha( $self->surface, $flags, $value ) < 0 ) {
187		Carp::confess 'alpha died :' . SDL::get_error;
188	}
189
190	return $self;
191}
192
193sub rotation {
194	my ( $self, $angle, $smooth ) = @_;
195
196	if ( $angle && $self->{orig_surface} ) {
197
198		require SDL::GFX::Rotozoom;
199
200		my $rotated = SDL::GFX::Rotozoom::surface(
201			$self->{orig_surface}, #prevents rotting of the surface
202			$angle,
203			1,                     # zoom
204			( defined $smooth && $smooth != 0 )
205		) or Carp::confess 'rotation error: ' . SDL::get_error;
206
207		#After rotation the surface is on a undefined background.
208		#This causes problems with alpha. So we create a surface with a fill of the src_color.
209		#This insures less artifacts.
210		if ( $self->{alpha_key} ) {
211			my $background = SDLx::Surface::duplicate($rotated);
212			$background->draw_rect(
213				[ 0, 0, $background->w, $background->h ],
214				$self->{alpha_key}
215			);
216			SDLx::Surface->new( surface => $rotated )->blit($background);
217
218			$self->handle_surface( $background->surface );
219			$self->alpha_key( $self->{alpha_key} );
220		} else {
221			$self->handle_surface($rotated);
222		}
223
224		$self->alpha( $self->{alpha} ) if $self->{alpha};
225		$self->{angle} = $angle;
226	}
227	return $self->{angle};
228}
229
230sub surface {
231	my ( $self, $surface ) = @_;
232
233	if ($surface) {
234		$self->{surface} = SDLx::Validate::surfacex($surface);
235	}
236	return $self->{surface};
237}
238
239sub w {
240	return $_[0]->{surface}->w;
241}
242
243sub h {
244	return $_[0]->{surface}->h;
245}
246
2471;