File Coverage

blib/lib/PDF/Builder/UniWrap.pm
Criterion Covered Total %
statement 30 152 19.7
branch 0 104 0.0
condition 0 21 0.0
subroutine 10 18 55.5
pod 0 7 0.0
total 40 302 13.2


line stmt bran cond sub pod time code
1             package PDF::Builder::UniWrap;
2              
3 1     1   1841 use strict;
  1         3  
  1         37  
4 1     1   6 use warnings;
  1         2  
  1         63  
5             #no warnings qw[ deprecated recursion uninitialized ];
6              
7             our $VERSION = '3.023'; # VERSION
8             our $LAST_UPDATE = '3.021'; # manually update whenever code is changed
9              
10             =head1 NAME
11              
12             PDF::Builder::UniWrap - support routines for finding line breakpoints with Unicode text
13              
14             =cut
15              
16             # Implements UAX#14: Line Breaking Properties
17             # David Nesting
18              
19 0         0 BEGIN {
20              
21 1     1   6 use Encode qw(:all);
  1         1  
  1         248  
22              
23             #use 5.008; as of 3.010, 5.16 is the minimum
24 1     1   11 use base 'Exporter';
  1         2  
  1         126  
25              
26 1     1   3305 use Unicode::UCD;
  1         53972  
  1         69  
27 1     1   11 use Carp;
  1     0   3  
  1         104  
28              
29             }
30              
31             our $DEBUG = 0;
32             our $columns = 75;
33              
34             my %classified;
35             my $txt;
36              
37 1     1   7 use constant PROHIBITED => 0; ## no critic
  1         3  
  1         81  
38 1     1   9 use constant INDIRECT => 1; ## no critic
  1         3  
  1         47  
39 1     1   7 use constant DIRECT => 2; ## no critic
  1         3  
  1         44  
40 1     1   7 use constant REQUIRED => 3; ## no critic
  1         3  
  1         2119  
