File Coverage

blib/lib/SDLx/Text.pm

Criterion	Covered	Total	%
statement	116	205	56.5
branch	34	94	36.1
condition	10	23	43.4
subroutine	26	35	74.2
pod	0	22	0.0
total	186	379	49.0

package SDLx::Text;
use strict;
use warnings;
use SDL;
use SDL::Video;
use SDL::Config;
use SDL::TTF;
use SDL::TTF::Font;
use SDLx::Validate;
use List::Util qw(max sum);

use Carp ();

sub new {
	my ($class, %options) = @_;
	unless ( SDL::Config->has('SDL_ttf') ) {
		Carp::cluck("SDL_ttf support has not been compiled");
	}
	my $file = $options{'font'};
    if (!$file) {
        require File::ShareDir;
        $file = File::ShareDir::dist_file('SDL', 'GenBasR.ttf');
    }

	my $color = defined $options{'color'} ? $options{'color'} : [255, 255, 255];

	my $size = $options{'size'} || 24;

	my $shadow        = $options{'shadow'}        || 0;
	my $shadow_offset = $options{'shadow_offset'} || 1;

	my $shadow_color  = defined $options{'shadow_color'}
	                  ? $options{'shadow_color'}
	                  : [0, 0, 0]
	                  ;

	my $self = bless {}, ref($class) || $class;

	$self->{x} = $options{'x'} || 0;
	$self->{y} = $options{'y'} || 0;

	$self->{h_align} = $options{'h_align'} || 'left';
# TODO: validate
# TODO: v_align
	unless ( SDL::TTF::was_init() ) {
		Carp::cluck ("Cannot init TTF: " . SDL::get_error() )
		    unless SDL::TTF::init() == 0;
	}

	$self->size($size);
	$self->font($file);
	$self->color($color);
	$self->shadow($shadow);
	$self->shadow_color($shadow_color);
	$self->shadow_offset($shadow_offset);

    $self->bold($options{'bold'}) if exists $options{'bold'};
    $self->italic($options{'italic'}) if exists $options{'italic'};
    $self->underline($options{'underline'}) if exists $options{'underline'};
    $self->strikethrough($options{'strikethrough'}) if exists $options{'strikethrough'};

    # word wrapping
    $self->{word_wrap} = $options{'word_wrap'} || 0;

	$self->text( $options{'text'} ) if exists $options{'text'};

	return $self;
}

sub font {
	my ($self, $font_filename) = @_;

	if ($font_filename) {
		my $size = $self->size;

		$self->{_font} = SDL::TTF::open_font($font_filename, $size)
			or Carp::cluck "Error opening font '$font_filename': " . SDL::get_error;

	    $self->{_font_filename} = $font_filename;
	    $self->{_update_surfaces} = 1;
	}

	return $self->{_font};
}

sub font_filename {
    return $_[0]->{_font_filename};
}

sub color {
	my ($self, $color) = @_;

	if (defined $color) {
		$self->{_color} = SDLx::Validate::color($color);
	    $self->{_update_surfaces} = 1;
	}

	return $self->{_color};
}

sub size {
	my ($self, $size) = @_;

	if ($size) {
		$self->{_size} = $size;

		# reload the font using new size.
		# No need to set "_update_surfaces"
		# since font() already does it.
		$self->font( $self->font_filename );
	}

	return $self->{_size};
}

sub _style {
    my ($self, $flag, $enable) = @_;

    my $styles = SDL::TTF::get_font_style( $self->font );

    # do we have an enable flag?
    if (@_ > 2) {

        # we do! setup flags if we're enabling or disabling
        if ($enable) {
            $styles |= $flag;
        }
        else {
            $styles ^= $flag if $flag & $styles;
        }

        SDL::TTF::set_font_style( $self->font, $styles );

        # another run, returning true if value was properly set.
        return SDL::TTF::get_font_style( $self->font ) & $flag;
    }
    # no enable flag present, just return
    # whether the style is enabled/disabled
    else {
        return $styles & $flag;
    }
}

sub normal        { my $self = shift; $self->_style( TTF_STYLE_NORMAL,        @_ ) }
sub bold          { my $self = shift; $self->_style( TTF_STYLE_BOLD,          @_ ) }
sub italic        { my $self = shift; $self->_style( TTF_STYLE_ITALIC,        @_ ) }
sub underline     { my $self = shift; $self->_style( TTF_STYLE_UNDERLINE,     @_ ) }
sub strikethrough { my $self = shift; $self->_style( TTF_STYLE_STRIKETHROUGH, @_ ) }


sub h_align {
	my ($self, $align) = @_;

	if ($align) {
		$self->{h_align} = $align;
		$self->{_update_surfaces} = 1;
	}

	return $self->{h_align};
}

sub shadow {
	my ($self, $shadow) = @_;

	if ($shadow) {
	    $self->{shadow} = $shadow;
	    $self->{_update_surfaces} = 1;
	}

	return $self->{shadow};
}

sub shadow_color {
	my ($self, $shadow_color) = @_;

	if (defined $shadow_color) {
		$self->{shadow_color} = SDLx::Validate::color($shadow_color);
	    $self->{_update_surfaces} = 1;
	}

	return $self->{shadow_color};
}


