File Coverage

blib/lib/PDF/API2/UniWrap.pm
Criterion Covered Total %
statement 38 159 23.9
branch 0 104 0.0
condition 0 21 0.0
subroutine 13 21 61.9
pod 0 7 0.0
total 51 312 16.3


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