1package Text::UnicodeBox; 2 3=encoding utf-8 4 5=head1 NAME 6 7Text::UnicodeBox - Text box drawing using the Unicode box symbols 8 9=head1 SYNOPSIS 10 11 use Text::UnicodeBox; 12 use Text::UnicodeBox::Control qw(:all); 13 14 my $box = Text::UnicodeBox->new(); 15 $box->add_line( 16 BOX_START( style => 'double', top => 'double', bottom => 'double' ), ' ', BOX_END(), 17 ' ', 18 BOX_START( style => 'heavy', top => 'heavy', bottom => 'heavy' ), ' ', BOX_END() 19 ); 20 print $box->render(); 21 22 # Renders: 23 # ╔═══╗ ┏━━━┓ 24 # ║ ║ ┃ ┃ 25 # ╚═══╝ ┗━━━┛ 26 27=head1 DESCRIPTION 28 29Text::UnicodeBox is a low level box drawing interface. You'll most likely want to use one of the higher level modules such as L<Text::UnicodeBox::Table>. 30 31The unicode box symbol table (L<http://en.wikipedia.org/wiki/Box-drawing_character>) is a fairly robust set of symbols that allow you to draw lines and boxes with monospaced fonts. This module allows you to focus on the content of the boxes you need to draw and mostly ignore how to draw a good looking box with proper connections between all the lines. 32 33The low level approach is line-based. A box object is created, C<add_line> is called for each line of content you'd like to render, and C<render> is called to complete the box. 34 35Output is built up over time, which allows you to stream the output rather then buffering it and printing it in one go. 36 37=cut 38 39use Moose; 40 41use Text::UnicodeBox::Control qw(:all); 42use Text::UnicodeBox::Text qw(:all); 43use Text::UnicodeBox::Utility qw(normalize_box_character_parameters); 44use Scalar::Util qw(blessed); 45 46has 'buffer_ref' => ( is => 'rw', default => sub { my $buffer = ''; return \$buffer } ); 47has 'last_line' => ( is => 'rw' ); 48has 'whitespace_character' => ( is => 'ro', default => ' ' ); 49has 'fetch_box_character' => ( is => 'rw' ); 50 51our $VERSION = 0.03; 52 53=head1 METHODS 54 55=head2 new (%params) 56 57Create a new instance. Provide arguments as a list. Valid arguments are: 58 59=over 4 60 61=item whitespace_character (default: ' ') 62 63When the box renderer needs to pad the output of the interstitial lines of output, this character will be used. Defaults to a simple space. 64 65=item fetch_box_character 66 67Provide a subroutine which will be used instead of the L<Text::UnicodeBox::Utility/fetch_box_character>. This allows the user granular control over what symbols will be used for box drawing. The subroutine will be called with a hash with any or all of the following keys: 'left', 'right', up', 'down', 'vertical' or 'horizontal'. The value of each will be either '1' (default style), 'light', 'heavy', 'single' or 'double'. 68 69Return a single width character or return undefined and a '?' will be used for rendering. 70 71=back 72 73=head2 buffer 74 75Return the current buffer of rendered text. 76 77=cut 78 79sub buffer { 80 my $self = shift; 81 return ${ $self->buffer_ref }; 82} 83 84=head2 add_line (@parts) 85 86Pass a list of parts for a rendered line of output. You may pass either a string, a L<Text::UnicodeBox::Control> or a L<Text::UnicodeBox::Text> object. Strings will be transformed into the latter. The line will be rendered to the buffer. 87 88=cut 89 90sub add_line { 91 my $self = shift; 92 my @parts; 93 94 # Read off each arg, validate, then push onto @parts as objects 95 foreach my $part (@_) { 96 if (ref $part && blessed $part && ($part->isa('Text::UnicodeBox::Control') || $part->isa('Text::UnicodeBox::Text'))) { 97 push @parts, $part; 98 } 99 elsif (ref $part) { 100 die "add_line() takes only strings or Text::UnicodeBox:: objects as arguments"; 101 } 102 else { 103 push @parts, BOX_STRING($part); 104 } 105 } 106 107 my %current_line = ( 108 parts => \@parts, 109 parts_at_position => {}, 110 ); 111 112 # Generate this line as text 113 my $line = ''; 114 { 115 my $position = 0; 116 my %context; 117 foreach my $part (@parts) { 118 $current_line{parts_at_position}{$position} = $part; 119 $line .= $part->to_string(\%context, $self); 120 $position += $part->can('length') ? $part->length : 1; 121 } 122 $line .= "\n"; 123 $current_line{final_position} = $position; 124 } 125 126 ## Generate the top of the box if needed 127 128 my $box_border_line; 129 if (grep { $_->can('top') && $_->top } @parts) { 130 $box_border_line = $self->_generate_box_border_line(\%current_line); 131 } 132 elsif ($self->last_line && grep { $_->can('bottom') && $_->bottom } @{ $self->last_line->{parts} }) { 133 $box_border_line = $self->_generate_box_border_line(\%current_line); 134 } 135 136 # Store this for later reference 137 $self->last_line(\%current_line); 138 139 # Add lines to the buffer ref 140 my $buffer_ref = $self->buffer_ref; 141 $$buffer_ref .= $box_border_line if defined $box_border_line; 142 $$buffer_ref .= $line; 143} 144 145=head2 render 146 147Complete the rendering of the box, drawing any final lines needed to close up the drawing. 148 149Returns the buffer 150 151=cut 152 153sub render { 154 my $self = shift; 155 156 my @box_bottoms = grep { $_->can('bottom') && $_->bottom } @{ $self->last_line->{parts} }; 157 if (@box_bottoms) { 158 my $box_border_line = $self->_generate_box_border_line(); 159 my $buffer_ref = $self->buffer_ref; 160 $$buffer_ref .= $box_border_line; 161 } 162 163 return $self->buffer(); 164} 165 166sub _find_part_at_position { 167 my ($line_details, $position) = @_; 168 return if $position >= $line_details->{final_position}; 169 while ($position >= 0) { 170 if (my $return = $line_details->{parts_at_position}{$position}) { 171 return $return; 172 } 173 $position--; 174 } 175 return; 176} 177 178sub _generate_box_border_line { 179 my ($self, $current_line) = @_; 180 my ($below_box_style, $above_box_style); 181 182 # Find the largest final_position value 183 my $final_position = $current_line ? $current_line->{final_position} : 0; 184 $final_position = $self->last_line->{final_position} 185 if $self->last_line && $self->last_line->{final_position} > $final_position; 186 187 my $line = ''; 188 foreach my $position (0..$final_position - 1) { 189 my ($above_part, $below_part); 190 $above_part = _find_part_at_position($self->last_line, $position) if $self->last_line; 191 $below_part = _find_part_at_position($current_line, $position) if $current_line; 192 193 my %symbol; 194 # First, let the above part specify styling 195 if ($above_part && $above_part->isa('Text::UnicodeBox::Control')) { 196 $symbol{up} = $above_part->style || 'light'; 197 if ($above_part->position eq 'start' && $above_part->bottom) { 198 $above_box_style = $above_part->bottom; 199 $symbol{right} = $above_box_style; 200 } 201 elsif ($above_part->position eq 'end') { 202 $symbol{left} = $above_box_style; 203 $above_box_style = undef; 204 } 205 elsif ($above_part->position eq 'rule') { 206 $symbol{left} = $symbol{right} = $above_box_style; 207 } 208 } 209 elsif ($above_part && $above_part->isa('Text::UnicodeBox::Text') && $above_box_style) { 210 $symbol{left} = $symbol{right} = $above_box_style; 211 } 212 213 # Next, let the below part override 214 if ($below_part && $below_part->isa('Text::UnicodeBox::Control')) { 215 $symbol{down} = $below_part->style || 'light'; 216 if ($below_part->position eq 'start' && $below_part->top) { 217 $below_box_style = $below_part->top; 218 $symbol{right} = $below_box_style if $below_box_style; 219 } 220 elsif ($below_part->position eq 'end') { 221 $symbol{left} = $below_box_style if $below_box_style; 222 $below_box_style = undef; 223 } 224 elsif ($below_part->position eq 'rule') { 225 $symbol{left} = $symbol{right} = $below_box_style if $below_box_style; 226 } 227 } 228 elsif ($below_part && $below_part->isa('Text::UnicodeBox::Text') && $below_box_style) { 229 $symbol{left} = $symbol{right} = $below_box_style; 230 } 231 if (! keys %symbol) { 232 $symbol{horizontal} = $below_box_style ? $below_box_style : $above_box_style ? $above_box_style : undef; 233 delete $symbol{horizontal} unless defined $symbol{horizontal}; 234 } 235 236 # Find the character and add it to the line 237 my $char; 238 if (! keys %symbol) { 239 $char = $self->whitespace_character(); 240 } 241 else { 242 $char = $self->_fetch_box_character(%symbol); 243 } 244 $char = '?' unless defined $char; 245 $line .= $char; 246 } 247 248 $line .= "\n"; 249 250 return $line; 251} 252 253sub _fetch_box_character { 254 my ($self, %symbol) = @_; 255 my $cache_key = join ';', map { "$_=$symbol{$_}" } sort keys %symbol; 256 if (exists $self->{_fetch_box_character_cache}{$cache_key}) { 257 return $self->{_fetch_box_character_cache}{$cache_key}; 258 } 259 my $char; 260 if ($self->fetch_box_character) { 261 $char = $self->fetch_box_character->( 262 normalize_box_character_parameters(%symbol) 263 ); 264 } 265 else { 266 $char = Text::UnicodeBox::Utility::fetch_box_character(%symbol); 267 } 268 $self->{_fetch_box_character_cache}{$cache_key} = $char; 269 return $char; 270} 271 272=head1 DEVELOPMENT 273 274This module is being developed via a git repository publicly avaiable at http://github.com/ewaters/Text-UnicodeBox. I encourage anyone who is interested to fork my code and contribute bug fixes or new features, or just have fun and be creative. 275 276=head1 COPYRIGHT 277 278Copyright (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. 279 280The full text of the license can be found in the LICENSE file included with this module. 281 282=head1 AUTHOR 283 284Eric Waters <ewaters@gmail.com> 285 286=cut 287 2881; 289