sub shadow_offset {
	my ($self, $shadow_offset) = @_;

	if ($shadow_offset) {
	    $self->{shadow_offset} = $shadow_offset;
	    $self->{_update_surfaces} = 1;
	}

	return $self->{shadow_offset};
}

sub w {
    my $surface = $_[0]->{surface};
    return $surface->w unless $surface and ref $surface eq 'ARRAY';

    return max map { $_ ? $_->w() : 0 } @$surface;
}

sub h {
    my $surface = $_[0]->{surface};
    return $surface->h unless $surface and ref $surface eq 'ARRAY';

    return sum map { $_ ? $_->h() : 0 } @$surface;
}

sub x {
	my ($self, $x) = @_;

	if (defined $x) {
		$self->{x} = $x;
	}
	return $self->{x};
}

sub y {
	my ($self, $y) = @_;

	if (defined $y) {
		$self->{y} = $y;
	}
	return $self->{y};
}

sub text {
	my ($self, $text) = @_;

    return $self->{text} if scalar @_ == 1;

    if ( defined $text ) {
        $text = $self->_word_wrap($text) if $self->{word_wrap};
        my $font = $self->{_font};
        my $surface = _get_surfaces_for($font, $text, $self->{_color} )
            or Carp::croak 'TTF rendering error: ' . SDL::get_error;

	    if ($self->{shadow}) {
	        my $shadow_surface = _get_surfaces_for($font, $text, $self->{shadow_color})
	            or Carp::croak 'TTF shadow rendering error: ' . SDL::get_error;

            $shadow_surface = [ $shadow_surface ] unless ref $shadow_surface eq 'ARRAY';

	        $self->{_shadow_surface} = $shadow_surface;
	    }

        $self->{surface} = $surface;
        $self->{text} = $text;
    }
    else {
        $self->{surface} = undef;
    }


	return $self;
}

# Returns the TTF surface for the given text.
# If the text contains linebreaks, we split into
# several surfaces (since SDL can't render '\n').
sub _get_surfaces_for {
    my ($font, $text, $color) = @_;

    return SDL::TTF::render_utf8_blended($font, $text, $color)
        if index($text, "\n") == -1;

    my @surfaces = ();
    my @paragraphs = split /\n/ => $text;
    foreach my $paragraph (@paragraphs) {
        push @surfaces, SDL::TTF::render_utf8_blended($font, $paragraph, $color);
    }
    return \@surfaces;
}

sub _word_wrap {
    my ($self, $text) = @_;

    my $maxlen = $self->{word_wrap};
    my $font   = $self->{_font};

    # code heavily based on Text::Flow::Wrap
    my @paragraphs = split /\n/ => $text;
    my @output;

    foreach my $paragraph (@paragraphs) {
        my @paragraph_output = ('');
        my @words  = split /\s+/ => $paragraph;

        foreach my $word (@words) {
            my $padded    = $word . q[ ];
            my $candidate = $paragraph_output[-1] . $padded;
            my ($w) = @{ SDL::TTF::size_utf8($font, $candidate) };
            if ($w < $maxlen) {
                $paragraph_output[-1] = $candidate;
            }
            else {
                push @paragraph_output, $padded;
            }
        }
        chop $paragraph_output[-1] if substr( $paragraph_output[-1], -1, 1 ) eq q[ ];

        push @output, \@paragraph_output;

    }

    return join "\n" => map {
        join "\n" => @$_
    } @output;
}

sub surface {
	return $_[0]->{surface};
}

sub write_to {
	my ($self, $target, $text) = @_;

    if (@_ > 2) {
        $self->text($text);
        $self->{_update_surfaces} = 0;
    }
    $self->write_xy($target, $self->{x}, $self->{y});
}

sub write_xy {
	my ($self, $target, $x, $y, $text) = @_;

	if (@_ > 4) {
	    $self->text($text);
        $self->{_update_surfaces} = 0;
	}
	elsif ($self->{_update_surfaces}) {
	    $self->text( $self->text );
	    $self->{_update_surfaces} = 0;
	}

	if ( my $surfaces = $self->{surface} ) {

        $surfaces = [ $surfaces ] unless ref $surfaces eq 'ARRAY';
        my $linebreaks = 0;

        foreach my $i ( 0 .. $#{$surfaces}) {
            if (my $surface = $surfaces->[$i]) {
                $y += ($linebreaks * $surface->h);
                $linebreaks = 0;

                if ($self->{h_align} eq 'center' ) {
                    # $x = ($target->w / 2) - ($surface->w / 2);
                    $x -= $surface->w / 2;
                }
                elsif ($self->{h_align} eq 'right' ) {
                    # $x = $target->w - $surface->w;
                    $x -= $surface->w;
                }

                # blit the shadow
                if ($self->{shadow}) {
                    my $shadow = $self->{_shadow_surface}->[$i];
                    my $offset = $self->{shadow_offset};

                    SDL::Video::blit_surface(
                       $shadow, SDL::Rect->new(0,0,$shadow->w, $shadow->h),
                       $target, SDL::Rect->new($x + $offset, $y + $offset, 0, 0)
                    );
                }

                # blit the text
                SDL::Video::blit_surface(
                    $surface, SDL::Rect->new(0,0,$surface->w, $surface->h),
                    $target, SDL::Rect->new($x, $y, 0, 0)
                );
            }
            $linebreaks++;
        }

	}
	return;
}

1;