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