package SDLx::Surface;
use strict;
use warnings;
use vars qw(@ISA @EXPORT @EXPORT_OK);
require Exporter;
require DynaLoader;
use Carp ();
use SDL;
use SDL::Rect;
use SDL::Video;
use SDL::Image;
use SDL::Color;
use SDL::Config;
use SDL::Surface;
use SDL::PixelFormat;
use SDL::GFX::Primitives;
use Tie::Simple;
use SDLx::Validate;
use SDLx::Surface::TiedMatrix;
use overload (
'@{}' => '_array',
fallback => 1,
);
use SDL::Constants ':SDL::Video';
our @ISA = qw(Exporter DynaLoader SDL::Surface);
use SDL::Internal::Loader;
internal_load_dlls(__PACKAGE__);
bootstrap SDLx::Surface;
# I won't use a module here for efficiency and simplification of the
# hierarchy.
# Inside out object
my %_tied_array;
sub new {
my ( $class, %options ) = @_;
my $self;
if ( $options{surface} ) {
$self = bless $options{surface}, $class;
} else {
my $width = $options{width} || $options{w};
my $height = $options{height} || $options{h};
if ( $width and $height ) #atleast give a dimension
{
$options{flags} ||= SDL_ANYFORMAT;
$options{depth} ||= 32;
$options{redmask} ||= 0xFF000000;
$options{greenmask} ||= 0x00FF0000;
$options{bluemask} ||= 0x0000FF00;
$options{alphamask} ||= 0x000000FF;
$self = bless SDL::Surface->new(
$options{flags}, $width, $height,
$options{depth}, $options{redmask}, $options{greenmask},
$options{bluemask}, $options{alphamask}
), $class;
} else {
Carp::confess 'Provide surface, or atleast width and height';
}
}
if ( exists $options{color} ) {
$self->draw_rect( undef, $options{color} );
}
return $self;
}
sub display {
my $disp = SDL::Video::get_video_surface;
return SDLx::Surface->new( surface => $disp ) if $disp;
my %options = @_;
my $width = $options{width} || $options{w};
my $height = $options{height} || $options{h};
if ( $width and $height ) #atleast give a dimension
{
$options{depth} ||= 32;
$options{flags} ||= SDL_ANYFORMAT;
my $surface = SDL::Video::set_video_mode(
$width, $height, $options{depth},
$options{flags},
);
return SDLx::Surface->new( surface => $surface );
} else {
Carp::confess 'set_video_mode externally or atleast provide width and height';
}
}
sub duplicate {
my $surface = shift;
SDLx::Validate::surface($surface);
return SDLx::Surface->new(
width => $surface->w,
height => $surface->h,
depth => $surface->format->BitsPerPixel,
flags => $surface->flags
);
}
### Overloads
sub _tied_array {
my ( $self, $array ) = @_;
if ($array) {
$_tied_array{$$self} = $array if $array;
}
return $_tied_array{$$self};
}
sub get_pixel {
my ( $self, $y, $x ) = @_;
return SDLx::Surface::get_pixel_xs( $self, $x, $y );
}
sub set_pixel {
my ( $self, $y, $x, $new_value ) = @_;
$new_value = SDLx::Validate::num_rgba($new_value);
SDLx::Surface::set_pixel_xs( $self, $x, $y, $new_value );
}
sub _array {
my $self = shift;
my $array = $self->_tied_array;
unless ($array) {
tie my @array, 'SDLx::Surface::TiedMatrix', $self;
$array = \@array;
$self->_tied_array($array);
}
return $array;
}
#ATTRIBUTE
sub surface { $_[0] }
sub width { $_[0]->w }
sub height { $_[0]->h }
#WRAPPING
sub clip_rect {
SDL::Video::set_clip_rect( $_[1] ) if $_[1] && $_[1]->isa('SDL::Rect');
SDL::Video::get_clip_rect( $_[0] );
}
sub load {
my ( $self, $filename, $type ) = @_;
my $surface;
# short-circuit if it's a bitmap
if ( ( $type and lc $type eq 'bmp' )
or lc substr( $filename, -4, 4 ) eq '.bmp' )
{
$surface = SDL::Video::load_BMP($filename)
or Carp::confess "error loading image $filename: " . SDL::get_error;
} else {
# otherwise, make sure we can load first
#eval { require SDL::Image; 1 }; This doesn't work. As you can still load SDL::Image but can't call any functions.
#
Carp::confess 'no SDL_image support found. Can only load bitmaps'
unless SDL::Config->has('SDL_image'); #this checks if we actually have that library. C Library != SDL::Image
require SDL::Image;
if ($type) { #I don't understand what you are doing here
require SDL::RWOps;
my $file = SDL::RWOps->new_file( $filename, "rb" )
or Carp::confess "error loading file $filename: " . SDL::get_error;
$surface = SDL::Image::load_typed_rw( $file, 1, $type )
or Carp::confess "error loading image $file: " . SDL::get_error;
} else {
$surface = SDL::Image::load($filename)
or Carp::confess "error loading image $filename: " . SDL::get_error;
}
}
my $formated_surface = $surface;
if( SDL::Video::get_video_surface )
{
#Reduces memory usage for loaded images
$formated_surface = SDL::Video::display_format_alpha($surface);
}
return SDLx::Surface->new( surface => $formated_surface );
}
#EXTENSTIONS
sub blit {
my ( $src, $dest, $src_rect, $dest_rect ) = @_;
$src = SDLx::Validate::surface($src);
$dest = SDLx::Validate::surface($dest);
if(defined $src_rect) {
$src_rect = SDLx::Validate::rect($src_rect);
}
else {
$src_rect = SDL::Rect->new( 0, 0, $src->w, $src->h );
}
if(defined $dest_rect) {
$dest_rect = SDLx::Validate::rect($dest_rect);
}
else {
$dest_rect = SDL::Rect->new( 0, 0, $dest->w, $dest->h );
}
SDL::Video::blit_surface(
$src, $src_rect,
$dest, $dest_rect
);
return $src;
}
sub blit_by {
my ( $dest, $src, $src_rect, $dest_rect ) = @_;
SDLx::Surface::blit( $src, $dest, $src_rect, $dest_rect );
}
sub flip {
Carp::confess "surface is not defined" unless $_[0];
Carp::confess "Error flipping surface: " . SDL::get_error()
if ( SDL::Video::flip( $_[0] ) == -1 );
return $_[0];
}
sub update {
my ( $surface, $rects ) = @_;
if ( !defined($rects) || ( ref($rects) eq 'ARRAY' && !ref( $rects->[0] ) ) ) {
my @rect;
@rect = @{$rects} if $rects;
$rect[0] ||= 0;
$rect[1] ||= 0;
$rect[2] ||= $surface->w;
$rect[3] ||= $surface->h;
SDL::Video::update_rect( $surface, @rect );
} else {
SDL::Video::update_rects( $surface, map { SDLx::Validate::rect($_) } @{$rects} );
}
return $surface;
}
sub draw_rect {
my ( $self, $rect, $color ) = @_;
$color = SDLx::Validate::map_rgba( $color, $self->format );
if ( defined $rect ) {
$rect = SDLx::Validate::rect($rect);
} else {
$rect = SDL::Rect->new( 0, 0, $self->w, $self->h );
}
SDL::Video::fill_rect( $self, $rect, $color )
and Carp::confess "Error drawing rect: " . SDL::get_error();
return $self;
}
sub draw_line {
my ( $self, $start, $end, $color, $antialias ) = @_;
Carp::confess "Error start needs an array ref [x,y]"
unless ref($start) eq 'ARRAY';
Carp::confess "Error end needs an array ref [x,y]"
unless ref($end) eq 'ARRAY';
unless ( SDL::Config->has('SDL_gfx_primitives') ) {
Carp::cluck("SDL_gfx_primitives support has not been compiled");
return;
}
$color = SDLx::Validate::num_rgba($color);
my $result;
if ($antialias) {
$result = SDL::GFX::Primitives::aaline_color( $self, @$start, @$end, $color );
} else {
$result = SDL::GFX::Primitives::line_color( $self, @$start, @$end, $color );
}
Carp::confess "Error drawing line: " . SDL::get_error() if ( $result == -1 );
return $self;
}
sub draw_circle {
my ( $self, $center, $radius, $color, $antialias ) = @_;
unless ( SDL::Config->has('SDL_gfx_primitives') ) {
Carp::cluck("SDL_gfx_primitives support has not been compiled");
return;
}
Carp::cluck "Center needs to be an array of format [x,y]" unless ( ref $center eq 'ARRAY' && scalar @$center == 2 );
$color = SDLx::Validate::num_rgba($color);
unless( $antialias )
{
SDL::GFX::Primitives::circle_color( $self, @{$center}, $radius, $color );
}
else
{
SDL::GFX::Primitives::aacircle_color( $self, @{$center}, $radius, $color );
}
return $self;
}
sub draw_circle_filled {
my ( $self, $center, $radius, $color ) = @_;
unless ( SDL::Config->has('SDL_gfx_primitives') ) {
Carp::cluck("SDL_gfx_primitives support has not been compiled");
return;
}
Carp::cluck "Center needs to be an array of format [x,y]" unless ( ref $center eq 'ARRAY' && scalar @$center == 2 );
$color = SDLx::Validate::num_rgba($color);
SDL::GFX::Primitives::filled_circle_color( $self, @{$center}, $radius, $color );
return $self;
}
sub draw_trigon {
my ( $self, $vertices, $color, $antialias ) = @_;
$color = SDLx::Validate::num_rgba($color);
if ($antialias) {
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 );
}
else
{
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 );
}
return $self;
}
sub draw_trigon_filled {
my ( $self, $vertices, $color ) = @_;
$color = SDLx::Validate::num_rgba($color);
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 );
return $self;
}
sub draw_polygon_filled {
my ( $self, $vertices, $color ) = @_;
$color = SDLx::Validate::num_rgba($color);
my @vx = map { $_->[0] } @$vertices;
my @vy = map { $_->[1] } @$vertices;
SDL::GFX::Primitives::filled_polygon_color( $self, \@vx, \@vy, scalar @$vertices, $color );
return $self;
}
sub draw_arc {
my ( $self, $center, $radius, $start, $end, $color ) = @_;
Carp::cluck "Center needs to be an array of format [x,y]" unless ( ref $center eq 'ARRAY' && scalar @$center == 2 );
$color = SDLx::Validate::num_rgba($color);
SDL::GFX::Primitives::arc_color( $self, @$center, $radius, $start, $end, $color );
return $self;
}
sub draw_ellipse {
my ( $self, $center, $rx, $ry, $color, $antialias ) = @_;
Carp::cluck "Center needs to be an array of format [x,y]" unless ( ref $center eq 'ARRAY' && scalar @$center == 2 );
$color = SDLx::Validate::num_rgba($color);
if ($antialias)
{
SDL::GFX::Primitives::aaellipse_color( $self, @$center, $rx, $ry, $color );
}
else
{
SDL::GFX::Primitives::ellipse_color( $self, @$center, $rx, $ry, $color );
}
return $self;
}
sub draw_ellipse_filled {
my ( $self, $center, $rx, $ry, $color ) = @_;
Carp::cluck "Center needs to be an array of format [x,y]" unless ( ref $center eq 'ARRAY' && scalar @$center == 2 );
$color = SDLx::Validate::num_rgba($color);
SDL::GFX::Primitives::filled_ellipse_color( $self, @$center, $rx, $ry, $color );
return $self;
}
sub draw_bezier {
my ( $self, $vector, $smooth, $color ) = @_;
$color = SDLx::Validate::num_rgba($color);
my @vx = map { $_->[0] } @$vector;
my @vy = map { $_->[1] } @$vector;
SDL::GFX::Primitives::bezier_color( $self, \@vx, \@vy, scalar @$vector, $smooth, $color );
return $self;
}
sub draw_gfx_text {
my ( $self, $vector, $color, $text, $font ) = @_;
unless ( SDL::Config->has('SDL_gfx_primitives') ) {
Carp::cluck("SDL_gfx_primitives support has not been compiled");
return;
}
if ($font) {
if ( ref($font) eq 'HASH' && exists $font->{data} && exists $font->{cw} && exists $font->{ch} ) {
SDL::GFX::Primitives::set_font( $font->{data}, $font->{cw}, $font->{ch} );
} else {
Carp::cluck
"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.";
}
}
Carp::confess "vector needs to be an array ref of size 2. [x,y] "
unless ( ref($vector) eq 'ARRAY' && scalar(@$vector) == 2 );
$color = SDLx::Validate::num_rgba($color);
my $result = SDL::GFX::Primitives::string_color( $self, $vector->[0], $vector->[1], $text, $color );
Carp::confess "Error drawing text: " . SDL::get_error() if ( $result == -1 );
return $self;
}
sub DESTROY {
my $self = shift;
delete $_tied_array{$$self};
SDL::Surface::DESTROY($self);
}
1;