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