File Coverage

blib/lib/SDLx/App.pm

Criterion	Covered	Total	%
statement	92	147	62.5
branch	12	62	19.3
condition	27	67	40.3
subroutine	17	29	58.6
pod	0	13	0.0
total	148	318	46.5

#!/usr/bin/env perl
#
# App.pm
#

package SDLx::App;

use strict;
use warnings;
use Carp;
use SDL;

use SDL::Rect;
use SDL::Video;
use SDL::Event;
use SDL::Events;
use SDL::Surface;
use SDL::PixelFormat;
use SDL::VideoInfo;
use SDLx::Surface;
use Data::Dumper;
use Scalar::Util 'refaddr';
use base qw/SDLx::Surface SDLx::Controller/;

our $VERSION = 2.548;

my $screen_w;
my $screen_h;
my $screen_d;

sub new {
	my $proto   = shift;
	my $class   = ref($proto) || $proto;
	my %options = @_;

	unless($screen_w && $screen_h && $screen_d) {
		my $video_info = SDL::Video::get_video_info();
		if($video_info) {
			$screen_w = $video_info->current_w;
			$screen_h = $video_info->current_h;
			$screen_d = $video_info->vfmt->BitsPerPixel;
		}
	}

	# SDL_INIT_VIDEO() is 0, so check defined instead of truth.
	unless ( exists( $options{noinit} ) ) # we shouldn't do init always
	{
		my $init =
			defined $options{init}
			? $options{init}
			: SDL::SDL_INIT_EVERYTHING;

		SDL::init($init);
	}

	my $t   = $options{title}            || $options{t}   || $0;
	my $it  = $options{icon_title}       || $options{it}  || $t;
	my $ic  = $options{icon}             || $options{i}   || "";
	my $w   = $options{width}            || $options{w}   || 800;
	my $h   = $options{height}           || $options{h}   || 600;
	my $d   = $options{depth}            || $options{d}   || 16;
	my $f   = $options{flags}            || $options{f}   || SDL::Video::SDL_ANYFORMAT;
	my $r   = $options{red_size}         || $options{r}   || 5;
	my $g   = $options{green_size}       || $options{g}   || 5;
	my $b   = $options{blue_size}        || $options{b}   || 5;
	my $a   = $options{alpha_size}       || $options{a}   || 0;
	my $ras = $options{red_accum_size}   || $options{ras} || 0;
	my $gas = $options{green_accum_size} || $options{gas} || 0;
	my $bas = $options{blue_accum_size}  || $options{bas} || 0;
	my $aas = $options{alpha_accum_size} || $options{aas} || 0;
	my $db  = $options{double_buffer}    || $options{db}  || 0;

	my $bs = $options{buffer_size}  || $options{bs} || 0;
	my $st = $options{stencil_size} || $options{st} || 0;
	my $async = $options{asyncblit} || 0;

	$f |= SDL::Video::SDL_OPENGL if ( $options{gl} || $options{opengl} );
	$f |= SDL::Video::SDL_FULLSCREEN
		if ( $options{fullscreen} || $options{full} );
	$f |= SDL::Video::SDL_RESIZABLE if ( $options{resizeable} );
	$f |= SDL::Video::SDL_DOUBLEBUF if ($db);
	$f |= SDL::Video::SDL_ASYNCBLIT if ($async);

	if ( $f & SDL::Video::SDL_OPENGL ) {
		$SDLx::App::USING_OPENGL = 1;
		SDL::Video::GL_set_attribute( SDL::Constants::SDL_GL_RED_SIZE(), $r )
			if ($r);
		SDL::Video::GL_set_attribute( SDL::Constants::SDL_GL_GREEN_SIZE(), $g )
			if ($g);
		SDL::Video::GL_set_attribute( SDL::Constants::SDL_GL_BLUE_SIZE(), $b )
			if ($b);
		SDL::Video::GL_set_attribute( SDL::Constants::SDL_GL_ALPHA_SIZE(), $a )
			if ($a);

		SDL::Video::GL_set_attribute(
			SDL::Constants::SDL_GL_RED_ACCUM_SIZE(),
			$ras
		) if ($ras);
		SDL::Video::GL_set_attribute(
			SDL::Constants::SDL_GL_GREEN_ACCUM_SIZE(),
			$gas
		) if ($gas);
		SDL::Video::GL_set_attribute(
			SDL::Constants::SDL_GL_BLUE_ACCUM_SIZE(),
			$bas
		) if ($bas);
		SDL::Video::GL_set_attribute(
			SDL::Constants::SDL_GL_ALPHA_ACCUM_SIZE(),
			$aas
		) if ($aas);

		SDL::Video::GL_set_attribute(
			SDL::Constants::SDL_GL_DOUBLEBUFFER(),
			$db
		) if ($db);
		SDL::Video::GL_set_attribute(
			SDL::Constants::SDL_GL_BUFFER_SIZE(),
			$bs
		) if ($bs);
		SDL::Video::GL_set_attribute( SDL::Constants::SDL_GL_DEPTH_SIZE(), $d );
	} else {
		$SDLx::App::USING_OPENGL = 0;
	}

	my $surface = SDL::Video::set_video_mode( $w, $h, $d, $f )
		or Carp::confess SDL::get_error();
	$options{surface} = $surface;

	my $self = SDLx::Surface->new(%options);

	if ( $ic and -e $ic ) {
		my $icon = SDL::Video::load_BMP($ic);
		SDL::Video::wm_set_icon($icon);
	}

	SDL::Video::wm_set_caption( $t, $it );
	$self = $self->SDLx::Controller::new(%options);
	bless $self, $class;

	return $self;
}