41              
42             my @CLASSES = qw{ OP CL QU GL NS EX SY IS PR PO NU AL ID IN HY BA BB B2 ZW CM };
43             my %BREAK_TABLE = (
44             OP => [qw[ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 ]],
45             CL => [qw[ 2 0 1 1 0 0 0 0 2 1 2 2 2 2 1 1 2 2 0 1 ]],
46             QU => [qw[ 0 0 1 1 1 0 0 0 1 1 1 1 1 1 1 1 1 1 0 1 ]],
47             GL => [qw[ 1 0 1 1 1 0 0 0 1 1 1 1 1 1 1 1 1 1 0 1 ]],
48             NS => [qw[ 2 0 1 1 1 0 0 0 2 2 2 2 2 2 1 1 2 2 0 1 ]],
49             EX => [qw[ 2 0 1 1 1 0 0 0 2 2 2 2 2 2 1 1 2 2 0 1 ]],
50             SY => [qw[ 2 0 1 1 1 0 0 0 2 2 1 2 2 2 1 1 2 2 0 1 ]],
51             IS => [qw[ 2 0 1 1 1 0 0 0 2 2 1 2 2 2 1 1 2 2 0 1 ]],
52             PR => [qw[ 1 0 1 1 1 0 0 0 2 2 1 1 1 2 1 1 2 2 0 1 ]],
53             PO => [qw[ 2 0 1 1 1 0 0 0 2 2 2 2 2 2 1 1 2 2 0 1 ]],
54             NU => [qw[ 2 0 1 1 1 0 0 0 2 1 1 1 2 1 1 1 2 2 0 1 ]],
55             AL => [qw[ 2 0 1 1 1 0 0 0 2 2 1 1 2 1 1 1 2 2 0 1 ]],
56             ID => [qw[ 2 0 1 1 1 0 0 0 2 1 2 2 2 1 1 1 2 2 0 1 ]],
57             IN => [qw[ 2 0 1 1 1 0 0 0 2 2 2 2 2 1 1 1 2 2 0 1 ]],
58             HY => [qw[ 2 0 1 1 1 0 0 0 2 2 0 2 2 2 1 1 2 2 0 1 ]],
59             BA => [qw[ 2 0 1 1 1 0 0 0 2 2 2 2 2 2 1 1 2 2 0 1 ]],
60             BB => [qw[ 1 0 1 1 1 0 0 0 1 1 1 1 1 1 1 1 1 1 0 1 ]],
61             B2 => [qw[ 2 0 1 1 1 0 0 0 2 2 2 2 2 2 1 1 2 0 0 1 ]],
62             ZW => [qw[ 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 0 1 ]],
63             CM => [qw[ 2 0 1 1 1 0 0 0 2 2 1 1 2 1 1 1 2 2 0 1 ]],
64             );
65              
66             # Convert the table above into a hash that we can use for speedier lookups
67              
68             foreach (keys %BREAK_TABLE) {
69             my @t = @CLASSES;
70             $BREAK_TABLE{$_} = { map { shift(@t) => $_ } @{$BREAK_TABLE{$_}} };
71             }
72              
73             sub new {
74 0     0 0   my $pkg = shift;
75 0           my $self = { @_ };
76 0   0       $self->{'line_length'} ||= $columns;
77 0   0       $self->{'break_table'} ||= \%BREAK_TABLE;
78              
79 0   0       $self->{'widthfunc'} ||= 1;
80              
81 0   0       bless($self, ref($pkg) || $pkg);
82 0           return $self;
83             }
84              
85             # This attempts to identify the on-screen length of a given character.
86             # For normal displays, you can generally assume the character has a
87             # length of 1, but some terminals may expand the width of certain
88             # characters, so that extra space needs to be taken into consideration
89             # here so the wrapping occurs at the proper place.
90              
91             sub char_length {
92 0 0   0 0   shift if ref($_[0]);
93 0           my ($c) = @_;
94              
95 0 0 0       if ($c eq 'CM' || $c eq 'ZW') {
96 0           return 0;
97             }
98              
99 0           return 1;
100             }
101              
102             sub lb_class {
103 0 0   0 0   my $self = ref($_[0]) ? shift() : self();
104 0           my $code = Unicode::UCD::_getcode(ord $_[0]);
105 0           my $hex;
106              
107 0 0         if (defined $code) {
108 0           $hex = sprintf("%04X", $code);
109             } else {
110 0           carp("unexpected arg \"$_[1]\" to Text::Wrap::lb_class()");
111 0           return;
112             }
113              
114 0 0         return $classified{$hex} if $classified{$hex};
115              
116 0 0         $txt = do "unicore/Lbrk.pl" unless $txt;
117              
118 0 0         if ($txt =~ m/^$hex\t\t(.+)/m) {
119 0 0         print STDERR "< found direct match for $hex = $1 >\n" if $DEBUG > 1;
120 0           return $classified{$hex} = $1;
121             } else {
122 0 0         print STDERR "< no direct match $hex >\n" if $DEBUG > 1;
123 0           pos($txt) = 0;
124              
125 0           while ($txt =~ m/^([0-9A-F]+)\t([0-9A-F]+)\t(.+)/mg) {
126 0 0         print STDERR "< examining $1 -> $2 >\n" if $DEBUG > 1;
127 0 0 0       if (hex($1) <= $code && hex($2) >= $code) {
128 0 0         print STDERR "< found range match for $hex = $3 between $1 and $2 >\n" if $DEBUG > 1;
129 0           return $classified{$hex} = $3;
130             }
131             }
132 0           return 'XX';
133             }
134             }
135              
136             # Returns a list of breaking properties for the given text
137             sub text_properties {
138 0 0   0 0   my $self = ref($_[0])? shift(): self();
139 0           my ($text) = @_;
140              
141 0           my @characters = split(//, $text);
142 0           my @classifications = map { $self->lb_class($_) } @characters;
  0            
143              
144 0           return class_properties(@classifications);
145             }
146              
147             # Returns a list of breaking properties for the provided breaking classes
148             sub class_properties {
149 0 0   0 0   my $self = ref($_[0])? shift(): self();
150             # no warnings 'uninitialized';
151              
152 0           my @breaks;
153 0           my $last_class = $_[0];
154              
155 0 0         $last_class = 'ID' if $last_class eq 'CM'; # broken combining mark
156              
157 0 0         print STDERR "find_breaks: first class=$last_class\n" if $DEBUG;
158              
159 0           for (my $i=1; $i <= $#_; $i++) {
160 0 0         print STDERR "find_breaks: i=$i class=$_[$i] prev=$last_class breaks[i-1]=$breaks[$i-1]\n" if $DEBUG;
161 0   0       $breaks[$i-1] ||= 0;
162              
163 0 0         $_[$i] = 'ID' if $_[$i] eq 'XX'; # we want as few of these as possible!
164              
165 0 0         if ($_[$i] eq 'SA') {
    0          
    0          
    0          
    0          
    0          
    0          
166             # TODO: Need a classifiation system for complex characters
167             } elsif ($_[$i] eq 'CR') {
168 0           $breaks[$i] = REQUIRED;
169             } elsif ($_[$i] eq 'LF') {
170 0 0         if ($_[$i-1] eq 'CR') {
171 0           $breaks[$i-1] = PROHIBITED;
172             }
173 0           $breaks[$i] = REQUIRED;
174             } elsif ($_[$i] eq 'BK') {
175 0           $breaks[$i] = REQUIRED;
176             } elsif ($_[$i] eq 'SP') {
177 0           $breaks[$i-1] = PROHIBITED;
178 0           next;
179             } elsif ($_[$i] eq 'CM') {
180 0 0         if ($_[$i-1] eq 'SP') {
181 0           $last_class = 'ID';
182 0 0         if ($i > 1) {
183 0 0         $breaks[$i-2] = $self->{'break_table'}->{$_[$i-2]}->{'ID'}
184             == DIRECT? DIRECT: PROHIBITED;
185             }
186             }
187             } elsif ($last_class ne 'SP') {
188 0 0         if ($breaks[$i-1] != REQUIRED) {
189 0           my $this_break = $self->{'break_table'}->{$last_class}->{$_[$i]};
190              
191 0 0         if ($this_break == INDIRECT) {
192 0 0         $breaks[$i-1] = $_[$i-1] eq 'SP'? INDIRECT: PROHIBITED;
193             } else {
194             # die "Internal error: no table mapping between '$last_class' and '$_[$i]'\n"
195             # unless defined $this_break;
196 0 0         if (defined $this_break) {
197 0           $breaks[$i-1] = $this_break;
198             } else {
199 0           $breaks[$i-1] = DIRECT;
200             }
201             }
202             }
203             }
204              
205 0           $last_class = $_[$i];
206             }
207              
208             # $breaks[$#breaks] = DIRECT;
209 0           push(@breaks, REQUIRED);
210              
211 0 0         print STDERR "find_breaks: returning " . join(":", @breaks) . "\n" if $DEBUG;
212 0           return @breaks;
213             }
214              
215             # Returns a list of break points in the provided text, based on
216             # the line length
217             sub find_breaks {
218 0 0   0 0   my $self = ref($_[0])? shift(): self();
219 0           my $text = shift;
220              
221             # no warnings 'uninitialized'; # since we do a lot of subscript +/- 1 checks
222              
223 0           my @characters = split(//, $text);
224              
225 0           my @classifications = map { $self->lb_class($_) } @characters;
  0            
226 0           my @lengths = map { $self->char_length($_) } @characters;
  0            
227              
228 0           my @breaks = $self->class_properties(@classifications);
229 0           my @breakpoints;
230              
231 0           my $last_start = 0;
232 0           my $last_break;
233             my $last_length;
234 0           my $pos = 0;
235              
236 0           for (my $i=0; $i <= $#lengths; $i++) {
237              
238 0 0         print STDERR "[i=$i '$characters[$i]' $classifications[$i] $breaks[$i]] " if $DEBUG;
239 0 0         if ($breaks[$i] == REQUIRED) {
240 0 0         print STDERR "required breakpoint\n" if $DEBUG;
241 0           push(@breakpoints, $i+1);
242 0           $last_start = $i+1;
243 0           $pos = 0;
244 0           next;
245             }
246              
247 0           my $c = $pos + $lengths[$i];
248              
249 0 0         if ($c > $self->{'line_length'}) {
250 0 0         print STDERR "want to break " if $DEBUG;
251 0 0 0       if (defined $last_break) {
    0          
252 0 0         print STDERR "at $last_break\n" if $DEBUG;
253 0           push(@breakpoints, $last_break + 1);
254 0           $last_start = $last_break + 1;
255 0           undef $last_break;
256 0           $pos -= $last_length - 1;
257 0 0         print STDERR "[pos now $pos]\n" if $DEBUG;
258 0           next;
259             } elsif (defined $self->{'emergency_break'} && $c > $self->{'emergency_break'}) {
260 0 0         print STDERR "NOW\n" if $DEBUG;
261 0           push(@breakpoints, $i+1);
262 0           $pos = 0;
263             } else {
264 0 0         print STDERR "but can't" if $DEBUG;
265             }
266             }
267 0 0         print STDERR "\n" if $DEBUG;
268              
269 0 0         $last_break = $i if $breaks[$i];
270 0 0         $last_length = $pos if $breaks[$i];
271              
272 0           $pos += $lengths[$i];
273             }
274              
275 0 0         push(@breakpoints, $#lengths) if $breakpoints[-1] < $#lengths;
276              
277 0 0         print STDERR "find_breaks: returning breakpoints " . join(":", @breakpoints) . "\n" if $DEBUG;
278              
279 0           return @breakpoints;
280             }
281              
282             # Returns a list of lines, broken up with find_breaks
283             sub break_lines {
284 0 0   0 0   my $self = ref($_[0])? shift(): self();
285 0           my $text = shift;
286              
287 0           my @breaks = $self->find_breaks($text);
288 0           my @lines;
289              
290 0           my $last = 0;
291 0           foreach (@breaks) {
292 0           push(@lines, substr($text, $last, $_-$last));
293 0           $last = $_;
294             }
295              
296 0           return @lines;
297             }
298              
299             1;
300              
301             __END__