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