/lib/SDLx/Sprite.pm
http://github.com/PerlGameDev/SDL · Perl · 247 lines · 181 code · 55 blank · 11 comment · 25 complexity · 0c8843f53ed5ef74174320f0d4aec0aa MD5 · raw file
- package SDLx::Sprite;
- use strict;
- use warnings;
- use SDL;
- use SDL::Video;
- use SDL::Image;
- use SDLx::Rect;
- use SDL::Surface;
- use SDLx::Surface;
- use SDLx::Validate;
- use Carp ();
- our $VERSION = 2.548;
- sub new {
- my ( $class, %options ) = @_;
- my $self = bless {}, $class;
- if ( exists $options{surface} ) {
- $self->{surface} = SDLx::Surface->new( surface => $options{surface} );
- $self->{orig_surface} = $options{surface};
- $self->_init_rects(%options);
- $self->handle_surface( $self->surface );
- } elsif ( exists $options{image} ) {
- my $surf = SDLx::Surface->load( $options{image} );
- $self->{surface} = SDLx::Surface->new( surface => $surf );
- $self->_init_rects(%options);
- $self->handle_surface($surf);
- $self->{orig_surface} = $self->{surface};
- } elsif ( exists $options{width} && $options{height} ) {
- $self->{surface} = SDLx::Surface->new(%options);
- $self->{orig_surface} = $self->surface;
- $self->_init_rects(%options);
- $self->handle_surface( $self->surface );
- } else {
- Carp::confess "Need a surface => SDL::Surface, an image => name, or ( width => ... , height => ...)";
- }
- # short-circuit
- return $self unless %options;
- Carp::confess 'rect cannot be instantiated together with x or y'
- if exists $options{rect} and ( exists $options{x} or exists $options{y} );
- Carp::confess 'image and surface cannot be instantiated together'
- if exists $options{image} and exists $options{surface};
- # note: ordering here is somewhat important. If you change anything,
- # please rerun the test suite to make sure everything still works :)
- $self->x( $options{x} ) if exists $options{x};
- $self->y( $options{y} ) if exists $options{y};
- $self->rotation( $options{rotation} ) if exists $options{rotation};
- $self->alpha_key( $options{alpha_key} ) if exists $options{alpha_key};
- $self->alpha( $options{alpha} ) if exists $options{alpha};
- return $self;
- }
- sub _init_rects {
- my ( $self, %options ) = @_;
- # create our two initial rects
- $self->rect(
- exists $options{rect}
- ? $options{rect}
- : SDLx::Rect->new( 0, 0, 0, 0 )
- );
- $self->clip(
- exists $options{clip}
- ? $options{clip}
- : SDLx::Rect->new( 0, 0, 0, 0 )
- );
- }
- sub load {
- my ( $self, $filename ) = @_;
- my $surface = SDLx::Surface->load($filename);
- $self->{orig_surface} = $surface unless $self->{orig_surface};
- $self->handle_surface($surface);
- return $self;
- }
- sub handle_surface {
- my ( $self, $surface ) = @_;
- # short-circuit
- return $self->surface unless $surface;
- my $old_surface = $self->surface();
- $self->surface($surface);
- # update our source and destination rects
- $self->rect->w( $surface->w );
- $self->rect->h( $surface->h );
- $self->clip->w( $surface->w );
- $self->clip->h( $surface->h );
- return $old_surface;
- }
- sub rect {
- my ( $self, $rect ) = @_;
- # short-circuit
- return $self->{rect} unless $rect;
- return $self->{rect} = SDLx::Validate::rect($rect);
- }
- sub clip {
- my ( $self, $clip ) = @_;
- # short-circuit
- return $self->{clip} unless $clip;
- return $self->{clip} = SDLx::Validate::rect($clip);
- }
- sub x {
- my ( $self, $x ) = @_;
- if ( defined $x ) {
- $self->rect->x($x);
- }
- return $self->rect->x;
- }
- sub y {
- my ( $self, $y ) = @_;
- if ( defined $y ) {
- $self->rect->y($y);
- }
- return $self->rect->y;
- }
- sub draw {
- my ( $self, $surface ) = @_;
- SDLx::Validate::surface($surface);
- $self->{surface}->blit( $surface, $self->clip, $self->rect );
- return $self;
- }
- sub draw_xy {
- my ( $self, $surface, $x, $y ) = @_;
- SDLx::Validate::surface($surface);
- $self->x($x);
- $self->y($y);
- return $self->draw($surface);
- }
- sub alpha_key {
- my ( $self, $color ) = @_;
- $color = SDLx::Validate::color($color);
- Carp::confess 'SDL::Video::set_video_mode must be called first'
- unless ref SDL::Video::get_video_surface();
- $self->{alpha_key} = $color
- unless $self->{alpha_key}; # keep a copy just in case
- $self->surface( SDL::Video::display_format( $self->surface ) );
- if ( SDL::Video::set_color_key( $self->surface, SDL_SRCCOLORKEY, $color ) < 0 ) {
- Carp::confess ' alpha_key died :' . SDL::get_error;
- }
- return $self;
- }
- sub alpha {
- my ( $self, $value ) = @_;
- $value = int( $value * 0xff ) if $value < 1 and $value > 0;
- $value = 0 if $value < 0;
- $value = 0xff if $value > 0xff;
- $self->{alpha} = $value; # keep a copy just in case
- $self->surface( SDL::Video::display_format( $self->surface ) );
- my $flags = SDL_SRCALPHA | SDL_RLEACCEL; #this should be predictive
- if ( SDL::Video::set_alpha( $self->surface, $flags, $value ) < 0 ) {
- Carp::confess 'alpha died :' . SDL::get_error;
- }
- return $self;
- }
- sub rotation {
- my ( $self, $angle, $smooth ) = @_;
- if ( $angle && $self->{orig_surface} ) {
- require SDL::GFX::Rotozoom;
- my $rotated = SDL::GFX::Rotozoom::surface(
- $self->{orig_surface}, #prevents rotting of the surface
- $angle,
- 1, # zoom
- ( defined $smooth && $smooth != 0 )
- ) or Carp::confess 'rotation error: ' . SDL::get_error;
- #After rotation the surface is on a undefined background.
- #This causes problems with alpha. So we create a surface with a fill of the src_color.
- #This insures less artifacts.
- if ( $self->{alpha_key} ) {
- my $background = SDLx::Surface::duplicate($rotated);
- $background->draw_rect(
- [ 0, 0, $background->w, $background->h ],
- $self->{alpha_key}
- );
- SDLx::Surface->new( surface => $rotated )->blit($background);
- $self->handle_surface( $background->surface );
- $self->alpha_key( $self->{alpha_key} );
- } else {
- $self->handle_surface($rotated);
- }
- $self->alpha( $self->{alpha} ) if $self->{alpha};
- $self->{angle} = $angle;
- }
- return $self->{angle};
- }
- sub surface {
- my ( $self, $surface ) = @_;
- if ($surface) {
- $self->{surface} = SDLx::Validate::surfacex($surface);
- }
- return $self->{surface};
- }
- sub w {
- return $_[0]->{surface}->w;
- }
- sub h {
- return $_[0]->{surface}->h;
- }
- 1;