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