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; 428