Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

425 lines (325 sloc) 10.885 kb
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 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_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_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;
Jump to Line
Something went wrong with that request. Please try again.