/lib/SDLx/Sprite.pm

http://github.com/PerlGameDev/SDL · Perl · 247 lines · 181 code · 55 blank · 11 comment · 25 complexity · 0c8843f53ed5ef74174320f0d4aec0aa MD5 · raw file

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