File Coverage

blib/lib/PDF/API2/Content.pm
Criterion Covered Total %
statement 774 1035 74.7
branch 209 372 56.1
condition 56 160 35.0
subroutine 128 146 87.6
pod 79 101 78.2
total 1246 1814 68.6


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