sub resize {
	my ( $self, $w, $h ) = @_;
	my $flags = $self->flags;
	if ( $flags & SDL::Video::SDL_RESIZABLE ) {
		my $bpp = $self->format->BitsPerPixel;
		$self = SDL::Video::set_video_mode( $w, $h, $bpp, $flags )
			or die "SDL cannot set video:" . SDL::get_error;
	} else {
		die "Application surface not resizable";
	}
}

sub title {
	my $self = shift;
	my ( $title, $icon );
	if (@_) {
		$title = shift;
		$icon = shift || $title;
		SDL::Video::wm_set_caption( $title, $icon );
	}
	return SDL::Video::wm_get_caption();
}

sub delay {
	my $self  = shift;
	my $delay = shift;
	SDL::delay($delay);
}

sub ticks {
	return SDL::get_ticks();
}

sub error {
	return SDL::get_error();
}

sub warp {
	my $self = shift;
	SDL::Mouse::warp_mouse(@_);
}

sub fullscreen {
	my $self = shift;
	SDL::Video::wm_toggle_fullscreen($self);
}

sub iconify {
	my $self = shift;
	SDL::Video::wm_iconify_window();
}

sub grab_input {
	my ( $self, $mode ) = @_;
	SDL::Video::wm_grab_input($mode);
}

sub sync {
	my $self = shift;
	if ($SDLx::App::USING_OPENGL) {
		SDL::Video::GL_swap_buffers();
	} else {
		$self->flip();
	}
}

sub attribute {
	my ( $self, $mode, $value ) = @_;
	return undef unless ($SDLx::App::USING_OPENGL);
	if ( defined $value ) {
		SDL::Video::GL_set_attribute( $mode, $value );
	}
	my $returns = SDL::Video::GL_get_attribute($mode);
	Carp::confess "SDLx::App::attribute failed to get GL attribute"
		if ( $$returns[0] < 0 );
	$$returns[1];
}



my %_stash;
sub stash :lvalue{
	my $ref = refaddr($_[0]);
	$_stash{ $ref } = {} unless $_stash{ $ref };
	return $_stash{ $ref }
}

sub DESTROY {
	if($screen_w && $screen_h && $screen_d) {
		SDL::Video::set_video_mode( $screen_w, $screen_h, $screen_d, SDL_ANYFORMAT );
	}
}

1;