File Coverage

blib/lib/PDF/Builder/Content.pm
Criterion Covered Total %
statement 823 1446 56.9
branch 230 534 43.0
condition 39 178 21.9
subroutine 106 124 85.4
pod 66 69 95.6
total 1264 2351 53.7


line stmt bran cond sub pod time code
1             package PDF::Builder::Content;
2              
3 34     34   262 use base 'PDF::Builder::Basic::PDF::Dict';
  34         84  
  34         3636  
4              
5 34     34   227 use strict;
  34         78  
  34         737  
6 34     34   171 use warnings;
  34         74  
  34         1680  
7             #no warnings qw( deprecated recursion uninitialized );
8              
9             our $VERSION = '3.023'; # VERSION
10             our $LAST_UPDATE = '3.023'; # manually update whenever code is changed
11              
12 34     34   214 use Carp;
  34         92  
  34         2022  
13 34     34   238 use Compress::Zlib qw();
  34         91  
  34         782  
14 34     34   216 use Encode;
  34         103  
  34         3246  
15 34     34   251 use Math::Trig; # CAUTION: deg2rad(0) = deg2rad(360) = 0!
  34         76  
  34         6214  
16 34     34   258 use List::Util qw(min max);
  34         80  
  34         2161  
17 34     34   16022 use PDF::Builder::Matrix;
  34         98  
  34         1154  
18              
19 34     34   236 use PDF::Builder::Basic::PDF::Utils;
  34         82  
  34         2643  
20 34     34   248 use PDF::Builder::Util;
  34         83  
  34         4163  
21 34     34   20817 use PDF::Builder::Content::Text;
  34         113  
  34         542989  
