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


line stmt bran cond sub pod time code
1             package SDLx::Text;
2 1     1   543 use strict;
  1         2  
  1         29  
3 1     1   4 use warnings;
  1         1  
  1         23  
4 1     1   3 use SDL;
  1         2  
  1         69  
5 1     1   4 use SDL::Video;
  1         2  
  1         148  
6 1     1   4 use SDL::Config;
  1         1  
  1         18  
7 1     1   268 use SDL::TTF;
  1         2  
  1         56  
8 1     1   264 use SDL::TTF::Font;
  1         1  
  1         47  
9 1     1   4 use SDLx::Validate;
  1         1  
  1         24  
10 1     1   3 use List::Util qw(max sum);
  1         1  
  1         65  
11              
12 1     1   4 use Carp ();
  1         0  
  1         1345  
13              
14             sub new {
15 1     1 0 331 my ($class, %options) = @_;
16 1 50       6 unless ( SDL::Config->has('SDL_ttf') ) {
17 0         0 Carp::cluck("SDL_ttf support has not been compiled");
18             }
19 1         2 my $file = $options{'font'};
20 1 50       3 if (!$file) {
21 0         0 require File::ShareDir;
22 0         0 $file = File::ShareDir::dist_file('SDL', 'GenBasR.ttf');
23             }
24              
25 1 50       2 my $color = defined $options{'color'} ? $options{'color'} : [255, 255, 255];
26              
27 1   50     9 my $size = $options{'size'} || 24;
28              
29 1   50     4 my $shadow = $options{'shadow'} || 0;
30 1   50     4 my $shadow_offset = $options{'shadow_offset'} || 1;
31              
32 1 50       3 my $shadow_color = defined $options{'shadow_color'}
33             ? $options{'shadow_color'}
34             : [0, 0, 0]
35             ;
36              
37 1   33     4 my $self = bless {}, ref($class) || $class;
38              
39 1   50     7 $self->{x} = $options{'x'} || 0;
40 1   50     4 $self->{y} = $options{'y'} || 0;
41              
42 1   50     8 $self->{h_align} = $options{'h_align'} || 'left';
43             # TODO: validate
44             # TODO: v_align
45 1 50       8 unless ( SDL::TTF::was_init() ) {
46 1 50       56 Carp::cluck ("Cannot init TTF: " . SDL::get_error() )
47             unless SDL::TTF::init() == 0;
48             }
49              
50 1         2 $self->size($size);
51 1         2 $self->font($file);
52 1         3 $self->color($color);
53 1         3 $self->shadow($shadow);
54 1         1 $self->shadow_color($shadow_color);
55 1         2 $self->shadow_offset($shadow_offset);
56              
57 1 50       2 $self->bold($options{'bold'}) if exists $options{'bold'};
58 1 50       3 $self->italic($options{'italic'}) if exists $options{'italic'};
59 1 50       2 $self->underline($options{'underline'}) if exists $options{'underline'};
60 1 50       2 $self->strikethrough($options{'strikethrough'}) if exists $options{'strikethrough'};
61              
62             # word wrapping
63 1   50     4 $self->{word_wrap} = $options{'word_wrap'} || 0;
64              
65 1 50       2 $self->text( $options{'text'} ) if exists $options{'text'};
66              
67 1         3 return $self;
68             }
69              
70             sub font {
71 3     3 0 3 my ($self, $font_filename) = @_;
72              
73 3 100       6 if ($font_filename) {
74 1         1 my $size = $self->size;
75              
76 1 50       215 $self->{_font} = SDL::TTF::open_font($font_filename, $size)
77             or Carp::cluck "Error opening font '$font_filename': " . SDL::get_error;
78              
79 1         3 $self->{_font_filename} = $font_filename;
80 1         1 $self->{_update_surfaces} = 1;
81             }
82              
83 3         7 return $self->{_font};
84             }
85              
86             sub font_filename {
87 1     1 0 2 return $_[0]->{_font_filename};
88             }
89              
90             sub color {
91 2     2 0 2 my ($self, $color) = @_;
92              
93 2 100       3 if (defined $color) {
94 1         4 $self->{_color} = SDLx::Validate::color($color);
95 1         2 $self->{_update_surfaces} = 1;
96             }
97              
98 2         4 return $self->{_color};
99             }
100              
101             sub size {
102 3     3 0 4 my ($self, $size) = @_;
103              
104 3 100       9 if ($size) {
105 1         2 $self->{_size} = $size;
106              
107             # reload the font using new size.
108             # No need to set "_update_surfaces"
109             # since font() already does it.
110 1         1 $self->font( $self->font_filename );
111             }
112              
113 3         5 return $self->{_size};
114             }
115              
116             sub _style {
117 0     0   0 my ($self, $flag, $enable) = @_;
118              
119 0         0 my $styles = SDL::TTF::get_font_style( $self->font );
120              
121             # do we have an enable flag?
122 0 0       0 if (@_ > 2) {
123              
124             # we do! setup flags if we're enabling or disabling
125 0 0       0 if ($enable) {
126 0         0 $styles |= $flag;
127             }
128             else {
129 0 0       0 $styles ^= $flag if $flag & $styles;
130             }
131              
132 0         0 SDL::TTF::set_font_style( $self->font, $styles );
133              
134             # another run, returning true if value was properly set.
135 0         0 return SDL::TTF::get_font_style( $self->font ) & $flag;
136             }
137             # no enable flag present, just return
138             # whether the style is enabled/disabled
139             else {
140 0         0 return $styles & $flag;
141             }
142             }
143              
144 0     0 0 0 sub normal { my $self = shift; $self->_style( TTF_STYLE_NORMAL, @_ ) }
  0         0  
