1package Text::UnicodeBox::Text;
2
3=head1 NAME
4
5Text::UnicodeBox::Text - Objects to describe text rendering
6
7=head1 DESCRIPTION
8
9This module is part of the low level interface to L<Text::UnicodeBox>; you probably don't need to use it directly.
10
11=cut
12
13use Moose;
14use Text::UnicodeBox::Utility;
15use Text::CharWidth qw(mbwidth mbswidth);
16use Term::ANSIColor qw(colorstrip);
17use Exporter 'import';
18use List::Util qw(max);
19use utf8;
20
21=head1 METHODS
22
23=head2 new (%params)
24
25=over 4
26
27=item value
28
29The string representation of the text.
30
31=item length
32
33How many characters wide the text represents when rendered on the screen.
34
35=back
36
37=cut
38
39has 'value'    => ( is => 'rw' );
40has 'length'   => ( is => 'rw' );
41has 'line_count' => ( is => 'rw', default => 1 );
42has 'longest_word_length' => ( is => 'ro', lazy => 1, builder => '_build_longest_word_length' );
43has '_lines'   => ( is => 'rw' );
44has '_longest_line_length' => ( is => 'rw' );
45
46our @EXPORT_OK = qw(BOX_STRING);
47our %EXPORT_TAGS = ( all => [@EXPORT_OK] );
48
49=head1 EXPORTED METHODS
50
51The following methods are exportable by name or by the tag ':all'
52
53=head2 BOX_STRING ($value)
54
55Given the passed text, figures out the a smart value for the C<length> field and returns a new instance.
56
57=cut
58
59sub BOX_STRING {
60	my $string = shift;
61
62	# Strip out any colors
63	my $stripped_string = colorstrip($string);
64
65	# Determine the width on a terminal of the string given; may be composed of unicode characters that take up two columns, or by ones taking up 0 columns
66	my $length = mbswidth($stripped_string);
67
68	return __PACKAGE__->new(value => $string, length => $length);
69}
70
71=head2 align_and_pad
72
73  my $text = BOX_STRING('Test');
74  $text->align_and_pad(8);
75  # is the same as
76  # $text->align_and_pad( width => 8, pad => 1, pad_char => ' ', align => 'left' );
77  $text->value eq ' Test     ';
78
79Modify the value of this object to pad and align the text according to the specification.  Pass any of the following parameters:
80
81=over 4
82
83=item width
84
85Defaults to the object's C<length>.  Specifies how wide of a space the string is to be fit in.  Doesn't make sense for this value to smaller then the width of the string.  If you pass only one parameter to C<align_and_pad>, this is the parameter it's assigned to.
86
87=item align
88
89If the string looks like a number, the align default to 'right'; otherwise, 'left'.
90
91=item pad (default: 1)
92
93How much padding on the right and left
94
95=item pad_char (default: ' ')
96
97What character to use for padding
98
99=back
100
101=cut
102
103sub align_and_pad {
104	my $self = shift;
105	my %opt;
106	if (int @_ == 1) {
107		$opt{width} = shift;
108	}
109	else {
110		%opt = @_;
111	}
112
113	my $string = $self->value();
114	my $length = $self->length();
115
116	$opt{width} ||= $length;
117	$opt{pad}   = 1 if ! defined $opt{pad};
118	$opt{pad_char} ||= ' ';
119	if (! $opt{align}) {
120		# Align numbers to the right and text to the left
121		my $is_a_number = $string =~ m{^([0-9]+|[0-9]*\.[0-9]+)$};
122		$opt{align} = $is_a_number ? 'right' : 'left';
123	}
124
125	# Align
126	while ($length < $opt{width}) {
127		$string = $opt{align} eq 'right' ? $opt{pad_char} . $string : $string . $opt{pad_char};
128		$length++;
129	}
130
131	# Pad
132	$string = ($opt{pad_char} x $opt{pad}) . $string . ($opt{pad_char} x $opt{pad});
133	$length += $opt{pad} * 2;
134
135	$self->value($string);
136	$self->length($length);
137
138	return $self;
139}
140
141=head2 to_string
142
143Returns the value of this object.
144
145=cut
146
147sub to_string {
148	my $self = shift;
149	return $self->value;
150}
151
152## _build_longest_word_length
153#
154#  In order to find ideal widths of a wrapped column without breaking words, it's necessary to know the longest word length in the string.
155
156sub _build_longest_word_length {
157	my $self = shift;
158
159	my $longest_word = 0;
160	foreach my $word (split / /, $self->value) {
161		my $obj = BOX_STRING($word);
162		$longest_word = max($obj->length, $longest_word);
163	}
164
165	return $longest_word;
166}
167
168=head2 lines
169
170Return array of objects of this string split into new strings on the newline character
171
172=cut
173
174sub lines {
175	my $self = shift;
176	$self->_split_up_on_newline();
177	if ($self->_lines) {
178		return @{ $self->_lines };
179	}
180	else {
181		return $self;
182	}
183}
184
185=head2 line_count
186
187Provides the count of C<lines()>
188
189=head2 longest_line_length
190
191Return the length of the longest line in C<lines()>
192
193=cut
194
195sub longest_line_length {
196	my $self = shift;
197	$self->_split_up_on_newline();
198	return $self->_longest_line_length;
199}
200
201## _split_up_on_newline
202#
203#  Populate _lines, line_count and _longest_line_length
204
205sub _split_up_on_newline {
206	my $self = shift;
207
208	# Don't repeat work
209	return if defined $self->_longest_line_length;
210
211	my (@lines, $longest_line);
212	foreach my $line (split /\n/, $self->value) {
213		my $obj = BOX_STRING($line);
214		push @lines, $obj;
215		$longest_line = max($obj->length, $longest_line || 0);
216	}
217
218	$self->_longest_line_length($longest_line || 0);
219	$self->_lines(\@lines);
220	$self->line_count(int @lines);
221}
222
223=head2 split (%args)
224
225  my @segments = $obj->split( max_width => 100, break_words => 1 );
226
227Return array of objects of this string split at the max width given.  If break_words => 1, break anywhere, otherwise only break on the space character.
228
229=cut
230
231sub split {
232	my ($self, %args) = @_;
233	my $class = ref $self;
234
235	my @segments;
236	my $value = $self->value;
237
238	my $width = 0;
239	my $buffer = '';
240	my $color_state_tracker = _color_state_tracker();
241	my $save_buffer = sub {
242		my $esc = chr(27);
243		$buffer .= $esc . '[0m' if $color_state_tracker->{is_colored}->();
244
245		# If the string is split at a boundary between different color codes, you may get
246		# a series of redundant reset statements
247		$buffer =~ s/$esc\[\d+m $esc\[0m/$esc\[0m/gx;
248		$buffer =~ s/^$esc\[0m//;
249
250		push @segments, $class->new(value => $buffer, length => $width);
251		$buffer = '';
252		$width = 0;
253		$buffer .= $color_state_tracker->{stringify_states}->();
254	};
255
256	my $add_char = sub {
257		my ($char, $value_ref) = @_;
258		my $ord = ord($char);
259
260		# Check for a color escape sequence
261		if ($ord == 27 && $$value_ref =~ m{^\[(\d+)m}) {
262			my $color_state = $1 * 1;
263			$$value_ref =~ s{^\[\d+m}{};
264			$buffer .= $char . "[${color_state}m";
265
266			$color_state_tracker->{add_state}->($color_state);
267			return;
268		}
269
270		my $char_width = mbwidth($char);
271		$save_buffer->() if $char_width + $width > $args{max_width};
272
273		$buffer .= $char;
274		$width += $char_width;
275		$save_buffer->() if $width == $args{max_width};
276	};
277
278	my $character_by_character = $args{break_words} ? 1 : 0;
279
280	while (length $value) {
281		if ($character_by_character) {
282			my $char = substr $value, 0, 1, '';
283			$add_char->($char, \$value);
284		}
285		else {
286			# Extract the next word, up to a space
287			my $word;
288			my $next_space_index = index $value, ' ';
289			while ($next_space_index == 0) {
290				# Value currently starts with a space; write each space out
291				$add_char->( substr($value, 0, 1, ''), \$value );
292				$next_space_index = index $value, ' ';
293			}
294			if ($next_space_index > 0) {
295				$word = substr $value, 0, $next_space_index, '';
296			}
297			if (! $word) {
298				$word = $value;
299				$value = '';
300			}
301			# Wrap to the next line if the current line can't hold this word
302			my $word_width = mbswidth($word);
303			$save_buffer->() if $word_width + $width > $args{max_width};
304
305			# Write out the word, character by character
306			while (length $word) {
307				my $char = substr $word, 0, 1, '';
308				$add_char->($char, \$word);
309			}
310		}
311	}
312	$save_buffer->();
313
314	return @segments;
315}
316
317## _color_state_tracker
318#
319#  Pass in a numerical ANSI color escape and it'll track what the cumulative state is over time
320
321sub _color_state_tracker {
322	my %color_state;
323	my %set_order;
324	my $set_count = 0;
325
326	return {
327		is_colored => sub {
328			return keys %color_state ? 1 : 0;
329		},
330		add_state => sub {
331			my $color_state = shift;
332			my $type;
333			# 0 is the reset code
334			if ($color_state == 0) {
335				%color_state = ();
336				return;
337			}
338			elsif ($color_state == 1 || $color_state == 22) {
339				$type = 'bold';
340			}
341			elsif ($color_state == 3 || $color_state == 23) {
342				$type = 'italics';
343			}
344			elsif ($color_state == 4 || $color_state == 24) {
345				$type = 'underline';
346			}
347			elsif ($color_state == 7 || $color_state == 27) {
348				$type = 'inverse';
349			}
350			elsif ($color_state == 9 || $color_state == 29) {
351				$type = 'strikethrough';
352			}
353			elsif ($color_state >= 30 || $color_state <= 39) {
354				$type = 'foreground';
355			}
356			elsif ($color_state >= 40 || $color_state <= 49) {
357				$type = 'background';
358			}
359			return unless $type;
360
361			if ($color_state >= 20 && $color_state <= 29) {
362				delete $color_state{$type};
363				delete $set_order{$type};
364			}
365			else {
366				$color_state{$type} = $color_state;
367				$set_order{$type} = ++$set_count;
368			}
369		},
370		stringify_states => sub {
371			return join '', map { chr(27) . "[$color_state{$_}m" }
372				sort { $set_order{$a} <=> $set_order{$b} }
373				keys %color_state;
374		},
375	};
376}
377
378=head1 COPYRIGHT
379
380Copyright (c) 2012 Eric Waters and Shutterstock Images (http://shutterstock.com).  All rights reserved.  This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
381
382The full text of the license can be found in the LICENSE file included with this module.
383
384=head1 AUTHOR
385
386Eric Waters <ewaters@gmail.com>
387
388=cut
389
3901;
391