22              
23             # unless otherwise noted, routines beginning with _ are internal helper
24             # functions and should not be used by others
25             #
26             =head1 NAME
27              
28             PDF::Builder::Content - Methods for adding graphics and text to a PDF
29              
30             =head1 SYNOPSIS
31              
32             # Start with a PDF page (new or opened)
33             my $pdf = PDF::Builder->new();
34             my $page = $pdf->page();
35              
36             # Add new content object(s)
37             my $content = $page->gfx();
38             # and/or (as separate object name)
39             my $content = $page->text();
40              
41             # Then call the methods below to add graphics and text to the page.
42             # Note that negative coordinates can have unpredictable effects, so
43             # keep your coordinates non-negative!
44              
45             These methods add content to I output for text or graphics objects.
46             Unless otherwise restricted by a check that we are in or out of text mode,
47             many methods listed here apply equally to text and graphics streams. It is
48             possible that there I some which have no effect in one stream type or
49             the other, but are currently lacking a check to prevent them from being
50             inserted into an inapplicable stream.
51              
52             =head1 METHODS
53              
54             All public methods listed, I return C<$self>.
55              
56             =cut
57              
58             sub new {
59 111     111 1 294 my ($class) = @_;
60              
61 111         470 my $self = $class->SUPER::new(@_);
62 111         276 $self->{' stream'} = '';
63 111         238 $self->{' poststream'} = '';
64 111         236 $self->{' font'} = undef;
65 111         217 $self->{' fontset'} = 0;
66 111         235 $self->{' fontsize'} = 0;
67 111         229 $self->{' charspace'} = 0;
68 111         314 $self->{' hscale'} = 100;
69 111         233 $self->{' wordspace'} = 0;
70 111         226 $self->{' leading'} = 0;
71 111         218 $self->{' rise'} = 0;
72 111         233 $self->{' render'} = 0;
73 111         358 $self->{' matrix'} = [1,0,0,1,0,0];
74 111         309 $self->{' textmatrix'} = [1,0,0,1,0,0];
75 111         270 $self->{' textlinematrix'} = [0,0];
76 111         354 $self->{' fillcolor'} = [0];
77 111         263 $self->{' strokecolor'} = [0];
78 111         275 $self->{' translate'} = [0,0];
79 111         251 $self->{' scale'} = [1,1];
80 111         242 $self->{' skew'} = [0,0];
81 111         225 $self->{' rotate'} = 0;
82 111         214 $self->{' linewidth'} = 1; # see also gs LW
83 111         255 $self->{' linecap'} = 0; # see also gs LC
84 111         195 $self->{' linejoin'} = 0; # see also gs LJ
85 111         200 $self->{' miterlimit'} = 10; # see also gs ML
86 111         293 $self->{' linedash'} = [[],0]; # see also gs D
87 111         206 $self->{' flatness'} = 1; # see also gs FL
88 111         200 $self->{' apiistext'} = 0;
89 111         232 $self->{' openglyphlist'} = 0;
90              
91 111         298 return $self;
92             }
93              
94             # internal helper method
95             sub outobjdeep {
96 102     102 1 193 my $self = shift();
97              
98 102         414 $self->textend();
99             # foreach my $k (qw[ api apipdf apiistext apipage font fontset fontsize
100             # charspace hscale wordspace leading rise render matrix
101             # textmatrix textlinematrix fillcolor strokecolor
102             # translate scale skew rotate ]) {
103             # $self->{" $k"} = undef;
104             # delete($self->{" $k"});
105             # }
106 102 50 66     296 if ($self->{'-docompress'} && $self->{'Filter'}) {
107 4         29 $self->{' stream'} = Compress::Zlib::compress($self->{' stream'});
108 4         1769 $self->{' nofilt'} = 1;
109 4         11 delete $self->{'-docompress'};
110             }
111 102         412 return $self->SUPER::outobjdeep(@_);
112             }
113              
114             =head2 Coordinate Transformations
115              
116             The methods in this section change the coordinate system for the
117             current content object relative to the rest of the document.
118             B the changes are relative to the I page coordinates (and
119             thus, absolute), not to the previous position! Thus, C
120             translate(10, 10);> ends up only moving the origin to C<[10, 10]>, rather than
121             to C<[20, 20]>. There is one call, C, which makes your changes
122             I to the previous position.
123              
124             If you call more than one of these methods, the PDF specification
125             recommends calling them in the following order: translate, rotate,
126             scale, skew. Each change builds on the last, and you can get
127             unexpected results when calling them in a different order.
128              
129             B a I object ($content) behaves a bit differently. Individual
130             translate, rotate, scale, and skew calls I any previous settings.
131             If you want to combine multiple transformations for text, use the C
132             call.
133              
134             =over
135              
136             =item $content->translate($dx,$dy)
137              
138             Moves the origin along the x and y axes by
139             C<$dx> and C<$dy> respectively.
140              
141             =cut
142              
143             sub _translate {
144 8     8   21 my ($x,$y) = @_;
145              
146 8         23 return (1,0,0,1, $x,$y);
147             }
148              
149             # transform in turn calls _translate
150             sub translate {
151 2     2 1 12 my ($self, $x,$y) = @_;
152              
153 2         20 $self->transform(-translate => [$x,$y]);
154              
155 2         7 return $self;
156             }
157              
158             =item $content->rotate($degrees)
159              
160             Rotates the coordinate system counter-clockwise (anti-clockwise) around the
161             current origin. Use a negative argument to rotate clockwise. Note that 360
162             degrees will be treated as 0 degrees.
163              
164             B Unless you have already moved (translated) the origin, it is, and will
165             remain, at the lower left corner of the visible sheet. It will I
166             automatically shift to another corner. For example, a rotation of +90 degrees
167             (counter-clockwise) will leave the entire visible sheet in negative Y territory (0 at the left edge, -original_width at the right edge), while X remains in
168             positive territory (0 at bottom, +original_height at the top edge).
169              
170             This C call permits any angle. Do not confuse it with the I
171             rotation C call, which only permits increments of 90 degrees (with
172             opposite sign!), but I shift the origin to another corner of the sheet.
173              
174             =cut
175              
176             sub _rotate {
177 5     5   11 my ($deg) = @_;
178              
179 5         19 return (cos(deg2rad($deg)), sin(deg2rad($deg)), -sin(deg2rad($deg)), cos(deg2rad($deg)), 0,0);
180             }
181              
182             # transform in turn calls _rotate
183             sub rotate {
184 1     1 1 9 my ($self, $deg) = @_;
185              
186 1         7 $self->transform(-rotate => $deg);
187              
188 1         3 return $self;
189             }
190              
191             =item $content->scale($sx,$sy)
192              
193             Scales (stretches) the coordinate systems along the x and y axes.
194             Separate multipliers are provided for x and y.
195              
196             =cut
197              
198             sub _scale {
199 5     5   12 my ($sx,$sy) = @_;
200              
201 5         18 return ($sx,0,0,$sy, 0,0);
202             }
203              
204             # transform in turn calls _scale
205             sub scale {
206 1     1 1 9 my ($self, $sx,$sy) = @_;
207              
208 1         7 $self->transform(-scale => [$sx,$sy]);
209              
210 1         4 return $self;
211             }
212              
213             =item $content->skew($skx,$sky)
214              
215             Skews the coordinate system by C<$skx> degrees
216             (counter-clockwise/anti-clockwise) from
217             the x axis I C<$sky> degrees (clockwise) from the y axis.
218             Note that 360 degrees will be treated the same as 0 degrees.
219              
220             =cut
221              
222             sub _skew {
223 5     5   11 my ($skx,$sky) = @_;
224              
225 5         23 return (1, tan(deg2rad($skx)), tan(deg2rad($sky)), 1, 0,0);
226             }
227              
228             # transform in turn calls _skew
229             sub skew {
230 1     1 1 8 my ($self, $skx,$sky) = @_;
231              
232 1         7 $self->transform(-skew => [$skx,$sky]);
233              
234 1         3 return $self;
235             }
236              
237             =item $content->transform(%opts)
238              
239             Use one or more of the given %opts:
240              
241             $content->transform(
242             -translate => [$dx,$dy],
243             -rotate => $degrees,
244             -scale => [$sx,$sy],
245             -skew => [$skx,$sky],
246             -matrix => [$a, $b, $c, $d, $e, $f],
247             -point => [$x,$y]
248             )
249              
250             A six element list may be given (C<-matrix>) for a
251             further transformation matrix:
252              
253             $a = cos(rot) * scale factor for X
254             $b = sin(rot) * tan(skew for X)
255             $c = -sin(rot) * tan(skew for Y)
256             $d = cos(rot) * scale factor for Y
257             $e = translation for X
258             $f = translation for Y
259              
260             Performs multiple coordinate transformations at once, in the order
261             recommended by the PDF specification (translate, rotate, scale, skew).
262             This is equivalent to making each transformation separately, I
263             indicated order>.
264             A matrix of 6 values may also be given (C<-matrix>). The transformation matrix
265             is updated.
266             A C<-point> may be given (a point to be multiplied [transformed] by the
267             completed matrix).
268              
269             =cut
270              
271             sub _transform {
272 11     11   42 my (%opts) = @_;
273              
274             # start with "no-op" identity matrix
275 11         110 my $mtx = PDF::Builder::Matrix->new([1,0,0], [0,1,0], [0,0,1]);
276             # note order of operations, compared to PDF spec
277 11         39 foreach my $o (qw( -matrix -skew -scale -rotate -translate )) {
278 55 100       140 next unless defined $opts{$o};
279              
280 23 100       80 if ($o eq '-translate') {
    100          
    100          
    50          
    0          
281 8         25 my @mx = _translate(@{$opts{$o}});
  8         30  
282 8         47 $mtx = $mtx->multiply(PDF::Builder::Matrix->new(
283             [$mx[0],$mx[1],0],
284             [$mx[2],$mx[3],0],
285             [$mx[4],$mx[5],1]
286             ));
287             } elsif ($o eq '-rotate') {
288 5         17 my @mx = _rotate($opts{$o});
289 5         218 $mtx = $mtx->multiply(PDF::Builder::Matrix->new(
290             [$mx[0],$mx[1],0],
291             [$mx[2],$mx[3],0],
292             [$mx[4],$mx[5],1]
293             ));
294             } elsif ($o eq '-scale') {
295 5         19 my @mx = _scale(@{$opts{$o}});
  5         18  
296 5         29 $mtx = $mtx->multiply(PDF::Builder::Matrix->new(
297             [$mx[0],$mx[1],0],
298             [$mx[2],$mx[3],0],
299             [$mx[4],$mx[5],1]
300             ));
301             } elsif ($o eq '-skew') {
302 5         9 my @mx = _skew(@{$opts{$o}});
  5         18  
303 5         284 $mtx = $mtx->multiply(PDF::Builder::Matrix->new(
304             [$mx[0],$mx[1],0],
305             [$mx[2],$mx[3],0],
306             [$mx[4],$mx[5],1]
307             ));
308             } elsif ($o eq '-matrix') {
309 0         0 my @mx = @{$opts{$o}}; # no check that 6 elements given
  0         0  
310 0         0 $mtx = $mtx->multiply(PDF::Builder::Matrix->new(
311             [$mx[0],$mx[1],0],
312             [$mx[2],$mx[3],0],
313             [$mx[4],$mx[5],1]
314             ));
315             }
316             }
317 11 50       46 if ($opts{'-point'}) {
318 0         0 my $mp = PDF::Builder::Matrix->new([$opts{'-point'}->[0], $opts{'-point'}->[1], 1]);
319 0         0 $mp = $mp->multiply($mtx);
320 0         0 return ($mp->[0][0], $mp->[0][1]);
321             }
322              
323             # if not -point
324             return (
325 11         91 $mtx->[0][0],$mtx->[0][1],
326             $mtx->[1][0],$mtx->[1][1],
327             $mtx->[2][0],$mtx->[2][1]
328             );
329             }
330              
331             sub transform {
332 11     11 1 1040 my ($self, %opts) = @_;
333              
334             # includes -point and -matrix operations
335 11         73 $self->matrix(_transform(%opts));
336              
337 11 100       38 if ($opts{'-translate'}) {
338 8         23 @{$self->{' translate'}} = @{$opts{'-translate'}};
  8         25  
  8         21  
339             } else {
340 3         16 @{$self->{' translate'}} = (0,0);
  3         12  
341             }
342              
343 11 100       53 if ($opts{'-rotate'}) {
344 5         15 $self->{' rotate'} = $opts{'-rotate'};
345             } else {
346 6         16 $self->{' rotate'} = 0;
347             }
348              
349 11 100       42 if ($opts{'-scale'}) {
350 5         8 @{$self->{' scale'}} = @{$opts{'-scale'}};
  5         12  
  5         11  
351             } else {
352 6         14 @{$self->{' scale'}} = (1,1);
  6         15  
353             }
354              
355 11 100       31 if ($opts{'-skew'}) {
356 5         9 @{$self->{' skew'}} = @{$opts{'-skew'}};
  5         11  
  5         10  
357             } else {
358 6         12 @{$self->{' skew'}} = (0,0);
  6         15  
359             }
360              
361 11         29 return $self;
362             }
363              
364             =item $content->transform_rel(%opts)
365              
366             Makes transformations similarly to C, except that it I
367             to the previously set values, rather than I them (except for
368             I, which B the new values with the old).
369              
370             Unlike C, C<-matrix> and C<-point> are not supported.
371              
372             =cut
373              
374             sub transform_rel {
375 1     1 1 14 my ($self, %opts) = @_;
376              
377 1 50       3 my ($sa1,$sb1) = @{$opts{'-skew'} ? $opts{'-skew'} : [0,0]};
  1         7  
378 1         2 my ($sa0,$sb0) = @{$self->{" skew"}};
  1         4  
379              
380 1 50       2 my ($sx1,$sy1) = @{$opts{'-scale'} ? $opts{'-scale'} : [1,1]};
  1         6  
381 1         2 my ($sx0,$sy0) = @{$self->{" scale"}};
  1         4  
382              
383 1   50     4 my $rot1 = $opts{'-rotate'} || 0;
384 1         2 my $rot0 = $self->{" rotate"};
385              
386 1 50       3 my ($tx1,$ty1) = @{$opts{'-translate'} ? $opts{'-translate'} : [0,0]};
  1         4  
387 1         2 my ($tx0,$ty0) = @{$self->{" translate"}};
  1         2  
388              
389 1         10 $self->transform(
390             -skew => [$sa0+$sa1, $sb0+$sb1],
391             -scale => [$sx0*$sx1, $sy0*$sy1],
392             -rotate => $rot0+$rot1,
393             -translate => [$tx0+$tx1, $ty0+$ty1]
394             );
395              
396 1         5 return $self;
397             }
398              
399             =item $content->matrix($a, $b, $c, $d, $e, $f)
400              
401             I<(Advanced)> Sets the current transformation matrix manually. Unless
402             you have a particular need to enter transformations manually, you
403             should use the C method instead.
404              
405             $a = cos(rot) * scale factor for X
406             $b = sin(rot) * tan(skew for X)
407             $c = -sin(rot) * tan(skew for Y)
408             $d = cos(rot) * scale factor for Y
409             $e = translation for X
410             $f = translation for Y
411              
412             In text mode, the text matrix is B.
413             In graphics mode, C<$self> is B.
414              
415             =cut
416              
417             sub _matrix_text {
418 3     3   8 my ($a, $b, $c, $d, $e, $f) = @_;
419              
420 3         15 return (floats($a, $b, $c, $d, $e, $f), 'Tm');
421             }
422              
423             sub _matrix_gfx {
424 17     17   59 my ($a, $b, $c, $d, $e, $f) = @_;
425              
426 17         93 return (floats($a, $b, $c, $d, $e, $f), 'cm');
427             }
428              
429             # internal helper method
430             sub matrix_update {
431 70     70 0 174 my ($self, $tx,$ty) = @_;
432              
433 70         152 $self->{' textlinematrix'}->[0] += $tx;
434 70         124 $self->{' textlinematrix'}->[1] += $ty;
435 70         142 return $self;
436             }
437              
438             sub matrix {
439 20     20 1 88 my ($self, $a, $b, $c, $d, $e, $f) = @_;
440              
441 20 50       75 if (defined $a) {
442 20 100       78 if ($self->_in_text_object()) {
443 3         12 $self->add(_matrix_text($a, $b, $c, $d, $e, $f));
444 3         9 @{$self->{' textmatrix'}} = ($a, $b, $c, $d, $e, $f);
  3         9  
445 3         7 @{$self->{' textlinematrix'}} = (0,0);
  3         8  
446             } else {
447 17         79 $self->add(_matrix_gfx($a, $b, $c, $d, $e, $f));
448             }
449             }
450 20 100       98 if ($self->_in_text_object()) {
451 3         6 return @{$self->{' textmatrix'}};
  3         9  
452             } else {
453 17         48 return $self;
454             }
455             }
456              
457             =back
458              
459             =head2 Graphics State Parameters
460              
461             The following calls also affect the B state.
462              
463             =over
464              
465             =item $content->linewidth($width)
466              
467             Sets the width of the stroke. This is the line drawn in graphics mode, or the
468             I of a character in text mode (with appropriate C mode).
469             If no C<$width> is given, the current setting is B. If the width is
470             being set, C<$self> is B so that calls may be chained.
471              
472             =cut
473              
474             sub _linewidth {
475 87     87   134 my ($linewidth) = @_;
476              
477 87         202 return ($linewidth, 'w');
478             }
479              
480             sub linewidth {
481 87     87 1 204 my ($self, $linewidth) = @_;
482              
483 87 50       164 if (!defined $linewidth) {
484 0         0 return $self->{' linewidth'};
485             }
486 87         137 $self->add(_linewidth($linewidth));
487 87         138 $self->{' linewidth'} = $linewidth;
488              
489 87         130 return $self;
490             }
491              
492             =item $content->linecap($style)
493              
494             Sets the style to be used at the end of a stroke. This applies to lines
495             which come to a free-floating end, I to "joins" ("corners") in
496             polylines (see C).
497              
498             =over
499              
500             =item 0 = Butt Cap
501              
502             The stroke ends at the end of the path, with no projection.
503              
504             =item 1 = Round Cap
505              
506             A semicircular arc is drawn around the end of the path with a diameter equal to
507             the line width, and is filled in.
508              
509             =item 2 = Projecting Square Cap
510              
511             The stroke continues past the end of the path for half the line width.
512              
513             =back
514              
515             If no C<$style> is given, the current setting is B. If the style is
516             being set, C<$self> is B so that calls may be chained.
517              
518             =cut
519              
520             sub _linecap {
521 1     1   3 my ($linecap) = @_;
522              
523 1         5 return ($linecap, 'J');
524             }
525              
526             sub linecap {
527 1     1 1 8 my ($self, $linecap) = @_;
528              
529 1 50       6 if (!defined $linecap) {
530 0         0 return $self->{' linecap'};
531             }
532 1         5 $self->add(_linecap($linecap));
533 1         4 $self->{' linecap'} = $linecap;
534              
535 1         3 return $self;
536             }
537              
538             =item $content->linejoin($style)
539              
540             Sets the style of join to be used at corners of a path
541             (within a multisegment polyline).
542              
543             =over
544              
545             =item 0 = Miter Join
546              
547             The outer edges of the strokes extend until they meet, up to the limit
548             specified by I. If the limit would be surpassed, a I join
549             is used instead. For a given linewidth, the more acute the angle is (closer
550             to 0 degrees), the higher the ratio of miter length to linewidth will be, and
551             that's what I controls.
552              
553             =item 1 = Round Join
554              
555             A filled circle with a diameter equal to the I is drawn around the
556             corner point, producing a rounded corner. The arc will meet up with the sides
557             of the line in a smooth tangent.
558              
559             =item 2 = Bevel Join
560              
561             A filled triangle is drawn to fill in the notch between the two strokes.
562              
563             =back
564              
565             If no C<$style> is given, the current setting is B. If the style is
566             being set, C<$self> is B so that calls may be chained.
567              
568             =cut
569              
570             sub _linejoin {
571 1     1   3 my ($style) = @_;
572              
573 1         5 return ($style, 'j');
574             }
575              
576             sub linejoin {
577 1     1 1 9 my ($self, $style) = @_;
578              
579 1 50       4 if (!defined $style) {
580 0         0 return $self->{' linejoin'};
581             }
582 1         4 $self->add(_linejoin($style));
583 1         3 $self->{' linejoin'} = $style;
584              
585 1         4 return $self;
586             }
587              
588             =item $content->miterlimit($ratio)
589              
590             Sets the miter limit when the line join style is a I join.
591              
592             The ratio is the maximum length of the miter (inner to outer corner) divided
593             by the line width. Any miter above this ratio will be converted to a I
594             join. The practical effect is that lines meeting at shallow
595             angles are chopped off instead of producing long pointed corners.
596              
597             The default miter limit is 10.0 (approximately 11.5 degree cutoff angle).
598             The smaller the limit, the larger the cutoff angle.
599              
600             If no C<$ratio> is given, the current setting is B. If the ratio is
601             being set, C<$self> is B so that calls may be chained.
602              
603             =cut
604              
605             sub _miterlimit {
606 1     1   3 my ($ratio) = @_;
607              
608 1         4 return ($ratio, 'M');
609             }
610              
611             sub miterlimit {
612 1     1 1 7 my ($self, $ratio) = @_;
613              
614 1 50       5 if (!defined $ratio) {
615 0         0 return $self->{' miterlimit'};
616             }
617 1         4 $self->add(_miterlimit($ratio));
618 1         3 $self->{' miterlimit'} = $ratio;
619              
620 1         2 return $self;
621             }
622              
623             # Note: miterlimit was originally named incorrectly to meterlimit, renamed
624              
625             =item $content->linedash()
626              
627             =item $content->linedash($length)
628              
629             =item $content->linedash($dash_length, $gap_length, ...)
630              
631             =item $content->linedash(-pattern => [$dash_length, $gap_length, ...], -shift => $offset)
632              
633             Sets the line dash pattern.
634              
635             If called without any arguments, a solid line will be drawn.
636              
637             If called with one argument, the dashes and gaps (strokes and
638             spaces) will have equal lengths.
639              
640             If called with two or more arguments, the arguments represent
641             alternating dash and gap lengths.
642              
643             If called with a hash of arguments, the I<-pattern> array may have one or
644             more elements, specifying the dash and gap lengths.
645             A dash phase may be set (I<-shift>), which is a B
646             specifying the distance into the pattern at which to start the dashed line.
647             Note that if you wish to give a I amount, using C<-shift>,
648             you need to use C<-pattern> instead of one or two elements.
649              
650             If an B number of dash array elements are given, the list is repeated by
651             the reader software to form an even number of elements (pairs).
652              
653             If a single argument of B<-1> is given, the current setting is B.
654             This is an array consisting of two elements: an anonymous array containing the
655             dash pattern (default: empty), and the shift (offset) amount (default: 0).
656             If the dash pattern is being I, C<$self> is B so that calls may
657             be chained.
658              
659             =cut
660              
661             sub _linedash {
662 10     10   22 my ($self, @pat) = @_;
663              
664 10 100       25 unless (scalar @pat) { # no args
665 7         26 $self->{' linedash'} = [[],0];
666 7         39 return ('[', ']', '0', 'd');
667             } else {
668 3 100       13 if ($pat[0] =~ /^\-/) {
669 1         5 my %pat = @pat;
670              
671             # Note: use -pattern to replace the old -full and -clear options
672 1   50     3 $self->{' linedash'} = [[@{$pat{'-pattern'}}],($pat{'-shift'} || 0)];
  1         6  
673 1   50     4 return ('[', floats(@{$pat{'-pattern'}}), ']', ($pat{'-shift'} || 0), 'd');
  1         6  
674             } else {
675 2         10 $self->{' linedash'} = [[@pat],0];
676 2         10 return ('[', floats(@pat), '] 0 d');
677             }
678             }
679             }
680              
681             sub linedash {
682 10     10 1 50 my ($self, @pat) = @_;
683              
684 10 50 66     64 if (scalar @pat == 1 && $pat[0] == -1) {
685 0         0 return @{$self->{' linedash'}};
  0         0  
686             }
687 10         48 $self->add($self->_linedash(@pat));
688              
689 10         28 return $self;
690             }
691              
692             =item $content->flatness($tolerance)
693              
694             I<(Advanced)> Sets the maximum variation in output pixels when drawing
695             curves. The defined range of C<$tolerance> is 0 to 100, with 0 meaning I
696             the device default flatness>. According to the PDF specification, you should
697             not try to force visible line segments (the curve's approximation); results
698             will be unpredictable. Usually, results for different flatness settings will be
699             indistinguishable to the eye.
700              
701             The C<$tolerance> value is silently clamped to be between 0 and 100.
702              
703             If no C<$tolerance> is given, the current setting is B. If the
704             tolerance is being set, C<$self> is B so that calls may be chained.
705              
706             =cut
707              
708             sub _flatness {
709 1     1   3 my ($tolerance) = @_;
710              
711 1 50       5 if ($tolerance < 0 ) { $tolerance = 0; }
  0         0  
712 1 50       3 if ($tolerance > 100) { $tolerance = 100; }
  0         0  
713 1         6 return ($tolerance, 'i');
714             }
715              
716             sub flatness {
717 1     1 1 8 my ($self, $tolerance) = @_;
718              
719 1 50       5 if (!defined $tolerance) {
720 0         0 return $self->{' flatness'};
721             }
722 1         4 $self->add(_flatness($tolerance));
723 1         3 $self->{' flatness'} = $tolerance;
724              
725 1         4 return $self;
726             }
727              
728             =item $content->egstate($object)
729              
730             I<(Advanced)> Adds an Extended Graphic State B containing additional
731             state parameters.
732              
733             =cut
734              
735             sub egstate {
736 0     0 1 0 my ($self, $egs) = @_;
737              
738 0         0 $self->add('/' . $egs->name(), 'gs');
739 0         0 $self->resource('ExtGState', $egs->name(), $egs);
740              
741 0         0 return $self;
742             }
743              
744             =back
745              
746             =head2 Path Construction (Drawing)
747              
748             =over
749              
750             =item $content->move($x,$y)
751              
752             Starts a new path at the specified coordinates.
753             Note that multiple x,y pairs I be given, although this isn't that useful
754             (only the last pair would have an effect).
755              
756             =cut
757              
758             sub _move {
759 0     0   0 my ($x,$y) = @_;
760              
761 0         0 return (floats($x,$y), 'm');
762             }
763              
764             sub move {
765 107     107 1 232 my ($self) = shift;
766              
767 107         166 my ($x,$y);
768 107         234 while (scalar @_ >= 2) {
769 107         155 $x = shift;
770 107         124 $y = shift;
771 107         152 $self->{' mx'} = $x;
772 107         149 $self->{' my'} = $y;
773 107 50       210 if ($self->_in_text_object()) {
774 0         0 $self->add_post(floats($x,$y), 'm');
775             } else {
776 107         280 $self->add(floats($x,$y), 'm');
777             }
778 107         197 $self->{' x'} = $x; # set new current position
779 107         244 $self->{' y'} = $y;
780             }
781             #if (scalar @_) { # normal practice is to discard unused values
782             # warn "extra coordinate(s) ignored in move\n";
783             #}
784              
785 107         187 return $self;
786             }
787              
788             =item $content->close()
789              
790             Closes and ends the current path by extending a line from the current
791             position to the starting position.
792              
793             =cut
794              
795             sub close {
796 10     10 1 38 my ($self) = shift;
797              
798 10         25 $self->add('h');
799 10         23 $self->{' x'} = $self->{' mx'};
800 10         17 $self->{' y'} = $self->{' my'};
801              
802 10         20 return $self;
803             }
804              
805             =item $content->endpath()
806              
807             Ends the current path without explicitly enclosing it.
808             That is, unlike C, there is B line segment
809             drawn back to the starting position.
810              
811             =cut
812              
813             sub endpath {
814 1     1 1 6 my ($self) = shift;
815              
816 1         4 $self->add('n');
817              
818 1         2 return $self;
819             }
820              
821             =back
822              
823             =head3 Straight line constructs
824              
825             B None of these will actually be I until you call C or
826             C. They are merely setting up the path to draw.
827              
828             =over
829              
830             =item $content->line($x,$y)
831              
832             =item $content->line($x,$y, $x2,$y2,...)
833              
834             Extends the path in a line from the I coordinates to the
835             specified coordinates, and updates the current position to be the new
836             coordinates.
837              
838             Multiple additional C<[$x,$y]> pairs are permitted, to draw joined multiple
839             line segments. Note that this is B equivalent to a polyline (see C),
840             because the first C<[$x,$y]> pair in a polyline is a I operation.
841             Also, the C setting will be used rather than the C
842             setting for treating the ends of segments.
843              
844             =cut
845              
846             sub _line {
847 0     0   0 my ($x,$y) = @_;
848              
849 0         0 return (floats($x,$y), 'l');
850             }
851              
852             sub line {
853 92     92 1 157 my ($self) = shift;
854              
855 92         123 my ($x,$y);
856 92         167 while (scalar @_ >= 2) {
857 93         118 $x = shift;
858 93         117 $y = shift;
859 93 50       153 if ($self->_in_text_object()) {
860 0         0 $self->add_post(floats($x,$y), 'l');
861             } else {
862 93         220 $self->add(floats($x,$y), 'l');
863             }
864 93         168 $self->{' x'} = $x; # new current point
865 93         206 $self->{' y'} = $y;
866             }
867             #if (scalar @_) { leftovers ignored, as is usual practice
868             # warn "line() has leftover coordinate (ignored).";
869             #}
870              
871 92         158 return $self;
872             }
873              
874             =item $content->hline($x)
875              
876             =item $content->vline($y)
877              
878             Shortcuts for drawing horizontal and vertical lines from the current
879             position. They are like C, but to the new x and current y (C),
880             or to the the current x and new y (C).
881              
882             =cut
883              
884             sub hline {
885 2     2 1 15 my ($self, $x) = @_;
886              
887 2 50       7 if ($self->_in_text_object()) {
888 0         0 $self->add_post(floats($x, $self->{' y'}), 'l');
889             } else {
890 2         10 $self->add(floats($x, $self->{' y'}), 'l');
891             }
892             # extraneous inputs discarded
893 2         6 $self->{' x'} = $x; # update current position
894              
895 2         5 return $self;
896             }
897              
898             sub vline {
899 1     1 1 8 my ($self, $y) = @_;
900              
901 1 50       4 if ($self->_in_text_object()) {
902 0         0 $self->add_post(floats($self->{' x'}, $y), 'l');
903             } else {
904 1         5 $self->add(floats($self->{' x'}, $y), 'l');
905             }
906             # extraneous inputs discarded
907 1         4 $self->{' y'} = $y; # update current position
908              
909 1         3 return $self;
910             }
911              
912             =item $content->poly($x1,$y1, ..., $xn,$yn)
913              
914             This is a shortcut for creating a polyline path. It moves to C<[$x1,$y1]>, and
915             then extends the path in line segments along the specified coordinates.
916             The current position is changed to the last C<[$x,$y]> pair given.
917              
918             The difference between a polyline and a C with multiple C<[$x,$y]>
919             pairs is that the first pair in a polyline are a I, while in a line
920             they are a I.
921             Also, C instead of C is used to control the appearance
922             of the ends of line segments.
923              
924             =cut
925              
926             sub poly {
927             # not implemented as self,x,y = @_, as @_ must be shifted
928 2     2 1 15 my ($self) = shift;
929 2         5 my $x = shift;
930 2         3 my $y = shift;
931              
932 2         7 $self->move($x,$y);
933 2         10 $self->line(@_);
934              
935 2         4 return $self;
936             }
937              
938             =item $content->rect($x,$y, $w,$h)
939              
940             =item $content->rect($x1,$y1, $w1,$h1, ..., $xn,$yn, $wn,$hn)
941              
942             This creates paths for one or more rectangles, with their lower left points
943             at C<[$x,$y]> and specified widths (+x direction) and heights (+y direction).
944             Negative widths and heights are permitted, which draw to the left (-x) and
945             below (-y) the given corner point, respectively.
946             The current position is changed to the C<[$x,$y]> of the last rectangle given.
947             Note that this is the I point of the rectangle, not the end point.
948              
949             =cut
950              
951             sub rect {
952 5     5 1 21 my $self = shift;
953              
954 5         10 my ($x,$y, $w,$h);
955 5         14 while (scalar @_ >= 4) {
956 6         9 $x = shift;
957 6         10 $y = shift;
958 6         9 $w = shift;
959 6         7 $h = shift;
960 6         21 $self->add(floats($x,$y, $w,$h), 're');
961             }
962             #if (scalar @_) { # usual practice is to ignore extras
963             # warn "rect() extra coordinates discarded.\n";
964             #}
965 5         12 $self->{' x'} = $x; # set new current position
966 5         8 $self->{' y'} = $y;
967              
968 5         11 return $self;
969             }
970              
971             =item $content->rectxy($x1,$y1, $x2,$y2)
972              
973             This creates a rectangular path, with C<[$x1,$y1]> and C<[$x2,$y2]>
974             specifying I corners. They can be Lower Left and Upper Right,
975             I Upper Left and Lower Right, in either order, so long as they are
976             diagonally opposite each other.
977             The current position is changed to the C<[$x1,$y1]> (first) pair.
978              
979             =cut
980              
981             # TBD allow multiple rectangles, as in rect()
982              
983             sub rectxy {
984 2     2 1 14 my ($self, $x,$y, $x2,$y2) = @_;
985              
986 2         9 $self->rect($x,$y, ($x2-$x),($y2-$y));
987              
988 2         5 return $self;
989             }
990              
991             =back
992              
993             =head3 Curved line constructs
994              
995             B None of these will actually be I until you call C or
996             C. They are merely setting up the path to draw.
997              
998             =over
999              
1000             =item $content->circle($xc,$yc, $radius)
1001              
1002             This creates a circular path centered on C<[$xc,$yc]> with the specified
1003             radius. It does B change the current position.
1004              
1005             =cut
1006              
1007             sub circle {
1008 1     1 1 9 my ($self, $xc,$yc, $r) = @_;
1009              
1010 1         6 $self->arc($xc,$yc, $r,$r, 0,360, 1);
1011 1         4 $self->close();
1012              
1013 1         3 return $self;
1014             }
1015              
1016             =item $content->ellipse($xc,$yc, $rx,$ry)
1017              
1018             This creates a closed elliptical path centered on C<[$xc,$yc]>, with axis radii
1019             (semidiameters) specified by C<$rx> (x axis) and C<$ry> (y axis), respectively.
1020             It does not change the current position.
1021              
1022             =cut
1023              
1024             sub ellipse {
1025 1     1 1 11 my ($self, $xc,$yc, $rx,$ry) = @_;
1026              
1027 1         6 $self->arc($xc,$yc, $rx,$ry, 0,360, 1);
1028 1         4 $self->close();
1029              
1030 1         3 return $self;
1031             }
1032              
1033             # input: x and y axis radii
1034             # sweep start and end angles
1035             # sweep direction (0=CCW (default), or 1=CW)
1036             # output: two endpoints and two control points for
1037             # the Bezier curve describing the arc
1038             # maximum 30 degrees of sweep: is broken up into smaller
1039             # arc segments if necessary
1040             # if crosses 0 degree angle in either sweep direction, split there at 0
1041             # if alpha=beta (0 degree sweep) or either radius <= 0, fatal error
1042             sub _arctocurve {
1043 159     159   316 my ($rx,$ry, $alpha,$beta, $dir) = @_;
1044              
1045 159 50       276 if (!defined $dir) { $dir = 0; } # default is CCW sweep
  0         0  
1046             # check for non-positive radius
1047 159 50 33     475 if ($rx <= 0 || $ry <= 0) {
1048 0         0 die "curve request with radius not > 0 ($rx, $ry)";
1049             }
1050             # check for zero degrees of sweep
1051 159 50       301 if ($alpha == $beta) {
1052 0         0 die "curve request with zero degrees of sweep ($alpha to $beta)";
1053             }
1054              
1055             # constrain alpha and beta to 0..360 range so 0 crossing check works
1056 159         281 while ($alpha < 0.0) { $alpha += 360.0; }
  0         0  
1057 159         263 while ( $beta < 0.0) { $beta += 360.0; }
  1         4  
1058 159         288 while ($alpha > 360.0) { $alpha -= 360.0; }
  0         0  
1059 159         257 while ( $beta > 360.0) { $beta -= 360.0; }
  0         0  
1060              
1061             # Note that there is a problem with the original code, when the 0 degree
1062             # angle is crossed. It especially shows up in arc() and pie(). Therefore,
1063             # split the original sweep at 0 degrees, if it crosses that angle.
1064 159 50 66     389 if (!$dir && $alpha > $beta) { # CCW pass over 0 degrees
1065 0 0 0     0 if ($alpha == 360.0 && $beta == 0.0) { # oddball case
    0          
    0          
1066 0         0 return (_arctocurve($rx,$ry, 0.0,360.0, 0));
1067             } elsif ($alpha == 360.0) { # alpha to 360 would be null
1068 0         0 return (_arctocurve($rx,$ry, 0.0,$beta, 0));
1069             } elsif ($beta == 0.0) { # 0 to beta would be null
1070 0         0 return (_arctocurve($rx,$ry, $alpha,360.0, 0));
1071             } else {
1072             return (
1073 0         0 _arctocurve($rx,$ry, $alpha,360.0, 0),
1074             _arctocurve($rx,$ry, 0.0,$beta, 0)
1075             );
1076             }
1077             }
1078 159 100 100     350 if ($dir && $alpha < $beta) { # CW pass over 0 degrees
1079 1 50 33     10 if ($alpha == 0.0 && $beta == 360.0) { # oddball case
    50          
    0          
1080 0         0 return (_arctocurve($rx,$ry, 360.0,0.0, 1));
1081             } elsif ($alpha == 0.0) { # alpha to 0 would be null
1082 1         4 return (_arctocurve($rx,$ry, 360.0,$beta, 1));
1083             } elsif ($beta == 360.0) { # 360 to beta would be null
1084 0         0 return (_arctocurve($rx,$ry, $alpha,0.0, 1));
1085             } else {
1086             return (
1087 0         0 _arctocurve($rx,$ry, $alpha,0.0, 1),
1088             _arctocurve($rx,$ry, 360.0,$beta, 1)
1089             );
1090             }
1091             }
1092              
1093             # limit arc length to 30 degrees, for reasonable smoothness
1094             # none of the long arcs or short resulting arcs cross 0 degrees
1095 158 100       295 if (abs($beta-$alpha) > 30) {
1096             return (
1097 74         183 _arctocurve($rx,$ry, $alpha,($beta+$alpha)/2, $dir),
1098             _arctocurve($rx,$ry, ($beta+$alpha)/2,$beta, $dir)
1099             );
1100             } else {
1101             # Note that we can't use deg2rad(), because closed arcs (circle() and
1102             # ellipse()) are 0-360 degrees, which deg2rad treats as 0-0 radians!
1103 84         134 $alpha = ($alpha * pi / 180);
1104 84         123 $beta = ($beta * pi / 180);
1105              
1106 84         185 my $bcp = (4.0/3 * (1 - cos(($beta - $alpha)/2)) / sin(($beta - $alpha)/2));
1107 84         140 my $sin_alpha = sin($alpha);
1108 84         118 my $sin_beta = sin($beta);
1109 84         128 my $cos_alpha = cos($alpha);
1110 84         134 my $cos_beta = cos($beta);
1111              
1112 84         127 my $p0_x = $rx * $cos_alpha;
1113 84         123 my $p0_y = $ry * $sin_alpha;
1114 84         134 my $p1_x = $rx * ($cos_alpha - $bcp * $sin_alpha);
1115 84         118 my $p1_y = $ry * ($sin_alpha + $bcp * $cos_alpha);
1116 84         139 my $p2_x = $rx * ($cos_beta + $bcp * $sin_beta);
1117 84         128 my $p2_y = $ry * ($sin_beta - $bcp * $cos_beta);
1118 84         115 my $p3_x = $rx * $cos_beta;
1119 84         117 my $p3_y = $ry * $sin_beta;
1120              
1121 84         450 return ($p0_x,$p0_y, $p1_x,$p1_y, $p2_x,$p2_y, $p3_x,$p3_y);
1122             }
1123             }
1124              
1125             =item $content->arc($xc,$yc, $rx,$ry, $alpha,$beta, $move, $dir)
1126              
1127             =item $content->arc($xc,$yc, $rx,$ry, $alpha,$beta, $move)
1128              
1129             This extends the path along an arc of an ellipse centered at C<[$xc,$yc]>.
1130             The semidiameters of the elliptical curve are C<$rx> (x axis) and C<$ry>
1131             (y axis), respectively, and the arc sweeps from C<$alpha> degrees to C<$beta>
1132             degrees. The current position is then set to the endpoint of the arc.
1133              
1134             Set C<$move> to a I value if this arc is the beginning of a new
1135             path instead of the continuation of an existing path. Either way, the
1136             current position will be updated to the end of the arc.
1137             Use C<$rx == $ry> for a circular arc.
1138              
1139             The optional C<$dir> arc sweep direction defaults to 0 (I), for a
1140             counter-clockwise/anti-clockwise sweep. Set to 1 (I) for a clockwise
1141             sweep.
1142              
1143             =cut
1144              
1145             sub arc {
1146 5     5 1 25 my ($self, $xc,$yc, $rx,$ry, $alpha,$beta, $move, $dir) = @_;
1147              
1148 5 100       16 if (!defined $dir) { $dir = 0; }
  4         6  
1149 5         15 my @points = _arctocurve($rx,$ry, $alpha,$beta, $dir);
1150 5         13 my ($p0_x,$p0_y, $p1_x,$p1_y, $p2_x,$p2_y, $p3_x,$p3_y);
1151              
1152 5         14 $p0_x = $xc + shift @points;
1153 5         8 $p0_y = $yc + shift @points;
1154              
1155 5 100       26 $self->move($p0_x,$p0_y) if $move;
1156              
1157 5         17 while (scalar @points >= 6) {
1158 44         74 $p1_x = $xc + shift @points;
1159 44         70 $p1_y = $yc + shift @points;
1160 44         73 $p2_x = $xc + shift @points;
1161 44         64 $p2_y = $yc + shift @points;
1162 44         79 $p3_x = $xc + shift @points;
1163 44         67 $p3_y = $yc + shift @points;
1164 44         132 $self->curve($p1_x,$p1_y, $p2_x,$p2_y, $p3_x,$p3_y);
1165 44         71 shift @points;
1166 44         69 shift @points;
1167 44         72 $self->{' x'} = $p3_x; # set new current position
1168 44         108 $self->{' y'} = $p3_y;
1169             }
1170             # should we worry about anything left over in @points?
1171             # supposed to be blocks of 8 (4 points)
1172              
1173 5         13 return $self;
1174             }
1175              
1176             =item $content->pie($xc,$yc, $rx,$ry, $alpha,$beta, $dir)
1177              
1178             =item $content->pie($xc,$yc, $rx,$ry, $alpha,$beta)
1179              
1180             Creates a pie-shaped path from an ellipse centered on C<[$xc,$yc]>.
1181             The x-axis and y-axis semidiameters of the ellipse are C<$rx> and C<$ry>,
1182             respectively, and the arc sweeps from C<$alpha> degrees to C<$beta>
1183             degrees.
1184             It does not change the current position.
1185             Depending on the sweep angles and direction, this can draw either the
1186             pie "slice" or the remaining pie (with slice removed).
1187             Use C<$rx == $ry> for a circular pie.
1188             Use a different C<[$xc,$yc]> for the slice, to offset it from the remaining pie.
1189              
1190             The optional C<$dir> arc sweep direction defaults to 0 (I), for a
1191             counter-clockwise/anti-clockwise sweep. Set to 1 (I) for a clockwise
1192             sweep.
1193              
1194             This is a shortcut to draw a section of elliptical (or circular) arc and
1195             connect it to the center of the ellipse or circle, to form a pie shape.
1196              
1197             =cut
1198              
1199             sub pie {
1200 1     1 1 8 my ($self, $xc,$yc, $rx,$ry, $alpha,$beta, $dir) = @_;
1201              
1202 1 50       4 if (!defined $dir) { $dir = 0; }
  1         3  
1203 1         3 my ($p0_x,$p0_y) = _arctocurve($rx,$ry, $alpha,$beta, $dir);
1204 1         6 $self->move($xc,$yc);
1205 1         6 $self->line($p0_x+$xc, $p0_y+$yc);
1206 1         5 $self->arc($xc,$yc, $rx,$ry, $alpha,$beta, 0, $dir);
1207 1         4 $self->close();
1208              
1209 1         2 return $self;
1210             }
1211              
1212             =item $content->curve($cx1,$cy1, $cx2,$cy2, $x,$y)
1213              
1214             This extends the path in a curve from the current point to C<[$x,$y]>,
1215             using the two specified I points to create a cubic Bezier curve, and
1216             updates the current position to be the new point (C<[$x,$y]>).
1217              
1218             Within a B object, the text's baseline follows the Bezier curve.
1219              
1220             Note that while multiple sets of three C<[x,y]> pairs are permitted, these
1221             are treated as I cubic Bezier curves. There is no attempt made to
1222             smoothly blend one curve into the next!
1223              
1224             =cut
1225              
1226             sub curve {
1227 89     89 1 159 my ($self) = shift;
1228              
1229 89         141 my ($cx1,$cy1, $cx2,$cy2, $x,$y);
1230 89         175 while (scalar @_ >= 6) {
1231 89         143 $cx1 = shift;
1232 89         116 $cy1 = shift;
1233 89         128 $cx2 = shift;
1234 89         119 $cy2 = shift;
1235 89         110 $x = shift;
1236 89         150 $y = shift;
1237 89 50       163 if ($self->_in_text_object()) {
1238 0         0 $self->add_post(floats($cx1,$cy1, $cx2,$cy2, $x,$y), 'c');
1239             } else {
1240 89         226 $self->add(floats($cx1,$cy1, $cx2,$cy2, $x,$y), 'c');
1241             }
1242 89         184 $self->{' x'} = $x; # set new current position
1243 89         230 $self->{' y'} = $y;
1244             }
1245              
1246 89         153 return $self;
1247             }
1248              
1249             =item $content->qbspline($cx1,$cy1, $x,$y)
1250              
1251             This extends the path in a curve from the current point to C<[$x,$y]>,
1252             using the two specified points to create a quadratic Bezier curve, and updates
1253             the current position to be the new point.
1254              
1255             Internally, these splines are one or more cubic Bezier curves (see C)
1256             with the two control points synthesized from the two given points (a control
1257             point and the end point of a I Bezier curve).
1258              
1259             Note that while multiple sets of two C<[x,y]> pairs are permitted, these
1260             are treated as I quadratic Bezier curves. There is no attempt
1261             made to smoothly blend one curve into the next!
1262              
1263             Further note that this "spline" does not match the common definition of
1264             a spline being a I curve passing I B the given
1265             points! It is a piecewise non-continuous cubic Bezier curve. Use with care, and
1266             do not make assumptions about splines for you or your readers. You may wish
1267             to use the C call to have a continuously smooth spline to pass through
1268             all given points.
1269              
1270             Pairs of points (control point and end point) are consumed in a loop. If one
1271             point or coordinate is left over at the end, it is discarded (as usual practice
1272             for excess data to a routine). There is no check for duplicate points or other
1273             degeneracies.
1274              
1275             =cut
1276              
1277             sub qbspline {
1278 1     1 1 7 my ($self) = shift;
1279              
1280 1         6 while (scalar @_ >= 4) {
1281 1         4 my $cx = shift; # single Control Point
1282 1         2 my $cy = shift;
1283 1         3 my $x = shift; # new end point
1284 1         2 my $y = shift;
1285             # synthesize 2 cubic Bezier control points from two given points
1286 1         5 my $c1x = (2*$cx + $self->{' x'})/3;
1287 1         4 my $c1y = (2*$cy + $self->{' y'})/3;
1288 1         4 my $c2x = (2*$cx + $x)/3;
1289 1         3 my $c2y = (2*$cy + $y)/3;
1290 1         5 $self->curve($c1x,$c1y, $c2x,$c2y, $x,$y);
1291             }
1292             ## one left over point? straight line (silent error recovery)
1293             #if (scalar @_ >= 2) {
1294             # my $x = shift; # new end point
1295             # my $y = shift;
1296             # $self->line($x,$y);
1297             #}
1298             #if (scalar @_) { leftovers ignored, as is usual practice
1299             # warn "qbspline() has leftover coordinate (ignored).";
1300             #}
1301              
1302 1         3 return $self;
1303             }
1304              
1305             =item $content->bspline($ptsRef, %opts)
1306              
1307             =item $content->bspline($ptsRef)
1308              
1309             This extends the path in a curve from the current point to the end of a list
1310             of coordinate pairs in the array referenced by C<$ptsRef>. Smoothly continuous
1311             cubic Bezier splines are used to create a curve that passes through I
1312             the given points. Multiple control points are synthesized; they are not
1313             supplied in the call. The current position is updated to the last point.
1314              
1315             Internally, these splines are one cubic Bezier curve (see C) per pair
1316             of input points, with the two control points synthesized from the tangent
1317             through each point as set by the polyline that would connect each point to its
1318             neighbors. The intent is that the resulting curve should follow reasonably
1319             closely a polyline that would connect the points, and should avoid any major
1320             excursions. See the discussions below for the handling of the control points
1321             at the endpoints (current point and last input point). The point at the end
1322             of the last line or curve drawn becomes the new current point.
1323              
1324             %opts
1325              
1326             =over
1327              
1328             =item -firstseg => 'I'
1329              
1330             where I is
1331              
1332             =over
1333              
1334             =item curve
1335              
1336             This is the B behavior.
1337             This forces the first segment (from the current point to the first given point)
1338             to be drawn as a cubic Bezier curve. This means that the direction of the curve
1339             coming off the current point is unconstrained (it will end up being a reflection
1340             of the tangent at the first given point).
1341              
1342             =item line1
1343              
1344             This forces the first segment (from the current point to the first given point)
1345             to be drawn as a curve, with the tangent at the current point to be constrained
1346             as parallel to the polyline segment.
1347              
1348             =item line2
1349              
1350             This forces the first segment (from the current point to the first given point)
1351             to be drawn as a line segment. This also sets the tangent through the first
1352             given point as a continuation of the line, as well as constraining the direction
1353             of the line at the current point.
1354              
1355             =item constraint1
1356              
1357             This forces the first segment (from the current point to the first given point)
1358             to B be drawn, but to be an invisible curve (like mode=line1) to leave
1359             the tangent at the first given point unconstrained. A I will be made to
1360             the first given point, and the current point is otherwise ignored.
1361              
1362             =item constraint2
1363              
1364             This forces the first segment (from the current point to the first given point)
1365             to B be drawn, but to be an invisible line (like mode=line2) to constrain
1366             the tangent at the first given point. A I will be made to the first given
1367             point, and the current point is otherwise ignored.
1368              
1369             =back
1370              
1371             =item -lastseg => 'I'
1372              
1373             where I is
1374              
1375             =over
1376              
1377             =item curve
1378              
1379             This is the B behavior.
1380             This forces the last segment (to the last given input point)
1381             to be drawn as a cubic Bezier curve. This means that the direction of the curve
1382             goin to the last point is unconstrained (it will end up being a reflection
1383             of the tangent at the next-to-last given point).
1384              
1385             =item line1
1386              
1387             This forces the last segment (to the last given input point) to be drawn as a
1388             curve with the the tangent through the last given point parallel to the
1389             polyline segment, thus constraining the direction of the line at the last
1390             point.
1391              
1392             =item line2
1393              
1394             This forces the last segment (to the last given input point)
1395             to be drawn as a line segment. This also sets the tangent through the
1396             next-to-last given point as a back continuation of the line, as well as
1397             constraining the direction of the line at the last point.
1398              
1399             =item constraint1
1400              
1401             This forces the last segment (to the last given input point)
1402             to B be drawn, but to be an invisible curve (like mode=line1) to leave
1403             the tangent at the next-to-last given point unconstrained. The last given
1404             input point is ignored, and next-to-last point becomes the new current point.
1405              
1406             =item constraint2
1407              
1408             This forces the last segment (to the last given input point)
1409             to B be drawn, but to be an invisible line (like mode=line2) to constrain
1410             the tangent at the next-to-last given point. The last given input point is
1411             ignored, and next-to-last point becomes the new current point.
1412              
1413             =back
1414              
1415             =item -ratio => I
1416              
1417             I is the ratio of the length from a point to a control point to the length
1418             of the polyline segment on that side of the given point. It must be greater
1419             than 0.1, and the default is 0.3333 (1/3).
1420              
1421             =item -colinear => 'I'
1422              
1423             This describes how to handle the middle segment when there are four or more
1424             colinear points in the input set. A I of 'line' specifies that a line
1425             segment will be drawn between each of the interior colinear points. A I
1426             of 'curve' (this is the default) will draw a Bezier curve between each of those
1427             points.
1428              
1429             C<-colinear> applies only to interior runs of colinear points, between curves.
1430             It does not apply to runs at the beginning or end of the point list, which are
1431             drawn as line segments or linear constraints regardless of I<-firstseg> and
1432             I<-lastseg> settings.
1433              
1434             =item -debug => I
1435              
1436             If I is 0 (the default), only the spline is returned. If it is greater than
1437             0, a number of additional items will be drawn: (N>0) the points, (N>1) a green
1438             solid polyline connecting them, (N>2) blue original tangent lines at each
1439             interior point, and (N>3) red dashed lines and hollow points representing the
1440             Bezier control points.
1441              
1442             =back
1443              
1444             =back
1445              
1446             =head3 Special cases
1447              
1448             Adjacent points which are duplicates are consolidated.
1449             An extra coordinate at the end of the input point list (not a full
1450             C<[x,y]> pair) will, as usual, be ignored.
1451              
1452             =over
1453              
1454             =item 0 given points (after duplicate consolidation)
1455              
1456             This leaves only the current point (unchanged), so it is a no-op.
1457              
1458             =item 1 given point (after duplicate consolidation)
1459              
1460             This leaves the current point and one point, so it is rendered as a line,
1461             regardless of %opt flags.
1462              
1463             =item 2 given points (after duplicate consolidation)
1464              
1465             This leaves the current point, an intermediate point, and the end point. If
1466             the three points are colinear, two line segments will be drawn. Otherwise, both
1467             segments are curves (through the tangent at the intermediate point). If either
1468             end segment mode is requested to be a line or constraint, it is treated as a
1469             B mode request instead.
1470              
1471             =item I colinear points at beginning or end
1472              
1473             I colinear points at beginning or end of the point set causes I line
1474             segments (C or C, regardless of the settings of
1475             C<-firstseg>, C<-lastseg>, and C<-colinear>.
1476              
1477             =back
1478              
1479             =cut
1480              
1481             sub bspline {
1482 1     1 1 8 my ($self, $ptsRef, %opts) = @_;
1483 1         4 my @inputPts = @$ptsRef;
1484 1         5 my ($firstseg, $lastseg, $ratio, $colinear, $debug);
1485 1         0 my (@oldColor, @oldFill, $oldWidth, @oldDash);
1486             # specific treatment of the first and last segments of the spline
1487             # code will be checking for line[12] and constraint[12], and assume it's
1488             # 'curve' if nothing else matches (silent error)
1489 1 50       4 if (defined $opts{'-firstseg'}) {
1490 0         0 $firstseg = $opts{'-firstseg'};
1491             } else {
1492 1         3 $firstseg = 'curve';
1493             }
1494 1 50       3 if (defined $opts{'-lastseg'}) {
1495 0         0 $lastseg = $opts{'-lastseg'};
1496             } else {
1497 1         3 $lastseg = 'curve';
1498             }
1499             # ratio of the length of a Bezier control point line to the distance
1500             # between the points
1501 1 50       4 if (defined $opts{'-ratio'}) {
1502 0         0 $ratio = $opts{'-ratio'};
1503             # clamp it (silent error) to be >0.1. probably no need to limit high end
1504 0 0       0 if ($ratio <= 0.1) { $ratio = 0.1; }
  0         0  
1505             } else {
1506 1         2 $ratio = 0.3333; # default
1507             }
1508             # colinear points (4 or more) draw a line instead of a curve
1509 1 50       4 if (defined $opts{'-colinear'}) {
1510 0         0 $colinear = $opts{'-colinear'}; # 'line' or 'curve'
1511             } else {
1512 1         3 $colinear = 'curve'; # default
1513             }
1514             # debug options to draw out intermediate stages
1515 1 50       4 if (defined $opts{'-debug'}) {
1516 0         0 $debug = $opts{'-debug'};
1517             } else {
1518 1         2 $debug = 0; # default
1519             }
1520              
1521             # copy input point list pairs, checking for duplicates
1522 1         3 my (@inputs, $x,$y);
1523 1         5 @inputs = ([$self->{' x'}, $self->{' y'}]); # initialize to current point
1524 1         6 while (scalar(@inputPts) >= 2) {
1525 7         12 $x = shift @inputPts;
1526 7         10 $y = shift @inputPts;
1527 7         15 push @inputs, [$x, $y];
1528             # eliminate duplicate point just added
1529 7 50 66     22 if ($inputs[-2][0] == $inputs[-1][0] &&
1530             $inputs[-2][1] == $inputs[-1][1]) {
1531             # duplicate
1532 0         0 pop @inputs;
1533             }
1534             }
1535             #if (scalar @inputPts) { leftovers ignored, as is usual practice
1536             # warn "bspline() has leftover coordinate (ignored).";
1537             #}
1538              
1539             # handle special cases of 1, 2, or 3 points in @inputs
1540 1 50       10 if (scalar @inputs == 1) {
    50          
    50          
1541             # only current point in list: no-op
1542 0         0 return $self;
1543             } elsif (scalar @inputs == 2) {
1544             # just two points: draw a line
1545 0         0 $self->line($inputs[1][0],$inputs[1][1]);
1546 0         0 return $self;
1547             } elsif (scalar @inputs == 3) {
1548             # just 3 points: adjust flags
1549 0 0       0 if ($firstseg ne 'curve') { $firstseg = 'line1'; }
  0         0  
1550 0 0       0 if ($lastseg ne 'curve') { $lastseg = 'line1'; }
  0         0  
1551             # note that if colinear, will become line2 for both
1552             }
1553              
1554             # save existing settings if -debug draws anything
1555 1 50       4 if ($debug > 0) {
1556 0         0 @oldColor = $self->strokecolor();
1557 0         0 @oldFill = $self->fillcolor();
1558 0         0 $oldWidth = $self->linewidth();
1559 0         0 @oldDash = $self->linedash(-1);
1560             }
1561             # initialize working arrays
1562             # dx,dy are unit vector (sum of squares is 1)
1563             # polyline [n][0] = dx, [n][1] = dy, [n][2] = length for segment between
1564             # points n and n+1
1565             # colinpt [n] = 0 if not, 1 if it is interior colinear point
1566             # type [n] = 0 it's a Bezier curve, 1 it's a line between pts n, n+1
1567             # 2 it's a curve constraint (not drawn), 3 line constraint ND
1568             # tangent [n][0] = dx, [n][1] = dy for tangent line direction (forward)
1569             # at point n
1570             # cp [n][0][0,1] = dx,dy direction to control point "before" point n
1571             # [2] = distance from point n to this control point
1572             # [1] likewise for control point "after" point n
1573             # n=0 doesn't use "before" and n=last doesn't use "after"
1574             #
1575             # every time a tangent is set, also set the cp unit vectors, so nothing
1576             # is overlooked, even if a tangent may be changed later
1577 1         3 my ($i,$j,$k, $l, $dx,$dy, @polyline, @colinpt, @type, @tangent, @cp);
1578 1         2 my $last = $#inputs; # index number of last point (first is 0)
1579              
1580 1         4 for ($i=0; $i<=$last; $i++) { # through all points
1581 8         39 $polyline[$i] = [0,0,0];
1582 8 100       23 if ($i < $last) { # polyline[i] is line point i to i+1
1583 7         15 $dx = $inputs[$i+1][0] - $inputs[$i][0];
1584 7         11 $dy = $inputs[$i+1][1] - $inputs[$i][1];
1585 7         17 $polyline[$i][2] = $l = sqrt($dx*$dx + $dy*$dy);
1586 7         15 $polyline[$i][0] = $dx/$l;
1587 7         11 $polyline[$i][1] = $dy/$l;
1588             }
1589              
1590 8         14 $colinpt[$i] = 0; # default: not colinear at this point i
1591 8         12 $type[$i] = 0; # default: using a curve at this point i to i+1
1592             # N/A if i=last, will ignore
1593 8 100 100     25 if ($i > 0 && $i < $last) { # colinpt... look at polyline unit vectors
1594             # of lines coming into and out of point i
1595 6 50 33     20 if ($polyline[$i-1][0] == $polyline[$i][0] &&
1596             $polyline[$i-1][1] == $polyline[$i][1]) {
1597 0         0 $colinpt[$i] = 1; # same unit vector at prev point
1598             # so point is colinear (inside run)
1599             # set type[i] even if may change later
1600 0 0       0 if ($i == 1) {
1601             # point 1 is colinear? force line2 or constraint2
1602 0 0       0 if ($firstseg =~ m#^constraint#) {
1603 0         0 $firstseg = 'constraint2';
1604 0         0 $type[0] = 3;
1605             } else {
1606 0         0 $firstseg = 'line2';
1607 0         0 $type[0] = 1;
1608             }
1609 0         0 $colinpt[0] = 1; # if 1 is colinear, so is 0
1610 0         0 $type[1] = 1;
1611             }
1612 0 0       0 if ($i == $last-1) {
1613             # point last-1 is colinear? force line2 or constraint2
1614 0 0       0 if ($lastseg =~ m#^constraint#) {
1615 0         0 $lastseg = 'constraint2';
1616 0         0 $type[$i] = 3;
1617             } else {
1618 0         0 $lastseg = 'line2';
1619 0         0 $type[$i] = 1;
1620             }
1621 0         0 $colinpt[$last] = 1; # if last-1 is colinear, so is last
1622 0         0 $type[$last-2] = 1;
1623             }
1624             } # it is colinear
1625             } # looking for colinear interior points
1626             # if 3 or more colinear points at beginning or end, handle later
1627              
1628 8         13 $tangent[$i] = [0,0]; # set tangent at each point
1629             # endpoints & interior colinear points just use the polyline they're on
1630             #
1631             # at point $i, [0 1] "before" for previous curve and "after"
1632             # each [dx, dy, len] from this point to control point
1633 8         51 $cp[$i] = [[0,0,0], [0,0,0]];
1634             # at least can set the lengths here. uvecs will be set to tangents,
1635             # even though some may be changed later
1636            
1637 8 100       18 if ($i > 0) { # do 'before' cp length
1638 7         14 $cp[$i][0][2] = $polyline[$i-1][2] * $ratio;
1639             }
1640 8 100       18 if ($i < $last) { # do 'after' cp length
1641 7         11 $cp[$i][1][2] = $polyline[$i][2] * $ratio;
1642             }
1643              
1644 8 100 66     45 if ($i == 0 || $i < $last && $colinpt[$i]) {
    100 66        
1645 1         4 $cp[$i][1][0] = $tangent[$i][0] = $polyline[$i][0];
1646 1         4 $cp[$i][1][1] = $tangent[$i][1] = $polyline[$i][1];
1647 1 50       13 if ($i > 0) {
1648 0         0 $cp[$i][0][0] = -$cp[$i][1][0];
1649 0         0 $cp[$i][0][1] = -$cp[$i][1][1];
1650             }
1651             } elsif ($i == $last) {
1652 1         4 $tangent[$i][0] = $polyline[$i-1][0];
1653 1         3 $tangent[$i][1] = $polyline[$i-1][1];
1654 1         3 $cp[$i][0][0] = -$tangent[$i][0];
1655 1         4 $cp[$i][0][1] = -$tangent[$i][1];
1656             } else {
1657             # for other points, add the incoming and outgoing polylines
1658             # and normalize to unit length
1659 6         13 $dx = $polyline[$i-1][0] + $polyline[$i][0];
1660 6         10 $dy = $polyline[$i-1][1] + $polyline[$i][1];
1661 6         12 $l = sqrt($dx*$dx + $dy*$dy);
1662             # degenerate sequence A-B-A would give a length of 0, so avoid /0
1663             # TBD: look at entry and exit curves to instead have assigned
1664             # tangent go left instead of right, to avoid in some cases a
1665             # twist in the loop
1666 6 50       15 if ($l == 0) {
1667             # still no direction to it. assign 90 deg right turn
1668             # on outbound A-B (at point B)
1669 0         0 my $theta = atan2($polyline[$i-1][1], $polyline[$i-1][0]) - Math::Trig::pip2;
1670 0         0 $cp[$i][1][0] = $tangent[$i][0] = cos($theta);
1671 0         0 $cp[$i][1][1] = $tangent[$i][1] = sin($theta);
1672             } else {
1673 6         12 $cp[$i][1][0] = $tangent[$i][0] = $dx/$l;
1674 6         12 $cp[$i][1][1] = $tangent[$i][1] = $dy/$l;
1675             }
1676 6         10 $cp[$i][0][0] = -$cp[$i][1][0];
1677 6         15 $cp[$i][0][1] = -$cp[$i][1][1];
1678             }
1679             } # for loop to initialize all arrays
1680              
1681             # debug: show points, polyline, and original tangents
1682 1 50       12 if ($debug > 0) {
1683 0         0 $self->linedash(); # solid
1684 0         0 $self->linewidth(2);
1685 0         0 $self->strokecolor('green');
1686 0         0 $self->fillcolor('green');
1687              
1688             # points (debug = 1+)
1689 0         0 for ($i=0; $i<=$last; $i++) {
1690 0         0 $self->circle($inputs[$i][0],$inputs[$i][1], 2);
1691             }
1692 0         0 $self->fillstroke();
1693             # polyline (@inputs not in correct format for poly() call)
1694 0 0       0 if ($debug > 1) {
1695 0         0 $self->move($inputs[0][0], $inputs[0][1]);
1696 0         0 for ($i=1; $i<=$last; $i++) {
1697 0         0 $self->line($inputs[$i][0], $inputs[$i][1]);
1698             }
1699 0         0 $self->stroke();
1700 0         0 $self->fillcolor(@oldFill);
1701             }
1702              
1703             # original tangents (before adjustment)
1704 0 0       0 if ($debug > 2) {
1705 0         0 $self->linewidth(1);
1706 0         0 $self->strokecolor('blue');
1707 0         0 for ($i=0; $i<=$last; $i++) {
1708 0         0 $self->move($inputs[$i][0], $inputs[$i][1]);
1709 0         0 $self->line($inputs[$i][0] + 20*$tangent[$i][0],
1710             $inputs[$i][1] + 20*$tangent[$i][1]);
1711             }
1712 0         0 $self->stroke();
1713             }
1714              
1715             # prepare for control points and dashed lines
1716 0 0       0 if ($debug > 3) {
1717 0         0 $self->linedash(2); # repeating 2 on 2 off (solid for points)
1718 0         0 $self->linewidth(2); # 1 for points (circles)
1719 0         0 $self->strokecolor('red');
1720             }
1721             } # debug dump of intermediate results
1722             # at this point, @tangent unit vectors need to be adjusted for several
1723             # reasons, and @cp unit vectors need to await final tangent vectors.
1724             # @type is "displayed curve" (0) for all segments ex possibly first and last
1725              
1726             # follow colinear segments at beginning and end (not interior).
1727             # follow colinear segments from 1 to $last-1, and same $last-1 to 1,
1728             # setting type to 1 (line segment). once type set to non-zero, will
1729             # not revisit it. we should have at least 3 points ($last >= 2), and points
1730             # 0, 1, last-1, and last should already have been set. tangents already set.
1731 1         14 for ($i=1; $i<$last-1; $i++) {
1732 1 50       6 if ($colinpt[$i]) {
1733 0         0 $type[$i] = 1;
1734 0         0 $cp[$i+1][1][0] = $tangent[$i+1][0] = $polyline[$i][0];
1735 0         0 $cp[$i+1][1][1] = $tangent[$i+1][1] = $polyline[$i][1];
1736 0         0 $cp[$i+1][0][0] = -$tangent[$i+1][0];
1737 0         0 $cp[$i+1][0][1] = -$tangent[$i+1][1];
1738             } else {
1739 1         3 last;
1740             }
1741             }
1742 1         5 for ($i=$last-1; $i>1; $i--) {
1743 1 50       3 if ($colinpt[$i]) {
1744 0         0 $type[$i-1] = 1;
1745 0         0 $cp[$i-1][1][0] = $tangent[$i-1][0] = $polyline[$i-1][0];
1746 0         0 $cp[$i-1][1][1] = $tangent[$i-1][1] = $polyline[$i-1][1];
1747 0         0 $cp[$i-1][0][0] = -$tangent[$i-1][0];
1748 0         0 $cp[$i-1][0][1] = -$tangent[$i-1][1];
1749             } else {
1750 1         2 last;
1751             }
1752             }
1753              
1754             # now the major work of deciding whether line segment or Bezier curve
1755             # at each polyline segment, and placing the control points for the curves
1756             #
1757             # handle first and last segments first, as they affect tangents.
1758             # then go through, setting colinear sections to lines if requested,
1759             # or setting tangents if curves. calculate all control points from final
1760             # tangents, and draw them if debug.
1761 1         3 my ($ptheta, $ttheta, $dtheta);
1762             # special treatments for first segment
1763 1 50       8 if ($firstseg eq 'line1') {
    50          
    50          
    50          
1764             # Bezier curve from point 0 to 1, constrained to polyline at point 0
1765             # but no constraint on tangent at point 1.
1766             # should already be type 0 between points 0 and 1
1767             # point 0 tangent should already be on polyline segment
1768             } elsif ($firstseg eq 'line2') {
1769             # line drawn from point 0 to 1, constraining the tangent at point 1
1770 0         0 $type[0] = 1; # set to type 1 between points 0 and 1
1771             # no need to set tangent at point 0, or set control points
1772 0         0 $cp[1][1][0] = $tangent[1][0] = $polyline[0][0];
1773 0         0 $cp[1][1][1] = $tangent[1][1] = $polyline[0][1];
1774 0         0 $cp[1][0][0] = -$tangent[1][0];
1775 0         0 $cp[1][0][1] = -$tangent[1][1];
1776             } elsif ($firstseg eq 'constraint1') {
1777             # Bezier curve from point 0 to 1, constrained to polyline at point 0
1778             # (not drawn, allows unconstrained tangent at point 1)
1779 0         0 $type[0] = 2;
1780             # no need to set after and before, as is not drawn
1781             } elsif ($firstseg eq 'constraint2') {
1782             # line from point 0 to 1 (not drawn, only sets tangent at point 1)
1783 0         0 $type[0] = 3;
1784             # no need to set before, as is not drawn and is line anyway
1785 0         0 $cp[1][1][0] = $tangent[1][0] = $polyline[0][0];
1786 0         0 $cp[1][1][1] = $tangent[1][1] = $polyline[0][1];
1787             } else { # 'curve'
1788             # Bezier curve from point 0 to 1. both ends unconstrained, at point 0
1789             # it is just a reflection of the tangent at point 1
1790             #$type[0] = 0; # should already be 0
1791 1         6 $ptheta = atan2($polyline[0][1], $polyline[0][0]);
1792 1         5 $ttheta = atan2(-$tangent[1][1], -$tangent[1][0]);
1793 1         6 $dtheta = _leftright($ptheta, $ttheta);
1794 1         12 $ptheta = atan2(-$polyline[0][1], -$polyline[0][0]);
1795 1         7 $ttheta = _sweep($ptheta, $dtheta);
1796 1         6 $cp[0][1][0] = $tangent[0][0] = cos($ttheta); # also 'after' uvec at 0
1797 1         225 $cp[0][1][1] = $tangent[0][1] = sin($ttheta);
1798             }
1799             # special treatments for last segment
1800 1 50       151 if ($lastseg eq 'line1') {
    50          
    50          
    50          
1801             # Bezier curve from point last-1 to last, constrained to polyline at
1802             # point last but no constraint on tangent at point last-1
1803             # should already be type 0 at last-1
1804             # point last tangent should already be on polyline segment
1805             } elsif ($lastseg eq 'line2') {
1806             # line drawn from point last-1 to last, constraining the tangent at point last-1
1807 0         0 $type[$last-1] = 1;
1808             # no need to set tangent at point last, or set control points at last
1809 0         0 $cp[$last-1][1][0] = $tangent[$last-1][0] = $polyline[$last-1][0];
1810 0         0 $cp[$last-1][1][1] = $tangent[$last-1][1] = $polyline[$last-1][1];
1811 0         0 $cp[$last-1][0][0] = -$tangent[$last-1][0];
1812 0         0 $cp[$last-1][0][1] = -$tangent[$last-1][1];
1813             } elsif ($lastseg eq 'constraint1') {
1814             # Bezier curve from point last-1 to last, constrained to polyline at point last
1815             # (not drawn, allows unconstrained tangent at point last-1)
1816 0         0 $type[$last-1] = 2;
1817             } elsif ($lastseg eq 'constraint2') {
1818             # line from point last-1 to last (not drawn, only sets tangent at point last-1)
1819 0         0 $type[$last-1] = 3;
1820             # no need to set after, as is not drawn and is line anyway
1821 0         0 $tangent[$last-1][0] = $polyline[$last-1][0];
1822 0         0 $tangent[$last-1][1] = $polyline[$last-1][1];
1823 0         0 $cp[$last-1][0][0] = -$tangent[$last-1][0];
1824 0         0 $cp[$last-1][0][1] = -$tangent[$last-1][1];
1825             } else { # 'curve'
1826             # Bezier curve from point last-1 to last. both ends unconstrained, at point last
1827             # it is just a reflection of the tangent at point last-1
1828             #$type[$last-1] = 0; # should already be 0
1829 1         12 $ptheta = atan2($polyline[$last-1][1], $polyline[$last-1][0]);
1830 1         4 $ttheta = atan2($tangent[$last-1][1], $tangent[$last-1][0]);
1831 1         3 $dtheta = _leftright($ptheta, $ttheta);
1832 1         6 $ptheta = atan2(-$polyline[$last-1][1], -$polyline[$last-1][0]);
1833 1         3 $ttheta = _sweep($ptheta, $dtheta);
1834 1         4 $tangent[$last][0] = -cos($ttheta);
1835 1         4 $tangent[$last][1] = -sin($ttheta);
1836 1         3 $cp[$last][0][0] = -$tangent[$last][0]; # set 'before' unit vector at point 1
1837 1         3 $cp[$last][0][1] = -$tangent[$last][1];
1838             }
1839              
1840             # go through interior points (2..last-2) and set tangents if colinear
1841             # (and not forcing lines). by default are curves.
1842 1         6 for ($i=2; $i<$last-1; $i++) {
1843 4 50       11 if ($colinpt[$i]) {
1844             # this is a colinear point (1 or more in a row with endpoints of
1845             # run). first, find run
1846 0         0 for ($j=$i+1; $j<$last-1; $j++) {
1847 0 0       0 if (!$colinpt[$j]) { last; }
  0         0  
1848             }
1849 0         0 $j--; # back up one
1850             # here with $i = first of a run of colinear points, and $j = last
1851             # of the run. $i may equal $j (no lines to force)
1852 0 0 0     0 if ($colinear eq 'line' && $j>$i) {
1853 0         0 for ($k=$i; $k<$j; $k++) {
1854 0         0 $type[$k] = 1; # force a drawn line, ignore tangents/cps
1855             }
1856             } else {
1857             # colinear, will draw curve
1858 0         0 my ($pthetap, $tthetap, $dthetap, $count, $odd, $kk,
1859             $center, $tthetax, $same);
1860             # odd number of points or even?
1861 0         0 $count = $j - $i + 1; # only interior colinear points (>= 1)
1862 0         0 $odd = $count % 2; # odd = 1 if odd count, 0 if even
1863              
1864             # need to figure tangents for each colinear point (draw curves)
1865             # first get d-theta for entry angle, d-theta' for exit angle
1866             # for which side of polyline the entry, exit control points are
1867 0         0 $ptheta = atan2($polyline[$i-1][1], $polyline[$i-1][0]);
1868 0         0 $ttheta = atan2($tangent[$i-1][1], $tangent[$i-1][0]);
1869 0         0 $dtheta = _leftright($ptheta, $ttheta); # >=0 CCW left side
1870             # <0 CW right side
1871 0         0 $pthetap = atan2(-$polyline[$j][1], -$polyline[$j][0]);
1872 0         0 $tthetap = atan2(-$tangent[$j+1][1], -$tangent[$j+1][0]);
1873 0         0 $dthetap = _leftright($pthetap, $tthetap); # >=0 CCW right side
1874             # <0 CW left side
1875              
1876             # both dtheta and dtheta' are modified below, so preserve here
1877 0 0 0     0 if ($dtheta >= 0 && $dthetap < 0 ||
      0        
      0        
1878             $dtheta < 0 && $dthetap >= 0) {
1879             # non-colinear end tangents are on same side
1880 0         0 $same = 1;
1881             } else {
1882             # non-colinear end tangents are on opposite sides
1883 0         0 $same = 0;
1884             }
1885             # $kk is how many points on each side to set tangent at,
1886             # including $i and $j (but excluding $center)
1887 0 0       0 if ($odd) {
1888             # center (i + (count-1)/2) stays flat tangent,
1889 0         0 $kk = ($count-1)/2; # ignore if 0
1890 0         0 $center = $i + $kk;
1891             } else {
1892             # center falls between i+count/2 and i+count/2+1
1893 0         0 $kk = $count/2; # minimum 1
1894 0         0 $center = -1; # not used
1895             }
1896              
1897             # dtheta[p]/2,3,4... towards center alternating
1898             # direction from initial dtheta[p]
1899             # from left, i, i+1, i+2,...,i+kk-1, (center)
1900             # from right, j, j-1, j-2,...,j-kk+1, (center)
1901 0         0 for ($k=0; $k<$kk; $k++) {
1902             # handle i+k and j-k points
1903 0         0 $dtheta = -$dtheta;
1904 0         0 $tthetax = _sweep($ptheta, -$dtheta/($k+2));
1905 0         0 $cp[$i+$k][1][0] = $tangent[$i+$k][0] = cos($tthetax);
1906 0         0 $cp[$i+$k][1][1] = $tangent[$i+$k][1] = sin($tthetax);
1907 0         0 $cp[$i+$k][0][0] = -$tangent[$i+$k][0];
1908 0         0 $cp[$i+$k][0][1] = -$tangent[$i+$k][1];
1909              
1910 0         0 $dthetap = -$dthetap;
1911 0         0 $tthetax = _sweep($pthetap, -$dthetap/($k+2));
1912 0         0 $cp[$j-$k][1][0] = $tangent[$j-$k][0] = -cos($tthetax);
1913 0         0 $cp[$j-$k][1][1] = $tangent[$j-$k][1] = -sin($tthetax);
1914 0         0 $cp[$j-$k][0][0] = -$tangent[$j-$k][0];
1915 0         0 $cp[$j-$k][0][1] = -$tangent[$j-$k][1];
1916             }
1917              
1918             # if odd (there is a center point), either flat or averaged
1919 0 0       0 if ($odd) {
1920 0 0       0 if ($same) {
1921             # non-colinear tangents are on same side,
1922             # so tangent is flat (in line with polyline)
1923             # tangent[center] should already be set to polyline
1924             } else {
1925             # non-colinear tangents are on opposite sides
1926             # so tangent is average of both neighbors dtheta's
1927             # and is opposite sign of the left neighbor
1928 0         0 $dtheta = -($dtheta + $dthetap)/2/($kk+2);
1929 0         0 $tthetax = _sweep($ptheta, -$dtheta);
1930 0         0 $tangent[$center][0] = cos($tthetax);
1931 0         0 $tangent[$center][1] = sin($tthetax);
1932             }
1933             # finally, the cps for the center. redundant for flat
1934 0         0 $cp[$center][0][0] = -$tangent[$center][0];
1935 0         0 $cp[$center][0][1] = -$tangent[$center][1];
1936 0         0 $cp[$center][1][0] = $tangent[$center][0];
1937 0         0 $cp[$center][1][1] = $tangent[$center][1];
1938             } # odd length of run
1939             } # it IS a colinear point
1940              
1941             # done dealing with run of colinear points
1942 0         0 $i = $j; # jump ahead over the run
1943 0         0 next;
1944             # end of handling colinear points
1945             } else {
1946             # non-colinear. just set cp before and after uvecs (lengths should
1947             # already be set)
1948             }
1949             } # end of for loop through interior points
1950              
1951             # all cp entries should be set, and all type entries should be set. if
1952             # debug flag, output control points (hollow red circles) with dashed 2-2
1953             # red lines from their points
1954 1 50       4 if ($debug > 3) {
1955 0         0 for ($i=0; $i<$last; $i++) {
1956             # if a line or constraint line, no cp/line to draw
1957             # don't forget, for i=last-1 and type=0 or 2, need to draw at last
1958 0 0 0     0 if ($i < $last && ($type[$i] == 1 || $type[$i] == 3)) { next; }
  0   0     0  
1959              
1960             # have point i that is end of curve, so draw dashed line to
1961             # control point, change to narrow solid line, draw open circle,
1962             # change back to heavy dashed line for next
1963 0         0 for ($j=0; $j<2; $j++) {
1964             # j=0 'after' control point for point $i
1965             # j=1 'before' control point for point $i+1
1966              
1967             # dashed red line
1968 0         0 $self->move($inputs[$i+$j][0], $inputs[$i+$j][1]);
1969 0         0 $self->line($inputs[$i+$j][0] + $cp[$i+$j][1-$j][0]*$cp[$i+$j][1-$j][2],
1970             $inputs[$i+$j][1] + $cp[$i+$j][1-$j][1]*$cp[$i+$j][1-$j][2]);
1971 0         0 $self->stroke();
1972             # red circle
1973 0         0 $self->linewidth(1);
1974 0         0 $self->linedash();
1975 0         0 $self->circle($inputs[$i+$j][0] + $cp[$i+$j][1-$j][0]*$cp[$i+$j][1-$j][2],
1976             $inputs[$i+$j][1] + $cp[$i+$j][1-$j][1]*$cp[$i+$j][1-$j][2],
1977             2);
1978 0         0 $self->stroke();
1979             # prepare for next line
1980 0         0 $self->linewidth(2);
1981 0         0 $self->linedash(2);
1982             }
1983             } # loop through all points
1984             } # debug == 3
1985              
1986             # restore old settings
1987 1 50       3 if ($debug > 0) {
1988 0         0 $self->fillstroke();
1989 0         0 $self->strokecolor(@oldColor);
1990 0         0 $self->linewidth($oldWidth);
1991 0         0 $self->linedash(@oldDash);
1992             }
1993              
1994             # the final act: go through each segment and draw either a line or a
1995             # curve
1996 1 50       4 if ($type[0] < 2) { # start drawing at 0 or 1?
1997 1         4 $self->move($inputs[0][0], $inputs[0][1]);
1998             } else {
1999 0         0 $self->move($inputs[1][0], $inputs[1][1]);
2000             }
2001 1         5 for ($i=0; $i<$last; $i++) {
2002 7 50       18 if ($type[$i] > 1) { next; } # 2, 3 constraints, not drawn
  0         0  
2003 7 50       15 if ($type[$i] == 0) {
2004             # Bezier curve, use $cp[$i][1] and $cp[$i+1][0] to generate
2005             # points for curve call
2006 7         47 $self->curve($inputs[$i][0] + $cp[$i][1][0]*$cp[$i][1][2],
2007             $inputs[$i][1] + $cp[$i][1][1]*$cp[$i][1][2],
2008             $inputs[$i+1][0] + $cp[$i+1][0][0]*$cp[$i+1][0][2],
2009             $inputs[$i+1][1] + $cp[$i+1][0][1]*$cp[$i+1][0][2],
2010             $inputs[$i+1][0],
2011             $inputs[$i+1][1]);
2012             } else {
2013             # line to next point
2014 0         0 $self->line($inputs[$i+1][0], $inputs[$i+1][1]);
2015             }
2016             }
2017            
2018 1         46 return $self;
2019             }
2020             # helper function for bspline()
2021             # given two unit vectors (direction in radians), return the delta change in
2022             # direction (radians) of the first vector to the second. left is positive.
2023             sub _leftright {
2024 2     2   6 my ($ptheta, $ttheta) = @_;
2025             # ptheta is the angle (radians) of the polyline vector from one
2026             # point to the next, and ttheta is the tangent vector at the point
2027 2         3 my ($dtheta, $antip);
2028              
2029 2 100 33     46 if ($ptheta >= 0 && $ttheta >= 0 || # both in top half (QI, QII)
      66        
      66        
2030             $ptheta < 0 && $ttheta < 0) { # both in bottom half (QIII, QIV)
2031 1         3 $dtheta = $ttheta - $ptheta;
2032             } else { # p in top half (QI, QII), t,antip in bottom half (QIII, QIV)
2033             # or p in bottom half, t,antip in top half
2034 1 50       4 if ($ttheta < 0) {
2035 0         0 $antip = $ptheta - pi;
2036             } else {
2037 1         4 $antip = $ptheta + pi;
2038             }
2039 1 50       4 if ($ttheta <= $antip) {
2040 0         0 $dtheta = pi - $antip + $ttheta; # pi - (antip - ttheta)
2041             } else {
2042 1         3 $dtheta = $ttheta - $antip - pi; # (ttheta - antip) - pi
2043             }
2044             }
2045              
2046 2         6 return $dtheta;
2047             }
2048             # helper function. given a unit direction ptheta, swing +dtheta radians right,
2049             # return normalized result
2050             sub _sweep {
2051 2     2   6 my ($ptheta, $dtheta) = @_;
2052 2         5 my ($max, $result);
2053              
2054 2 50       7 if ($ptheta >= 0) { # p in QI or QII
2055 2 50       5 if ($dtheta >= 0) { # delta CW radians
2056 0         0 $result = $ptheta - $dtheta; # OK to go into bottom quadrants
2057             } else { # delta CCW radians
2058 2         3 $max = pi - $ptheta; # max delta (>0) to stay in top quadrants
2059 2 50       6 if ($max >= -$dtheta) { # end up still in top quadrants
2060 2         4 $result = $ptheta - $dtheta;
2061             } else { # into bottom quadrants
2062 0         0 $dtheta += $max; # remaining CCW amount from -pi
2063 0         0 $result = -1*pi - $dtheta; # -pi caused some problems
2064             }
2065             }
2066             } else { # p in QIII or QIV
2067 0 0       0 if ($dtheta >= 0) { # delta CW radians
2068 0         0 $max = pi + $ptheta; # max delta (>0) to stay in bottom quadrants
2069 0 0       0 if ($max >= $dtheta) { # end up still in bottom quadrants
2070 0         0 $result = $ptheta - $dtheta;
2071             } else { # into top quadrants
2072 0         0 $dtheta -= $max; # remaining CCW amount from +pi
2073 0         0 $result = pi - $dtheta;
2074             }
2075             } else { # delta CCW radians
2076 0         0 $result = $ptheta - $dtheta; # OK to go into top quadrants
2077             }
2078             }
2079              
2080 2         5 return $result;
2081             }
2082              
2083             =over
2084              
2085             =item $content->bogen($x1,$y1, $x2,$y2, $radius, $move, $larger, $reverse)
2086              
2087             =item $content->bogen($x1,$y1, $x2,$y2, $radius, $move, $larger)
2088              
2089             =item $content->bogen($x1,$y1, $x2,$y2, $radius, $move)
2090              
2091             =item $content->bogen($x1,$y1, $x2,$y2, $radius)
2092              
2093             (German for I, as in a segment (arc) of a circle. This is a segment
2094             of a circle defined by the intersection of two circles of a given radius,
2095             with the two intersection points as inputs. There are four possible resulting
2096             arcs, which can be selected with C<$larger> and C<$reverse>.)
2097              
2098             This extends the path along an arc of a circle of the specified radius
2099             between C<[$x1,$y1]> to C<[$x2,$y2]>. The current position is then set
2100             to the endpoint of the arc (C<[$x2,$y2]>).
2101              
2102             Set C<$move> to a I value if this arc is the beginning of a new
2103             path instead of the continuation of an existing path. Note that the default
2104             (C<$move> = I) is
2105             I a straight line to I and then the arc, but a blending into the curve
2106             from the current point. It will often I pass through I!
2107              
2108             Set C<$larger> to a I value to draw the larger ("outer") arc between the
2109             two points, instead of the smaller one. Both arcs are
2110             drawn I from I to I. The default value of I draws
2111             the smaller arc.
2112              
2113             Set C<$reverse> to a I value to draw the mirror image of the
2114             specified arc (flip it over, so that its center point is on the other
2115             side of the line connecting the two points). Both arcs are drawn
2116             I from I to I. The default (I) draws
2117             clockwise arcs.
2118              
2119             The C<$radius> value cannot be smaller than B the distance from
2120             C<[$x1,$y1]> to C<[$x2,$y2]>. If it is too small, the radius will be set to
2121             half the distance between the points (resulting in an arc that is a
2122             semicircle). This is a silent error.
2123              
2124             =cut
2125              
2126             sub bogen {
2127 4     4 1 40 my ($self, $x1,$y1, $x2,$y2, $r, $move, $larc, $spf) = @_;
2128              
2129 4         14 my ($p0_x,$p0_y, $p1_x,$p1_y, $p2_x,$p2_y, $p3_x,$p3_y);
2130 4         0 my ($dx,$dy, $x,$y, $alpha,$beta, $alpha_rad, $d,$z, $dir, @points);
2131              
2132 4 50 33     13 if ($x1 == $x2 && $y1 == $y2) {
2133 0         0 die "bogen requires two distinct points";
2134             }
2135 4 50       11 if ($r <= 0.0) {
2136 0         0 die "bogen requires a positive radius";
2137             }
2138 4 50       10 $move = 0 if !defined $move;
2139 4 100       10 $larc = 0 if !defined $larc;
2140 4 100       10 $spf = 0 if !defined $spf;
2141              
2142 4         8 $dx = $x2 - $x1;
2143 4         7 $dy = $y2 - $y1;
2144 4         12 $z = sqrt($dx**2 + $dy**2);
2145 4         20 $alpha_rad = asin($dy/$z); # |dy/z| guaranteed <= 1.0
2146 4 50       37 $alpha_rad = pi - $alpha_rad if $dx < 0;
2147              
2148             # alpha is direction of vector P1 to P2
2149 4         18 $alpha = rad2deg($alpha_rad);
2150             # use the complementary angle for flipped arc (arc center on other side)
2151             # effectively clockwise draw from P2 to P1
2152 4 100       52 $alpha -= 180 if $spf;
2153              
2154 4         9 $d = 2*$r;
2155             # z/d must be no greater than 1.0 (arcsine arg)
2156 4 50       9 if ($z > $d) {
2157 0         0 $d = $z; # SILENT error and fixup
2158 0         0 $r = $d/2;
2159             }
2160              
2161 4         11 $beta = rad2deg(2*asin($z/$d));
2162             # beta is the sweep P1 to P2: ~0 (r very large) to 180 degrees (min r)
2163 4 100       55 $beta = 360-$beta if $larc; # large arc is remainder of small arc
2164             # for large arc, beta could approach 360 degrees if r is very large
2165              
2166             # always draw CW (dir=1)
2167             # note that start and end could be well out of +/-360 degree range
2168 4         24 @points = _arctocurve($r,$r, 90+$alpha+$beta/2,90+$alpha-$beta/2, 1);
2169              
2170 4 100       15 if ($spf) { # flip order of points for reverse arc
2171 1         10 my @pts = @points;
2172 1         3 @points = ();
2173 1         5 while (scalar @pts) {
2174 16         22 $y = pop @pts;
2175 16         23 $x = pop @pts;
2176 16         29 push(@points, $x,$y);
2177             }
2178             }
2179              
2180 4         9 $p0_x = shift @points;
2181 4         7 $p0_y = shift @points;
2182 4         9 $x = $x1 - $p0_x;
2183 4         8 $y = $y1 - $p0_y;
2184              
2185 4 100       46 $self->move($x1,$y1) if $move;
2186              
2187 4         13 while (scalar @points > 0) {
2188 36         67 $p1_x = $x + shift @points;
2189 36         55 $p1_y = $y + shift @points;
2190 36         50 $p2_x = $x + shift @points;
2191 36         55 $p2_y = $y + shift @points;
2192             # if we run out of data points, use the end point instead
2193 36 50       73 if (scalar @points == 0) {
2194 0         0 $p3_x = $x2;
2195 0         0 $p3_y = $y2;
2196             } else {
2197 36         44 $p3_x = $x + shift @points;
2198 36         51 $p3_y = $y + shift @points;
2199             }
2200 36         103 $self->curve($p1_x,$p1_y, $p2_x,$p2_y, $p3_x,$p3_y);
2201 36         62 shift @points;
2202 36         77 shift @points;
2203             }
2204              
2205 4         12 return $self;
2206             }
2207              
2208             =back
2209              
2210             =head2 Path Painting (Drawing)
2211              
2212             =over
2213              
2214             =item $content->stroke()
2215              
2216             Strokes the current path.
2217              
2218             =cut
2219              
2220             sub _stroke {
2221 115     115   260 return 'S';
2222             }
2223              
2224             sub stroke {
2225 115     115 1 256 my ($self) = shift;
2226              
2227 115         205 $self->add(_stroke());
2228              
2229 115         180 return $self;
2230             }
2231              
2232             =item $content->fill($use_even_odd_fill)
2233              
2234             Fill the current path's enclosed I.
2235             It does I stroke the enclosing path around the area.
2236              
2237             If the path intersects with itself, the nonzero winding rule will be
2238             used to determine which part of the path is filled in. This basically
2239             fills in I inside the path. If you would prefer to use
2240             the even-odd rule, pass a I argument. This basically will fill
2241             alternating closed sub-areas.
2242              
2243             See the PDF Specification, section 8.5.3.3, for more details on
2244             filling.
2245              
2246             =cut
2247              
2248             sub fill {
2249 2     2 1 13 my ($self) = shift;
2250              
2251 2 100       10 $self->add(shift() ? 'f*' : 'f');
2252              
2253 2         4 return $self;
2254             }
2255              
2256             =item $content->fillstroke($use_even_odd_fill)
2257              
2258             Fill the enclosed area and then stroke the current path.
2259              
2260             =cut
2261              
2262             sub fillstroke {
2263 2     2 1 14 my ($self) = shift;
2264              
2265 2 100       12 $self->add(shift() ? 'B*' : 'B');
2266              
2267 2         4 return $self;
2268             }
2269              
2270             =item $content->clip($use_even_odd_fill)
2271              
2272             =item $content->clip()
2273              
2274             Modifies the current clipping path by intersecting it with the current
2275             path. Initially (a fresh page), the clipping path is the entire media. Each
2276             definition of a path, and a C call, intersects the new path with the
2277             existing clip path, so the resulting clip path is no larger than the new path,
2278             and may even be empty if the intersection is null.
2279              
2280             If any C<$use_even_odd_fill> parameter is given, use even-odd fill (B)
2281             instead of winding-rule fill (B). It is common usage to make the
2282             C call (B) after the C call, to clear the path (unless
2283             you want to reuse that path, such as to fill and/or stroke it to show the clip
2284             path). If you want to clip text glyphs, it gets rather complicated, as a clip
2285             port cannot be created within a text object (that will have an effect on text).
2286             See the object discussion in L.
2287              
2288             my $grfxC1 = $page->gfx();
2289             my $textC = $page->text();
2290             my $grfxC2 = $page->gfx();
2291             ...
2292             $grfxC1->save();
2293             $grfxC1->endpath();
2294             $grfxC1->rect(...);
2295             $grfxC1->clip();
2296             $grfxC1->endpath();
2297             ...
2298             $textC-> output text to be clipped
2299             ...
2300             $grfxC2->restore();
2301              
2302             =cut
2303              
2304             sub clip {
2305 2     2 1 14 my ($self) = shift;
2306              
2307 2 100       10 $self->add(shift() ? 'W*' : 'W');
2308              
2309 2         5 return $self;
2310             }
2311              
2312             =back
2313              
2314             =head2 Colors
2315              
2316             =over
2317              
2318             =item $content->fillcolor($color)
2319              
2320             =item $content->strokecolor($color)
2321              
2322             Sets the fill (enclosed area) or stroke (path) color. The interior of text
2323             characters are I, and (if ordered by C) the outline is
2324             I.
2325              
2326             # Use a named color
2327             # -> RGB color model
2328             # there are many hundreds of named colors defined in
2329             # PDF::Builder::Resource::Colors
2330             $content->fillcolor('blue');
2331              
2332             # Use an RGB color (# followed by 3, 6, 9, or 12 hex digits)
2333             # -> RGB color model
2334             # This maps to 0-1.0 values for red, green, and blue
2335             $content->fillcolor('#FF0000'); # red
2336              
2337             # Use a CMYK color (% followed by 4, 8, 12, or 16 hex digits)
2338             # -> CMYK color model
2339             # This maps to 0-1.0 values for cyan, magenta, yellow, and black
2340             $content->fillcolor('%FF000000'); # cyan
2341              
2342             # Use an HSV color (! followed by 3, 6, 9, or 12 hex digits)
2343             # -> RGB color model
2344             # This maps to 0-360 degrees for the hue, and 0-1.0 values for
2345             # saturation and value
2346             $content->fillcolor('!FF0000');
2347              
2348             # Use an HSL color (& followed by 3, 6, 9, or 12 hex digits)
2349             # -> L*a*b color model
2350             # This maps to 0-360 degrees for the hue, and 0-1.0 values for
2351             # saturation and lightness. Note that 360 degrees = 0 degrees (wraps)
2352             $content->fillcolor('&FF0000');
2353              
2354             # Use an L*a*b color ($ followed by 3, 6, 9, or 12 hex digits)
2355             # -> L*a*b color model
2356             # This maps to 0-100 for L, -100 to 100 for a and b
2357             $content->fillcolor('$FF0000');
2358              
2359             In all cases, if too few digits are given, the given digits
2360             are silently right-padded with 0's (zeros). If an incorrect number
2361             of digits are given, the next lowest number of expected
2362             digits are used, and the remaining digits are silently ignored.
2363              
2364             # A single number between 0.0 (black) and 1.0 (white) is an alternate way
2365             # of specifying a gray scale.
2366             $content->fillcolor(0.5);
2367              
2368             # Three array elements between 0.0 and 1.0 is an alternate way of specifying
2369             # an RGB color.
2370             $content->fillcolor(0.3, 0.59, 0.11);
2371              
2372             # Four array elements between 0.0 and 1.0 is an alternate way of specifying
2373             # a CMYK color.
2374             $content->fillcolor(0.1, 0.9, 0.3, 1.0);
2375              
2376             In all cases, if a number is less than 0, it is silently turned into a 0. If
2377             a number is greater than 1, it is silently turned into a 1. This "clamps" all
2378             values to the range 0.0-1.0.
2379              
2380             # A single reference is treated as a pattern or shading space.
2381              
2382             # Two or more entries with the first element a Perl reference, is treated
2383             # as either an indexed colorspace reference plus color-index(es), or
2384             # as a custom colorspace reference plus parameter(s).
2385              
2386             If no value was passed in, the current fill color (or stroke color) I
2387             is B, otherwise C<$self> is B.
2388              
2389             =cut
2390              
2391             # TBD document in POD (examples) and add t tests for (pattern/shading space,
2392             # indexed colorspace + color-index, or custom colorspace + parameter)
2393             # for both fillcolor() and strokecolor(). t/cs-webcolor.t does test
2394             # cs + index
2395              
2396             # note that namecolor* routines all handle #, %, !, &, and named
2397             # colors, even though _makecolor only sends each type to proper
2398             # routine. reserved for different output color models?
2399              
2400             # I would have preferred to move _makecolor and _clamp over to Util.pm, but
2401             # some subtle errors were showing up. Maybe in the future...
2402             sub _makecolor {
2403 34     34   73 my ($self, $sf, @clr) = @_;
2404              
2405             # $sf is the stroke/fill flag (0/1)
2406             # note that a scalar argument is turned into a single element array
2407             # there will be at least one element, guaranteed
2408              
2409 34 100       124 if (scalar @clr == 1) { # a single @clr element
    50          
2410 29 50       185 if (ref($clr[0])) {
    100          
    100          
    100          
2411             # pattern or shading space
2412 0 0       0 return '/Pattern', ($sf? 'cs': 'CS'), '/'.($clr[0]->name()), ($sf? 'scn': 'SCN');
    0          
2413            
2414             } elsif ($clr[0] =~ m/^[a-z#!]/i) {
2415             # colorname (alpha) or # (RGB) or ! (HSV) specifier and 3/6/9/12 digits
2416             # with rgb target colorspace
2417             # namecolor always returns an RGB
2418 23 100       107 return namecolor($clr[0]), ($sf? 'rg': 'RG');
2419            
2420             } elsif ($clr[0] =~ m/^%/) {
2421             # % (CMYK) specifier and 4/8/12/16 digits
2422             # with cmyk target colorspace
2423 2 100       12 return namecolor_cmyk($clr[0]), ($sf? 'k': 'K');
2424              
2425             } elsif ($clr[0] =~ m/^[\$\&]/) {
2426             # & (HSL) or $ (L*a*b) specifier
2427             # with L*a*b target colorspace
2428 2 50       9 if (!defined $self->resource('ColorSpace', 'LabS')) {
2429 2         5 my $dc = PDFDict();
2430 2         7 my $cs = PDFArray(PDFName('Lab'), $dc);
2431 2         6 $dc->{'WhitePoint'} = PDFArray(map { PDFNum($_) } qw(1 1 1));
  6         13  
2432 2         7 $dc->{'Range'} = PDFArray(map { PDFNum($_) } qw(-128 127 -128 127));
  8         13  
2433 2         5 $dc->{'Gamma'} = PDFArray(map { PDFNum($_) } qw(2.2 2.2 2.2));
  6         13  
2434 2         8 $self->resource('ColorSpace', 'LabS', $cs);
2435             }
2436 2 100       15 return '/LabS', ($sf? 'cs': 'CS'), namecolor_lab($clr[0]), ($sf? 'sc': 'SC');
    100          
2437              
2438             } else { # should be a float number... add a test and else failure?
2439             # grey color spec.
2440 2         20 $clr[0] = _clamp($clr[0], 0, 0, 1);
2441 2 100       14 return $clr[0], ($sf? 'g': 'G');
2442              
2443             #} else {
2444             # die 'invalid color specification.';
2445             } # @clr 1 element
2446              
2447             } elsif (scalar @clr > 1) { # 2 or more @clr elements
2448 5 100       26 if (ref($clr[0])) {
    100          
    50          
2449             # indexed colorspace plus color-index(es)
2450             # or custom colorspace plus param(s)
2451 1         19 my $cs = shift @clr;
2452 1 50       7 return '/'.$cs->name(), ($sf? 'cs': 'CS'), $cs->param(@clr), ($sf? 'sc': 'SC');
    50          
2453              
2454             # What exactly is the difference between the following case and the
2455             # previous case? The previous allows multiple indices or parameters and
2456             # this one doesn't. Also, this one would try to process a bad call like
2457             # fillcolor('blue', 'gray').
2458             #} elsif (scalar @clr == 2) {
2459             # # indexed colorspace plus color-index
2460             # # or custom colorspace plus param
2461             # return '/'.$clr[0]->name(), ($sf? 'cs': 'CS'), $clr[0]->param($clr[1]), ($sf? 'sc': 'SC');
2462              
2463             } elsif (scalar @clr == 3) {
2464             # legacy rgb color-spec (0 <= x <= 1)
2465 2         8 $clr[0] = _clamp($clr[0], 0, 0, 1);
2466 2         7 $clr[1] = _clamp($clr[1], 0, 0, 1);
2467 2         7 $clr[2] = _clamp($clr[2], 0, 0, 1);
2468 2 100       12 return floats($clr[0], $clr[1], $clr[2]), ($sf? 'rg': 'RG');
2469              
2470             } elsif (scalar @clr == 4) {
2471             # legacy cmyk color-spec (0 <= x <= 1)
2472 2         10 $clr[0] = _clamp($clr[0], 0, 0, 1);
2473 2         7 $clr[1] = _clamp($clr[1], 0, 0, 1);
2474 2         8 $clr[2] = _clamp($clr[2], 0, 0, 1);
2475 2         11 $clr[3] = _clamp($clr[3], 0, 0, 1);
2476 2 100       11 return floats($clr[0], $clr[1], $clr[2], $clr[3]), ($sf? 'k': 'K');
2477              
2478             } else {
2479 0         0 die 'invalid color specification.';
2480             } # @clr with 2 or more elements
2481              
2482             } else { # @clr with 0 elements. presumably won't see...
2483 0         0 die 'invalid color specification.';
2484             }
2485             }
2486              
2487             # silent error if non-numeric value (assign default),
2488             # or outside of min..max limits (clamp to closer limit).
2489             sub _clamp {
2490 16     16   35 my ($val, $default, $min, $max) = @_;
2491              
2492 16 50       40 if (!Scalar::Util::looks_like_number($val)) { $val = $default; }
  0         0  
2493 16 100       46 if ($val < $min) {
    100          
2494 1         3 $val = $min;
2495             } elsif ($val > $max) {
2496 2         4 $val = $max;
2497             }
2498              
2499 16         35 return $val;
2500             }
2501              
2502             sub _fillcolor {
2503 19     19   50 my ($self, @clrs) = @_;
2504              
2505 19 50       82 if (ref($clrs[0]) =~ m|^PDF::Builder::Resource::ColorSpace|) {
    50          
2506 0         0 $self->resource('ColorSpace', $clrs[0]->name(), $clrs[0]);
2507             } elsif (ref($clrs[0]) =~ m|^PDF::Builder::Resource::Pattern|) {
2508 0         0 $self->resource('Pattern', $clrs[0]->name(), $clrs[0]);
2509             }
2510              
2511 19         87 return $self->_makecolor(1, @clrs);
2512             }
2513              
2514             sub fillcolor {
2515 19     19 1 101 my $self = shift;
2516              
2517 19 50       55 if (scalar @_) {
2518 19         41 @{$self->{' fillcolor'}} = @_;
  19         63  
2519 19         111 $self->add($self->_fillcolor(@_));
2520              
2521 19         49 return $self;
2522             } else {
2523              
2524 0         0 return @{$self->{' fillcolor'}};
  0         0  
2525             }
2526             }
2527              
2528             sub _strokecolor {
2529 15     15   39 my ($self, @clrs) = @_;
2530              
2531 15 100       72 if (ref($clrs[0]) =~ m|^PDF::Builder::Resource::ColorSpace|) {
    50          
2532 1         5 $self->resource('ColorSpace', $clrs[0]->name(), $clrs[0]);
2533             } elsif (ref($clrs[0]) =~ m|^PDF::Builder::Resource::Pattern|) {
2534 0         0 $self->resource('Pattern', $clrs[0]->name(), $clrs[0]);
2535             }
2536              
2537 15         56 return $self->_makecolor(0, @clrs);
2538             }
2539              
2540             sub strokecolor {
2541 15     15 1 73 my $self = shift;
2542              
2543 15 50       57 if (scalar @_) {
2544 15         35 @{$self->{' strokecolor'}} = @_;
  15         40  
2545 15         74 $self->add($self->_strokecolor(@_));
2546              
2547 15         39 return $self;
2548             } else {
2549              
2550 0         0 return @{$self->{' strokecolor'}};
  0         0  
2551             }
2552             }
2553              
2554             =item $content->shade($shade, @coord)
2555              
2556             Sets the shading matrix.
2557              
2558             =over
2559              
2560             =item $shade
2561              
2562             A hash reference that includes a C method for the shade name.
2563              
2564             =item @coord
2565              
2566             An array of 4 items: X-translation, Y-translation,
2567             X-scaled and translated, Y-scaled and translated.
2568              
2569             =back
2570              
2571             =cut
2572              
2573             sub shade {
2574 0     0 1 0 my ($self, $shade, @coord) = @_;
2575              
2576 0         0 my @tm = (
2577             $coord[2]-$coord[0] , 0,
2578             0 , $coord[3]-$coord[1],
2579             $coord[0] , $coord[1]
2580             );
2581 0         0 $self->save();
2582 0         0 $self->matrix(@tm);
2583 0         0 $self->add('/'.$shade->name(), 'sh');
2584              
2585 0         0 $self->resource('Shading', $shade->name(), $shade);
2586 0         0 $self->restore();
2587              
2588 0         0 return $self;
2589             }
2590              
2591             =back
2592              
2593             =head2 External Objects
2594              
2595             =over
2596              
2597             =item $content->image($image_object, $x,$y, $width,$height)
2598              
2599             =item $content->image($image_object, $x,$y, $scale)
2600              
2601             =item $content->image($image_object, $x,$y)
2602              
2603             =item $content->image($image_object)
2604              
2605             # Example
2606             my $image_object = $pdf->image_jpeg($my_image_file);
2607             $content->image($image_object, 100, 200);
2608              
2609             Places an image on the page in the specified location (specifies the lower
2610             left corner of the image). The default location is C<[0,0]>.
2611              
2612             If coordinate transformations have been made (see I
2613             Transformations> above), the position and scale will be relative to the
2614             updated coordinates. Otherwise, C<[0,0]> will represent the bottom left
2615             corner of the page, and C<$width> and C<$height> will be measured at
2616             72dpi.
2617              
2618             For example, if you have a 600x600 image that you would like to be
2619             shown at 600dpi (i.e., one inch square), set the width and height to 72.
2620             (72 Big Points is one inch)
2621              
2622             =cut
2623              
2624             sub image {
2625 6     6 1 63 my ($self, $img, $x,$y, $w,$h) = @_;
2626              
2627 6 50       29 if (!defined $y) { $y = 0; }
  0         0  
2628 6 50       22 if (!defined $x) { $x = 0; }
  0         0  
2629              
2630 6 50       24 if (defined $img->{'Metadata'}) {
2631 0         0 $self->_metaStart('PPAM:PlacedImage', $img->{'Metadata'});
2632             }
2633 6         45 $self->save();
2634 6 50       118 if (!defined $w) {
    50          
2635 0         0 $h = $img->height();
2636 0         0 $w = $img->width();
2637             } elsif (!defined $h) {
2638 0         0 $h = $img->height()*$w;
2639 0         0 $w = $img->width()*$w;
2640             }
2641 6         64 $self->matrix($w,0,0,$h, $x,$y);
2642 6         36 $self->add("/".$img->name(), 'Do');
2643 6         30 $self->restore();
2644 6         18 $self->{' x'} = $x;
2645 6         18 $self->{' y'} = $y;
2646 6         25 $self->resource('XObject', $img->name(), $img);
2647 6 50       40 if (defined $img->{'Metadata'}) {
2648 0         0 $self->_metaEnd();
2649             }
2650              
2651 6         16 return $self;
2652             }
2653              
2654             =item $content->formimage($form_object, $x,$y, $scaleX, $scaleY)
2655              
2656             =item $content->formimage($form_object, $x,$y, $scale)
2657              
2658             =item $content->formimage($form_object, $x,$y)
2659              
2660             =item $content->formimage($form_object)
2661              
2662             Places an XObject on the page in the specified location (giving the lower
2663             left corner of the image) and scale (applied to the image's native height
2664             and width). If no scale is given, use 1 for both X and Y. If one scale is
2665             given, use for both X and Y. If two scales given, they are for (separately)
2666             X and Y. In general, you should not greatly distort an image by using greatly
2667             different scaling factors in X and Y, although it is now possible for when
2668             that effect is desirable. The C<$x,$y> default is C<[0,0]>.
2669              
2670             B that while this method is named form I, it is also used for the
2671             pseudoimages created by the barcode routines. Images are naturally dimensionless
2672             (1 point square) and need at some point to be scaled up to the desired point
2673             size. Barcodes are naturally sized in points, and should be scaled at
2674             approximately I<1>. Therefore, it would greatly overscale barcodes to multiply
2675             by image width and height I C, and require scaling of
2676             1/width and 1/height in the call. So, we leave scaling alone within
2677             C and have the user manually scale I by the image width and
2678             height (in pixels) in the call to C.
2679              
2680             =cut
2681              
2682             sub formimage {
2683 2     2 1 16 my ($self, $img, $x,$y, $sx,$sy) = @_;
2684              
2685 2 50       31 if (!defined $y) { $y = 0; }
  0         0  
2686 2 50       9 if (!defined $x) { $x = 0; }
  0         0  
2687              
2688             # if one scale given, use for both
2689             # if no scale given, use 1 for both
2690 2 50       8 if (!defined $sx) { $sx = 1; }
  0         0  
2691 2 50       8 if (!defined $sy) { $sy = $sx; }
  2         5  
2692              
2693             ## convert to desired height and width in pixels
2694             #$sx *= $img->width();
2695             #$sy *= $img->height();
2696              
2697 2         13 $self->save();
2698              
2699 2         11 $self->matrix($sx,0,0,$sy, $x,$y);
2700 2         13 $self->add('/'.$img->name(), 'Do');
2701 2         11 $self->restore();
2702 2         7 $self->resource('XObject', $img->name(), $img);
2703              
2704 2         6 return $self;
2705             }
2706              
2707             =back
2708              
2709             =head2 Text
2710              
2711             =head3 Text State Parameters
2712              
2713             All of the following parameters that take a size are applied before
2714             any scaling takes place, so you don't need to adjust values to
2715             counteract scaling.
2716              
2717             =over
2718              
2719             =item $spacing = $content->charspace($spacing)
2720              
2721             Sets additional spacing between B in a line. This is in I,
2722             and is initially zero.
2723             It may be positive to give an I effect to words, or
2724             it may be negative to give a I effect to words.
2725             If C<$spacing> is given, the current setting is replaced by that value and
2726             C<$self> is B (to permit chaining).
2727             If C<$spacing> is not given, the current setting is B.
2728              
2729             B be careful about using C if you are using a connected
2730             font. This might include Arabic, Devanagari, Latin cursive handwriting, and so
2731             on. You don't want to leave gaps between characters, or cause overlaps. For
2732             such fonts and typefaces, set the C spacing to 0.
2733              
2734             =cut
2735              
2736             sub _charspace {
2737 11     11   25 my ($space) = @_;
2738              
2739 11         31 return float($space, 6) . ' Tc';
2740             }
2741              
2742             sub charspace {
2743 16     16 1 1030 my ($self, $space) = @_;
2744              
2745 16 100       45 if (defined $space) {
2746 11         24 $self->{' charspace'} = $space;
2747 11         36 $self->add(_charspace($space));
2748              
2749 11         30 return $self;
2750             } else {
2751 5         19 return $self->{' charspace'};
2752             }
2753             }
2754              
2755             =item $spacing = $content->wordspace($spacing)
2756              
2757             Sets additional spacing between B in a line. This is in I and
2758             is initially zero
2759             (i.e., just the width of the space, without anything extra). It may be negative
2760             to close up sentences a bit.
2761             If C<$spacing> is given, the current setting is replaced by that value and
2762             C<$self> is B (to permit chaining).
2763             If C<$spacing> is not given, the current setting is B.
2764              
2765             Note that it is a limitation of the PDF specification (as of version 1.7,
2766             section 9.3.3) that only spacing with an ASCII space (x20) is adjusted. Neither
2767             required blanks (xA0) nor any multiple-byte spaces (including thin and wide
2768             spaces) are currently adjusted.
2769              
2770             =cut
2771              
2772             sub _wordspace {
2773 14     14   29 my ($space) = @_;
2774              
2775 14         45 return float($space, 6) . ' Tw';
2776             }
2777              
2778             sub wordspace {
2779 19     19 1 606 my ($self, $space) = @_;
2780              
2781 19 100       51 if (defined $space) {
2782 14         31 $self->{' wordspace'} = $space;
2783 14         42 $self->add(_wordspace($space));
2784              
2785 14         35 return $self;
2786             } else {
2787 5         19 return $self->{' wordspace'};
2788             }
2789             }
2790              
2791             =item $scale = $content->hscale($scale)
2792              
2793             Sets the percentage of horizontal text scaling (relative sizing, I
2794             spacing). This is initally 100 (percent, i.e., no scaling). A scale of greater
2795             than 100 will stretch the text, while less than 100 will compress it.
2796             If C<$scale> is given, the current setting is replaced by that value and
2797             C<$self> is B (to permit chaining).
2798             If C<$scale> is not given, the current setting is B.
2799              
2800             Note that scaling affects all of the character widths, interletter spacing, and
2801             interword spacing. It is inadvisable to stretch or compress text by a large
2802             amount, as it will quickly make the text unreadable. If your objective is to
2803             justify text, you will usually be better off using C and C
2804             to expand (or slightly condense) a line to fill a desired width. Also see
2805             the C calls for this purpose.
2806              
2807             =cut
2808              
2809             sub _hscale {
2810 9     9   20 my ($scale) = @_;
2811              
2812 9         37 return float($scale, 6) . ' Tz';
2813             }
2814              
2815             sub hscale {
2816 25     25 1 69 my ($self, $scale) = @_;
2817              
2818 25 100       66 if (defined $scale) {
2819 9         21 $self->{' hscale'} = $scale;
2820 9         31 $self->add(_hscale($scale));
2821              
2822 9         24 return $self;
2823             } else {
2824 16         81 return $self->{' hscale'};
2825             }
2826             }
2827              
2828             # Note: hscale was originally named incorrectly as hspace, renamed
2829             # note that the private class data ' hspace' is no longer supported
2830              
2831             =item $leading = $content->leading($leading)
2832              
2833             =item $leading = $content->leading()
2834              
2835             Sets the text leading, which is the distance between baselines. This
2836             is initially B (i.e., the lines will be printed on top of each
2837             other). The unit of leading is points.
2838             If C<$leading> is given, the current setting is replaced by that value and
2839             C<$self> is B (to permit chaining).
2840             If C<$leading> is not given, the current setting is B.
2841              
2842             Note that C here is defined as used in electronic typesetting and
2843             the PDF specification, which is the full interline spacing (text baseline to
2844             text baseline distance, in points). In cold metal typesetting, I was
2845             usually the I spacing between lines beyond the font height itself,
2846             created by inserting lead (type alloy) shims.
2847              
2848             =item $leading = $content->lead($leading)
2849              
2850             =item $leading = $content->lead()
2851              
2852             B to be removed after March 2023. Use C now.
2853              
2854             Note that the C<$self->{' lead'}> internal variable is no longer available,
2855             having been replaced by C<$self->{' leading'}>.
2856              
2857             =cut
2858              
2859             # to be removed 3/2023 or later
2860             sub lead {
2861 1     1 1 19 return $_[0]->leading($_[1]);
2862             }
2863              
2864             sub _leading {
2865 11     11   33 my ($leading) = @_;
2866              
2867 11         47 return float($leading) . ' TL';
2868             }
2869              
2870             sub leading {
2871 47     47 1 173 my ($self, $leading) = @_;
2872              
2873 47 100       112 if (defined $leading) {
2874 11         33 $self->{' leading'} = $leading;
2875 11         48 $self->add(_leading($leading));
2876              
2877 11         31 return $self;
2878             } else {
2879 36         115 return $self->{' leading'};
2880             }
2881             }
2882              
2883             =item $mode = $content->render($mode)
2884              
2885             Sets the text rendering mode.
2886              
2887             =over
2888              
2889             =item 0 = Fill text
2890              
2891             =item 1 = Stroke text (outline)
2892              
2893             =item 2 = Fill, then stroke text
2894              
2895             =item 3 = Neither fill nor stroke text (invisible)
2896              
2897             =item 4 = Fill text and add to path for clipping
2898              
2899             =item 5 = Stroke text and add to path for clipping
2900              
2901             =item 6 = Fill, then stroke text and add to path for clipping
2902              
2903             =item 7 = Add text to path for clipping
2904              
2905             =back
2906              
2907             If C<$mode> is given, the current setting is replaced by that value and
2908             C<$self> is B (to permit chaining).
2909             If C<$mode> is not given, the current setting is B.
2910              
2911             =cut
2912              
2913             sub _render {
2914 1     1   2 my ($mode) = @_;
2915              
2916 1         6 return intg($mode) . ' Tr';
2917             }
2918              
2919             sub render {
2920 1     1 1 9 my ($self, $mode) = @_;
2921              
2922 1 50       5 if (defined $mode) {
2923 1         10 $mode = max(0, min(7, int($mode))); # restrict to integer range 0..7
2924 1         2 $self->{' render'} = $mode;
2925 1         7 $self->add(_render($mode));
2926              
2927 1         3 return $self;
2928             } else {
2929 0         0 return $self->{' render'};
2930             }
2931             }
2932              
2933             =item $dist = $content->rise($dist)
2934              
2935             Adjusts the baseline up or down from its current location. This is
2936             initially zero. A C<$dist> greater than 0 moves the baseline B the page
2937             (y increases).
2938              
2939             Use this for creating superscripts or subscripts (usually along with an
2940             adjustment to the font size).
2941             If C<$dist> is given, the current setting is replaced by that value and
2942             C<$self> is B (to permit chaining).
2943             If C<$dist> is not given, the current setting is B.
2944              
2945             =cut
2946              
2947             sub _rise {
2948 1     1   3 my ($dist) = @_;
2949              
2950 1         4 return float($dist) . ' Ts';
2951             }
2952              
2953             sub rise {
2954 1     1 1 8 my ($self, $dist) = @_;
2955              
2956 1 50       4 if (defined $dist) {
2957 1         3 $self->{' rise'} = $dist;
2958 1         4 $self->add(_rise($dist));
2959              
2960 1         3 return $self;
2961             } else {
2962 0         0 return $self->{' rise'};
2963             }
2964             }
2965              
2966             =item %state = $content->textstate(charspace => $value, wordspace => $value, ...)
2967              
2968             This is a shortcut for setting multiple text state parameters at once.
2969             If any parameters are set, an I hash is B.
2970             This can also be used without arguments to retrieve the current text
2971             state settings (a hash of the state is B).
2972              
2973             B This does not work with the C and C commands.
2974              
2975             =cut
2976              
2977             sub textstate {
2978 0     0 1 0 my ($self) = shift;
2979              
2980 0         0 my %state;
2981 0 0       0 if (scalar @_) {
2982 0         0 %state = @_;
2983 0         0 foreach my $k (qw( charspace hscale wordspace leading rise render )) {
2984 0 0       0 next unless $state{$k};
2985 0         0 $self->can($k)->($self, $state{$k});
2986             }
2987 0 0 0     0 if ($state{'font'} && $state{'fontsize'}) {
2988 0         0 $self->font($state{'font'}, $state{'fontsize'});
2989             }
2990 0 0       0 if ($state{'textmatrix'}) {
2991 0         0 $self->matrix(@{$state{'textmatrix'}});
  0         0  
2992 0         0 @{$self->{' translate'}} = @{$state{'translate'}};
  0         0  
  0         0  
2993 0         0 $self->{' rotate'} = $state{'rotate'};
2994 0         0 @{$self->{' scale'}} = @{$state{'scale'}};
  0         0  
  0         0  
2995 0         0 @{$self->{' skew'}} = @{$state{'skew'}};
  0         0  
  0         0  
2996             }
2997 0 0       0 if ($state{'fillcolor'}) {
2998 0         0 $self->fillcolor(@{$state{'fillcolor'}});
  0         0  
2999             }
3000 0 0       0 if ($state{'strokecolor'}) {
3001 0         0 $self->strokecolor(@{$state{'strokecolor'}});
  0         0  
3002             }
3003 0         0 %state = ();
3004             } else {
3005 0         0 foreach my $k (qw( font fontsize charspace hscale wordspace leading rise render )) {
3006 0         0 $state{$k}=$self->{" $k"};
3007             }
3008 0         0 $state{'matrix'} = [@{$self->{" matrix"}}];
  0         0  
3009 0         0 $state{'textmatrix'} = [@{$self->{" textmatrix"}}];
  0         0  
3010 0         0 $state{'textlinematrix'} = [@{$self->{" textlinematrix"}}];
  0         0  
3011 0         0 $state{'rotate'} = $self->{" rotate"};
3012 0         0 $state{'scale'} = [@{$self->{" scale"}}];
  0         0  
3013 0         0 $state{'skew'} = [@{$self->{" skew"}}];
  0         0  
3014 0         0 $state{'translate'} = [@{$self->{" translate"}}];
  0         0  
3015 0         0 $state{'fillcolor'} = [@{$self->{" fillcolor"}}];
  0         0  
3016 0         0 $state{'strokecolor'} = [@{$self->{" strokecolor"}}];
  0         0  
3017             }
3018              
3019 0         0 return %state;
3020             }
3021              
3022             =item $content->font($font_object, $size)
3023              
3024             Sets the font and font size.
3025              
3026             # Example (12 point Helvetica)
3027             my $pdf = PDF::Builder->new();
3028             my $fontname = $pdf->corefont('Helvetica');
3029             $content->font($fontname, 12);
3030              
3031             =cut
3032              
3033             sub _font {
3034 17     17   55 my ($font, $size) = @_;
3035              
3036 17 100       82 if ($font->isvirtual()) {
3037 1         6 return '/'.$font->fontlist()->[0]->name().' '.float($size).' Tf';
3038             } else {
3039 16         65 return '/'.$font->name().' '.float($size).' Tf';
3040             }
3041             }
3042              
3043             sub font {
3044 18     18 1 895 my ($self, $font, $size) = @_;
3045              
3046 18 100       74 unless ($size) {
3047 1         102 croak q{A font size is required};
3048             }
3049 17         106 $self->_fontset($font, $size);
3050 17         107 $self->add(_font($font, $size));
3051 17         49 $self->{' fontset'} = 1;
3052              
3053 17         61 return $self;
3054             }
3055              
3056             sub _fontset {
3057 17     17   72 my ($self, $font, $size) = @_;
3058              
3059 17         58 $self->{' font'} = $font;
3060 17         58 $self->{' fontsize'} = $size;
3061 17         44 $self->{' fontset'} = 0;
3062              
3063 17 100       142 if ($font->isvirtual()) {
3064 1         2 foreach my $f (@{$font->fontlist()}) {
  1         5  
3065 2         12 $self->resource('Font', $f->name(), $f);
3066             }
3067             } else {
3068 16         116 $self->resource('Font', $font->name(), $font);
3069             }
3070              
3071 17         45 return $self;
3072             }
3073              
3074             =back
3075              
3076             =head3 Positioning Text
3077              
3078             =over
3079              
3080             =item $content->distance($dx,$dy)
3081              
3082             This moves to the start of the previously-written line, plus an offset by the
3083             given amounts, which are both required. C<[0,0]> would overwrite the previous
3084             line, while C<[0,36]> would place the new line 36pt I the old line
3085             (higher y). The C<$dx> moves to the right, if positive.
3086              
3087             C is analogous to graphic's C, except that it is relative to
3088             the beginning of the previous text write, not to the coordinate origin.
3089             B that subsequent text writes will be relative to this new starting
3090             (left) point and Y position! E.g., if you give a non-zero C<$dx>, subsequent
3091             lines will be indented by that amount.
3092              
3093             =cut
3094              
3095             sub distance {
3096 1     1 1 9 my ($self, $dx,$dy) = @_;
3097              
3098 1         5 $self->add(float($dx), float($dy), 'Td');
3099 1         7 $self->matrix_update($dx,$dy);
3100 1         2 $self->{' textlinematrix'}->[0] = $dx;
3101              
3102 1         3 return $self;
3103             }
3104              
3105             =item $content->cr()
3106              
3107             =item $content->cr($vertical_offset)
3108              
3109             =item $content->cr(0)
3110              
3111             If passed without an argument, moves (down) to the start of the I line
3112             (distance set by C). This is similar to C.
3113              
3114             If passed I an argument, the C distance is ignored and the next
3115             line starts that far I the page (positive value) or I the page
3116             (negative value) from the current line. "Y" increases upward, so a negative
3117             value would normally be used to get to the next line down.
3118              
3119             An argument of I<0> would
3120             simply return to the start of the present line, overprinting it with new text.
3121             That is, it acts as a simple carriage return, without a linefeed.
3122              
3123             =cut
3124              
3125             sub cr {
3126 4     4 1 20 my ($self, $offset) = @_;
3127              
3128 4 100       11 if (defined $offset) {
3129 3         11 $self->add(0, float($offset), 'Td');
3130 3         7 $self->matrix_update(0, $offset);
3131             } else {
3132 1         4 $self->add('T*');
3133 1         4 $self->matrix_update(0, $self->leading() * -1);
3134             }
3135 4         8 $self->{' textlinematrix'}->[0] = 0;
3136              
3137 4         7 return $self;
3138             }
3139              
3140             =item $content->nl()
3141              
3142             =item $content->nl($indent)
3143              
3144             =item $content->nl(0)
3145              
3146             Moves to the start of the next line (see C). If C<$indent> is not given,
3147             or is 0, there is no indentation. Otherwise, indent by that amount (Ident
3148             if a negative value). The unit of measure is hundredths of a "unit of text
3149             space", or roughly 88 per em.
3150              
3151             =cut
3152              
3153             sub nl {
3154 23     23 1 65 my ($self, $indent) = @_;
3155              
3156             # can't use Td, because it permanently changes the line start by $indent
3157             # same problem using the distance() call
3158 23         69 $self->add('T*'); # go to start of next line
3159 23         79 $self->matrix_update(0, $self->leading() * -1);
3160 23         51 $self->{' textlinematrix'}->[0] = 0;
3161 23 100 100     76 if (defined($indent) && $indent != 0) {
3162             # move right or left by $indent
3163 1         7 $self->add('[' . (-10 * $indent) . '] TJ');
3164             }
3165              
3166 23         51 return $self;
3167             }
3168              
3169             =item ($tx,$ty) = $content->textpos()
3170              
3171             B the current text position on the page (where next write will happen)
3172             as an array.
3173              
3174             B This does not affect the PDF in any way. It only tells you where the
3175             the next write will occur.
3176              
3177             =cut
3178              
3179             sub _textpos {
3180 0     0   0 my ($self, @xy) = @_;
3181              
3182 0         0 my ($x,$y) = (0,0);
3183 0         0 while (scalar @xy > 0) {
3184 0         0 $x += shift @xy;
3185 0         0 $y += shift @xy;
3186             }
3187             my @m = _transform(
3188 0         0 -matrix => $self->{" textmatrix"},
3189             -point => [$x,$y]
3190             );
3191 0         0 return ($m[0],$m[1]);
3192             }
3193              
3194             sub _textpos2 {
3195 60     60   134 my ($self) = shift;
3196              
3197 60         97 return (@{$self->{" textlinematrix"}});
  60         207  
3198             }
3199              
3200             sub textpos {
3201 0     0 1 0 my ($self) = shift;
3202              
3203 0         0 return ($self->_textpos(@{$self->{" textlinematrix"}}));
  0         0  
3204             }
3205              
3206             =item $width = $content->advancewidth($string, %opts)
3207              
3208             =item $width = $content->advancewidth($string)
3209              
3210             Options %opts:
3211              
3212             =over
3213              
3214             =item font => $f3_TimesRoman
3215              
3216             Change the font used, overriding $self->{' font'}. The font must have been
3217             previously created (i.e., is not the name). Example: use Times-Roman.
3218              
3219             =item fontsize => 12
3220              
3221             Change the font size, overriding $self->{' fontsize'}. Example: 12 pt font.
3222              
3223             =item wordspace => 0.8
3224              
3225             Change the additional word spacing, overriding $self->wordspace().
3226             Example: add 0.8 pt between words.
3227              
3228             =item charspace => -2.1
3229              
3230             Change the additional character spacing, overriding $self->charspace().
3231             Example: subtract 2.1 pt between letters, to condense the text.
3232              
3233             =item hscale => 125
3234              
3235             Change the horizontal scaling factor, overriding $self->hscale().
3236             Example: stretch text to 125% of its natural width.
3237              
3238             =back
3239              
3240             B the B based on all currently set text-state
3241             attributes. These can optionally be overridden with %opts. I
3242             values temporarily B the existing values, B scaling them up or
3243             down.> For example, if the existing charspace is 2, and you give in options
3244             a value of 3, the value used is 3, not 5.
3245              
3246             B This does not affect the PDF in any way. It only tells you how much
3247             horizontal space a text string will take up.
3248              
3249             =cut
3250              
3251             sub advancewidth {
3252 190     190 1 1533 my ($self, $text, %opts) = @_;
3253              
3254 190         321 my ($glyph_width, $num_space, $num_char, $word_spaces,
3255             $char_spaces, $advance);
3256              
3257 190 50 33     722 return 0 unless defined($text) and length($text);
3258             # fill %opts from current settings unless explicitly given
3259 190         349 foreach my $k (qw[ font fontsize wordspace charspace hscale]) {
3260 950 100       2465 $opts{$k} = $self->{" $k"} unless defined $opts{$k};
3261             }
3262             # any other options given are ignored
3263              
3264 190         534 $glyph_width = $opts{'font'}->width($text)*$opts{'fontsize'};
3265 190         390 $num_space = $text =~ y/\x20/\x20/;
3266 190         300 $num_char = length($text);
3267 190         312 $word_spaces = $opts{'wordspace'}*$num_space;
3268 190         290 $char_spaces = $opts{'charspace'}*($num_char - 1);
3269 190         403 $advance = ($glyph_width+$word_spaces+$char_spaces)*$opts{'hscale'}/100;
3270              
3271 190         572 return $advance;
3272             }
3273              
3274             =back
3275              
3276             =head3 Rendering Text
3277              
3278             =over
3279              
3280             =back
3281              
3282             =head4 Single Lines
3283              
3284             =over
3285              
3286             =item $width = $content->text($text, %opts)
3287              
3288             =item $width = $content->text($text)
3289              
3290             Adds text to the page (left justified).
3291             The width used (in points) is B.
3292              
3293             Options:
3294              
3295             =over
3296              
3297             =item -indent => $distance
3298              
3299             Indents the text by the number of points (A value less than 0 gives an
3300             I).
3301              
3302             =item -underline => 'none'
3303              
3304             =item -underline => 'auto'
3305              
3306             =item -underline => $distance
3307              
3308             =item -underline => [$distance, $thickness, ...]
3309              
3310             Underlines the text. C<$distance> is the number of units beneath the
3311             baseline, and C<$thickness> is the width of the line.
3312             Multiple underlines can be made by passing several distances and
3313             thicknesses.
3314             A value of 'none' means no underlining (is the default).
3315              
3316             Example:
3317            
3318             # 3 underlines:
3319             # distance 4, thickness 1, color red
3320             # distance 7, thickness 1.5, color yellow
3321             # distance 11, thickness 2, color (strokecolor default)
3322             -underline=>[4,[1,'red'],7,[1.5,'yellow'],11,2],
3323              
3324             =item -strikethru => 'none'
3325              
3326             =item -strikethru => 'auto'
3327              
3328             =item -strikethru => $distance
3329              
3330             =item -strikethru => [$distance, $thickness, ...]
3331              
3332             Strikes through the text (like HTML I tag). A value of 'auto' places the
3333             line about 30% of the font size above the baseline, or a specified C<$distance>
3334             (above the baseline) and C<$thickness> (in points).
3335             Multiple strikethroughs can be made by passing several distances and
3336             thicknesses.
3337             A value of 'none' means no strikethrough. It is the default.
3338              
3339             Example:
3340            
3341             # 2 strikethroughs:
3342             # distance 4, thickness 1, color red
3343             # distance 7, thickness 1.5, color yellow
3344             -strikethru=>[4,[1,'red'],7,[1.5,'yellow']],
3345              
3346             =back
3347              
3348             =cut
3349              
3350             sub _text_underline {
3351 0     0   0 my ($self, $xy1,$xy2, $underline, $color) = @_;
3352              
3353 0   0     0 $color ||= 'black';
3354 0         0 my @underline = ();
3355 0 0       0 if (ref($underline) eq 'ARRAY') {
3356 0         0 @underline = @{$underline};
  0         0  
3357             } else {
3358 0 0       0 if ($underline eq 'none') { return; }
  0         0  
3359 0         0 @underline = ($underline, 1);
3360             }
3361 0 0       0 push @underline,1 if @underline%2;
3362              
3363 0   0     0 my $underlineposition = (-$self->{' font'}->underlineposition()*$self->{' fontsize'}/1000||1);
3364 0   0     0 my $underlinethickness = ($self->{' font'}->underlinethickness()*$self->{' fontsize'}/1000||1);
3365 0         0 my $pos = 1;
3366              
3367 0         0 while (@underline) {
3368 0         0 $self->add_post(_save());
3369              
3370 0         0 my $distance = shift @underline;
3371 0         0 my $thickness = shift @underline;
3372 0         0 my $scolor = $color;
3373 0 0       0 if (ref $thickness) {
3374 0         0 ($thickness, $scolor) = @{$thickness};
  0         0  
3375             }
3376              
3377 0 0       0 if ($distance eq 'auto') {
3378 0         0 $distance = $pos*$underlineposition;
3379             }
3380 0 0       0 if ($thickness eq 'auto') {
3381 0         0 $thickness = $underlinethickness;
3382             }
3383              
3384 0         0 my ($x1,$y1, $x2,$y2);
3385 0         0 my $h = $distance+($thickness/2);
3386 0 0       0 if (scalar(@{$xy1}) > 2) {
  0         0  
3387             # actual baseline start and end points, not old reduced method
3388 0         0 my @xyz = @{$xy1};
  0         0  
3389 0         0 $x1 = $xyz[1]; $y1 = $xyz[2] - $h;
  0         0  
3390 0         0 @xyz = @{$xy2};
  0         0  
3391 0         0 $x2 = $xyz[1]; $y2 = $xyz[2] - $h;
  0         0  
3392             } else {
3393 0         0 ($x1,$y1) = $self->_textpos(@{$xy1}, 0, -$h);
  0         0  
3394 0         0 ($x2,$y2) = $self->_textpos(@{$xy2}, 0, -$h);
  0         0  
3395             }
3396              
3397 0         0 $self->add_post($self->_strokecolor($scolor));
3398 0         0 $self->add_post(_linewidth($thickness));
3399 0         0 $self->add_post(_move($x1,$y1));
3400 0         0 $self->add_post(_line($x2,$y2));
3401 0         0 $self->add_post(_stroke);
3402              
3403 0         0 $self->add_post(_restore());
3404 0         0 $pos++;
3405             }
3406 0         0 return;
3407             }
3408              
3409             sub _text_strikethru {
3410 0     0   0 my ($self, $xy1,$xy2, $strikethru, $color) = @_;
3411              
3412 0   0     0 $color ||= 'black';
3413 0         0 my @strikethru = ();
3414 0 0       0 if (ref($strikethru) eq 'ARRAY') {
3415 0         0 @strikethru = @{$strikethru};
  0         0  
3416             } else {
3417 0 0       0 if ($strikethru eq 'none') { return; }
  0         0  
3418 0         0 @strikethru = ($strikethru, 1);
3419             }
3420 0 0       0 push @strikethru,1 if @strikethru%2;
3421              
3422             # fonts define an underline position and thickness, but not strikethrough
3423             # ideally would be just under 1ex
3424             #my $strikethruposition = (-$self->{' font'}->strikethruposition()*$self->{' fontsize'}/1000||1);
3425 0   0     0 my $strikethruposition = 5*(($self->{' fontsize'}||20)/20); # >0 is up
3426             # let's borrow the underline thickness for strikethrough purposes
3427 0   0     0 my $strikethruthickness = ($self->{' font'}->underlinethickness()*$self->{' fontsize'}/1000||1);
3428 0         0 my $pos = 1;
3429              
3430 0         0 while (@strikethru) {
3431 0         0 $self->add_post(_save());
3432              
3433 0         0 my $distance = shift @strikethru;
3434 0         0 my $thickness = shift @strikethru;
3435 0         0 my $scolor = $color;
3436 0 0       0 if (ref $thickness) {
3437 0         0 ($thickness, $scolor) = @{$thickness};
  0         0  
3438             }
3439              
3440 0 0       0 if ($distance eq 'auto') {
3441 0         0 $distance = $pos*$strikethruposition;
3442             }
3443 0 0       0 if ($thickness eq 'auto') {
3444 0         0 $thickness = $strikethruthickness;
3445             }
3446              
3447 0         0 my ($x1,$y1, $x2,$y2);
3448 0         0 my $h = $distance+($thickness/2);
3449 0 0       0 if (scalar(@{$xy1}) > 2) {
  0         0  
3450             # actual baseline start and end points, not old reduced method
3451 0         0 my @xyz = @{$xy1};
  0         0  
3452 0         0 $x1 = $xyz[1]; $y1 = $xyz[2] + $h;
  0         0  
3453 0         0 @xyz = @{$xy2};
  0         0  
3454 0         0 $x2 = $xyz[1]; $y2 = $xyz[2] + $h;
  0         0  
3455             } else {
3456 0         0 ($x1,$y1) = $self->_textpos(@{$xy1}, 0, $h);
  0         0  
3457 0         0 ($x2,$y2) = $self->_textpos(@{$xy2}, 0, $h);
  0         0  
3458             }
3459              
3460 0         0 $self->add_post($self->_strokecolor($scolor));
3461 0         0 $self->add_post(_linewidth($thickness));
3462 0         0 $self->add_post(_move($x1,$y1));
3463 0         0 $self->add_post(_line($x2,$y2));
3464 0         0 $self->add_post(_stroke);
3465              
3466 0         0 $self->add_post(_restore());
3467 0         0 $pos++;
3468             }
3469 0         0 return;
3470             }
3471              
3472             sub text {
3473 31     31 1 156 my ($self, $text, %opts) = @_;
3474              
3475 31         61 my $wd = 0;
3476 31 100       111 if ($self->{' fontset'} == 0) {
3477 1 50 33     6 unless (defined($self->{' font'}) and $self->{' fontsize'}) {
3478 1         225 croak q{Can't add text without first setting a font and font size};
3479             }
3480 0         0 $self->font($self->{' font'}, $self->{' fontsize'});
3481 0         0 $self->{' fontset'} = 1;
3482             }
3483 30 100       131 if (defined $opts{'-indent'}) {
3484 12         31 $wd += $opts{'-indent'};
3485 12         60 $self->matrix_update($wd, 0);
3486             }
3487 30         119 my $ulxy1 = [$self->_textpos2()];
3488              
3489 30 100       91 if (defined $opts{'-indent'}) {
3490             # changed for Acrobat 8 and possibly others
3491             # $self->add('[', (-$opts{'-indent'}*(1000/$self->{' fontsize'})*(100/$self->hscale())), ']', 'TJ');
3492 12         152 $self->add($self->{' font'}->text($text, $self->{' fontsize'}, (-$opts{'-indent'}*(1000/$self->{' fontsize'})*(100/$self->hscale()))));
3493             } else {
3494 18         97 $self->add($self->{' font'}->text($text, $self->{' fontsize'}));
3495             }
3496              
3497 30         117 $wd = $self->advancewidth($text);
3498 30         128 $self->matrix_update($wd, 0);
3499              
3500 30         77 my $ulxy2 = [$self->_textpos2()];
3501              
3502 30 50       113 if (defined $opts{'-underline'}) {
3503 0         0 $self->_text_underline($ulxy1,$ulxy2, $opts{'-underline'}, $opts{'-strokecolor'});
3504             }
3505              
3506 30 50       91 if (defined $opts{'-strikethru'}) {
3507 0         0 $self->_text_strikethru($ulxy1,$ulxy2, $opts{'-strikethru'}, $opts{'-strokecolor'});
3508             }
3509              
3510 30         120 return $wd;
3511             }
3512              
3513             sub _metaStart {
3514 0     0   0 my ($self, $tag, $obj) = @_;
3515              
3516 0         0 $self->add("/$tag");
3517 0 0       0 if (defined $obj) {
3518 0         0 my $dict = PDFDict();
3519 0         0 $dict->{'Metadata'} = $obj;
3520 0         0 $self->resource('Properties', $obj->name(), $dict);
3521 0         0 $self->add('/'.($obj->name()));
3522 0         0 $self->add('BDC');
3523             } else {
3524 0         0 $self->add('BMC');
3525             }
3526 0         0 return $self;
3527             }
3528              
3529             sub _metaEnd {
3530 0     0   0 my ($self) = shift;
3531              
3532 0         0 $self->add('EMC');
3533 0         0 return $self;
3534             }
3535              
3536             =item $width = $content->textHS($HSarray, $settings, %opts)
3537              
3538             =item $width = $content->textHS($HSarray, $settings)
3539              
3540             Takes an array of hashes produced by HarfBuzz::Shaper and outputs them to the
3541             PDF output file. HarfBuzz outputs glyph CIDs and positioning information.
3542             It may rearrange and swap characters (glyphs), and the result may bear no
3543             resemblance to the original Unicode point list. You should see
3544             examples/HarfBuzz.pl, which shows a number of examples with Latin and non-Latin
3545             text, as well as vertical writing.
3546             examples/resources/HarfBuzz_example.pdf is available in case you want to see
3547             some examples and don't yet have HarfBuzz::Shaper installed.
3548              
3549             =over
3550              
3551             =item $HSarray
3552              
3553             This is the reference to array of hashes produced by HarfBuzz::Shaper, normally
3554             unchanged after being created (but I be modified). See
3555             L for some things that can be done.
3556              
3557             =item $settings
3558              
3559             This a reference to a hash of various pieces of information that C
3560             needs in order to function. They include:
3561              
3562             =over
3563              
3564             =item script => 'script_name'
3565              
3566             This is the standard 4 letter code (e.g., 'Latn') for the script (alphabet and
3567             writing system) you're using. Currently, only Latn (Western writing systems)
3568             do kerning, and 'Latn' is the default. HarfBuzz::Shaper will usually be able to
3569             figure out from the Unicode points used what the script is, and you might be
3570             able to use the C call to override its guess. However,
3571             PDF::Builder and HarfBuzz::Shaper do not talk to each other about the script
3572             being used.
3573              
3574             =item features => array_of_features
3575              
3576             This item is B, but may be empty, e.g.,
3577             C<$settings-E{'features'} = ();>.
3578             It can include switches using the standard HarfBuzz naming, and a + or -
3579             switch, such as '-liga' to turn B ligatures. '-liga' and '-kern', to turn
3580             off ligatures and kerning, are the only features supported currently. B
3581             that this is separate from any switches for features that you send to
3582             HarfBuzz::Shaper (with C<$hb-Eadd_features()>, etc.) when you run it
3583             (before C).
3584              
3585             =item language => 'language_code'
3586              
3587             This item is optional and currently does not appear to have any substantial
3588             effect with HarfBuzz::Shaper. It is the standard code for the
3589             language to be used, such as 'en' or 'en_US'. You might need to define this for
3590             HarfBuzz::Shaper, in case that system can't surmise the language rules to be
3591             used.
3592              
3593             =item dir => 'flag'
3594              
3595             Tell C whether this text is to be written in a Left-To-Right manner
3596             (B, the B), Right-To-Left (B), Top-To-Bottom (B), or
3597             Bottom-To-Top (B). From the script used (Unicode points), HarfBuzz::Shaper
3598             can usually figure out what direction to write text in. Also, HarfBuzz::Shaper
3599             does not share its information with PDF::Builder -- you need to separately
3600             specify the direction, unless you want to accept the default LTR direction. You
3601             I use HarfBuzz::Shaper's C call (in addition to
3602             C and C) to see what HarfBuzz thinks is the
3603             correct text direction. C may be used to override Shaper's
3604             guess as to the direction.
3605              
3606             By the way, if the direction is RTL, HarfBuzz will reverse the text and return
3607             an array with the last character first (to be written LTR). Likewise, for BTT,
3608             HarfBuzz will reverse the text and return a string to be written from the top
3609             down. Languages which are normally written horizontally are usually set
3610             vertically with direction TTB. If setting text vertically, ligatures and
3611             kerning, as well as character connectivity for cursive scripts, are
3612             automatically turned off, so don't let the direction default to LTR or RTL in
3613             the Shaper call, and then try to fix it up in C.
3614              
3615             =item align => 'flag'
3616              
3617             Given the current output location, align the
3618             text at the Beginning of the line (left for LTR, right for RTL), Bentered
3619             at the location, or at the Bnd of the line (right for LTR, left for RTL).
3620             The default is B. Bentered is analogous to using C, and
3621             Bnd is analogous to using C. Similar alignments are done for
3622             TTB and BTT.
3623              
3624             =item dump => flag
3625              
3626             Set to 1, it prints out positioning and glyph CID information (to STDOUT) for
3627             each glyph in the chunk. The default is 0 (no information dump).
3628              
3629             =item -minKern => amount (default 1)
3630              
3631             If the amount of kerning (font character width I glyph ax value)
3632             is I than this many character grid units, use the unaltered ax for the
3633             width (C will output a kern amount in the TJ operation). Otherwise,
3634             ignore kerning and use ax of the actual character width. The intent is to avoid
3635             bloating the PDF code with unnecessary tiny kerning adjustments in the TJ
3636             operation.
3637              
3638             =back
3639              
3640             =item %opts
3641              
3642             This a hash of options.
3643              
3644             =over
3645              
3646             =item -underline => underlining_instructions
3647              
3648             See C for available instructions.
3649              
3650             =item -strikethru => strikethrough_instructions
3651              
3652             See C for available instructions.
3653              
3654             =item -strokecolor => line_color
3655              
3656             Color specification (e.g., 'green', '#FF3377') for underline or strikethrough,
3657             if not given in an array with their instructions.
3658              
3659             =back
3660              
3661             =back
3662              
3663             Text is sent I to HarfBuzz::Shaper in 'chunks' ('segments') of a
3664             single script (alphabet), a
3665             single direction (LTR, RTL, TTB, or BTT), a single font file,
3666             and a single font size. A
3667             chunk may consist of a large amount of text, but at present, C can
3668             only output a single line. For long lines that need to be split into
3669             column-width lines, the best way may be to take the array of hashes returned by
3670             HarfBuzz::Shaper and split it into smaller chunks at spaces and other
3671             whitespace. You may have to query the font to see what the glyph CIDs are for
3672             space and anything else used.
3673              
3674             It is expected that when C is called, that the font and font size
3675             have already been set in PDF::Builder code, as this information is needed to
3676             interpret what HarfBuzz::Shaper is returning, and to write it to the PDF file.
3677             Needless to say, the font should be opened from the same file as was given
3678             to HarfBuzz::Shaper (C only, with .ttf or .otf files), and the font
3679             size must be the same. The appropriate location on the page must also already
3680             have been specified.
3681              
3682             B as HarfBuzz::Shaper is still in its early days, it is possible that
3683             there will be major changes in its API. We hope that all changes will be
3684             upwardly compatible, but do not control this package and cannot guarantee that
3685             there will not be any incompatible changes that in turn require changes to
3686             PDF::Builder (C).
3687              
3688             =cut
3689              
3690             sub textHS {
3691 0     0 1 0 my ($self, $HSarray, $settings, %opts) = @_;
3692             # TBD justify would be multiple lines split up from a long string,
3693             # not really applicable here
3694             # full justification to stretch/squeeze a line to fit a given width
3695             # might better be done on the $info array out of Shaper
3696             # indent probably not useful at this level
3697              
3698 0         0 my $font = $self->{' font'};
3699 0         0 my $fontsize = $self->{' fontsize'};
3700 0   0     0 my $dir = $settings->{'dir'} || 'L';
3701 0   0     0 my $align = $settings->{'align'} || 'B';
3702 0   0     0 my $dump = $settings->{'dump'} || 0;
3703 0   0     0 my $script = $settings->{'script'} || 'Latn'; # Latn (Latin), etc.
3704 0         0 my $language; # not used
3705 0 0       0 if (defined $settings->{'language'}) {
3706 0         0 $language = $settings->{'language'};
3707             }
3708 0   0     0 my $minKern = $settings->{'minKern'} || 1; # greater than 1 don't omit kern
3709 0         0 my (@ulxy1, @ulxy2);
3710              
3711 0         0 my $dokern = 1; # why did they take away smartmatch???
3712 0         0 foreach my $feature (@{ $settings->{'features'} }) {
  0         0  
3713 0 0       0 if ($feature ne '-kern') { next; }
  0         0  
3714 0         0 $dokern = 0;
3715 0         0 last;
3716             }
3717 0 0 0     0 if ($dir eq 'T' || $dir eq 'B') { $dokern = 0; }
  0         0  
3718              
3719             # check if font and font size set
3720 0 0       0 if ($self->{' fontset'} == 0) {
3721 0 0 0     0 unless (defined($self->{' font'}) and $self->{' fontsize'}) {
3722 0         0 croak q{Can't add text without first setting a font and font size};
3723             }
3724 0         0 $self->font($self->{' font'}, $self->{' fontsize'});
3725 0         0 $self->{' fontset'} = 1;
3726             }
3727             # TBD consider -indent option (at Beginning of line)
3728              
3729             # Horiz width, Vert height
3730 0         0 my $chunkLength = $self->advancewidthHS($HSarray, $settings,
3731             %opts, -doKern=>$dokern, -minKern=>$minKern);
3732 0         0 my $kernPts = 0; # amount of kerning (left adjust) this glyph
3733 0         0 my $prevKernPts = 0; # amount previous glyph (THIS TJ operator)
3734              
3735             # Ltr: lower left of next character box
3736             # Rtl: lower right of next character box
3737             # Ttb: center top of next character box
3738             # Btt: center bottom of next character box
3739 0         0 my @currentOffset = (0, 0);
3740 0         0 my @currentPos = $self->textpos();
3741 0         0 my @startPos = @currentPos;
3742              
3743 0         0 my $mult;
3744             # need to first back up (to left) to write chunk
3745             # LTR/TTB B and RTL/BTT E write (LTR/TTB) at current position anyway
3746 0 0 0     0 if ($dir eq 'L' || $dir eq 'T') {
3747 0 0       0 if ($align eq 'B') {
    0          
3748 0         0 $mult = 0;
3749             } elsif ($align eq 'C') {
3750 0         0 $mult = -.5;
3751             } else { # align E
3752 0         0 $mult = -1;
3753             }
3754             } else { # dir R or B
3755 0 0       0 if ($align eq 'B') {
    0          
3756 0         0 $mult = -1;
3757             } elsif ($align eq 'C') {
3758 0         0 $mult = -.5;
3759             } else { # align E
3760 0         0 $mult = 0;
3761             }
3762             }
3763 0 0       0 if ($mult != 0) {
3764 0 0 0     0 if ($dir eq 'L' || $dir eq 'R') {
3765 0         0 $self->translate($currentPos[0]+$chunkLength*$mult, $currentPos[1]);
3766             # now can just write chunk LTR
3767             } else {
3768 0         0 $self->translate($currentPos[0], $currentPos[1]-$chunkLength*$mult);
3769             # now can just write chunk TTB
3770             }
3771             }
3772              
3773             # start of any underline or strikethru
3774 0         0 @ulxy1 = (0, $self->textpos());
3775              
3776 0         0 foreach my $glyph (@$HSarray) { # loop through all glyphs in chunk
3777 0         0 my $ax = $glyph->{'ax'}; # output as LTR, +ax = advance to right
3778 0         0 my $ay = $glyph->{'ay'};
3779 0         0 my $dx = $glyph->{'dx'};
3780 0         0 my $dy = $glyph->{'dy'};
3781 0         0 my $g = $glyph->{'g'};
3782 0         0 my $gCID = sprintf("%04x", $g);
3783 0         0 my $cw = $ax;
3784            
3785             # kerning for any LTR or RTL script? not just Latin script?
3786 0 0       0 if ($dokern) {
3787             # kerning, etc. cw != ax, but ignore tiny differences
3788             # cw = width font (and Reader) thinks character is
3789 0         0 $cw = $font->wxByCId($g)/1000*$fontsize;
3790             # if kerning ( ax < cw ), set kern amount as difference.
3791             # very small amounts ignore by setting ax = cw
3792             # (> minKern? use the kerning, else ax = cw)
3793             # Shaper may expand spacing, too!
3794 0         0 $kernPts = $cw - $ax; # sometimes < 0 !
3795 0 0       0 if ($kernPts != 0) {
3796 0 0       0 if (int(abs($kernPts*1000/$fontsize)+0.5) <= $minKern) {
3797             # small amount, cancel kerning
3798 0         0 $kernPts = 0;
3799 0         0 $ax = $cw;
3800             }
3801             }
3802 0 0 0     0 if ($dump && $cw != $ax) {
3803 0         0 print "cw exceeds ax by ".sprintf("%.2f", $cw-$ax)."\n";
3804             }
3805             # kerning to NEXT glyph (used on next loop)
3806             # this is why we use axs and axr instead of changing ax, so it
3807             # won't think a huge amount of kerning is requested!
3808             }
3809              
3810 0 0       0 if ($dump) {
3811 0         0 print "glyph CID $g ";
3812 0 0       0 if ($glyph->{'name'} ne '') { print "name '$glyph->{'name'}' "; }
  0         0  
3813 0         0 print "offset x/y $dx/$dy ";
3814 0         0 print "orig. ax $ax ";
3815             } # continued after $ax modification...
3816              
3817             # keep coordinated with advancewidthHS(), see for documentation
3818 0 0       0 if (defined $glyph->{'axs'}) {
    0          
    0          
    0          
3819 0         0 $ax = $glyph->{'axs'};
3820             } elsif (defined $glyph->{'axsp'}) {
3821 0         0 $ax *= $glyph->{'axsp'}/100;
3822             } elsif (defined $glyph->{'axr'}) {
3823 0         0 $ax -= $glyph->{'axr'};
3824             } elsif (defined $glyph->{'axrp'}) {
3825 0         0 $ax *= (1 - $glyph->{'axrp'}/100);
3826             }
3827              
3828 0 0       0 if ($dump) { # ...continued
3829 0         0 print "advance x/y $ax/$ay "; # modified ax
3830 0         0 print "char width $cw ";
3831 0 0 0     0 if ($ay != 0 || $dx != 0 || $dy != 0) {
      0        
3832 0         0 print "! "; # flag that adjustments needed
3833             }
3834 0 0       0 if ($kernPts != 0) {
3835 0         0 print "!! "; # flag that kerning is apparently done
3836             }
3837 0         0 print "\n";
3838             }
3839              
3840             # dy not 0? end everything and output Td and do a Tj
3841             # internal location (textpos) should be at dx=dy=0, as should
3842             # be currentOffset array. however, Reader current position is
3843             # likely to be at last Tm or Td.
3844             # note that RTL is output LTR
3845 0 0       0 if ($dy != 0) {
3846 0         0 $self->_endCID();
3847              
3848             # consider ignoring any kern request, if vertically adjusting dy
3849 0         0 my $xadj = $dx - $prevKernPts;
3850 0         0 my $yadj = $dy;
3851             # currentOffset should be at beginning of glyph before dx/dy
3852             # text matrix should be there, too
3853             # Reader is still back at Tm/Td plus any glyphs so far
3854 0         0 @currentPos = ($currentPos[0]+$currentOffset[0]+$xadj,
3855             $currentPos[1]+$currentOffset[1]+$yadj);
3856             # $self->translate(@currentPos);
3857 0         0 $self->distance($currentOffset[0]+$xadj,
3858             $currentOffset[1]+$yadj);
3859              
3860 0         0 $self->add("<$gCID> Tj");
3861             # add glyph to subset list
3862 0         0 $font->fontfile()->subsetByCId($g);
3863              
3864 0         0 @currentOffset = (0, 0);
3865             # restore positions to base line for next character
3866 0         0 @currentPos = ($currentPos[0]+$prevKernPts-$dx+$ax,
3867             $currentPos[1]-$dy+$ay);
3868             # $self->translate(@currentPos);
3869 0         0 $self->distance($prevKernPts-$dx+$ax, -$dy+$ay);
3870              
3871             } else {
3872             # otherwise simply add glyph to TJ array, with possible x adj
3873 0         0 $self->_outputCID($gCID, $dx, $prevKernPts, $font);
3874 0         0 $currentOffset[0] += $ax + $dx;
3875 0         0 $currentOffset[1] += $ay; # for LTR/RTL probably always 0
3876 0         0 $self->matrix_update($ax + $dx, $ay);
3877             }
3878              
3879 0         0 $prevKernPts = $kernPts; # for next glyph's adjustment
3880 0         0 $kernPts = 0;
3881             } # end of chunk by individual glyphs
3882 0         0 $self->_endCID();
3883              
3884             # if LTR, need to move to right end, if RTL, need to return to left end.
3885             # if TTB, need to move to the bottom, if BTT, need to return to top
3886 0 0 0     0 if ($dir eq 'L' || $dir eq 'T') {
3887 0 0       0 if ($align eq 'B') {
    0          
3888 0         0 $mult = 1;
3889             } elsif ($align eq 'C') {
3890 0         0 $mult = .5;
3891             } else { # align E
3892 0         0 $mult = 0;
3893             }
3894             } else { # dir R or B
3895 0         0 $mult = -1;
3896 0 0       0 if ($align eq 'B') {
    0          
3897             } elsif ($align eq 'C') {
3898 0         0 $mult = -.5;
3899             } else { # align E
3900 0         0 $mult = 0;
3901             }
3902             }
3903 0 0 0     0 if ($dir eq 'L' || $dir eq 'R') {
3904 0         0 $self->translate($startPos[0]+$chunkLength*$mult, $startPos[1]);
3905             } else {
3906 0         0 $self->translate($startPos[0], $startPos[1]-$chunkLength*$mult);
3907             }
3908              
3909 0 0 0     0 if ($dir eq 'L' || $dir eq 'R') {
3910 0         0 @ulxy2 = (0, $ulxy1[1]+$chunkLength, $ulxy1[2]);
3911             } else {
3912 0         0 @ulxy2 = (0, $ulxy1[1], $ulxy1[2]-$chunkLength);
3913             }
3914              
3915             # need to swap ulxy1 and ulxy2? draw UL or ST L to R. direction of 'up'
3916             # depends on LTR, so doesn't work if draw RTL. ditto for TTB/BTT.
3917 0 0 0     0 if (($dir eq 'L' || $dir eq 'R') && $ulxy1[1] > $ulxy2[1] ||
      0        
      0        
      0        
      0        
3918             ($dir eq 'T' || $dir eq 'B') && $ulxy1[2] < $ulxy2[2]) {
3919 0         0 my $t;
3920 0         0 $t = $ulxy1[1]; $ulxy1[1]=$ulxy2[1]; $ulxy2[1]=$t;
  0         0  
  0         0  
3921 0         0 $t = $ulxy1[2]; $ulxy1[2]=$ulxy2[2]; $ulxy2[2]=$t;
  0         0  
  0         0  
3922             }
3923              
3924             # handle outputting underline and strikethru here
3925 0 0       0 if (defined $opts{'-underline'}) {
3926 0         0 $self->_text_underline(\@ulxy1,\@ulxy2, $opts{'-underline'}, $opts{'-strokecolor'});
3927             }
3928 0 0       0 if (defined $opts{'-strikethru'}) {
3929 0         0 $self->_text_strikethru(\@ulxy1,\@ulxy2, $opts{'-strikethru'}, $opts{'-strokecolor'});
3930             }
3931              
3932 0         0 return $chunkLength;
3933             } # end of textHS
3934              
3935             sub _startCID {
3936 0     0   0 my ($self) = @_;
3937 0 0       0 if ($self->{' openglyphlist'}) { return; }
  0         0  
3938 0         0 $self->addNS(" [<");
3939 0         0 return;
3940             }
3941            
3942             sub _endCID {
3943 0     0   0 my ($self) = @_;
3944 0 0       0 if (!$self->{' openglyphlist'}) { return; }
  0         0  
3945 0         0 $self->addNS(">] TJ ");
3946             # TBD look into detecting empty list already, avoid <> in TJ
3947 0         0 $self->{' openglyphlist'} = 0;
3948 0         0 return;
3949             }
3950              
3951             sub _outputCID {
3952 0     0   0 my ($self, $glyph, $dx, $kern, $font) = @_;
3953             # outputs a single glyph to TJ array, either adding to existing glyph
3954             # string or starting new one after kern amount. kern > 0 moves left,
3955             # dx > 0 moves right, both in points (change to milliems).
3956             # add glyph to subset list
3957 0         0 $font->fontfile()->subsetByCId(hex($glyph));
3958              
3959 0 0       0 if (!$self->{' openglyphlist'}) {
3960             # need to output [< first
3961 0         0 $self->_startCID();
3962 0         0 $self->{' openglyphlist'} = 1;
3963             }
3964              
3965 0 0       0 if ($dx == $kern) {
3966             # no adjustment, just add to existing output
3967 0         0 $self->addNS($glyph); # <> still open
3968             } else {
3969 0         0 $kern -= $dx;
3970             # adjust right by dx after closing glyph string
3971             # dx>0 is move char RIGHT, kern>0 is move char LEFT, both in points
3972             # kern/fontsize*1000 is units to move left, round to 1 decimal place
3973             # >0 means move left (in TJ operation) that many char grid units
3974 0         0 $kern *= (1000/$self->{' fontsize'});
3975             # output correction (char grid units) and this glyph in new <> string
3976 0         0 $self->addNS(sprintf("> %.1f <%s", $kern, $glyph));
3977             # TBD look into detecting empty list already, avoid <> in TJ
3978             }
3979 0         0 return;
3980             }
3981              
3982             =item $width = $content->advancewidthHS($HSarray, $settings, %opts)
3983              
3984             =item $width = $content->advancewidthHS($HSarray, $settings)
3985              
3986             Returns text chunk width (in points) for Shaper-defined glyph array.
3987             This is the horizontal width for LTR and RTL direction, and the vertical
3988             height for TTB and BTT direction.
3989             B You must define the font and font size I calling
3990             C.
3991              
3992             =over
3993              
3994             =item $HSarray
3995              
3996             The array reference of glyphs created by the HarfBuzz::Shaper call.
3997             See C for details.
3998              
3999             =item $settings
4000              
4001             the hash reference of settings. See C for details.
4002              
4003             =over
4004              
4005             =item dir => 'L' etc.
4006              
4007             the direction of the text, to know which "advance" value to sum up.
4008              
4009             =back
4010              
4011             =item %opts
4012              
4013             Options. Unlike C, you
4014             cannot override the font, font size, etc. used by HarfBuzz::Shaper to calculate
4015             the glyph list.
4016              
4017             =over
4018              
4019             =item -doKern => flag (default 1)
4020              
4021             If 1, cancel minor kerns per C<-minKern> setting. This flag should be 0 (false)
4022             if B<-kern> was passed to HarfBuzz::Shaper (do not kern text).
4023             This is treated as 0 if an ax override setting is given.
4024              
4025             =item -minKern => amount (default 1)
4026              
4027             If the amount of kerning (font character width I glyph ax value)
4028             is I than this many character grid units, use the unaltered ax for the
4029             width (C will output a kern amount in the TJ operation). Otherwise,
4030             ignore kerning and use ax of the actual character width. The intent is to avoid
4031             bloating the PDF code with unnecessary tiny kerning adjustments in the TJ
4032             operation.
4033              
4034             =back
4035              
4036             =back
4037              
4038             Returns total width in points.
4039              
4040             =cut
4041              
4042             sub advancewidthHS {
4043 0     0 1 0 my ($self, $HSarray, $settings, %opts) = @_;
4044              
4045             # check if font and font size set
4046 0 0       0 if ($self->{' fontset'} == 0) {
4047 0 0 0     0 unless (defined($self->{' font'}) and $self->{' fontsize'}) {
4048 0         0 croak q{Can't add text without first setting a font and font size};
4049             }
4050 0         0 $self->font($self->{' font'}, $self->{' fontsize'});
4051 0         0 $self->{' fontset'} = 1;
4052             }
4053              
4054 0   0     0 my $doKern = $opts{'-doKern'} || 1; # flag
4055 0   0     0 my $minKern = $opts{'-minKern'} || 1; # character grid units (about 1/1000 em)
4056 0         0 my $dir = $settings->{'dir'};
4057 0 0 0     0 if ($dir eq 'T' || $dir eq 'B') { # vertical text
4058 0         0 $doKern = 0;
4059             }
4060              
4061 0         0 my $width = 0;
4062 0         0 my $ax = 0;
4063 0         0 my $cw = 0;
4064             # simply go through the array and add up all the 'ax' values.
4065             # if 'axs' defined, use that instead of 'ax'
4066             # if 'axsp' defined, use that percentage of 'ax'
4067             # if 'axr' defined, reduce 'ax' by that amount (increase if <0)
4068             # if 'axrp' defined, reduce 'ax' by that percentage (increase if <0)
4069             # otherwise use 'ax' value unchanged
4070             # if vertical text, use ay instead
4071             #
4072             # as in textHS(), ignore kerning (small difference between cw and ax)
4073             # however, if user defined an override of ax, assume they want any
4074             # resulting kerning! only look at -minKern (default 1 char grid unit)
4075             # if original ax is used.
4076            
4077 0         0 foreach my $glyph (@$HSarray) {
4078 0         0 $ax = $glyph->{'ax'};
4079 0 0 0     0 if ($dir eq 'T' || $dir eq 'B') {
4080 0         0 $ax = $glyph->{'ay'} * -1;
4081             }
4082              
4083 0 0       0 if (defined $glyph->{'axs'}) {
    0          
    0          
    0          
4084 0         0 $width += $glyph->{'axs'};
4085             } elsif (defined $glyph->{'axsp'}) {
4086 0         0 $width += $glyph->{'axsp'}/100 * $ax;
4087             } elsif (defined $glyph->{'axr'}) {
4088 0         0 $width += ($ax - $glyph->{'axr'});
4089             } elsif (defined $glyph->{'axrp'}) {
4090 0         0 $width += $ax * (1 - $glyph->{'axrp'}/100);
4091             } else {
4092 0 0       0 if ($doKern) {
4093             # kerning, etc. cw != ax, but ignore tiny differences
4094 0         0 my $fontsize = $self->{' fontsize'};
4095             # cw = width font (and Reader) thinks character is (points)
4096 0         0 $cw = $self->{' font'}->wxByCId($glyph->{'g'})/1000*$fontsize;
4097             # if kerning ( ax < cw ), set kern amount as difference.
4098             # very small amounts ignore by setting ax = cw
4099             # (> minKern? use the kerning, else ax = cw)
4100             # textHS() should be making the same adjustment as here
4101 0         0 my $kernPts = $cw - $ax; # sometimes < 0 !
4102 0 0       0 if ($kernPts > 0) {
4103 0 0       0 if (int(abs($kernPts*1000/$fontsize)+0.5) <= $minKern) {
4104             # small amount, cancel kerning
4105 0         0 $ax = $cw;
4106             }
4107             }
4108             }
4109 0         0 $width += $ax;
4110             }
4111             }
4112              
4113 0         0 return $width; # height >0 for TTB and BTT
4114             }
4115              
4116             =back
4117              
4118             =head2 Advanced Methods
4119              
4120             =over
4121              
4122             =item $content->save()
4123              
4124             Saves the current I state on a PDF stack. See PDF definition 8.4.2
4125             through 8.4.4 for details. This includes the line width, the line cap style,
4126             line join style, miter limit, line dash pattern, stroke color, fill color,
4127             current transformation matrix, current clipping port, flatness, and dictname.
4128             This method applies to both I and I objects.
4129              
4130             =cut
4131              
4132             # 8.4.1 Table 52 Graphics State Parameters (device independent) -----------
4133             # current transformation matrix*, current clipping path*, current color space,
4134             # current color*, TEXT painting parameters (see 9.3), line width*%, line cap*%,
4135             # line join*%, miter limit*%, dash pattern*%, rendering intent%, stroke adjust%,
4136             # blend mode%, soft mask, alpha constant%, alpha source%
4137             # 8.4.1 Table 53 Graphics State Parameters (device dependent) -------------
4138             # overprint%, overprint mode%, black generation%, undercolor removal%,
4139             # transfer%, halftone%, flatness*%, smoothness%
4140             # 9.3 Table 104 Text State Parameters -------------------------------------
4141             # character spacing+, word spacing+, horizontal scaling+, leading+, text font+,
4142             # text font size+, text rendering mode+, text rise+, text knockout%
4143             # * saved on graphics state stack
4144             # + now saved on graphics state stack since save/restore enabled for text
4145             # % see ExtGState.pm for setting as extended graphics state
4146              
4147             sub _save {
4148 9     9   59 return 'q';
4149             }
4150              
4151             sub save {
4152 9     9 1 33 my ($self) = shift;
4153              
4154             #unless ($self->_in_text_object()) {
4155 9         41 $self->add(_save());
4156             #}
4157              
4158 9         18 return $self;
4159             }
4160              
4161             =item $content->restore()
4162              
4163             Restores the most recently saved graphics state (see C),
4164             removing it from the stack. You cannot I the graphics state (pop it off
4165             the stack) unless you have done at least one I (pushed it on the stack).
4166             This method applies to both I and I objects.
4167              
4168             =cut
4169              
4170             sub _restore {
4171 9     9   36 return 'Q';
4172             }
4173              
4174             sub restore {
4175 9     9 1 29 my ($self) = shift;
4176              
4177             #unless ($self->_in_text_object()) {
4178 9         49 $self->add(_restore());
4179             #}
4180              
4181 9         17 return $self;
4182             }
4183              
4184             =item $content->add(@content)
4185              
4186             Add raw content (arbitrary string(s)) to the PDF stream.
4187             You will generally want to use the other methods in this class instead,
4188             unless this is in order to implement some PDF operation that PDF::Builder
4189             does not natively support. An array of multiple strings may be given;
4190             they will be concatenated with spaces between them.
4191              
4192             Be careful when doing this, as you are dabbling in the black arts,
4193             directly setting PDF operations!
4194              
4195             One interesting use is to split up an overly long object stream that is giving
4196             your editor problems when exploring a PDF file. Add a newline B
4197             every few hundred bytes of output or so, to do this. Note that you must use
4198             double quotes (quotation marks), rather than single quotes (apostrophes).
4199              
4200             Use extreme care if inserting B and B markers into the PDF stream.
4201             You may want to use C and C calls instead, and even
4202             then, there are many side effects either way. It is generally not useful
4203             to suspend text mode with ET/textend and BT/textstart, but it is possible,
4204             if you I need to do it.
4205              
4206             Another, useful, case is when your input PDF is from the B
4207             printing a page to PDF with
4208             headers and/or footers. In some versions, this leaves the PDF page with a
4209             strange scaling (such as the page height in points divided by 3300) and the
4210             Y-axis flipped so 0 is at the top. This causes problems when trying to add
4211             additional text or graphics in a new text or graphics record, where text is
4212             flipped (mirrored) upsidedown and at the wrong end of the page. If this
4213             happens, you might be able to cure it by adding
4214              
4215             $scale = .23999999; # example, 792/3300, examine PDF or experiment!
4216             ...
4217             if ($scale != 1) {
4218             my @pageDim = $page->mediabox(); # e.g., 0 0 612 792
4219             my $size_page = $pageDim[3]/$scale; # 3300 = 792/.23999999
4220             my $invScale = 1.0/$scale; # 4.16666684
4221             $text->add("$invScale 0 0 -$invScale 0 $size_page cm");
4222             }
4223              
4224             as the first output to the C<$text> stream. Unfortunately, it is difficult to
4225             predict exactly what C<$scale> should be, as it may be 3300 units per page, or
4226             a fixed amount. You may need to examine an uncompressed PDF file stream to
4227             see what is being used. It I be possible to get the input (original)
4228             PDF into a string and look for a certain pattern of "cm" output
4229              
4230             .2399999 0 0 -.23999999 0 792 cm
4231              
4232             or similar, which is not within a save/restore (q/Q). If the stream is
4233             already compressed, this might not be possible.
4234              
4235             =item $content->addNS(@content)
4236              
4237             Like C, but does B make sure there is a space between each element
4238             and before and after the new content. It is up to I to ensure that any
4239             necessary spaces in the PDF stream are placed there explicitly!
4240              
4241             =cut
4242              
4243             # add to 'poststream' string (dumped by ET)
4244             sub add_post {
4245 0     0 0 0 my ($self) = shift;
4246              
4247 0 0       0 if (scalar @_) {
4248 0 0       0 $self->{' poststream'} .= ($self->{' poststream'} =~ m|\s$|o ? '' : ' ') . join(' ', @_) . ' ';
4249             }
4250              
4251 0         0 return $self;
4252             }
4253              
4254             sub add {
4255 779     779 1 1225 my $self = shift;
4256              
4257 779 50       1559 if (scalar @_) {
4258 779 100       5145 $self->{' stream'} .= encode('iso-8859-1', ($self->{' stream'} =~ m|\s$|o ? '' : ' ') . join(' ', @_) . ' ');
4259             }
4260              
4261 779         25836 return $self;
4262             }
4263              
4264             sub addNS {
4265 0     0 1 0 my $self = shift;
4266              
4267 0 0       0 if (scalar @_) {
4268 0         0 $self->{' stream'} .= encode('iso-8859-1', join('', @_));
4269             }
4270              
4271 0         0 return $self;
4272             }
4273              
4274             # Shortcut method for determining if we're inside a text object
4275             # (i.e., between BT and ET). See textstart() and textend().
4276             sub _in_text_object {
4277 464     464   767 my ($self) = shift;
4278              
4279 464   33     1796 return defined($self->{' apiistext'}) && $self->{' apiistext'};
4280             }
4281              
4282             =item $content->compressFlate()
4283              
4284             Marks content for compression on output. This is done automatically
4285             in nearly all cases, so you shouldn't need to call this yourself.
4286              
4287             The C call can set the B<-compress> parameter to 'flate' (default) to
4288             compress all object streams, or 'none' to suppress compression and allow you
4289             to examine the output in an editor.
4290              
4291             =cut
4292              
4293             sub compressFlate {
4294 26     26 1 57 my $self = shift;
4295              
4296 26         94 $self->{'Filter'} = PDFArray(PDFName('FlateDecode'));
4297 26         124 $self->{'-docompress'} = 1;
4298              
4299 26         78 return $self;
4300             }
4301              
4302             =item $content->textstart()
4303              
4304             Starts a text object (ignored if already in a text object). You will likely
4305             want to use the C method (text I, not text output) instead.
4306              
4307             Note that calling this method, besides outputting a B marker, will reset
4308             most text settings to their default values. In addition, B itself will
4309             reset some transformation matrices.
4310              
4311             =cut
4312              
4313             sub textstart {
4314 21     21 1 63 my ($self) = @_;
4315              
4316 21 50       101 unless ($self->_in_text_object()) {
4317 21         122 $self->add(' BT ');
4318 21         53 $self->{' apiistext'} = 1;
4319 21         52 $self->{' font'} = undef;
4320 21         45 $self->{' fontset'} = 0;
4321 21         55 $self->{' fontsize'} = 0;
4322 21         45 $self->{' charspace'} = 0;
4323 21         49 $self->{' hscale'} = 100;
4324 21         40 $self->{' wordspace'} = 0;
4325 21         39 $self->{' leading'} = 0;
4326 21         47 $self->{' rise'} = 0;
4327 21         49 $self->{' render'} = 0;
4328 21         69 @{$self->{' matrix'}} = (1,0,0,1,0,0);
  21         69  
4329 21         65 @{$self->{' textmatrix'}} = (1,0,0,1,0,0);
  21         52  
4330 21         76 @{$self->{' textlinematrix'}} = (0,0);
  21         60  
4331 21         41 @{$self->{' fillcolor'}} = (0);
  21         53  
4332 21         54 @{$self->{' strokecolor'}} = (0);
  21         63  
4333 21         49 @{$self->{' translate'}} = (0,0);
  21         45  
4334 21         43 @{$self->{' scale'}} = (1,1);
  21         79  
4335 21         55 @{$self->{' skew'}} = (0,0);
  21         51  
4336 21         48 $self->{' rotate'} = 0;
4337 21         62 $self->{' openglyphlist'} = 0;
4338             }
4339              
4340 21         59 return $self;
4341             }
4342              
4343             =item $content->textend()
4344              
4345             Ends a text object (ignored if not in a text object).
4346              
4347             Note that calling this method, besides outputting an B marker, will output
4348             any accumulated I content.
4349              
4350             =cut
4351              
4352             sub textend {
4353 111     111 1 234 my ($self) = @_;
4354              
4355 111 100       357 if ($self->_in_text_object()) {
4356 17         83 $self->add(' ET ', $self->{' poststream'});
4357 17         43 $self->{' apiistext'} = 0;
4358 17         42 $self->{' poststream'} = '';
4359             }
4360              
4361 111         201 return $self;
4362             }
4363              
4364             =back
4365              
4366             =cut
4367              
4368             # helper function for many methods
4369             sub resource {
4370 32     32 0 133 my ($self, $type, $key, $obj, $force) = @_;
4371              
4372 32 100       162 if ($self->{' apipage'}) {
4373             # we are a content stream on a page.
4374 30         238 return $self->{' apipage'}->resource($type, $key, $obj, $force);
4375             } else {
4376             # we are a self-contained content stream.
4377 2   33     8 $self->{'Resources'} ||= PDFDict();
4378              
4379 2         5 my $dict = $self->{'Resources'};
4380 2 50       11 $dict->realise() if ref($dict) =~ /Objind$/;
4381              
4382 2   33     21 $dict->{$type} ||= PDFDict();
4383 2 50       9 $dict->{$type}->realise() if ref($dict->{$type}) =~ /Objind$/;
4384 2 50       9 unless (defined $obj) {
4385 0   0       return $dict->{$type}->{$key} || undef;
4386             } else {
4387 2 50       6 if ($force) {
4388 0         0 $dict->{$type}->{$key} = $obj;
4389             } else {
4390 2   33     12 $dict->{$type}->{$key} ||= $obj;
4391             }
4392 2         9 return $dict;
4393             }
4394             }
4395             }
4396              
4397             1;