145 0     0 0 0 sub bold { my $self = shift; $self->_style( TTF_STYLE_BOLD, @_ ) }
  0         0  
146 0     0 0 0 sub italic { my $self = shift; $self->_style( TTF_STYLE_ITALIC, @_ ) }
  0         0  
147 0     0 0 0 sub underline { my $self = shift; $self->_style( TTF_STYLE_UNDERLINE, @_ ) }
  0         0  
148 0     0 0 0 sub strikethrough { my $self = shift; $self->_style( TTF_STYLE_STRIKETHROUGH, @_ ) }
  0         0  
149              
150              
151             sub h_align {
152 1     1 0 2 my ($self, $align) = @_;
153              
154 1 50       3 if ($align) {
155 0         0 $self->{h_align} = $align;
156 0         0 $self->{_update_surfaces} = 1;
157             }
158              
159 1         3 return $self->{h_align};
160             }
161              
162             sub shadow {
163 1     1 0 2 my ($self, $shadow) = @_;
164              
165 1 50       3 if ($shadow) {
166 0         0 $self->{shadow} = $shadow;
167 0         0 $self->{_update_surfaces} = 1;
168             }
169              
170 1         1 return $self->{shadow};
171             }
172              
173             sub shadow_color {
174 1     1 0 1 my ($self, $shadow_color) = @_;
175              
176 1 50       2 if (defined $shadow_color) {
177 1         2 $self->{shadow_color} = SDLx::Validate::color($shadow_color);
178 1         2 $self->{_update_surfaces} = 1;
179             }
180              
181 1         1 return $self->{shadow_color};
182             }
183              
184              
185             sub shadow_offset {
186 1     1 0 1 my ($self, $shadow_offset) = @_;
187              
188 1 50       2 if ($shadow_offset) {
189 1         1 $self->{shadow_offset} = $shadow_offset;
190 1         1 $self->{_update_surfaces} = 1;
191             }
192              
193 1         1 return $self->{shadow_offset};
194             }
195              
196             sub w {
197 2     2 0 5 my $surface = $_[0]->{surface};
198 2 50 33     15 return $surface->w unless $surface and ref $surface eq 'ARRAY';
199              
200 0 0       0 return max map { $_ ? $_->w() : 0 } @$surface;
  0         0  
201             }
202              
203             sub h {
204 1     1 0 1 my $surface = $_[0]->{surface};
205 1 50 33     9 return $surface->h unless $surface and ref $surface eq 'ARRAY';
206              
207 0 0       0 return sum map { $_ ? $_->h() : 0 } @$surface;
  0         0  
208             }
209              
210             sub x {
211 1     1 0 222 my ($self, $x) = @_;
212              
213 1 50       3 if (defined $x) {
214 0         0 $self->{x} = $x;
215             }
216 1         4 return $self->{x};
217             }
218              
219             sub y {
220 1     1 0 2 my ($self, $y) = @_;
221              
222 1 50       2 if (defined $y) {
223 0         0 $self->{y} = $y;
224             }
225 1         4 return $self->{y};
226             }
227              
228             sub text {
229 3     3 0 4 my ($self, $text) = @_;
230              
231 3 100       9 return $self->{text} if scalar @_ == 1;
232              
233 2 100       5 if ( defined $text ) {
234 1 50       2 $text = $self->_word_wrap($text) if $self->{word_wrap};
235 1         2 my $font = $self->{_font};
236 1 50       1 my $surface = _get_surfaces_for($font, $text, $self->{_color} )
237             or Carp::croak 'TTF rendering error: ' . SDL::get_error;
238              
239 1 50       3 if ($self->{shadow}) {
240 0 0       0 my $shadow_surface = _get_surfaces_for($font, $text, $self->{shadow_color})
241             or Carp::croak 'TTF shadow rendering error: ' . SDL::get_error;
242              
243 0 0       0 $shadow_surface = [ $shadow_surface ] unless ref $shadow_surface eq 'ARRAY';
244              
245 0         0 $self->{_shadow_surface} = $shadow_surface;
246             }
247              
248 1         1 $self->{surface} = $surface;
249 1         132 $self->{text} = $text;
250             }
251             else {
252 1         1 $self->{surface} = undef;
253             }
254              
255              
256 2         12 return $self;
257             }
258              
259             # Returns the TTF surface for the given text.
260             # If the text contains linebreaks, we split into
261             # several surfaces (since SDL can't render '\n').
262             sub _get_surfaces_for {
263 1     1   1 my ($font, $text, $color) = @_;
264              
265 1 50       724 return SDL::TTF::render_utf8_blended($font, $text, $color)
266             if index($text, "\n") == -1;
267              
268 0         0 my @surfaces = ();
269 0         0 my @paragraphs = split /\n/ => $text;
270 0         0 foreach my $paragraph (@paragraphs) {
271 0         0 push @surfaces, SDL::TTF::render_utf8_blended($font, $paragraph, $color);
272             }
273 0         0 return \@surfaces;
274             }
275              
276             sub _word_wrap {
277 0     0   0 my ($self, $text) = @_;
278              
279 0         0 my $maxlen = $self->{word_wrap};
280 0         0 my $font = $self->{_font};
281              
282             # code heavily based on Text::Flow::Wrap
283 0         0 my @paragraphs = split /\n/ => $text;
284 0         0 my @output;
285              
286 0         0 foreach my $paragraph (@paragraphs) {
287 0         0 my @paragraph_output = ('');
288 0         0 my @words = split /\s+/ => $paragraph;
289              
290 0         0 foreach my $word (@words) {
291 0         0 my $padded = $word . q[ ];
292 0         0 my $candidate = $paragraph_output[-1] . $padded;
293 0         0 my ($w) = @{ SDL::TTF::size_utf8($font, $candidate) };
  0         0  
294 0 0       0 if ($w < $maxlen) {
295 0         0 $paragraph_output[-1] = $candidate;
296             }
297             else {
298 0         0 push @paragraph_output, $padded;
299             }
300             }
301 0 0       0 chop $paragraph_output[-1] if substr( $paragraph_output[-1], -1, 1 ) eq q[ ];
302              
303 0         0 push @output, \@paragraph_output;
304              
305             }
306              
307 0         0 return join "\n" => map {
308 0         0 join "\n" => @$_
309             } @output;
310             }
311              
312             sub surface {
313 1     1 0 3 return $_[0]->{surface};
314             }
315              
316             sub write_to {
317 0     0 0   my ($self, $target, $text) = @_;
318              
319 0 0         if (@_ > 2) {
320 0           $self->text($text);
321 0           $self->{_update_surfaces} = 0;
322             }
323 0           $self->write_xy($target, $self->{x}, $self->{y});
324             }
325              
326             sub write_xy {
327 0     0 0   my ($self, $target, $x, $y, $text) = @_;
328              
329 0 0         if (@_ > 4) {
    0          
330 0           $self->text($text);
331 0           $self->{_update_surfaces} = 0;
332             }
333             elsif ($self->{_update_surfaces}) {
334 0           $self->text( $self->text );
335 0           $self->{_update_surfaces} = 0;
336             }
337              
338 0 0         if ( my $surfaces = $self->{surface} ) {
339              
340 0 0         $surfaces = [ $surfaces ] unless ref $surfaces eq 'ARRAY';
341 0           my $linebreaks = 0;
342              
343 0           foreach my $i ( 0 .. $#{$surfaces}) {
  0            
344 0 0         if (my $surface = $surfaces->[$i]) {
345 0           $y += ($linebreaks * $surface->h);
346 0           $linebreaks = 0;
347              
348 0 0         if ($self->{h_align} eq 'center' ) {
    0          
349             # $x = ($target->w / 2) - ($surface->w / 2);
350 0           $x -= $surface->w / 2;
351             }
352             elsif ($self->{h_align} eq 'right' ) {
353             # $x = $target->w - $surface->w;
354 0           $x -= $surface->w;
355             }
356              
357             # blit the shadow
358 0 0         if ($self->{shadow}) {
359 0           my $shadow = $self->{_shadow_surface}->[$i];
360 0           my $offset = $self->{shadow_offset};
361              
362 0           SDL::Video::blit_surface(
363             $shadow, SDL::Rect->new(0,0,$shadow->w, $shadow->h),
364             $target, SDL::Rect->new($x + $offset, $y + $offset, 0, 0)
365             );
366             }
367              
368             # blit the text
369             SDL::Video::blit_surface(
370 0           $surface, SDL::Rect->new(0,0,$surface->w, $surface->h),
371             $target, SDL::Rect->new($x, $y, 0, 0)
372             );
373             }
374 0           $linebreaks++;
375             }
376              
377             }
378 0           return;
379             }
380              
381             1;