/lib/SDLx/Surface.pm

http://github.com/PerlGameDev/SDL · Perl · 427 lines · 315 code · 100 blank · 12 comment · 54 complexity · b22f0f2c075f1e518e76d812b204f245 MD5 · raw file

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