File Coverage

blib/lib/PDF/API2/Content.pm
Criterion Covered Total %
statement 769 1030 74.6
branch 208 370 56.2
condition 54 157 34.3
subroutine 128 146 87.6
pod 79 101 78.2
total 1238 1804 68.6


line stmt bran cond sub pod time code
1             package PDF::API2::Content;
2              
3 38     38   300 use base 'PDF::API2::Basic::PDF::Dict';
  38         79  
  38         3854  
4              
5 38     38   260 use strict;
  38         75  
  38         725  
6 38     38   175 use warnings;
  38         80  
  38         1494  
7              
8             our $VERSION = '2.043'; # VERSION
9              
10 38     38   203 use Carp;
  38         79  
  38         1955  
11 38     38   234 use Compress::Zlib ();
  38         84  
  38         1118  
12 38     38   225 use Encode;
  38         75  
  38         3891  
13 38     38   298 use Math::Trig;
  38         84  
  38         6766  
14 38     38   16846 use PDF::API2::Matrix;
  38         104  
  38         1241  
15              
16 38     38   308 use PDF::API2::Basic::PDF::Utils;
  38         81  
  38         2766  
17 38     38   249 use PDF::API2::Util;
  38         97  
  38         469756  
18              
19             =head1 NAME
20              
21             PDF::API2::Content - Methods for adding graphics and text to a PDF
22              
23             =head1 SYNOPSIS
24              
25             # Start with a PDF page (new or opened)
26             my $pdf = PDF::API2->new();
27             my $page = $pdf->page();
28              
29             # Add a new content object
30             my $content = $page->graphics();
31             my $content = $page->text();
32              
33             # Then call the methods below add graphics and text to the page.
34              
35             =cut
36              
37             sub new {
38 122     122 1 228 my $class = shift();
39 122         424 my $self = $class->SUPER::new();
40              
41 122         285 $self->{' stream'} = '';
42 122         241 $self->{' poststream'} = '';
43 122         538 $self->{' font'} = undef;
44 122         242 $self->{' fontset'} = 0;
45 122         231 $self->{' fontsize'} = 0;
46 122         224 $self->{' charspace'} = 0;
47 122         300 $self->{' hscale'} = 100;
48 122         218 $self->{' wordspace'} = 0;
49 122         212 $self->{' leading'} = 0;
50 122         213 $self->{' rise'} = 0;
51 122         226 $self->{' render'} = 0;
52 122         332 $self->{' matrix'} = [1, 0, 0, 1, 0, 0];
53 122         321 $self->{' textmatrix'} = [1, 0, 0, 1, 0, 0];
54 122         264 $self->{' textlinematrix'} = [0, 0];
55 122         385 $self->{' fillcolor'} = [0];
56 122         325 $self->{' strokecolor'} = [0];
57 122         340 $self->{' translate'} = [0, 0];
58 122         290 $self->{' scale'} = [1, 1];
59 122         269 $self->{' skew'} = [0, 0];
60 122         188 $self->{' rotate'} = 0;
61 122         233 $self->{' apiistext'} = 0;
62              
63 122         272 return $self;
64             }
65              
66             sub outobjdeep {
67 114     114 1 224 my $self = shift();
68 114         378 $self->textend();
69 114 50 66     313 if ($self->{'-docompress'} and $self->{'Filter'}) {
70 6         43 $self->{' stream'} = Compress::Zlib::compress($self->{' stream'});
71 6         2056 $self->{' nofilt'} = 1;
72 6         21 delete $self->{'-docompress'};
73             }
74 114         383 return $self->SUPER::outobjdeep(@_);
75             }
76              
77             =head1 COORDINATE TRANSFORMATIONS
78              
79             The methods in this section change the coordinate system for the current content
80             object relative to the rest of the document.
81              
82             Changes to the coordinate system only affect subsequent paths or text.
83              
84             A call to any of the methods in this section resets the coordinate system before
85             applying its changes, unless the C option is set.
86              
87             =head2 translate
88              
89             $content = $content->translate($x, $y);
90              
91             Moves the origin along the x and y axes.
92              
93             =cut
94              
95             sub _translate {
96 12     12   34 my ($x, $y) = @_;
97 12         47 return (1, 0, 0, 1, $x, $y);
98             }
99              
100             sub translate {
101 2     2 1 14 my ($self, $x, $y) = @_;
102 2         15 $self->transform(translate => [$x, $y]);
103             }
104              
105             =head2 rotate
106              
107             $content = $content->rotate($degrees);
108              
109             Rotates the coordinate system counter-clockwise.
110              
111             Use a negative argument to rotate clockwise.
112              
113             =cut
114              
115             sub _rotate {
116 9     9   27 my $a = deg2rad(shift());
117 9         147 return (cos($a), sin($a), -sin($a), cos($a), 0, 0);
118             }
119              
120             sub rotate {
121 1     1 1 10 my ($self, $a) = @_;
122 1         4 $self->transform(rotate => $a);
123             }
124              
125             =head2 scale
126              
127             $content = $content->scale($x, $y);
128              
129             Scales (stretches) the coordinate systems along the x and y axes. A value of 1
130             for either C<$x> or C<$y> represents 100% scale (i.e. no change).
131              
132             =cut
133              
134             sub _scale {
135 9     9   18 my ($x, $y) = @_;
136 9         25 return ($x, 0, 0, $y, 0, 0);
137             }
138              
139             sub scale {
140 1     1 1 9 my ($self, $sx, $sy) = @_;
141 1         5 $self->transform(scale => [$sx, $sy]);
142             }
143              
144             =head2 skew
145              
146             $content = $content->skew($a, $b);
147              
148             Skews the coordinate system by C<$a> degrees (counter-clockwise) from the x axis
149             and C<$b> degrees (clockwise) from the y axis.
150              
151             =cut
152              
153             sub _skew {
154 9     9   29 my $a = deg2rad(shift());
155 9         116 my $b = deg2rad(shift());
156 9         85 return (1, tan($a), tan($b), 1, 0, 0);
157             }
158              
159             sub skew {
160 1     1 1 8 my ($self, $a, $b) = @_;
161 1         5 $self->transform(skew => [$a, $b]);
162             }
163              
164             =head2 transform
165              
166             $content = $content->transform(
167             translate => [$x, $y],
168             rotate => $degrees,
169             scale => [$x, $y],
170             skew => [$a, $b],
171             relative => $boolean,
172             );
173              
174             Performs multiple coordinate transformations, in the order recommended by the
175             PDF specification (translate, rotate, scale, then skew). Omitted options will
176             be unchanged.
177              
178             If C is true, the specified transformations will be added to any
179             previous changes to the coordinate system. By default, calling C or
180             any of the other transformation methods will overwrite any previous changes to
181             the coordinate system.
182              
183             =cut
184              
185             sub _to_matrix {
186 39     39   347 my @array = @_;
187 39         165 return PDF::API2::Matrix->new([$array[0], $array[1], 0],
188             [$array[2], $array[3], 0],
189             [$array[4], $array[5], 1]);
190             }
191              
192             sub _transform {
193 15     15   40 my %opts = @_;
194 15         126 my $m = PDF::API2::Matrix->new([1, 0, 0], [0, 1, 0], [0, 0, 1]);
195              
196             # Undocumented; only used by textpos()
197 15 50       78 if (defined $opts{'-matrix'}) {
198 0         0 $m = $m->multiply(_to_matrix(@{$opts{'-matrix'}}));
  0         0  
199             }
200              
201             # Note that the transformations are applied in reverse order. See PDF 1.7
202             # specification section 8.3.4: Transformation Matrices.
203 15 100       48 if (defined $opts{'skew'}) {
204 9         15 $m = $m->multiply(_to_matrix(_skew(@{$opts{'skew'}})));
  9         27  
205             }
206 15 100       52 if (defined $opts{'scale'}) {
207 9         17 $m = $m->multiply(_to_matrix(_scale(@{$opts{'scale'}})));
  9         22  
208             }
209 15 100       54 if (defined $opts{'rotate'}) {
210 9         29 $m = $m->multiply(_to_matrix(_rotate($opts{'rotate'})));
211             }
212 15 100       54 if (defined $opts{'translate'}) {
213 12         42 $m = $m->multiply(_to_matrix(_translate(@{$opts{'translate'}})));
  12         53  
214             }
215              
216             # Undocumented; only used by textpos()
217 15 50       70 if ($opts{'-point'}) {
218             my $mp = PDF::API2::Matrix->new([$opts{'-point'}->[0],
219 0         0 $opts{'-point'}->[1], 1]);
220 0         0 $mp = $mp->multiply($m);
221 0         0 return ($mp->[0][0], $mp->[0][1]);
222             }
223              
224             return (
225 15         155 $m->[0][0], $m->[0][1],
226             $m->[1][0], $m->[1][1],
227             $m->[2][0], $m->[2][1]
228             );
229             }
230              
231             # Transformations are described in the PDF 1.7 specification, section 8.3.3:
232             # Common Transformations.
233             sub transform {
234 16     16 1 2055 my ($self, %options) = @_;
235 16 100       67 return $self->transform_rel(%options) if $options{'relative'};
236              
237             # Deprecated options (remove hyphens)
238 15         40 foreach my $option (qw(translate rotate scale skew)) {
239 60 100       157 if (exists $options{'-' . $option}) {
240 14   33     82 $options{$option} //= delete $options{'-' . $option};
241             }
242             }
243              
244             # Apply the transformations
245 15         76 $self->matrix(_transform(%options));
246              
247             # Store the transformations for lookup or future relative transformations
248 15   100     70 $self->{' translate'} = $options{'translate'} // [0, 0];
249 15   100     73 $self->{' rotate'} = $options{'rotate'} // 0;
250 15   100     56 $self->{' scale'} = $options{'scale'} // [1, 1];
251 15   100     57 $self->{' skew'} = $options{'skew'} // [0, 0];
252              
253 15         51 return $self;
254             }
255              
256             sub transform_rel {
257 2     2 1 16 my ($self, %options) = @_;
258              
259             # Deprecated options (remove hyphens)
260 2         8 foreach my $option (qw(translate rotate scale skew)) {
261 8 100       25 if (exists $options{'-' . $option}) {
262 4   33     18 $options{$option} //= delete $options{'-' . $option};
263             }
264             }
265              
266 2 50       4 my ($sa1, $sb1) = @{$options{'skew'} ? $options{'skew'} : [0, 0]};
  2         11  
267 2         4 my ($sa0, $sb0) = @{$self->{' skew'}};
  2         8  
268              
269 2 50       5 my ($sx1, $sy1) = @{$options{'scale'} ? $options{'scale'} : [1, 1]};
  2         9  
270 2         16 my ($sx0, $sy0) = @{$self->{' scale'}};
  2         9  
271              
272 2   50     10 my $r1 = $options{'rotate'} // 0;
273 2         5 my $r0 = $self->{' rotate'};
274              
275 2 50       4 my ($tx1, $ty1) = @{$options{'translate'} ? $options{'translate'} : [0, 0]};
  2         7  
276 2         4 my ($tx0, $ty0) = @{$self->{' translate'}};
  2         8  
277              
278 2         18 $self->transform(
279             skew => [$sa0 + $sa1, $sb0 + $sb1],
280             scale => [$sx0 * $sx1, $sy0 * $sy1],
281             rotate => $r0 + $r1,
282             translate => [$tx0 + $tx1, $ty0 + $ty1],
283             );
284              
285 2         9 return $self;
286             }
287              
288             =head2 matrix
289              
290             $graphics = $graphics->matrix($a, $b, $c, $d, $e, $f);
291              
292             ($a, $b, $c, $d, $e, $f) = $text->matrix($a, $b, $c, $d, $e, $f);
293              
294             Sets the current transformation matrix manually. Unless you have a particular
295             need to enter transformations manually, you should use the C method
296             instead.
297              
298             The return value differs based on whether the caller is a graphics content
299             object or a text content object.
300              
301             =cut
302              
303             sub _matrix_text {
304 3     3   12 my ($a, $b, $c, $d, $e, $f) = @_;
305 3         21 return (floats($a, $b, $c, $d, $e, $f), 'Tm');
306             }
307              
308             sub _matrix_gfx {
309 23     23   61 my ($a, $b, $c, $d, $e, $f) = @_;
310 23         114 return (floats($a, $b, $c, $d, $e, $f), 'cm');
311             }
312              
313             sub matrix {
314 26     26 1 66 my $self = shift();
315 26 50       89 if (scalar(@_)) {
316 26         87 my ($a, $b, $c, $d, $e, $f) = @_;
317 26 100       79 if ($self->_in_text_object()) {
318 3         18 $self->add(_matrix_text($a, $b, $c, $d, $e, $f));
319 3         39 $self->{' textmatrix'} = [$a, $b, $c, $d, $e, $f];
320 3         16 $self->{' textlinematrix'} = [0, 0];
321             }
322             else {
323 23         139 $self->add(_matrix_gfx($a, $b, $c, $d, $e, $f));
324             }
325             }
326              
327 26 100       87 if ($self->_in_text_object()) {
328 3         10 return @{$self->{' textmatrix'}};
  3         11  
329             }
330             else {
331 23         47 return $self;
332             }
333             }
334              
335             sub matrix_update {
336 70     70 0 145 my ($self, $tx, $ty) = @_;
337 70         130 $self->{' textlinematrix'}->[0] += $tx;
338 70         110 $self->{' textlinematrix'}->[1] += $ty;
339 70         103 return $self;
340             }
341              
342             =head1 GRAPHICS STATE
343              
344             =head2 save
345              
346             $content = $content->save();
347              
348             Saves the current graphics state on a stack.
349              
350             =cut
351              
352             sub _save {
353 11     11   75 return 'q';
354             }
355              
356             sub save {
357 11     11 1 32 my $self = shift;
358 11 50       47 if ($self->_in_text_object()) {
359 0         0 carp 'Calling save from a text content object has no effect';
360 0         0 return;
361             }
362              
363 11         65 $self->add(_save());
364              
365 11         21 return $self;
366             }
367              
368             =head2 restore
369              
370             $content = $content->restore();
371              
372             Restores the most recently saved graphics state, removing it from the stack.
373              
374             =cut
375              
376             sub _restore {
377 11     11   45 return 'Q';
378             }
379              
380             sub restore {
381 11     11 1 43 my $self = shift;
382 11 50       34 if ($self->_in_text_object()) {
383 0         0 carp 'Calling save from a text content object has no effect';
384 0         0 return;
385             }
386              
387 11         65 $self->add(_restore());
388              
389 11         22 return $self;
390             }
391              
392             =head2 line_width
393              
394             $content = $content->line_width($points);
395              
396             Sets the width of the stroke in points.
397              
398             =cut
399              
400             sub _linewidth {
401 88     88   126 my $linewidth = shift();
402 88         227 return ($linewidth, 'w');
403             }
404              
405             # Deprecated (renamed)
406 87     87 1 203 sub linewidth { return line_width(@_) }
407              
408             sub line_width {
409 88     88 1 157 my ($self, $line_width) = @_;
410              
411 88         152 $self->add(_linewidth($line_width));
412              
413 88         166 return $self;
414             }
415              
416             =head2 line_cap
417              
418             $content = $content->line_cap($style);
419              
420             Sets the shape that will be used at the ends of open subpaths (and dashes, if
421             any) when they are stroked.
422              
423             =over
424              
425             =item * "butt" or 0 = Butt Cap, default
426              
427             The stroke ends at the end of the path, with no projection.
428              
429             =item * "round" or 1 = Round Cap)
430              
431             An arc is drawn around the end of the path with a diameter equal to the line
432             width, and is filled in.
433              
434             =item * "square" or 2 = Projecting Square Cap
435              
436             The stroke continues past the end of the path for half the line width.
437              
438             =back
439              
440             =cut
441              
442             sub _linecap {
443 2     2   6 my $linecap = shift();
444 2         8 return ($linecap, 'J');
445             }
446              
447             # Deprecated (renamed)
448 1     1 1 7 sub linecap { return line_cap(@_) }
449              
450             sub line_cap {
451 2     2 1 16 my $self = shift();
452              
453 2 50 66     15 if ($self->{' graphics'} and not @_) {
454 0         0 croak "Missing argument to line_cap";
455             }
456              
457 2   50     11 my $style = shift() // 0;
458 2 50       9 $style = 0 if $style eq 'butt';
459 2 100       8 $style = 1 if $style eq 'round';
460 2 50       8 $style = 2 if $style eq 'square';
461              
462 2 50 33     14 unless ($style >= 0 and $style <= 2) {
463 0 0       0 if ($self->{' graphics'}) {
464 0         0 croak "Unknown line cap style \"$style\"";
465             }
466             else {
467 0         0 confess "Unknown line cap style \"$style\"";
468             }
469             }
470              
471 2         9 $self->add(_linecap($style));
472              
473 2         8 return $self;
474             }
475              
476             =head2 line_join
477              
478             $content = $content->line_join($style);
479              
480             Sets the style of join to be used at corners of a path.
481              
482             =over
483              
484             =item * "miter" or 0 = Miter Join, default
485              
486             The outer edges of the stroke extend until they meet, up to the limit specified
487             below. If the limit would be surpassed, a bevel join is used instead.
488              
489             =item * "round" or 1 = Round Join
490              
491             A circle with a diameter equal to the linewidth is drawn around the corner
492             point, producing a rounded corner.
493              
494             =item * "bevel" or 2 = Bevel Join
495              
496             A triangle is drawn to fill in the notch between the two strokes.
497              
498             =back
499              
500             =cut
501              
502             sub _linejoin {
503 2     2   4 my $linejoin = shift();
504 2         10 return ($linejoin, 'j');
505             }
506              
507             # Deprecated (renamed)
508 1     1 1 8 sub linejoin { return line_join(@_) }
509              
510             sub line_join {
511 2     2 1 13 my $self = shift();
512              
513 2 50 66     14 if ($self->{' graphics'} and not @_) {
514 0         0 croak "Missing argument to line_join";
515             }
516              
517 2   50     8 my $style = shift() // 0;
518 2 50       12 $style = 0 if $style eq 'miter';
519 2 50       8 $style = 1 if $style eq 'round';
520 2 100       9 $style = 2 if $style eq 'bevel';
521              
522 2 50 33     14 unless ($style >= 0 and $style <= 2) {
523 0 0       0 if ($self->{' graphics'}) {
524 0         0 croak "Unknown line join style \"$style\"";
525             }
526             else {
527 0         0 confess "Unknown line join style \"$style\"";
528             }
529             }
530              
531 2         12 $self->add(_linejoin($style));
532              
533 2         6 return $self;
534             }
535              
536             =head2 miter_limit
537              
538             $content = $content->miter_limit($ratio);
539              
540             Sets the miter limit when the line join style is a miter join.
541              
542             The C<$ratio> is the maximum length of the miter (inner to outer corner) divided
543             by the line width. Any miter above this ratio will be converted to a bevel
544             join. The practical effect is that lines meeting at shallow angles are chopped
545             off instead of producing long pointed corners.
546              
547             There is no documented default miter limit.
548              
549             =cut
550              
551             sub _miterlimit {
552 3     3   6 my $limit = shift();
553 3         11 return ($limit, 'M');
554             }
555              
556             # Deprecated; miterlimit was originally named incorrectly
557 1     1 1 7 sub meterlimit { return miter_limit(@_) }
558              
559             # Deprecated (renamed)
560 1     1 1 8 sub miterlimit { return miter_limit(@_) }
561              
562             sub miter_limit {
563 3     3 1 19 my ($self, $limit) = @_;
564              
565 3         10 $self->add(_miterlimit($limit));
566              
567 3         8 return $self;
568             }
569              
570             =head2 line_dash_pattern
571              
572             # Solid line
573             $content = $content->line_dash_pattern();
574              
575             # Equal length lines and gaps
576             $content = $content->line_dash_pattern($length);
577              
578             # Specified line and gap lengths
579             $content = $content->line_dash_pattern($line1, $gap1, $line2, $gap2, ...);
580              
581             # Offset the starting point
582             $content = $content->line_dash_pattern(
583             pattern => [$line1, $gap1, $line2, $gap2, ...],
584             offset => $points,
585             );
586              
587             Sets the line dash pattern.
588              
589             If called without any arguments, a solid line will be drawn.
590              
591             If called with one argument, the dashes and gaps will have equal lengths.
592              
593             If called with two or more arguments, the arguments represent alternating dash
594             and gap lengths.
595              
596             If called with a hash of arguments, a dash phase may be set, which specifies the
597             distance into the pattern at which to start the dash.
598              
599             =cut
600              
601             sub _linedash {
602 10     10   21 my @options = @_;
603              
604 10 100       27 unless (@options) {
605 7         28 return ('[', ']', '0', 'd');
606             }
607              
608 3 50       20 if ($options[0] =~ /^\d/) {
609 3         19 return ('[', floats(@options), '] 0 d');
610             }
611              
612 0         0 my %options = @options;
613              
614             # Deprecated option names
615 0 0       0 if ($options{'-pattern'}) {
616 0   0     0 $options{'pattern'} //= delete $options{'-pattern'};
617             }
618 0 0       0 if ($options{'-shift'}) {
619 0   0     0 $options{'offset'} //= delete $options{'-shift'};
620             }
621              
622             # Deprecated: the -full and -clear options will be removed in a future
623             # release
624 0 0 0     0 if (exists $options{'-full'} or exists $options{'-clear'}) {
625 0   0     0 $options{'pattern'} //= [$options{'-full'} // 0, $options{'-clear'} // 0];
      0        
      0        
626             }
627              
628 0         0 return ('[', floats(@{$options{'pattern'}}), ']',
629 0   0     0 ($options{'offset'} || 0), 'd');
630             }
631              
632             # Deprecated (renamed)
633 7     7 1 24 sub linedash { return line_dash_pattern(@_) }
634              
635             sub line_dash_pattern {
636 10     10 1 33 my ($self, @a) = @_;
637              
638 10         31 $self->add(_linedash(@a));
639              
640 10         24 return $self;
641             }
642              
643             =head2 flatness_tolerance
644              
645             $content = $content->flatness_tolerance($tolerance);
646              
647             Sets the maximum distance in device pixels between the mathematically correct
648             path for a curve and an approximation constructed from straight line segments.
649              
650             C<$tolerance> is an integer between 0 and 100, where 0 represents the device's
651             default flatness tolerance.
652              
653             =cut
654              
655             sub _flatness {
656 2     2   5 my $flatness = shift();
657 2         9 return ($flatness, 'i');
658             }
659              
660             # Deprecated (renamed)
661 1     1 1 10 sub flatness { return flatness_tolerance(@_) }
662              
663             sub flatness_tolerance {
664 2     2 1 13 my ($self, $flatness) = @_;
665              
666 2         9 $self->add(_flatness($flatness));
667              
668 2         4 return $self;
669             }
670              
671             =head2 egstate
672              
673             $content = $content->egstate($object);
674              
675             Adds a L object containing a set of graphics
676             state parameters.
677              
678             =cut
679              
680             sub egstate {
681 0     0 1 0 my ($self, $egstate) = @_;
682 0         0 $self->add('/' . $egstate->name(), 'gs');
683 0         0 $self->resource('ExtGState', $egstate->name(), $egstate);
684 0         0 return $self;
685             }
686              
687             =head1 PATH CONSTRUCTION (DRAWING)
688              
689             Note that paths will not appear until a path painting method is called
690             (L, L, or L).
691              
692             =head2 move
693              
694             $content = $content->move($x, $y);
695              
696             Starts a new path at the specified coordinates.
697              
698             =cut
699              
700             sub _move {
701 0     0   0 my ($x, $y) =@_;
702 0         0 return (floats($x, $y), 'm');
703             }
704              
705             sub move {
706 107     107 1 248 my $self = shift();
707 107         167 my ($x, $y);
708 107         249 while (defined($x = shift())) {
709 107         172 $y = shift();
710 107 50       230 if ($self->_in_text_object()) {
711 0         0 $self->add_post(floats($x, $y), 'm');
712             }
713             else {
714 107         310 $self->add(floats($x, $y), 'm');
715             }
716 107         244 $self->{' x'} = $self->{' mx'} = $x;
717 107         279 $self->{' y'} = $self->{' my'} = $y;
718             }
719 107         214 return $self;
720             }
721              
722             =head2 line
723              
724             $content = $content->line($x, $y);
725              
726             Extends the path in a line from the current coordinates to the specified
727             coordinates.
728              
729             =cut
730              
731             sub _line {
732 0     0   0 my ($x, $y) = @_;
733 0         0 return (floats($x, $y), 'l');
734             }
735              
736             sub line {
737 95     95 1 151 my $self = shift();
738 95         131 my ($x, $y);
739 95         219 while (defined($x = shift())) {
740 96         132 $y = shift();
741 96 50       166 if ($self->_in_text_object()) {
742 0         0 $self->add_post(floats($x, $y), 'l');
743             }
744             else {
745 96         217 $self->add(floats($x, $y), 'l');
746             }
747 96         188 $self->{' x'} = $x;
748 96         225 $self->{' y'} = $y;
749             }
750 95         180 return $self;
751             }
752              
753             =head2 hline
754              
755             $content = $content->hline($x);
756              
757             Extends the path in a horizontal line from the current position to the specified
758             x coordinate.
759              
760             =cut
761              
762             sub hline {
763 2     2 1 14 my ($self, $x) = @_;
764 2         7 $self->{' x'} = $x;
765 2 50       6 if ($self->_in_text_object()) {
766 0         0 $self->add_post(floats($x, $self->{' y'}), 'l');
767             }
768             else {
769 2         10 $self->add(floats($x, $self->{' y'}), 'l');
770             }
771 2         7 return $self;
772             }
773              
774             =head2 vline
775              
776             $content = $content->vline($x);
777              
778             Extends the path in a vertical line from the current position to the specified y
779             coordinate.
780              
781             =cut
782              
783             sub vline {
784 1     1 1 10 my ($self, $y) = @_;
785 1 50       6 if ($self->_in_text_object()) {
786 0         0 $self->add_post(floats($self->{' x'}, $y), 'l');
787             }
788             else {
789 1         6 $self->add(floats($self->{' x'}, $y), 'l');
790             }
791 1         5 $self->{' y'} = $y;
792 1         2 return $self;
793             }
794              
795             =head2 polyline
796              
797             $content = $content->polyline($x1, $y1, $x2, $y2, ...);
798              
799             Extends the path from the current position in one or more straight lines.
800              
801             =cut
802              
803             sub polyline {
804 2     2 1 25 my $self = shift();
805 2 50       8 unless (@_ % 2 == 0) {
806 0         0 croak 'polyline requires pairs of coordinates';
807             }
808              
809 2         8 while (@_) {
810 3         5 my $x = shift();
811 3         6 my $y = shift();
812 3         9 $self->line($x, $y);
813             }
814              
815 2         14 return $self;
816             }
817              
818             # Deprecated; replace with move and polyline. Deprecated because poly breaks
819             # the convention followed by every other path-drawing method (other than
820             # enclosed shapes) of extending the path from the current position.
821             sub poly {
822 2     2 1 12 my $self = shift();
823 2         4 my $x = shift();
824 2         4 my $y = shift();
825 2         6 $self->move($x, $y);
826 2         7 $self->line(@_);
827 2         5 return $self;
828             }
829              
830             =head2 curve
831              
832             $content = $content->curve($cx1, $cy1, $cx2, $cy2, $x, $y);
833              
834             Extends the path in a curve from the current point to C<($x, $y)>, using the two
835             specified points to create a cubic Bezier curve.
836              
837             =cut
838              
839             sub curve {
840 78     78 1 117 my $self = shift();
841 78         111 my ($x1, $y1, $x2, $y2, $x3, $y3);
842 78         162 while (defined($x1 = shift())) {
843 78         99 $y1 = shift();
844 78         105 $x2 = shift();
845 78         99 $y2 = shift();
846 78         102 $x3 = shift();
847 78         100 $y3 = shift();
848 78 50       129 if ($self->_in_text_object()) {
849 0         0 $self->add_post(floats($x1, $y1, $x2, $y2, $x3, $y3), 'c');
850             }
851             else {
852 78         199 $self->add(floats($x1, $y1, $x2, $y2, $x3, $y3), 'c');
853             }
854 78         163 $self->{' x'} = $x3;
855 78         182 $self->{' y'} = $y3;
856             }
857 78         126 return $self;
858             }
859              
860             =head2 spline
861              
862             $content = $content->spline($cx1, $cy1, $x, $y);
863              
864             Extends the path in a curve from the current point to C<($x, $y)>, using the two
865             specified points to create a spline.
866              
867             =cut
868              
869             sub spline {
870 1     1 1 7 my $self = shift();
871              
872 1         6 while (scalar @_ >= 4) {
873 1         4 my $cx = shift();
874 1         3 my $cy = shift();
875 1         2 my $x = shift();
876 1         3 my $y = shift();
877 1         5 my $c1x = (2 * $cx + $self->{' x'}) / 3;
878 1         5 my $c1y = (2 * $cy + $self->{' y'}) / 3;
879 1         4 my $c2x = (2 * $cx + $x) / 3;
880 1         3 my $c2y = (2 * $cy + $y) / 3;
881 1         3 $self->curve($c1x, $c1y, $c2x, $c2y, $x, $y);
882             }
883             }
884              
885             =head2 arc
886              
887             $content = $content->arc($x, $y, $major, $minor, $a, $b);
888              
889             Extends the path along an arc of an ellipse centered at C<[$x, $y]>. C<$major>
890             and C<$minor> represent the axes of the ellipse, and the arc moves from C<$a>
891             degrees to C<$b> degrees.
892              
893             =cut
894              
895             # Private
896             sub arctocurve {
897 144     144 0 247 my ($a, $b, $alpha, $beta) = @_;
898 144 100       248 if (abs($beta - $alpha) > 30) {
899             return (
900 68         223 arctocurve($a, $b, $alpha, ($beta + $alpha) / 2),
901             arctocurve($a, $b, ($beta + $alpha) / 2, $beta)
902             );
903             }
904             else {
905 76         112 $alpha = ($alpha * pi / 180);
906 76         101 $beta = ($beta * pi / 180);
907              
908 76         144 my $bcp = (4.0 / 3 * (1 - cos(($beta - $alpha) / 2)) / sin(($beta - $alpha) / 2));
909 76         119 my $sin_alpha = sin($alpha);
910 76         115 my $sin_beta = sin($beta);
911 76         124 my $cos_alpha = cos($alpha);
912 76         97 my $cos_beta = cos($beta);
913              
914 76         114 my $p0_x = $a * $cos_alpha;
915 76         98 my $p0_y = $b * $sin_alpha;
916 76         111 my $p1_x = $a * ($cos_alpha - $bcp * $sin_alpha);
917 76         103 my $p1_y = $b * ($sin_alpha + $bcp * $cos_alpha);
918 76         100 my $p2_x = $a * ($cos_beta + $bcp * $sin_beta);
919 76         109 my $p2_y = $b * ($sin_beta - $bcp * $cos_beta);
920 76         94 my $p3_x = $a * $cos_beta;
921 76         92 my $p3_y = $b * $sin_beta;
922              
923 76         320 return ($p0_x, $p0_y, $p1_x, $p1_y, $p2_x, $p2_y, $p3_x, $p3_y);
924             }
925             }
926              
927             sub arc {
928 4     4 1 41 my ($self, $x, $y, $a, $b, $alpha, $beta, $move) = @_;
929 4         13 my @points = arctocurve($a, $b, $alpha, $beta);
930 4         10 my ($p0_x, $p0_y, $p1_x, $p1_y, $p2_x, $p2_y, $p3_x, $p3_y);
931              
932 4         9 $p0_x = $x + shift(@points);
933 4         7 $p0_y = $y + shift(@points);
934              
935             # Deprecated
936 4 100       16 $self->move($p0_x, $p0_y) if $move;
937              
938 4         16 while (scalar @points) {
939 40         61 $p1_x = $x + shift(@points);
940 40         70 $p1_y = $y + shift(@points);
941 40         57 $p2_x = $x + shift(@points);
942 40         66 $p2_y = $y + shift(@points);
943 40         54 $p3_x = $x + shift(@points);
944 40         51 $p3_y = $y + shift(@points);
945 40         93 $self->curve($p1_x, $p1_y, $p2_x, $p2_y, $p3_x, $p3_y);
946 40         59 shift(@points);
947 40         50 shift(@points);
948 40         66 $self->{' x'} = $p3_x;
949 40         82 $self->{' y'} = $p3_y;
950             }
951 4         10 return $self;
952             }
953              
954             # Extends the path along an arc of a circle of the specified radius from
955             # C<[x1,y1]> to C<[x2,y2]>.
956             #
957             # Set C<$move> to a true value if this arc is the beginning of a new path
958             # instead of the continuation of an existing path.
959             #
960             # Set C<$outer> to a true value to draw the larger arc between the two points
961             # instead of the smaller one.
962             #
963             # Set C<$reverse> to a true value to draw the mirror image of the specified arc.
964             #
965             # C<$radius * 2> cannot be smaller than the distance from C<[x1,y1]> to
966             # C<[x2,y2]>.
967              
968             # Deprecated; recreate using arc (Bogen is German for arc)
969             sub bogen {
970 4     4 0 29 my ($self, $x1, $y1, $x2, $y2, $r, $move, $larc, $spf) = @_;
971 4         7 my ($p0_x, $p0_y, $p1_x, $p1_y, $p2_x, $p2_y, $p3_x, $p3_y);
972 4         7 my $x = $x2 - $x1;
973 4         6 my $y = $y2 - $y1;
974 4         12 my $z = sqrt($x ** 2 + $y ** 2);
975 4         15 my $alpha_rad = asin($y / $z);
976              
977 4 50 33     39 $alpha_rad += pi / 2 if $x < 0 and $y > 0;
978 4 50 33     11 $alpha_rad -= pi / 2 if $x < 0 and $y < 0;
979              
980 4         14 my $alpha = rad2deg($alpha_rad);
981             # use the complement angle for span
982 4 100 66     48 $alpha -= 180 if $spf and $spf > 0;
983              
984 4         7 my $d = 2 * $r;
985 4         7 my ($beta, $beta_rad, @points);
986              
987 4         9 $beta = rad2deg(2 * asin($z / $d));
988 4 100 66     57 $beta = 360 - $beta if $larc and $larc > 0;
989              
990 4         9 $beta_rad = deg2rad($beta);
991              
992 4         42 @points = arctocurve($r, $r, 90 + $alpha + $beta / 2, 90 + $alpha - $beta / 2);
993              
994 4 100 66     17 if ($spf and $spf > 0) {
995 1         5 my @pts = @points;
996 1         4 @points = ();
997 1         4 while ($y = pop(@pts)) {
998 15         18 $x = pop(@pts);
999 15         29 push(@points, $x, $y);
1000             }
1001             }
1002              
1003 4         7 $p0_x = shift(@points);
1004 4         7 $p0_y = shift(@points);
1005 4         6 $x = $x1 - $p0_x;
1006 4         8 $y = $y1 - $p0_y;
1007              
1008 4 100       10 $self->move($x1, $y1) if $move;
1009              
1010 4         9 while (scalar @points) {
1011 36         57 $p1_x = $x + shift(@points);
1012 36         46 $p1_y = $y + shift(@points);
1013 36         53 $p2_x = $x + shift(@points);
1014 36         51 $p2_y = $y + shift(@points);
1015             # if we run out of data points, use the end point instead
1016 36 100       72 if (scalar @points == 0) {
1017 1         2 $p3_x = $x2;
1018 1         2 $p3_y = $y2;
1019             }
1020             else {
1021 35         51 $p3_x = $x + shift(@points);
1022 35         44 $p3_y = $y + shift(@points);
1023             }
1024 36         91 $self->curve($p1_x, $p1_y, $p2_x, $p2_y, $p3_x, $p3_y);
1025 36         50 shift(@points);
1026 36         73 shift(@points);
1027             }
1028 4         12 return $self;
1029             }
1030              
1031             =head2 close
1032              
1033             $content = $content->close();
1034              
1035             Closes the current path by extending a line from the current position to the
1036             starting position.
1037              
1038             =cut
1039              
1040             sub close {
1041 13     13 1 67 my $self = shift();
1042 13         34 $self->add('h');
1043 13         36 $self->{' x'} = $self->{' mx'};
1044 13         22 $self->{' y'} = $self->{' my'};
1045 13         25 return $self;
1046             }
1047              
1048             =head2 end
1049              
1050             $content = $content->end();
1051              
1052             Ends the current path without filling or stroking.
1053              
1054             =cut
1055              
1056             # Deprecated (renamed)
1057 1     1 1 10 sub endpath { return end(@_) }
1058              
1059             sub end {
1060 2     2 1 15 my $self = shift();
1061 2         11 $self->add('n');
1062 2         8 return $self;
1063             }
1064              
1065             =head1 SHAPE CONSTRUCTION (DRAWING)
1066              
1067             The following are convenience methods for drawing closed paths.
1068              
1069             Note that shapes will not appear until a path painting method is called
1070             (L, L, or L).
1071              
1072             =head2 rectangle
1073              
1074             $content = $content->rectangle($x1, $y1, $x2, $y2);
1075              
1076             Creates a new rectangle-shaped path, between the two points C<[$x1, $y1]>
1077             and C<[$x2, $y2]>.
1078              
1079             =cut
1080              
1081             sub rectangle {
1082 2     2 1 22 my ($self, $x1, $y1, $x2, $y2) = @_;
1083              
1084             # Ensure that x1,y1 is lower-left and x2,y2 is upper-right
1085 2 100       6 if ($x2 < $x1) {
1086 1         2 my $x = $x1;
1087 1         4 $x1 = $x2;
1088 1         2 $x2 = $x;
1089             }
1090 2 50       7 if ($y2 < $y1) {
1091 0         0 my $y = $y1;
1092 0         0 $y1 = $y2;
1093 0         0 $y2 = $y;
1094             }
1095              
1096 2         10 $self->add(floats($x1, $y1, ($x2 - $x1), ($y2 - $y1)), 're');
1097 2         5 $self->{' x'} = $x1;
1098 2         4 $self->{' y'} = $y1;
1099              
1100 2         5 return $self;
1101             }
1102              
1103             # Deprecated; replace with individual calls to rectangle
1104             sub rect {
1105 5     5 1 18 my $self = shift();
1106 5         10 my ($x, $y, $w, $h);
1107 5         11 while (defined($x = shift())) {
1108 6         9 $y = shift();
1109 6         8 $w = shift();
1110 6         9 $h = shift();
1111 6         17 $self->add(floats($x, $y, $w, $h), 're');
1112             }
1113 5         9 $self->{' x'} = $x;
1114 5         9 $self->{' y'} = $y;
1115 5         19 return $self;
1116             }
1117              
1118             # Deprecated; replace with rectangle, converting x2/y2 to w/h.
1119             sub rectxy {
1120 2     2 1 12 my ($self, $x, $y, $x2, $y2) = @_;
1121 2         9 $self->rect($x, $y, ($x2 - $x), ($y2 - $y));
1122 2         4 return $self;
1123             }
1124              
1125             =head2 circle
1126              
1127             $content = $content->circle($x, $y, $radius);
1128              
1129             Creates a new circular path centered on C<[$x, $y]> with the specified radius.
1130              
1131             =cut
1132              
1133             sub circle {
1134 1     1 1 11 my ($self, $x, $y, $r) = @_;
1135 1         6 $self->arc($x, $y, $r, $r, 0, 360, 1);
1136 1         5 $self->close();
1137 1         5 return $self;
1138             }
1139              
1140             =head2 ellipse
1141              
1142             $content = $content->ellipse($x, $y, $major, $minor);
1143              
1144             Creates a new elliptical path centered on C<[$x, $y]> with the specified major
1145             and minor axes.
1146              
1147             =cut
1148              
1149             sub ellipse {
1150 1     1 1 19 my ($self, $x, $y, $a, $b) = @_;
1151 1         5 $self->arc($x, $y, $a, $b, 0, 360, 1);
1152 1         6 $self->close();
1153 1         3 return $self;
1154             }
1155              
1156             =head2 pie
1157              
1158             $content = $content->pie($x, $y, $major, $minor, $a, $b);
1159              
1160             Creates a new wedge-shaped path from an ellipse centered on C<[$x, $y]> with the
1161             specified major and minor axes, extending from C<$a> degrees to C<$b> degrees.
1162              
1163             =cut
1164              
1165             sub pie {
1166 0     0 1 0 my $self = shift();
1167 0         0 my ($x, $y, $a, $b, $alpha, $beta) = @_;
1168 0         0 my ($p0_x, $p0_y) = arctocurve($a, $b, $alpha, $beta);
1169 0         0 $self->move($x, $y);
1170 0         0 $self->line($p0_x + $x, $p0_y + $y);
1171 0         0 $self->arc($x, $y, $a, $b, $alpha, $beta);
1172 0         0 $self->close();
1173             }
1174              
1175             =head1 PATH PAINTING (DRAWING)
1176              
1177             =head2 stroke_color
1178              
1179             $content = $content->stroke_color($color, @arguments);
1180              
1181             Sets the stroke color, which is black by default.
1182              
1183             # Use a named color
1184             $content->stroke_color('blue');
1185              
1186             # Use an RGB color (start with '#')
1187             $content->stroke_color('#FF0000');
1188              
1189             # Use a CMYK color (start with '%')
1190             $content->stroke_color('%FF000000');
1191              
1192             # Use a spot color with 100% coverage.
1193             my $spot = $pdf->colorspace('spot', 'PANTONE Red 032 C', '#EF3340');
1194             $content->stroke_color($spot, 1.0);
1195              
1196             RGB and CMYK colors can have one-byte, two-byte, three-byte, or four-byte values
1197             for each color, depending on the level of precision needed. For instance, cyan
1198             can be given as C<%F000> or C<%FFFF000000000000>.
1199              
1200             =head2 fill_color
1201              
1202             $content = $content->fill_color($color, @arguments);
1203              
1204             Sets the fill color, which is black by default. Arguments are the same as in
1205             L.
1206              
1207             =cut
1208              
1209             # default colorspaces: rgb/hsv/named cmyk/hsl lab
1210             # ... only one text string
1211             #
1212             # pattern or shading space
1213             # ... only one object
1214             #
1215             # legacy greylevel
1216             # ... only one value
1217             sub _makecolor {
1218 26     26   82 my ($self, $sf, @clr) = @_;
1219              
1220 26 100 33     180 if ($clr[0] =~ /^[a-z\#\!]+/) {
    100 33        
    50          
    50          
    50          
    50          
    0          
    0          
    0          
1221             # colorname or #! specifier
1222             # with rgb target colorspace
1223             # namecolor returns always a RGB
1224 23 100       89 return namecolor($clr[0]), ($sf ? 'rg' : 'RG');
1225             }
1226             elsif ($clr[0] =~ /^[\%]+/) {
1227             # % specifier
1228             # with cmyk target colorspace
1229 2 100       13 return namecolor_cmyk($clr[0]), ($sf ? 'k' : 'K');
1230             }
1231             elsif ($clr[0] =~ /^[\$\&]/) {
1232             # &$ specifier
1233             # with L*a*b target colorspace
1234 0 0       0 if (!defined $self->resource('ColorSpace', 'LabS')) {
1235 0         0 my $dc = PDFDict();
1236 0         0 my $cs = PDFArray(PDFName('Lab'), $dc);
1237 0         0 $dc->{'WhitePoint'} = PDFArray(map { PDFNum($_) } qw(1 1 1));
  0         0  
1238 0         0 $dc->{'Range'} = PDFArray(map { PDFNum($_) } qw(-128 127 -128 127));
  0         0  
1239 0         0 $dc->{'Gamma'} = PDFArray(map { PDFNum($_) } qw(2.2 2.2 2.2));
  0         0  
1240 0         0 $self->resource('ColorSpace', 'LabS', $cs);
1241             }
1242 0 0       0 return '/LabS', ($sf ? 'cs' : 'CS'), namecolor_lab($clr[0]), ($sf ? 'sc' : 'SC');
    0          
1243             }
1244             elsif (scalar @clr == 1 and ref($clr[0])) {
1245             # pattern or shading space
1246 0 0       0 return '/Pattern', ($sf ? 'cs' : 'CS'), '/' . ($clr[0]->name()), ($sf ? 'scn' : 'SCN');
    0          
1247             }
1248             elsif (scalar @clr == 1) {
1249             # grey color spec.
1250 0 0       0 return $clr[0], $sf ? 'g' : 'G';
1251             }
1252             elsif (scalar @clr > 1 and ref($clr[0])) {
1253             # indexed colorspace plus color-index
1254             # or custom colorspace plus param
1255 1         3 my $cs = shift(@clr);
1256 1 50       5 return '/' . $cs->name(), ($sf ? 'cs' : 'CS'), $cs->param(@clr), ($sf ? 'sc' : 'SC');
    50          
1257             }
1258             elsif (scalar @clr == 2) {
1259             # indexed colorspace plus color-index
1260             # or custom colorspace plus param
1261 0 0       0 return '/' . $clr[0]->name(), ($sf ? 'cs' : 'CS'), $clr[0]->param($clr[1]), ($sf ? 'sc' : 'SC');
    0          
1262             }
1263             elsif (scalar @clr == 3) {
1264             # legacy rgb color-spec (0 <= x <= 1)
1265 0 0       0 return floats($clr[0], $clr[1], $clr[2]), ($sf ? 'rg' : 'RG');
1266             }
1267             elsif (scalar @clr == 4) {
1268             # legacy cmyk color-spec (0 <= x <= 1)
1269 0 0       0 return floats($clr[0], $clr[1], $clr[2], $clr[3]), ($sf ? 'k' : 'K');
1270             }
1271             else {
1272 0         0 die 'invalid color specification.';
1273             }
1274             }
1275              
1276             sub _fillcolor {
1277 15     15   41 my ($self, @clrs) = @_;
1278 15 50       68 if (ref($clrs[0]) =~ m|^PDF::API2::Resource::ColorSpace|) {
    50          
1279 0         0 $self->resource('ColorSpace', $clrs[0]->name(), $clrs[0]);
1280             }
1281             elsif (ref($clrs[0]) =~ m|^PDF::API2::Resource::Pattern|) {
1282 0         0 $self->resource('Pattern', $clrs[0]->name(), $clrs[0]);
1283             }
1284              
1285 15         69 return $self->_makecolor(1, @clrs);
1286             }
1287              
1288             # Deprecated
1289 13     13 0 75 sub fillcolor { return fill_color(@_) }
1290              
1291             sub fill_color {
1292 15     15 1 39 my $self = shift();
1293 15 50       44 if (@_) {
1294 15         31 @{$self->{' fillcolor'}} = @_;
  15         43  
1295 15         100 $self->add($self->_fillcolor(@_));
1296             }
1297 15         32 return @{$self->{' fillcolor'}};
  15         66  
1298             }
1299              
1300             sub _strokecolor {
1301 11     11   27 my ($self, @clrs) = @_;
1302 11 100       57 if (ref($clrs[0]) =~ m|^PDF::API2::Resource::ColorSpace|) {
    50          
1303 1         7 $self->resource('ColorSpace', $clrs[0]->name(), $clrs[0]);
1304             }
1305             elsif (ref($clrs[0]) =~ m|^PDF::API2::Resource::Pattern|) {
1306 0         0 $self->resource('Pattern', $clrs[0]->name(), $clrs[0]);
1307             }
1308 11         33 return $self->_makecolor(0, @clrs);
1309             }
1310              
1311             # Deprecated
1312 8     8 0 35 sub strokecolor { return stroke_color(@_) }
1313              
1314             sub stroke_color {
1315 11     11 1 31 my $self = shift();
1316 11 50       30 if (@_) {
1317 11         23 @{$self->{' strokecolor'}} = @_;
  11         34  
1318 11         41 $self->add($self->_strokecolor(@_));
1319             }
1320 11         23 return @{$self->{' strokecolor'}};
  11         37  
1321             }
1322              
1323             =head2 stroke
1324              
1325             $content = $content->stroke();
1326              
1327             Strokes the current path.
1328              
1329             =cut
1330              
1331             sub _stroke {
1332 121     121   276 return 'S';
1333             }
1334              
1335             sub stroke {
1336 121     121 1 266 my $self = shift();
1337 121         210 $self->add(_stroke());
1338 121         236 return $self;
1339             }
1340              
1341             =head2 fill
1342              
1343             $content = $content->fill(rule => $rule);
1344              
1345             Fills the current path.
1346              
1347             C<$rule> describes which areas are filled in when the path intersects with itself.
1348              
1349             =over
1350              
1351             =item * nonzero (default)
1352              
1353             Use the nonzero winding number rule. This tends to mean that the entire area
1354             enclosed by the path is filled in, with some exceptions depending on the
1355             direction of the path.
1356              
1357             =item * even-odd
1358              
1359             Use the even-odd rule. This tends to mean that the presence of fill alternates
1360             each time the path is intersected.
1361              
1362             =back
1363              
1364             See PDF specification 1.7 section 8.5.3.3, Filling, for more details.
1365              
1366             =cut
1367              
1368             sub fill {
1369 3     3 1 27 my $self = shift();
1370              
1371 3         7 my $even_odd;
1372 3 100       11 if (@_ == 2) {
1373 1         6 my %options = @_;
1374 1 50 50     8 if (($options{'rule'} // 'nonzero') eq 'even-odd') {
1375 1         2 $even_odd = 1;
1376             }
1377             }
1378             else {
1379             # Deprecated
1380 2         4 $even_odd = shift();
1381             }
1382              
1383 3 100       15 $self->add($even_odd ? 'f*' : 'f');
1384              
1385 3         8 return $self;
1386             }
1387              
1388             =head2 paint
1389              
1390             $content = $content->paint(rule => $rule);
1391              
1392             Fills and strokes the current path. C<$rule> is as described in L.
1393              
1394             =cut
1395              
1396             # Deprecated (renamed)
1397 2     2 1 14 sub fillstroke { return paint(@_) }
1398              
1399             sub paint {
1400 4     4 1 33 my $self = shift();
1401              
1402 4         6 my $even_odd;
1403 4 100       18 if (@_ == 2) {
1404 1         4 my %options = @_;
1405 1 50 50     6 if (($options{'rule'} // 'nonzero') eq 'even-odd') {
1406 1         3 $even_odd = 1;
1407             }
1408             }
1409             else {
1410             # Deprecated
1411 3         6 $even_odd = shift();
1412             }
1413              
1414 4 100       20 $self->add($even_odd ? 'B*' : 'B');
1415              
1416 4         9 return $self;
1417             }
1418              
1419             =head2 clip
1420              
1421             $content = $content->clip(rule => $rule);
1422              
1423             Modifies the current clipping path (initially the entire page) by intersecting
1424             it with the current path following the next path-painting command. C<$rule> is
1425             as described in L.
1426              
1427             =cut
1428              
1429             sub clip {
1430 3     3 1 26 my $self = shift();
1431              
1432 3         6 my $even_odd;
1433 3 100       14 if (@_ == 2) {
1434 1         5 my %options = @_;
1435 1 50 50     6 if (($options{'rule'} // 'nonzero') eq 'even-odd') {
1436 1         3 $even_odd = 1;
1437             }
1438             }
1439             else {
1440             # Deprecated
1441 2         6 $even_odd = shift();
1442             }
1443              
1444 3 100       16 $self->add($even_odd ? 'W*' : 'W');
1445              
1446 3         6 return $self;
1447             }
1448              
1449             sub shade {
1450 0     0 0 0 my ($self, $shade, @cord) = @_;
1451              
1452 0         0 my @tm = (
1453             $cord[2] - $cord[0], 0,
1454             0 , $cord[3] - $cord[1],
1455             $cord[0] , $cord[1],
1456             );
1457              
1458 0         0 $self->save();
1459 0         0 $self->matrix(@tm);
1460 0         0 $self->add('/' . $shade->name(), 'sh');
1461 0         0 $self->resource('Shading', $shade->name(), $shade);
1462 0         0 $self->restore();
1463              
1464 0         0 return $self;
1465             }
1466              
1467             =head1 EXTERNAL OBJECTS
1468              
1469             =head2 object
1470              
1471             $content = $content->object($object, $x, $y, $scale_x, $scale_y);
1472              
1473             Places an image or other external object (a.k.a. XObject) on the page in the
1474             specified location.
1475              
1476             For images, C<$scale_x> and C<$scale_y> represent the width and height of the
1477             image on the page in points. If C<$scale_x> is omitted, it will default to 72
1478             pixels per inch. If C<$scale_y> is omitted, the image will be scaled
1479             proportionally based on the image dimensions.
1480              
1481             For other external objects, the scale is a multiplier, where 1 (the default)
1482             represents 100% (i.e. no change).
1483              
1484             If coordinate transformations have been made (see Coordinate Transformations
1485             above), the position and scale will be relative to the updated coordinates.
1486              
1487             If no coordinate transformations are needed, this method can be called directly
1488             from the L object instead.
1489              
1490             =cut
1491              
1492             # Behavior based on argument count
1493             # 0: Place at 0, 0, 100%
1494             # 2: Place at X, Y, 100%
1495             # 3: Place at X, Y, scaled
1496             # 4: Place at X, Y, scale_w, scale_h
1497             sub object {
1498 0     0 1 0 my ($self, $object, $x, $y, $scale_x, $scale_y) = @_;
1499 0   0     0 $x //= 0;
1500 0   0     0 $y //= 0;
1501 0 0       0 if ($object->isa('PDF::API2::Resource::XObject::Image')) {
1502 0   0     0 $scale_x //= $object->width();
1503 0   0     0 $scale_y //= $object->height() * $scale_x / $object->width();
1504             }
1505             else {
1506 0   0     0 $scale_x //= 1;
1507 0   0     0 $scale_y //= $scale_x;
1508             }
1509              
1510 0         0 $self->save();
1511 0         0 $self->matrix($scale_x, 0, 0, $scale_y, $x, $y);
1512 0         0 $self->add('/' . $object->name(), 'Do');
1513 0         0 $self->restore();
1514              
1515 0         0 $self->resource('XObject', $object->name(), $object);
1516              
1517 0         0 return $self;
1518             }
1519              
1520             # Deprecated
1521             sub image {
1522 8     8 1 67 my $self = shift;
1523 8         19 my $img = shift;
1524 8         27 my ($x, $y, $w, $h) = @_;
1525 8 50       49 if (defined $img->{'Metadata'}) {
1526 0         0 $self->metaStart('PPAM:PlacedImage', $img->{'Metadata'});
1527             }
1528 8         77 $self->save();
1529 8 50 33     79 unless (defined $w) {
1530 0         0 $h = $img->height();
1531 0         0 $w = $img->width();
1532             }
1533             elsif (not defined $h) {
1534             $h = $img->height() * $w;
1535             $w = $img->width() * $w;
1536             }
1537 8         60 $self->matrix($w, 0, 0, $h, $x, $y);
1538 8         61 $self->add('/' . $img->name(), 'Do');
1539 8         45 $self->restore();
1540 8         34 $self->{' x'} = $x;
1541 8         34 $self->{' y'} = $y;
1542 8         44 $self->resource('XObject', $img->name(), $img);
1543 8 50       34 if (defined $img->{'Metadata'}) {
1544 0         0 $self->metaEnd();
1545             }
1546 8         25 return $self;
1547             }
1548              
1549             # Deprecated
1550             sub formimage {
1551 2     2 1 17 my ($self, $img, $x, $y, $s) = @_;
1552 2         12 $self->save();
1553 2 50       8 if (defined $s) {
1554 2         11 $self->matrix($s, 0, 0, $s, $x, $y);
1555             }
1556             else {
1557 0         0 $self->matrix(1, 0, 0, 1, $x, $y);
1558             }
1559 2         11 $self->add('/' . $img->name(), 'Do');
1560 2         12 $self->restore();
1561 2         17 $self->resource('XObject', $img->name(), $img);
1562 2         9 return $self;
1563             }
1564              
1565             =head1 TEXT STATE
1566              
1567             All of the following parameters that take a size are applied before any scaling
1568             takes place, so you don't need to adjust values to counteract scaling.
1569              
1570             =head2 font
1571              
1572             $content = $content->font($font, $size);
1573              
1574             Sets the font and font size. C<$font> is an object created by calling
1575             L to add the font to the document.
1576              
1577             my $pdf = PDF::API2->new();
1578             my $page = $pdf->page();
1579             my $text = $pdf->text();
1580              
1581             my $font = $pdf->font('Helvetica');
1582             $text->font($font, 24);
1583             $text->position(72, 720);
1584             $text->text('Hello, World!');
1585              
1586             $pdf->save('sample.pdf');
1587              
1588             =cut
1589              
1590             sub _font {
1591 18     18   76 my ($font, $size) = @_;
1592 18 100       65 if ($font->isvirtual()) {
1593 1         5 return('/' . $font->fontlist->[0]->name() . ' ' . float($size) . ' Tf');
1594             }
1595             else {
1596 17         59 return('/' . $font->name() . ' ' . float($size) . ' Tf');
1597             }
1598             }
1599             sub font {
1600 19     19 1 681 my ($self, $font, $size) = @_;
1601 19 100       46 unless ($size) {
1602 1         75 croak q{A font size is required};
1603             }
1604 18         70 $self->fontset($font, $size);
1605 18         76 $self->add(_font($font, $size));
1606 18         42 $self->{' fontset'} = 1;
1607 18         41 return $self;
1608             }
1609              
1610             sub fontset {
1611 18     18 0 41 my ($self, $font, $size) = @_;
1612 18         35 $self->{' font'} = $font;
1613 18         34 $self->{' fontsize'} = $size;
1614 18         34 $self->{' fontset'} = 0;
1615              
1616 18 100       88 if ($font->isvirtual()) {
1617 1         1 foreach my $f (@{$font->fontlist()}) {
  1         8  
1618 2         10 $self->resource('Font', $f->name(), $f);
1619             }
1620             }
1621             else {
1622 17         56 $self->resource('Font', $font->name(), $font);
1623             }
1624              
1625 18         32 return $self;
1626             }
1627              
1628             =head2 character_spacing
1629              
1630             $spacing = $content->character_spacing($spacing);
1631              
1632             Sets the spacing between characters. This is initially zero.
1633              
1634             =cut
1635              
1636             sub _charspace {
1637 3     3   7 my $spacing = shift();
1638 3         15 return float($spacing, 6) . ' Tc';
1639             }
1640              
1641             # Deprecated (renamed)
1642 3     3 1 797 sub charspace { return character_spacing(@_) }
1643              
1644             sub character_spacing {
1645 4     4 1 17 my ($self, $spacing) = @_;
1646 4 100       12 if (defined $spacing) {
1647 3         8 $self->{' charspace'} = $spacing;
1648 3         12 $self->add(_charspace($spacing));
1649             }
1650 4         13 return $self->{' charspace'};
1651             }
1652              
1653             =head2 word_spacing
1654              
1655             $spacing = $content->word_spacing($spacing);
1656              
1657             Sets the spacing between words. This is initially zero (i.e. just the width of
1658             the space).
1659              
1660             Word spacing might only affect simple fonts and composite fonts where the space
1661             character is a single-byte code. This is a limitation of the PDF specification
1662             at least as of version 1.7 (see section 9.3.3). It's possible that a later
1663             version of the specification will support word spacing in fonts that use
1664             multi-byte codes.
1665              
1666             =cut
1667              
1668             sub _wordspace {
1669 15     15   24 my $spacing = shift();
1670 15         75 return float($spacing, 6) . ' Tw';
1671             }
1672              
1673             # Deprecated (renamed)
1674 24     24 1 503 sub wordspace { return word_spacing(@_) }
1675              
1676             sub word_spacing {
1677 25     25 1 60 my ($self, $spacing) = @_;
1678 25 100       56 if (defined $spacing) {
1679 15         24 $self->{' wordspace'} = $spacing;
1680 15         35 $self->add(_wordspace($spacing));
1681             }
1682 25         51 return $self->{' wordspace'};
1683             }
1684              
1685             =head2 hscale
1686              
1687             $scale = $content->hscale($scale);
1688              
1689             Sets/gets the percentage of horizontal text scaling. Enter a scale greater than
1690             100 to stretch text, less than 100 to squeeze text, or 100 to disable any
1691             existing scaling.
1692              
1693             =cut
1694              
1695             sub _hscale {
1696 2     2   5 my $scale = shift();
1697 2         7 return float($scale, 6) . ' Tz';
1698             }
1699              
1700             sub hscale {
1701 14     14 1 51 my ($self, $scale) = @_;
1702 14 100       40 if (defined $scale) {
1703 2         5 $self->{' hscale'} = $scale;
1704 2         9 $self->add(_hscale($scale));
1705             }
1706 14         55 return $self->{' hscale'};
1707             }
1708              
1709             # Deprecated: hscale was originally named incorrectly (as hspace)
1710 1     1 1 8 sub hspace { return hscale(@_) }
1711 0     0   0 sub _hspace { return _hscale(@_) }
1712              
1713             =head2 leading
1714              
1715             $leading = $content->leading($leading);
1716              
1717             Sets/gets the text leading, which is the distance between baselines. This is
1718             initially zero (i.e. the lines will be printed on top of each other).
1719              
1720             =cut
1721              
1722             # Deprecated: leading is the correct name for this operator
1723 0     0   0 sub _lead { return _leading(@_) }
1724 1     1 1 9 sub lead { return leading(@_) }
1725              
1726             sub _leading {
1727 11     11   19 my $leading = shift();
1728 11         28 return float($leading) . ' TL';
1729             }
1730             sub leading {
1731 46     46 1 129 my ($self, $leading) = @_;
1732 46 100       87 if (defined ($leading)) {
1733 11         20 $self->{' leading'} = $leading;
1734 11         35 $self->add(_leading($leading));
1735             }
1736 46         89 return $self->{' leading'};
1737             }
1738              
1739             =head2 render
1740              
1741             $mode = $content->render($mode);
1742              
1743             Sets the text rendering mode.
1744              
1745             =over
1746              
1747             =item * 0 = Fill text
1748              
1749             =item * 1 = Stroke text (outline)
1750              
1751             =item * 2 = Fill, then stroke text
1752              
1753             =item * 3 = Neither fill nor stroke text (invisible)
1754              
1755             =item * 4 = Fill text and add to path for clipping
1756              
1757             =item * 5 = Stroke text and add to path for clipping
1758              
1759             =item * 6 = Fill, then stroke text and add to path for clipping
1760              
1761             =item * 7 = Add text to path for clipping
1762              
1763             =back
1764              
1765             =cut
1766              
1767             sub _render {
1768 1     1   2 my $mode = shift();
1769 1         7 return intg($mode) . ' Tr';
1770             }
1771              
1772             sub render {
1773 1     1 1 8 my ($self, $mode) = @_;
1774 1 50       3 if (defined ($mode)) {
1775 1         3 $self->{' render'} = $mode;
1776 1         5 $self->add(_render($mode));
1777             }
1778 1         3 return $self->{' render'};
1779             }
1780              
1781             =head2 rise
1782              
1783             $distance = $content->rise($distance);
1784              
1785             Adjusts the baseline up or down from its current location. This is initially
1786             zero.
1787              
1788             Use this to create superscripts or subscripts (usually with an adjustment to the
1789             font size as well).
1790              
1791             =cut
1792              
1793             sub _rise {
1794 1     1   2 my $distance = shift();
1795 1         5 return float($distance) . ' Ts';
1796             }
1797              
1798             sub rise {
1799 1     1 1 9 my ($self, $distance) = @_;
1800 1 50       5 if (defined ($distance)) {
1801 1         4 $self->{' rise'} = $distance;
1802 1         5 $self->add(_rise($distance));
1803             }
1804 1         4 return $self->{' rise'};
1805             }
1806              
1807             # Formerly documented; still used internally
1808             sub textstate {
1809 0     0 0 0 my $self = shift();
1810 0         0 my %state;
1811 0 0       0 if (@_) {
1812 0         0 %state = @_;
1813 0         0 foreach my $k (qw(charspace hscale wordspace leading rise render)) {
1814 0 0       0 next unless $state{$k};
1815 0         0 $self->can($k)->($self, $state{$k});
1816             }
1817 0 0 0     0 if ($state{'font'} and $state{'fontsize'}) {
1818 0         0 $self->font($state{'font'}, $state{'fontsize'});
1819             }
1820 0 0       0 if ($state{'textmatrix'}) {
1821 0         0 $self->matrix(@{$state{'textmatrix'}});
  0         0  
1822 0         0 @{$self->{' translate'}} = @{$state{'translate'}};
  0         0  
  0         0  
1823 0         0 $self->{' rotate'} = $state{'rotate'};
1824 0         0 @{$self->{' scale'}} = @{$state{'scale'}};
  0         0  
  0         0  
1825 0         0 @{$self->{' skew'}} = @{$state{'skew'}};
  0         0  
  0         0  
1826             }
1827 0 0       0 if ($state{'fillcolor'}) {
1828 0         0 $self->fillcolor(@{$state{'fillcolor'}});
  0         0  
1829             }
1830 0 0       0 if ($state{'strokecolor'}) {
1831 0         0 $self->strokecolor(@{$state{'strokecolor'}});
  0         0  
1832             }
1833 0         0 %state = ();
1834             }
1835             else {
1836 0         0 foreach my $k (qw(font fontsize charspace hscale wordspace leading rise render)) {
1837 0         0 $state{$k} = $self->{" $k"};
1838             }
1839 0         0 $state{'matrix'} = [@{$self->{' matrix'}}];
  0         0  
1840 0         0 $state{'textmatrix'} = [@{$self->{' textmatrix'}}];
  0         0  
1841 0         0 $state{'textlinematrix'} = [@{$self->{' textlinematrix'}}];
  0         0  
1842 0         0 $state{'rotate'} = $self->{' rotate'};
1843 0         0 $state{'scale'} = [@{$self->{' scale'}}];
  0         0  
1844 0         0 $state{'skew'} = [@{$self->{' skew'}}];
  0         0  
1845 0         0 $state{'translate'} = [@{$self->{' translate'}}];
  0         0  
1846 0         0 $state{'fillcolor'} = [@{$self->{' fillcolor'}}];
  0         0  
1847 0         0 $state{'strokecolor'} = [@{$self->{' strokecolor'}}];
  0         0  
1848             }
1849 0         0 return %state;
1850             }
1851              
1852             =head1 TEXT PLACEMENT
1853              
1854             =head2 position
1855              
1856             # Set
1857             $content = $content->position($x, $y);
1858              
1859             # Get
1860             ($x, $y) = $content->position();
1861              
1862             If called with arguments, moves to the start of the current line of text, offset
1863             by C<$x> and C<$y>.
1864              
1865             If called without arguments, returns the current position of the cursor (before
1866             the effects of any coordinate transformation methods).
1867              
1868             =cut
1869              
1870             sub position {
1871 59     59 1 139 my ($self, $x, $y) = @_;
1872              
1873 59 50 66     129 if (defined $x and not defined $y) {
1874 0         0 croak 'position requires either 0 or 2 arguments';
1875             }
1876              
1877 59 100       111 if (defined $x) {
1878 1         4 $self->add(float($x), float($y), 'Td');
1879 1         7 $self->matrix_update($x, $y);
1880 1         3 $self->{' textlinematrix'}->[0] = $x;
1881 1         3 return $self;
1882             }
1883              
1884 58         66 return @{$self->{' textlinematrix'}};
  58         169  
1885             }
1886              
1887             # Deprecated; replace with position
1888             sub distance {
1889 1     1 1 10 my ($self, $dx, $dy) = @_;
1890 1         4 $self->add(float($dx), float($dy), 'Td');
1891 1         8 $self->matrix_update($dx, $dy);
1892 1         4 $self->{' textlinematrix'}->[0] = $dx;
1893             }
1894              
1895             # Deprecated; use position (ignores leading) or crlf (uses leading) instead
1896             sub cr {
1897 3     3 1 16 my ($self, $offset) = @_;
1898 3 100       8 if (defined $offset) {
1899 2         7 $self->add(0, float($offset), 'Td');
1900 2         5 $self->matrix_update(0, $offset);
1901             }
1902             else {
1903 1         5 $self->add('T*');
1904 1         4 $self->matrix_update(0, $self->leading() * -1);
1905             }
1906 3         6 $self->{' textlinematrix'}->[0] = 0;
1907             }
1908              
1909             =head2 crlf
1910              
1911             $content = $content->crlf();
1912              
1913             Moves to the start of the next line, based on the L setting.
1914              
1915             If leading isn't set, a default distance of 120% of the font size will be used.
1916              
1917             =cut
1918              
1919             sub crlf {
1920 23     23 1 66 my $self = shift();
1921 23         47 my $leading = $self->leading();
1922 23 100 100     65 if ($leading or not $self->{' fontsize'}) {
1923 22         40 $self->add('T*');
1924             }
1925             else {
1926 1         4 $leading = $self->{' fontsize'} * 1.2;
1927 1         5 $self->add(0, float($leading * -1), 'Td');
1928             }
1929              
1930 23         60 $self->matrix_update(0, $leading * -1);
1931 23         30 $self->{' textlinematrix'}->[0] = 0;
1932 23         53 return $self;
1933             }
1934              
1935             # Deprecated; replace with crlf
1936             sub nl {
1937 1     1 1 7 my $self = shift();
1938 1         5 $self->add('T*');
1939 1         4 $self->matrix_update(0, $self->leading() * -1);
1940 1         3 $self->{' textlinematrix'}->[0] = 0;
1941             }
1942              
1943             sub _textpos {
1944 0     0   0 my ($self, @xy) = @_;
1945              
1946 0         0 my ($x, $y) = (0, 0);
1947 0         0 while (@xy) {
1948 0         0 $x += shift(@xy);
1949 0         0 $y += shift(@xy);
1950             }
1951             my (@m) = _transform(
1952 0         0 -matrix => $self->{' textmatrix'},
1953             -point => [$x, $y],
1954             );
1955              
1956 0         0 return ($m[0], $m[1]);
1957             }
1958              
1959             # Deprecated
1960             sub textpos {
1961 0     0 0 0 my $self = shift();
1962 0         0 return $self->_textpos(@{$self->{' textlinematrix'}});
  0         0  
1963             }
1964              
1965             # Deprecated; replace with position (without arguments)
1966             sub textpos2 {
1967 0     0 0 0 my $self = shift();
1968 0         0 return $self->position();
1969             }
1970              
1971             =head2 text
1972              
1973             my $width = $content->text($text, %options);
1974              
1975             Places text on the page. Returns the width of the text in points.
1976              
1977             Options:
1978              
1979             =over
1980              
1981             =item * align
1982              
1983             One of C (default), C
, or C. Text will be placed such that
1984             it begins, is centered on, or ends at the current text position, respectively.
1985              
1986             In each case, the position will then be moved to the end of the text.
1987              
1988             =item * indent
1989              
1990             Indents the text by the number of points.
1991              
1992             If C is set to anything other than C, this setting will be ignored.
1993              
1994             =item * underline
1995              
1996             Underlines the text. The value may be one of the following:
1997              
1998             =over
1999              
2000             =item * auto
2001              
2002             Determines the underline distance from the text based on the font and font size.
2003              
2004             =item * $distance
2005              
2006             Manually set the underline distance in points. A positive distance moves the
2007             line downward.
2008              
2009             =item * [$distance, $thickness, ...]
2010              
2011             Manually set both the underline distance and line thickness, both in points.
2012              
2013             Repeat these arguments to include multiple underlines.
2014              
2015             =back
2016              
2017             =back
2018              
2019             =cut
2020              
2021             sub _text_underline {
2022 0     0   0 my ($self, $xy1, $xy2, $underline, $color) = @_;
2023 0   0     0 $color ||= 'black';
2024              
2025 0         0 my @underline;
2026 0 0       0 if (ref($underline) eq 'ARRAY') {
2027 0         0 @underline = @$underline;
2028             }
2029             else {
2030 0         0 @underline = ($underline, 1);
2031             }
2032 0 0       0 push @underline, 1 if @underline % 2;
2033              
2034 0   0     0 my $underlineposition = (-$self->{' font'}->underlineposition() * $self->{' fontsize'} / 1000 || 1);
2035 0   0     0 my $underlinethickness = ($self->{' font'}->underlinethickness() * $self->{' fontsize'} / 1000 || 1);
2036 0         0 my $pos = 1;
2037              
2038 0         0 while (@underline) {
2039 0         0 $self->add_post(_save());
2040              
2041 0         0 my $distance = shift(@underline);
2042 0         0 my $thickness = shift(@underline);
2043 0         0 my $scolor = $color;
2044 0 0       0 if (ref($thickness)) {
2045 0         0 ($thickness, $scolor) = @$thickness;
2046             }
2047 0 0       0 if ($distance eq 'auto') {
2048 0         0 $distance = $pos * $underlineposition;
2049             }
2050 0 0       0 if ($thickness eq 'auto') {
2051 0         0 $thickness = $underlinethickness;
2052             }
2053              
2054 0         0 my ($x1, $y1) = $self->_textpos(@$xy1, 0, -($distance + ($thickness / 2)));
2055 0         0 my ($x2, $y2) = $self->_textpos(@$xy2, 0, -($distance + ($thickness / 2)));
2056              
2057 0         0 $self->add_post($self->_strokecolor($scolor));
2058 0         0 $self->add_post(_linewidth($thickness));
2059 0         0 $self->add_post(_move($x1, $y1));
2060 0         0 $self->add_post(_line($x2, $y2));
2061 0         0 $self->add_post(_stroke());
2062              
2063 0         0 $self->add_post(_restore());
2064 0         0 $pos++;
2065             }
2066             }
2067              
2068             sub text {
2069 30     30 1 128 my ($self, $text, %opts) = @_;
2070 30 100       77 unless ($self->{' fontset'}) {
2071 1 50 33     4 unless (defined $self->{' font'} and $self->{' fontsize'}) {
2072 1         168 croak q{Can't add text without first setting a font and font size};
2073             }
2074 0         0 $self->font($self->{' font'}, $self->{' fontsize'});
2075 0         0 $self->{' fontset'} = 1;
2076             }
2077              
2078             # Deprecated options (remove hyphens)
2079 29 100       61 if (exists $opts{'-indent'}) {
2080 10   33     57 $opts{'indent'} //= delete $opts{'-indent'};
2081             }
2082 29 50       83 if (exists $opts{'-underline'}) {
2083 0   0     0 $opts{'underline'} //= delete $opts{'-underline'};
2084             }
2085              
2086 29         70 my $width = $self->text_width($text);
2087              
2088 29 100       81 if (defined $opts{'align'}) {
2089 12 100       44 if ($opts{'align'} eq 'left') {
    100          
    50          
2090             # NOOP
2091             }
2092             elsif ($opts{'align'} eq 'center') {
2093 3         9 $opts{'indent'} = -($width / 2);
2094             }
2095             elsif ($opts{'align'} eq 'right') {
2096 3         7 $opts{'indent'} = -$width;
2097             }
2098             else {
2099 0         0 croak 'Invalid alignment: ' . $opts{'align'};
2100             }
2101             }
2102              
2103 29 100       77 if (defined $opts{'indent'}) {
2104 12         99 $self->matrix_update($opts{'indent'}, 0);
2105             }
2106              
2107 29         98 my $underline_start = [$self->position()];
2108              
2109 29 100       72 if (defined $opts{'indent'}) {
2110 12         28 my $indent = -$opts{'indent'};
2111 12         55 $indent *= (1000 / $self->{' fontsize'}) * (100 / $self->hscale());
2112 12         64 $self->add($self->{' font'}->text($text, $self->{' fontsize'}, $indent));
2113             }
2114             else {
2115 17         58 $self->add($self->{' font'}->text($text, $self->{' fontsize'}));
2116             }
2117              
2118 29         109 $self->matrix_update($width, 0);
2119              
2120 29         55 my $underline_end = [$self->position()];
2121              
2122 29 50       80 if (defined $opts{'underline'}) {
2123             $self->_text_underline($underline_start, $underline_end,
2124             $opts{'underline'},
2125 0         0 $opts{'-strokecolor'});
2126             }
2127              
2128 29         91 return $width;
2129             }
2130              
2131             # Deprecated; replace with text($line, align => 'center')
2132             sub text_center {
2133 6     6 1 59 my ($self, $text, @opts) = @_;
2134 6         30 my $width = $self->advancewidth($text);
2135 6         46 return $self->text($text, -indent => -($width / 2), @opts);
2136             }
2137              
2138             # Deprecated; replace with text($line, align => 'right')
2139             sub text_right {
2140 3     3 1 25 my ($self, $text, @opts) = @_;
2141 3         9 my $width = $self->advancewidth($text);
2142 3         12 return $self->text($text, -indent => -$width, @opts);
2143             }
2144              
2145             =head2 text_justified
2146              
2147             my $width = $content->text_justified($text, $width, %options);
2148              
2149             As C, filling the specified width by adjusting the space between words.
2150              
2151             =cut
2152              
2153             sub text_justified {
2154 1     1 1 17 my ($self, $text, $width, %opts) = @_;
2155 1         4 my $initial_width = $self->text_width($text);
2156 1         20 my $space_count = (split /\s/, $text) - 1;
2157 1         5 my $ws = $self->wordspace();
2158 1 50       7 $self->wordspace(($width - $initial_width) / $space_count) if $space_count;
2159 1         7 $self->text($text, %opts);
2160 1         4 $self->wordspace($ws);
2161 1         4 return $width;
2162             }
2163              
2164             sub _text_fill_line {
2165 19     19   33 my ($self, $text, $width) = @_;
2166 19         95 my @words = split(/\x20/, $text);
2167 19         34 my @line = ();
2168 19         27 local $" = ' ';
2169 19         36 while (@words) {
2170 112         175 push @line, (shift @words);
2171 112 100       254 last if $self->advancewidth("@line") > $width;
2172             }
2173 19 100 66     105 if ((scalar @line > 1) and ($self->advancewidth("@line") > $width)) {
2174 12         24 unshift @words, pop @line;
2175             }
2176 19         47 my $ret = "@words";
2177 19         35 my $line = "@line";
2178 19         58 return $line, $ret;
2179             }
2180              
2181             sub text_fill_left {
2182 7     7 0 14 my ($self, $text, $width, %opts) = @_;
2183 7         15 my ($line, $ret) = $self->_text_fill_line($text, $width);
2184 7         20 $width = $self->text($line, %opts);
2185 7         19 return $width, $ret;
2186             }
2187              
2188             sub text_fill_center {
2189 2     2 0 5 my ($self, $text, $width, %opts) = @_;
2190 2         5 my ($line, $ret) = $self->_text_fill_line($text, $width);
2191 2         10 $width = $self->text_center($line, %opts);
2192 2         6 return $width, $ret;
2193             }
2194              
2195             sub text_fill_right {
2196 2     2 0 9 my ($self, $text, $width, %opts) = @_;
2197 2         5 my ($line, $ret) = $self->_text_fill_line($text, $width);
2198 2         9 $width = $self->text_right($line, %opts);
2199 2         8 return $width, $ret;
2200             }
2201              
2202             sub text_fill_justified {
2203 8     8 0 21 my ($self, $text, $width, %opts) = @_;
2204 8         24 my ($line, $ret) = $self->_text_fill_line($text, $width);
2205 8         20 my $ws = $self->wordspace();
2206 8         15 my $w = $self->advancewidth($line);
2207 8         47 my $space_count = (split /\s/, $line) - 1;
2208              
2209             # Normal Line
2210 8 100       16 if ($ret) {
2211 4 50       17 $self->wordspace(($width - $w) / $space_count) if $space_count;
2212 4         15 $width = $self->text($line, %opts, align => 'left');
2213 4         10 $self->wordspace($ws);
2214 4         13 return $width, $ret;
2215             }
2216              
2217             # Last Line
2218 4 100       11 if ($opts{'align-last'}) {
2219 3 50       17 unless ($opts{'align-last'} =~ /^(left|center|right|justified)$/) {
2220 0         0 croak 'Invalid align-last (must be left, center, right, or justified)';
2221             }
2222             }
2223 4   100     13 my $align_last = $opts{'align-last'} // 'left';
2224 4 100       15 if ($align_last eq 'left') {
    100          
    100          
2225 1         5 $width = $self->text($line, %opts, align => 'left');
2226             }
2227             elsif ($align_last eq 'center') {
2228 1         5 $width = $self->text($line, %opts, align => 'center');
2229             }
2230             elsif ($align_last eq 'right') {
2231 1         5 $width = $self->text($line, %opts, align => 'right');
2232             }
2233             else {
2234 1 50       7 $self->wordspace(($width - $w) / $space_count) if $space_count;
2235 1         6 $width = $self->text($line, %opts, align => 'left');
2236 1         5 $self->wordspace($ws);
2237             }
2238 4         13 return $width, $ret;
2239             }
2240              
2241             =head2 paragraph
2242              
2243             # Scalar context
2244             $overflow_text = $content->paragraph($text, $width, $height, %options);
2245              
2246             # Array context
2247             ($overflow, $height) = $content->paragraph($text, $width, $height, %options);
2248              
2249             Fills the rectangle with as much of the provided text as will fit.
2250              
2251             In array context, returns the remaining text (if any) of the positioned text and
2252             the remaining (unused) height. In scalar context, returns the remaining text
2253             (if any).
2254              
2255             Line spacing follows L, if set, or 120% of the font size by default.
2256              
2257             B
2258              
2259             =over
2260              
2261             =item * align
2262              
2263             Specifies the alignment for each line of text. May be set to C (default),
2264             C
, C, or C.
2265              
2266             =item * align-last
2267              
2268             Specifies the alignment for the last line of justified text. May be set to
2269             C (default), C
, C, or C.
2270              
2271             =item * underline
2272              
2273             As described in L.
2274              
2275             =back
2276              
2277             =cut
2278              
2279             sub paragraph {
2280 10     10 1 63 my ($self, $text, $width, $height, %opts) = @_;
2281              
2282             # Deprecated options (remove hyphens)
2283 10 100       25 if (exists $opts{'-align'}) {
2284 6   33     23 $opts{'align'} //= delete $opts{'-align'};
2285             }
2286 10 100       21 if (exists $opts{'-align-last'}) {
2287 3   33     10 $opts{'align-last'} //= delete $opts{'-align-last'};
2288             }
2289 10 50       44 if (exists $opts{'-underline'}) {
2290 0   0     0 $opts{'underline'} //= delete $opts{'-underline'};
2291             }
2292              
2293 10         25 my $leading = $self->leading();
2294 10 50       20 unless ($leading) {
2295 0         0 $leading = $self->{' fontsize'} * 1.2;
2296             }
2297              
2298             # If the text contains newlines, call paragraph on each line
2299 10 100       27 if ($text =~ /\n/) {
2300 1         2 my $overflow = '';
2301 1         6 foreach my $line (split /\n/, $text) {
2302             # If there's overflow, no more text can be placed.
2303 3 50       8 if (length($overflow)) {
2304 0         0 $overflow .= "\n" . $line;
2305 0         0 next;
2306             }
2307              
2308             # Place a blank line if there are consecutive newlines
2309 3 100       5 unless (length($line)) {
2310 1         3 $self->crlf();
2311 1         2 $height -= $leading;
2312 1         1 next;
2313             }
2314              
2315 2         10 ($line, $height) = $self->paragraph($line, $width, $height, %opts);
2316 2 100       8 $overflow .= $line if length($line);
2317             }
2318              
2319 1 50       4 return ($overflow, $height) if wantarray();
2320 1         4 return $overflow;
2321             }
2322              
2323 9         12 my $w;
2324 9         23 while (length($text) > 0) {
2325 21         24 $height -= $leading;
2326 21 100       39 last if $height < 0;
2327              
2328 19   100     44 my $align = $opts{'align'} // 'left';
2329 19 100       44 if ($align eq 'justified') {
    100          
    100          
2330 8         33 ($w, $text) = $self->text_fill_justified($text, $width, %opts);
2331             }
2332             elsif ($align eq 'right') {
2333 2         16 ($w, $text) = $self->text_fill_right($text, $width, %opts);
2334             }
2335             elsif ($align eq 'center') {
2336 2         14 ($w, $text) = $self->text_fill_center($text, $width, %opts);
2337             }
2338             else {
2339 7         22 ($w, $text) = $self->text_fill_left($text, $width, %opts);
2340             }
2341 19         42 $self->crlf();
2342             }
2343              
2344 9 100       24 return ($text, $height) if wantarray();
2345 7         17 return $text;
2346             }
2347              
2348             # Deprecated former name
2349 0     0 1 0 sub section { return paragraphs(@_) }
2350              
2351             # Deprecated; merged into paragraph
2352 1     1 1 21 sub paragraphs { return paragraph(@_) }
2353              
2354             sub textlabel {
2355 0     0 0 0 my ($self, $x, $y, $font, $size, $text, %opts, $wht) = @_;
2356 0         0 my %trans_opts = (-translate => [$x,$y]);
2357 0         0 my %text_state;
2358 0 0       0 $trans_opts{'-rotate'} = $opts{'-rotate'} if $opts{'-rotate'};
2359              
2360 0         0 my $wastext = $self->_in_text_object();
2361 0 0       0 if ($wastext) {
2362 0         0 %text_state = $self->textstate();
2363 0         0 $self->textend();
2364             }
2365 0         0 $self->save();
2366 0         0 $self->textstart();
2367              
2368 0         0 $self->transform(%trans_opts);
2369              
2370 0 0       0 if ($opts{'-color'}) {
2371 0 0       0 my $color = ref($opts{'-color'}) ? @{$opts{'-color'}} : $opts{'-color'};
  0         0  
2372 0         0 $self->fillcolor($color);
2373             }
2374 0 0       0 if ($opts{'-strokecolor'}) {
2375             my $color = (ref($opts{'-strokecolor'})
2376 0         0 ? @{$opts{'-strokecolor'}}
2377 0 0       0 : $opts{'-strokecolor'});
2378 0         0 $self->strokecolor($color);
2379             }
2380              
2381 0         0 $self->font($font, $size);
2382              
2383 0 0       0 $self->charspace($opts{'-charspace'}) if $opts{'-charspace'};
2384 0 0       0 $self->hscale($opts{'-hscale'}) if $opts{'-hscale'};
2385 0 0       0 $self->wordspace($opts{'-wordspace'}) if $opts{'-wordspace'};
2386 0 0       0 $self->render($opts{'-render'}) if $opts{'-render'};
2387              
2388 0   0     0 my $align = $opts{'-align'} // 'left';
2389 0 0 0     0 if ($opts{'-right'} or $align =~ /^r/i) {
    0 0        
2390 0         0 $wht = $self->text_right($text, %opts);
2391             }
2392             elsif ($opts{'-center'} or $align =~ /^c/i) {
2393 0         0 $wht = $self->text_center($text, %opts);
2394             }
2395             else {
2396 0         0 $wht = $self->text($text, %opts);
2397             }
2398              
2399 0         0 $self->textend();
2400 0         0 $self->restore();
2401              
2402 0 0       0 if ($wastext) {
2403 0         0 $self->textstart();
2404 0         0 $self->textstate(%text_state);
2405             }
2406 0         0 return $wht;
2407             }
2408              
2409             =head2 text_width
2410              
2411             my $width = $content->text_width($line, %overrides);
2412              
2413             Returns the width of a line of text based on the current text state attributes.
2414             These can optionally be overridden:
2415              
2416             my $width = $content->text_width($line,
2417             font => $font,
2418             size => $size,
2419             character_spacing => $spacing,
2420             word_spacing => $spacing,
2421             hscale => $scale,
2422             );
2423              
2424             =cut
2425              
2426             # Deprecated (renamed)
2427 153     153 1 1057 sub advancewidth { return text_width(@_) }
2428              
2429             sub text_width {
2430 183     183 1 276 my ($self, $text, %opts) = @_;
2431 183 50 33     520 return 0 unless defined($text) and length($text);
2432              
2433             # Convert new names to old names
2434 183 50       285 if (exists $opts{'size'}) {
2435 0         0 $opts{'fontsize'} = delete $opts{'size'};
2436             }
2437 183 50       274 if (exists $opts{'character_spacing'}) {
2438 0         0 $opts{'charspace'} = delete $opts{'character_spacing'};
2439             }
2440 183 50       251 if (exists $opts{'word_spacing'}) {
2441 0         0 $opts{'charspace'} = delete $opts{'word_spacing'};
2442             }
2443              
2444 183         289 foreach my $k (qw(font fontsize wordspace charspace hscale)) {
2445 915 100       1904 $opts{$k} = $self->{" $k"} unless defined $opts{$k};
2446             }
2447              
2448             # Width of glyphs
2449 183         381 my $width = $opts{'font'}->width($text) * $opts{'fontsize'};
2450              
2451             # Width of space characters
2452 183         284 my $space_count = $text =~ y/\x20/\x20/;
2453 183         250 $width += $opts{'wordspace'} * $space_count;
2454              
2455             # Width of space between characters
2456 183         223 my $char_count = length($text);
2457 183         233 $width += $opts{'charspace'} * ($char_count - 1);
2458              
2459             # Horizontal scale multiplier
2460 183         232 $width *= $opts{'hscale'} / 100;
2461              
2462 183         508 return $width;
2463             }
2464              
2465             sub metaStart {
2466 0     0 0 0 my ($self, $tag, $obj) = @_;
2467 0         0 $self->add("/$tag");
2468 0 0       0 if (defined $obj) {
2469 0         0 my $dict = PDFDict();
2470 0         0 $dict->{'Metadata'} = $obj;
2471 0         0 $self->resource('Properties', $obj->name(), $dict);
2472 0         0 $self->add('/' . $obj->name());
2473 0         0 $self->add('BDC');
2474             }
2475             else {
2476 0         0 $self->add('BMC');
2477             }
2478 0         0 return $self;
2479             }
2480              
2481             sub metaEnd {
2482 0     0 0 0 my $self = shift();
2483 0         0 $self->add('EMC');
2484 0         0 return $self;
2485             }
2486              
2487             sub add_post {
2488 0     0 0 0 my $self = shift();
2489 0 0       0 if (@_) {
2490 0 0       0 unless ($self->{' poststream'} =~ /\s$/) {
2491 0         0 $self->{' poststream'} .= ' ';
2492             }
2493 0         0 $self->{' poststream'} .= join(' ', @_) . ' ';
2494             }
2495 0         0 return $self;
2496             }
2497              
2498             sub add {
2499 778     778 1 1185 my $self = shift();
2500 778 50       1517 if (@_) {
2501 778 100       2647 unless ($self->{' stream'} =~ /\s$/) {
2502 129         312 $self->{' stream'} .= ' ';
2503             }
2504 778         3211 $self->{' stream'} .= encode('iso-8859-1', join(' ', @_) . ' ');
2505             }
2506 778         24902 return $self;
2507             }
2508              
2509             # Shortcut method for determining if we're inside a text object
2510             # (i.e. between BT and ET). See textstart and textend.
2511             sub _in_text_object {
2512 500     500   729 my $self = shift();
2513 500         1197 return $self->{' apiistext'};
2514             }
2515              
2516             sub compressFlate {
2517 28     28 0 55 my $self = shift();
2518 28         87 $self->{'Filter'} = PDFArray(PDFName('FlateDecode'));
2519 28         71 $self->{'-docompress'} = 1;
2520 28         64 return $self;
2521             }
2522              
2523             sub textstart {
2524 19     19 0 38 my $self = shift();
2525 19 50       60 unless ($self->_in_text_object()) {
2526 19         74 $self->add(' BT ');
2527 19         47 $self->{' apiistext'} = 1;
2528 19         35 $self->{' font'} = undef;
2529 19         33 $self->{' fontset'} = 0;
2530 19         31 $self->{' fontsize'} = 0;
2531 19         36 $self->{' charspace'} = 0;
2532 19         30 $self->{' hscale'} = 100;
2533 19         29 $self->{' wordspace'} = 0;
2534 19         26 $self->{' leading'} = 0;
2535 19         28 $self->{' rise'} = 0;
2536 19         29 $self->{' render'} = 0;
2537 19         38 @{$self->{' matrix'}} = (1, 0, 0, 1, 0, 0);
  19         46  
2538 19         36 @{$self->{' textmatrix'}} = (1, 0, 0, 1, 0, 0);
  19         39  
2539 19         29 @{$self->{' textlinematrix'}} = (0, 0);
  19         31  
2540 19         34 @{$self->{' fillcolor'}} = 0;
  19         33  
2541 19         34 @{$self->{' strokecolor'}} = 0;
  19         26  
2542 19         33 @{$self->{' translate'}} = (0, 0);
  19         33  
2543 19         30 @{$self->{' scale'}} = (1, 1);
  19         30  
2544 19         28 @{$self->{' skew'}} = (0, 0);
  19         31  
2545 19         30 $self->{' rotate'} = 0;
2546             }
2547 19         54 return $self;
2548             }
2549              
2550             sub textend {
2551 123     123 0 195 my $self = shift();
2552 123 100       295 if ($self->_in_text_object()) {
2553 15         59 $self->add(' ET ', $self->{' poststream'});
2554 15         26 $self->{' apiistext'} = 0;
2555 15         31 $self->{' poststream'} = '';
2556             }
2557 123         210 return $self;
2558             }
2559              
2560             sub resource {
2561 31     31 0 111 my ($self, $type, $key, $obj, $force) = @_;
2562 31 100       113 if ($self->{' apipage'}) {
2563             # we are a content stream on a page.
2564 29         162 return $self->{' apipage'}->resource($type, $key, $obj, $force);
2565             }
2566             else {
2567             # we are a self-contained content stream.
2568 2   33     9 $self->{'Resources'} //= PDFDict();
2569              
2570 2         5 my $dict = $self->{'Resources'};
2571 2 50       12 $dict->realise() if ref($dict) =~ /Objind$/;
2572              
2573 2   33     16 $dict->{$type} ||= PDFDict();
2574 2 50       11 $dict->{$type}->realise() if ref($dict->{$type}) =~ /Objind$/;
2575 2 50       10 unless (defined $obj) {
2576 0           return $dict->{$type}->{$key};
2577             }
2578             else {
2579 2 50       6 if ($force) {
2580 0         0 $dict->{$type}->{$key} = $obj;
2581             }
2582             else {
2583 2   33     11 $dict->{$type}->{$key} //= $obj;
2584             }
2585 2         7 return $dict;
2586             }
2587             }
2588             }
2589              
2590             =head1 MIGRATION
2591              
2592             See L for an overview.
2593              
2594             =over
2595              
2596             =item transform(%hyphen_prefixed_options);
2597              
2598             Remove hyphens from option names (C<-translate> becomes C, etc.).
2599              
2600             =item transform_rel
2601              
2602             Replace with L, setting option C to true. Remove
2603             hyphens from the names of other options.
2604              
2605             =item linewidth
2606              
2607             Replace with L.
2608              
2609             =item linecap
2610              
2611             Replace with L.
2612              
2613             =item linejoin
2614              
2615             Replace with L.
2616              
2617             =item meterlimit
2618              
2619             =item miterlimit
2620              
2621             Replace with L.
2622              
2623             =item linedash
2624              
2625             Replace with L. Remove hyphens from option names. Rename
2626             C<-shift> to C.
2627              
2628             =item flatness
2629              
2630             Replace with L.
2631              
2632             =item poly
2633              
2634             Replace with L (first two arguments) and L (remaining
2635             arguments).
2636              
2637             =item endpath
2638              
2639             Replace with L.
2640              
2641             =item rect
2642              
2643             Replace with L, converting the C<$w> (third) and C<$h> (fourth)
2644             arguments to the X and Y values of the upper-right corner:
2645              
2646             # Old
2647             $content->rect($x, $y, $w, $h);
2648              
2649             # New
2650             $content->rectangle($x, $y, $x + $w, $y + $h);
2651              
2652             =item rectxy
2653              
2654             Replace with L.
2655              
2656             =item fill(1)
2657              
2658             Replace with C<$content-Efill(rule =E 'even-odd')>.
2659              
2660             =item fillstroke
2661              
2662             Replace with L.
2663              
2664             =item clip(1)
2665              
2666             Replace with C<$content-Eclip(rule =E 'even-odd')>.
2667              
2668             =item image
2669              
2670             =item formimage
2671              
2672             Replace with L.
2673              
2674             =item charspace
2675              
2676             Replace with L.
2677              
2678             =item wordspace
2679              
2680             Replace with L.
2681              
2682             =item hspace
2683              
2684             Replace with L.
2685              
2686             =item lead
2687              
2688             Replace with L.
2689              
2690             =item distance
2691              
2692             Replace with L.
2693              
2694             =item cr
2695              
2696             Replace with either L (if called with arguments) or L (if
2697             called without arguments).
2698              
2699             =item nl
2700              
2701             Replace with L.
2702              
2703             =item text(%hyphen_prefixed_options)
2704              
2705             Remove initial hyphens from option names.
2706              
2707             =item text_center
2708              
2709             Replace with L, setting C to C
.
2710              
2711             =item text_right
2712              
2713             Replace with L, setting C to C.
2714              
2715             =item paragraph(%hyphen_prefixed_options)
2716              
2717             Remove initial hyphens from option names. C<-align-last> becomes C.
2718              
2719             =item section
2720              
2721             =item paragraphs
2722              
2723             Replace with L.
2724              
2725             =item advancewidth
2726              
2727             Replace with L.
2728              
2729             =back
2730              
2731             =cut
2732              
2733             1;