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