1#!@PERL@ -w 2# 3# gropdf : PDF post processor for groff 4# 5# Copyright (C) 2011-2018 Free Software Foundation, Inc. 6# Written by Deri James <deri@chuzzlewit.myzen.co.uk> 7# 8# This file is part of groff. 9# 10# groff is free software; you can redistribute it and/or modify it under 11# the terms of the GNU General Public License as published by the Free 12# Software Foundation, either version 3 of the License, or 13# (at your option) any later version. 14# 15# groff is distributed in the hope that it will be useful, but WITHOUT ANY 16# WARRANTY; without even the implied warranty of MERCHANTABILITY or 17# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 18# for more details. 19# 20# You should have received a copy of the GNU General Public License 21# along with this program. If not, see <http://www.gnu.org/licenses/>. 22 23use strict; 24use Getopt::Long qw(:config bundling); 25 26use constant 27{ 28 WIDTH => 0, 29 CHRCODE => 1, 30 PSNAME => 2, 31 ASSIGNED => 3, 32 USED => 4, 33}; 34 35my $gotzlib=0; 36 37my $rc = eval 38{ 39 require Compress::Zlib; 40 Compress::Zlib->import(); 41 1; 42}; 43 44if($rc) 45{ 46 $gotzlib=1; 47} 48else 49{ 50 Msg(0,"Perl module Compress::Zlib not available - cannot compress this pdf"); 51} 52 53my %cfg; 54 55$cfg{GROFF_VERSION}='@VERSION@'; 56$cfg{GROFF_FONT_PATH}='@GROFF_FONT_DIR@'; 57$cfg{RT_SEP}='@RT_SEP@'; 58binmode(STDOUT); 59 60my @obj; # Array of PDF objects 61my $objct=0; # Count of Objects 62my $fct=0; # Output count 63my %fnt; # Used fonts 64my $lct=0; # Input Line Count 65my $src_name=''; 66my %env; # Current environment 67my %fontlst; # Fonts Loaded 68my $rot=0; # Portrait 69my %desc; # Contents of DESC 70my %download; # Contents of downlopad file 71my $pages; # Pointer to /Pages object 72my $devnm='devpdf'; 73my $cpage; # Pointer to current pages 74my $cpageno=0; # Object no of current page 75my $cat; # Pointer to catalogue 76my $dests; # Pointer to Dests 77my @mediabox=(0,0,595,842); 78my @defaultmb=(0,0,595,842); 79my $stream=''; # Current Text/Graphics stream 80my $cftsz=10; # Current font sz 81my $cft; # Current Font 82my $lwidth=1; # current linewidth 83my $linecap=1; 84my $linejoin=1; 85my $textcol=''; # Current groff text 86my $fillcol=''; # Current groff fill 87my $curfill=''; # Current PDF fill 88my $strkcol=''; 89my $curstrk=''; 90my @lin=(); # Array holding current line of text 91my @ahead=(); # Buffer used to hol the next line 92my $mode='g'; # Graphic (g) or Text (t) mode; 93my $xpos=0; # Current X position 94my $ypos=0; # Current Y position 95my $tmxpos=0; 96my $kernadjust=0; 97my $curkern=0; 98my $widtbl; # Pointer to width table for current font size 99my $origwidtbl; # Pointer to width table 100my $krntbl; # Pointer to kern table 101my $matrix="1 0 0 1"; 102my $whtsz; # Current width of a space 103my $poschg=0; # V/H pending 104my $fontchg=0; # font change pending 105my $tnum=2; # flatness of B-Spline curve 106my $tden=3; # flatness of B-Spline curve 107my $linewidth=40; 108my $w_flg=0; 109my $nomove=0; 110my $pendmv=0; 111my $gotT=0; 112my $suppress=0; # Suppress processing? 113my %incfil; # Included Files 114my @outlev=([0,undef,0,0]); # Structure pdfmark /OUT entries 115my $curoutlev=\@outlev; 116my $curoutlevno=0; # Growth point for @curoutlev 117my $Foundry=''; 118my $xrev=0; # Reverse x direction of font 119my $matrixchg=0; 120my $wt=-1; 121my $thislev=1; 122my $mark=undef; 123my $suspendmark=undef; 124 125 126 127my $n_flg=1; 128my $pginsert=-1; # Growth point for kids array 129my %pgnames; # 'names' of pages for switchtopage 130my @outlines=(); # State of Bookmark Outlines at end of each page 131my $custompaper=0; # Has there been an X papersize 132my $textenccmap=''; # CMap for groff text.enc encoding 133my @XOstream=(); 134my @PageAnnots={}; 135my $noslide=0; 136my $transition={PAGE => {Type => '/Trans', S => '', D => 1, Dm => '/H', M => '/I', Di => 0, SS => 1.0, B => 0}, 137 BLOCK => {Type => '/Trans', S => '', D => 1, Dm => '/H', M => '/I', Di => 0, SS => 1.0, B => 0}}; 138my $firstpause=0; 139my $present=0; 140 141$noslide=1 if exists($ENV{GROPDF_NOSLIDE}) and $ENV{GROPDF_NOSLIDE}; 142 143my %ppsz=( 'ledger'=>[1224,792], 144 'legal'=>[612,1008], 145 'letter'=>[612,792], 146 'a0'=>[2384,3370], 147 'a1'=>[1684,2384], 148 'a2'=>[1191,1684], 149 'a3'=>[842,1191], 150 'a4'=>[595,842], 151 'a5'=>[420,595], 152 'a6'=>[297,420], 153 'a7'=>[210,297], 154 'a8'=>[148,210], 155 'a9'=>[105,148], 156 'a10'=>[73,105], 157 'isob0'=>[2835,4008], 158 'isob1'=>[2004,2835], 159 'isob2'=>[1417,2004], 160 'isob3'=>[1001,1417], 161 'isob4'=>[709,1001], 162 'isob5'=>[499,709], 163 'isob6'=>[354,499], 164 'c0'=>[2599,3677], 165 'c1'=>[1837,2599], 166 'c2'=>[1298,1837], 167 'c3'=>[918,1298], 168 'c4'=>[649,918], 169 'c5'=>[459,649], 170 'c6'=>[323,459] ); 171 172my $ucmap=<<'EOF'; 173/CIDInit /ProcSet findresource begin 17412 dict begin 175begincmap 176/CIDSystemInfo 177<< /Registry (Adobe) 178/Ordering (UCS) 179/Supplement 0 180>> def 181/CMapName /Adobe-Identity-UCS def 182/CMapType 2 def 1831 begincodespacerange 184<0000> <FFFF> 185endcodespacerange 1862 beginbfrange 187<008b> <008f> [<00660066> <00660069> <0066006c> <006600660069> <00660066006C>] 188<00ad> <00ad> <002d> 189endbfrange 190endcmap 191CMapName currentdict /CMap defineresource pop 192end 193end 194EOF 195 196my $fd; 197my $frot; 198my $fpsz; 199my $embedall=0; 200my $debug=0; 201my $version=0; 202my $stats=0; 203my $unicodemap; 204my @idirs; 205 206#Load_Config(); 207 208GetOptions("F=s" => \$fd, 'I=s' => \@idirs, 'l' => \$frot, 'p=s' => \$fpsz, 'd!' => \$debug, 'v' => \$version, 'version' => \$version, 'e' => \$embedall, 'y=s' => \$Foundry, 's' => \$stats, 'u:s' => \$unicodemap); 209 210unshift(@idirs,'.'); 211 212if ($version) 213{ 214 print "GNU gropdf (groff) version $cfg{GROFF_VERSION}\n"; 215 exit; 216} 217 218if (defined($unicodemap)) 219{ 220 if ($unicodemap eq '') 221 { 222 $ucmap=''; 223 } 224 elsif (-r $unicodemap) 225 { 226 local $/; 227 open(F,"<$unicodemap") or die "gropdf: Failed to open '$unicodemap'"; 228 ($ucmap)=(<F>); 229 close(F); 230 } 231 else 232 { 233 Msg(0,"Failed to find '$unicodemap' - ignoring"); 234 } 235} 236 237# Search for 'font directory': paths in -f opt, shell var GROFF_FONT_PATH, default paths 238 239my $fontdir=$cfg{GROFF_FONT_PATH}; 240$fontdir=$ENV{GROFF_FONT_PATH}.$cfg{RT_SEP}.$fontdir if exists($ENV{GROFF_FONT_PATH}); 241$fontdir=$fd.$cfg{RT_SEP}.$fontdir if defined($fd); 242 243$rot=90 if $frot; 244$matrix="0 1 -1 0" if $frot; 245 246LoadDownload(); 247LoadDesc(); 248 249my $unitwidth=$desc{unitwidth}; 250my $papersz=$desc{papersize}; 251$papersz=lc($fpsz) if $fpsz; 252 253$env{FontHT}=0; 254$env{FontSlant}=0; 255MakeMatrix(); 256 257if (substr($papersz,0,1) eq '/' and -r $papersz) 258{ 259 if (open(P,"<$papersz")) 260 { 261 while (<P>) 262 { 263 chomp; 264 s/# .*//; 265 next if $_ eq ''; 266 $papersz=$_; 267 last 268 } 269 270 close(P); 271 } 272} 273 274if ($papersz=~m/([\d.]+)([cipP]),([\d.]+)([cipP])/) 275{ 276 @defaultmb=@mediabox=(0,0,ToPoints($3,$4),ToPoints($1,$2)); 277} 278elsif (exists($ppsz{$papersz})) 279{ 280 @defaultmb=@mediabox=(0,0,$ppsz{$papersz}->[0],$ppsz{$papersz}->[1]); 281} 282 283my (@dt)=localtime($ENV{SOURCE_DATE_EPOCH} || time); 284my $dt=PDFDate(\@dt); 285 286my %info=('Creator' => "(groff version $cfg{GROFF_VERSION})", 287 'Producer' => "(gropdf version $cfg{GROFF_VERSION})", 288 'ModDate' => "($dt)", 289 'CreationDate' => "($dt)"); 290 291while (<>) 292{ 293 chomp; 294 s/\r$//; 295 $lct++; 296 297 do # The ahead buffer behaves like 'ungetc' 298 {{ 299 if (scalar(@ahead)) 300 { 301 $_=shift(@ahead); 302 } 303 304 305 my $cmd=substr($_,0,1); 306 next if $cmd eq '#'; # just a comment 307 my $lin=substr($_,1); 308 309 while ($cmd eq 'w') 310 { 311 $cmd=substr($lin,0,1); 312 $lin=substr($lin,1); 313 $w_flg=1 if $gotT; 314 } 315 316 $lin=~s/^\s+//; 317# $lin=~s/\s#.*?$//; # remove comment 318 $stream.="\% $_\n" if $debug; 319 320 do_x($lin),next if ($cmd eq 'x'); 321 next if $suppress; 322 do_p($lin),next if ($cmd eq 'p'); 323 do_f($lin),next if ($cmd eq 'f'); 324 do_s($lin),next if ($cmd eq 's'); 325 do_m($lin),next if ($cmd eq 'm'); 326 do_D($lin),next if ($cmd eq 'D'); 327 do_V($lin),next if ($cmd eq 'V'); 328 do_v($lin),next if ($cmd eq 'v'); 329 do_t($lin),next if ($cmd eq 't'); 330 do_u($lin),next if ($cmd eq 'u'); 331 do_C($lin),next if ($cmd eq 'C'); 332 do_c($lin),next if ($cmd eq 'c'); 333 do_N($lin),next if ($cmd eq 'N'); 334 do_h($lin),next if ($cmd eq 'h'); 335 do_H($lin),next if ($cmd eq 'H'); 336 do_n($lin),next if ($cmd eq 'n'); 337 338 my $tmp=scalar(@ahead); 339 }} until scalar(@ahead) == 0; 340 341} 342 343exit 0 if $lct==0; 344 345if ($cpageno > 0) 346{ 347 my $trans='BLOCK'; 348 349 $trans='PAGE' if $firstpause; 350 351 if (scalar(@XOstream)) 352 { 353 MakeXO() if $stream; 354 $stream=join("\n",@XOstream)."\n"; 355 } 356 357 my %t=%{$transition->{$trans}}; 358 $cpage->{MediaBox}=\@mediabox if $custompaper; 359 $cpage->{Trans}=FixTrans(\%t) if $t{S}; 360 361 if ($#PageAnnots >= 0) 362 { 363 @{$cpage->{Annots}}=@PageAnnots; 364 } 365 366 PutObj($cpageno); 367 OutStream($cpageno+1); 368} 369 370$cat->{PageMode}='/FullScreen' if $present; 371 372PutOutlines(\@outlev); 373 374PutObj(1); 375 376my $info=BuildObj(++$objct,\%info); 377 378PutObj($objct); 379 380foreach my $fontno (keys %fontlst) 381{ 382 my $o=$fontlst{$fontno}->{FNT}; 383 384 foreach my $ch (@{$o->{NO}}) 385 { 386 my $psname=$o->{NAM}->{$ch->[1]}->[PSNAME] || '/.notdef'; 387 my $wid=$o->{NAM}->{$ch->[1]}->[WIDTH] || 0; 388 389 push(@{$o->{DIFF}},$psname); 390 push(@{$o->{WIDTH}},$wid); 391 last if $#{$o->{DIFF}} >= 255; 392 } 393 unshift(@{$o->{DIFF}},0); 394 my $p=GetObj($fontlst{$fontno}->{OBJ}); 395 396 if (exists($p->{LastChar}) and $p->{LastChar} > 255) 397 { 398 $p->{LastChar} = 255; 399 splice(@{$o->{DIFF}},256); 400 splice(@{$o->{WIDTH}},256); 401 } 402} 403 404foreach my $o (3..$objct) 405{ 406 PutObj($o) if (!exists($obj[$o]->{XREF})); 407} 408 409#my $encrypt=BuildObj(++$objct,{'Filter' => '/Standard', 'V' => 1, 'R' => 2, 'P' => 252}); 410#PutObj($objct); 411PutObj(2); 412 413my $xrefct=$fct; 414 415$objct+=1; 416print "xref\n0 $objct\n0000000000 65535 f \n"; 417 418foreach my $xr (@obj) 419{ 420 next if !defined($xr); 421 printf("%010d 00000 n \n",$xr->{XREF}); 422} 423 424print "trailer\n<<\n/Info $info\n/Root 1 0 R\n/Size $objct\n>>\nstartxref\n$fct\n\%\%EOF\n"; 425print "\% Pages=$pages->{Count}\n" if $stats; 426 427 428sub MakeMatrix 429{ 430 my $fontxrev=shift||0; 431 my @mat=($frot)?(0,1,-1,0):(1,0,0,1); 432 433 if (!$frot) 434 { 435 if ($env{FontHT} != 0) 436 { 437 $mat[3]=sprintf('%.3f',$env{FontHT}/$cftsz); 438 } 439 440 if ($env{FontSlant} != 0) 441 { 442 my $slant=$env{FontSlant}; 443 $slant*=$env{FontHT}/$cftsz if $env{FontHT} != 0; 444 my $ang=rad($slant); 445 446 $mat[2]=sprintf('%.3f',sin($ang)/cos($ang)); 447 } 448 449 if ($fontxrev) 450 { 451 $mat[0]=-$mat[0]; 452 } 453 } 454 455 $matrix=join(' ',@mat); 456 $matrixchg=1; 457} 458 459sub PutOutlines 460{ 461 my $o=shift; 462 my $outlines; 463 464 if ($#{$o} > 0) 465 { 466 # We've got Outlines to deal with 467 my $openct=$curoutlev->[0]->[2]; 468 469 while ($thislev-- > 1) 470 { 471 my $nxtoutlev=$curoutlev->[0]->[1]; 472 $nxtoutlev->[0]->[2]+=$openct if $curoutlev->[0]->[3]==1; 473 $openct=0 if $nxtoutlev->[0]->[3]==-1; 474 $curoutlev=$nxtoutlev; 475 } 476 477 $cat->{Outlines}=BuildObj(++$objct,{'Count' => abs($o->[0]->[0])+$o->[0]->[2]}); 478 $outlines=$obj[$objct]->{DATA}; 479 } 480 else 481 { 482 return; 483 } 484 485 SetOutObj($o); 486 487 $outlines->{First}=$o->[1]->[2]; 488 $outlines->{Last}=$o->[$#{$o}]->[2]; 489 490 LinkOutObj($o,$cat->{Outlines}); 491} 492 493sub SetOutObj 494{ 495 my $o=shift; 496 497 for my $j (1..$#{$o}) 498 { 499 my $ono=BuildObj(++$objct,$o->[$j]->[0]); 500 $o->[$j]->[2]=$ono; 501 502 SetOutObj($o->[$j]->[1]) if $#{$o->[$j]->[1]} > -1; 503 } 504} 505 506sub LinkOutObj 507{ 508 my $o=shift; 509 my $parent=shift; 510 511 for my $j (1..$#{$o}) 512 { 513 my $op=GetObj($o->[$j]->[2]); 514 515 $op->{Next}=$o->[$j+1]->[2] if ($j < $#{$o}); 516 $op->{Prev}=$o->[$j-1]->[2] if ($j > 1); 517 $op->{Parent}=$parent; 518 519 if ($#{$o->[$j]->[1]} > -1) 520 { 521 $op->{Count}=$o->[$j]->[1]->[0]->[2]*$o->[$j]->[1]->[0]->[3];# if exists($op->{Count}) and $op->{Count} > 0; 522 $op->{First}=$o->[$j]->[1]->[1]->[2]; 523 $op->{Last}=$o->[$j]->[1]->[$#{$o->[$j]->[1]}]->[2]; 524 LinkOutObj($o->[$j]->[1],$o->[$j]->[2]); 525 } 526 } 527} 528 529sub GetObj 530{ 531 my $ono=shift; 532 ($ono)=split(' ',$ono); 533 return($obj[$ono]->{DATA}); 534} 535 536 537 538sub PDFDate 539{ 540 my $dt=shift; 541 return(sprintf("D:%04d%02d%02d%02d%02d%02d%+03d'00'",$dt->[5]+1900,$dt->[4]+1,$dt->[3],$dt->[2],$dt->[1],$dt->[0],( localtime time() + 3600*( 12 - (gmtime)[2] ) )[2] - 12)); 542} 543 544sub ToPoints 545{ 546 my $num=shift; 547 my $unit=shift; 548 549 if ($unit eq 'i') 550 { 551 return($num*72); 552 } 553 elsif ($unit eq 'c') 554 { 555 return int($num*72/2.54); 556 } 557 elsif ($unit eq 'm') # millimetres 558 { 559 return int($num*72/25.4); 560 } 561 elsif ($unit eq 'p') 562 { 563 return($num); 564 } 565 elsif ($unit eq 'P') 566 { 567 return($num*6); 568 } 569 elsif ($unit eq 'z') 570 { 571 return($num/$unitwidth); 572 } 573 else 574 { 575 Msg(1,"Unknown scaling factor '$unit'"); 576 } 577} 578 579sub Load_Config 580{ 581 open(CFG,"<gropdf_config") or die "Can't open config file: $!"; 582 583 while (<CFG>) 584 { 585 chomp; 586 my ($key,$val)=split(/ ?= ?/); 587 588 $cfg{$key}=$val; 589 } 590 591 close(CFG); 592} 593 594sub LoadDownload 595{ 596 my $f; 597 my $found=0; 598 599 my (@dirs)=split($cfg{RT_SEP},$fontdir); 600 601 foreach my $dir (@dirs) 602 { 603 $f=undef; 604 OpenFile(\$f,$dir,"download"); 605 next if !defined($f); 606 $found++; 607 608 while (<$f>) 609 { 610 chomp; 611 s/#.*$//; 612 next if $_ eq ''; 613 my ($foundry,$name,$file)=split(/\t+/); 614 if (substr($file,0,1) eq '*') 615 { 616 next if !$embedall; 617 $file=substr($file,1); 618 } 619 620 $download{"$foundry $name"}=$file; 621 } 622 623 close($f); 624 } 625 626 Msg(1,"Failed to open 'download'") if !$found; 627} 628 629sub OpenFile 630{ 631 my $f=shift; 632 my $dirs=shift; 633 my $fnm=shift; 634 635 if (substr($fnm,0,1) eq '/' or substr($fnm,1,1) eq ':') # dos 636 { 637 return if -r "$fnm" and open($$f,"<$fnm"); 638 } 639 640 my (@dirs)=split($cfg{RT_SEP},$dirs); 641 642 foreach my $dir (@dirs) 643 { 644 last if -r "$dir/$devnm/$fnm" and open($$f,"<$dir/$devnm/$fnm"); 645 } 646} 647 648sub LoadDesc 649{ 650 my $f; 651 652 OpenFile(\$f,$fontdir,"DESC"); 653 Msg(1,"Failed to open 'DESC'") if !defined($f); 654 655 while (<$f>) 656 { 657 chomp; 658 s/#.*$//; 659 next if $_ eq ''; 660 my ($name,$prms)=split(' ',$_,2); 661 $desc{lc($name)}=$prms; 662 } 663 664 close($f); 665} 666 667sub rad { $_[0]*3.14159/180 } 668 669my $InPicRotate=0; 670 671sub do_x 672{ 673 my $l=shift; 674 my ($xcmd,@xprm)=split(' ',$l); 675 $xcmd=substr($xcmd,0,1); 676 677 if ($xcmd eq 'T') 678 { 679 Msg(0,"Expecting a pdf pipe (got $xprm[0])") if $xprm[0] ne substr($devnm,3); 680 } 681 elsif ($xcmd eq 'f') # Register Font 682 { 683 $xprm[1]="${Foundry}-$xprm[1]" if $Foundry ne ''; 684 LoadFont($xprm[0],$xprm[1]); 685 } 686 elsif ($xcmd eq 'F') # Source File (for errors) 687 { 688 $env{SourceFile}=$xprm[0]; 689 } 690 elsif ($xcmd eq 'H') # FontHT 691 { 692 $xprm[0]/=$unitwidth; 693 $xprm[0]=0 if $xprm[0] == $cftsz; 694 $env{FontHT}=$xprm[0]; 695 MakeMatrix(); 696 } 697 elsif ($xcmd eq 'S') # FontSlant 698 { 699 $env{FontSlant}=$xprm[0]; 700 MakeMatrix(); 701 } 702 elsif ($xcmd eq 'i') # Initialise 703 { 704 if ($objct == 0) 705 { 706 $objct++; 707 @defaultmb=@mediabox; 708 BuildObj($objct,{'Pages' => BuildObj($objct+1, 709 {'Kids' => [], 710 'Count' => 0, 711 'Type' => '/Pages', 712 'Rotate' => $rot, 713 'MediaBox' => \@defaultmb, 714 'Resources' => 715 {'Font' => {}, 716 'ProcSet' => ['/PDF', '/Text', '/ImageB', '/ImageC', '/ImageI']} 717 } 718 ), 719 'Type' => '/Catalog'}); 720 721 $cat=$obj[$objct]->{DATA}; 722 $objct++; 723 $pages=$obj[2]->{DATA}; 724 Put("%PDF-1.4\n\x25\xe2\xe3\xcf\xd3\n"); 725 } 726 } 727 elsif ($xcmd eq 'X') 728 { 729 # There could be extended args 730 do 731 {{ 732 LoadAhead(1); 733 if (substr($ahead[0],0,1) eq '+') 734 { 735 $l.="\n".substr($ahead[0],1); 736 shift(@ahead); 737 } 738 }} until $#ahead==0; 739 740 ($xcmd,@xprm)=split(' ',$l); 741 $xcmd=substr($xcmd,0,1); 742 743 if ($xprm[0]=~m/^(.+:)(.+)/) 744 { 745 splice(@xprm,1,0,$2); 746 $xprm[0]=$1; 747 } 748 749 my $par=join(' ',@xprm[1..$#xprm]); 750 751 if ($xprm[0] eq 'ps:') 752 { 753 if ($xprm[1] eq 'invis') 754 { 755 $suppress=1; 756 } 757 elsif ($xprm[1] eq 'endinvis') 758 { 759 $suppress=0; 760 } 761 elsif ($par=~m/exec gsave currentpoint 2 copy translate (.+) rotate neg exch neg exch translate/) 762 { 763 # This is added by gpic to rotate a single object 764 765 my $theta=-rad($1); 766 767 IsGraphic(); 768 my ($curangle,$hyp)=RtoP($xpos,GraphY($ypos)); 769 my ($x,$y)=PtoR($theta+$curangle,$hyp); 770 $stream.="q\n".sprintf("%.3f %.3f %.3f %.3f %.3f %.3f cm",cos($theta),sin($theta),-sin($theta),cos($theta),$xpos-$x,GraphY($ypos)-$y)."\n"; 771 $InPicRotate=1; 772 } 773 elsif ($par=~m/exec grestore/ and $InPicRotate) 774 { 775 IsGraphic(); 776 $stream.="Q\n"; 777 $InPicRotate=0; 778 } 779 elsif ($par=~m/exec (\d) setlinejoin/) 780 { 781 IsGraphic(); 782 $linejoin=$1; 783 $stream.="$linejoin j\n"; 784 } 785 elsif ($par=~m/exec (\d) setlinecap/) 786 { 787 IsGraphic(); 788 $linecap=$1; 789 $stream.="$linecap J\n"; 790 } 791 elsif ($par=~m/exec %%%%PAUSE/i and !$noslide) 792 { 793 my $trans='BLOCK'; 794 795 if ($firstpause) 796 { 797 $trans='PAGE'; 798 $firstpause=0; 799 } 800 MakeXO(); 801 NewPage($trans); 802 $present=1; 803 } 804 elsif ($par=~m/exec %%%%BEGINONCE/) 805 { 806 if ($noslide) 807 { 808 $suppress=1; 809 } 810 else 811 { 812 my $trans='BLOCK'; 813 814 if ($firstpause) 815 { 816 $trans='PAGE'; 817 $firstpause=0; 818 } 819 MakeXO(); 820 NewPage($trans); 821 $present=1; 822 } 823 } 824 elsif ($par=~m/exec %%%%ENDONCE/) 825 { 826 if ($noslide) 827 { 828 $suppress=0; 829 } 830 else 831 { 832 MakeXO(); 833 NewPage('BLOCK'); 834 $cat->{PageMode}='/FullScreen'; 835 pop(@XOstream); 836 } 837 } 838 elsif ($par=~m/\[(.+) pdfmark/) 839 { 840 my $pdfmark=$1; 841 $pdfmark=~s((\d{4,6}) u)(sprintf("%.1f",$1/$desc{sizescale}))eg; 842 $pdfmark=~s(\\\[u00(..)\])(chr(hex($1)))eg; 843 844 if ($pdfmark=~m/(.+) \/DOCINFO/) 845 { 846 my @xwds=split(' ',"<< $1 >>"); 847 my $docinfo=ParsePDFValue(\@xwds); 848 849 foreach my $k (keys %{$docinfo}) 850 { 851 $info{$k}=$docinfo->{$k} if $k ne 'Producer'; 852 } 853 } 854 elsif ($pdfmark=~m/(.+) \/DOCVIEW/) 855 { 856 my @xwds=split(' ',"<< $1 >>"); 857 my $docview=ParsePDFValue(\@xwds); 858 859 foreach my $k (keys %{$docview}) 860 { 861 $cat->{$k}=$docview->{$k} if !exists($cat->{$k}); 862 } 863 } 864 elsif ($pdfmark=~m/(.+) \/DEST/) 865 { 866 my @xwds=split(' ',"<< $1 >>"); 867 my $dest=ParsePDFValue(\@xwds); 868 foreach my $v (@{$dest->{View}}) 869 { 870 $v=GraphY(abs($v)) if substr($v,0,1) eq '-'; 871 } 872 unshift(@{$dest->{View}},"$cpageno 0 R"); 873 874 if (!defined($dests)) 875 { 876 $cat->{Dests}=BuildObj(++$objct,{}); 877 $dests=$obj[$objct]->{DATA}; 878 } 879 880 my $k=substr($dest->{Dest},1); 881 $dests->{$k}=$dest->{View}; 882 } 883 elsif ($pdfmark=~m/(.+) \/ANN/) 884 { 885 my $l=$1; 886 $l=~s/Color/C/; 887 $l=~s/Action/A/; 888 $l=~s/Title/T/; 889 $l=~s'/Subtype /URI'/S /URI'; 890 my @xwds=split(' ',"<< $l >>"); 891 my $annotno=BuildObj(++$objct,ParsePDFValue(\@xwds)); 892 my $annot=$obj[$objct]; 893 $annot->{DATA}->{Type}='/Annot'; 894 FixRect($annot->{DATA}->{Rect}); # Y origin to ll 895 FixPDFColour($annot->{DATA}); 896 push(@PageAnnots,$annotno); 897 } 898 elsif ($pdfmark=~m/(.+) \/OUT/) 899 { 900 my $t=$1; 901 $t=~s/\\\) /\\\\\) /g; 902 $t=~s/\\e/\\\\/g; 903 $t=~m/(^.*\/Title \()(.*)(\).*)/; 904 my ($pre,$title,$post)=($1,$2,$3); 905 $title=~s/(?<!\\)\(/\\\(/g; 906 $title=~s/(?<!\\)\)/\\\)/g; 907 my @xwds=split(' ',"<< $pre$title$post >>"); 908 my $out=ParsePDFValue(\@xwds); 909 910 my $this=[$out,[]]; 911 912 if (exists($out->{Level})) 913 { 914 my $lev=abs($out->{Level}); 915 my $levsgn=sgn($out->{Level}); 916 delete($out->{Level}); 917 918 if ($lev > $thislev) 919 { 920 my $thisoutlev=$curoutlev->[$#{$curoutlev}]->[1]; 921 $thisoutlev->[0]=[0,$curoutlev,0,$levsgn]; 922 $curoutlev=$thisoutlev; 923 $curoutlevno=$#{$curoutlev}; 924 $thislev++; 925 } 926 elsif ($lev < $thislev) 927 { 928 my $openct=$curoutlev->[0]->[2]; 929 930 while ($thislev > $lev) 931 { 932 my $nxtoutlev=$curoutlev->[0]->[1]; 933 $nxtoutlev->[0]->[2]+=$openct if $curoutlev->[0]->[3]==1; 934 $openct=0 if $nxtoutlev->[0]->[3]==-1; 935 $curoutlev=$nxtoutlev; 936 $thislev--; 937 } 938 939 $curoutlevno=$#{$curoutlev}; 940 } 941 942# push(@{$curoutlev},$this); 943 splice(@{$curoutlev},++$curoutlevno,0,$this); 944 $curoutlev->[0]->[2]++; 945 } 946 else 947 { 948 # This code supports old pdfmark.tmac, unused by pdf.tmac 949 while ($curoutlev->[0]->[0] == 0 and defined($curoutlev->[0]->[1])) 950 { 951 $curoutlev=$curoutlev->[0]->[1]; 952 } 953 954 $curoutlev->[0]->[0]--; 955 $curoutlev->[0]->[2]++; 956 push(@{$curoutlev},$this); 957 958 959 if (exists($out->{Count}) and $out->{Count} != 0) 960 { 961 push(@{$this->[1]},[abs($out->{Count}),$curoutlev,0,sgn($out->{Count})]); 962 $curoutlev=$this->[1]; 963 964 if ($out->{Count} > 0) 965 { 966 my $p=$curoutlev; 967 968 while (defined($p)) 969 { 970 $p->[0]->[2]+=$out->{Count}; 971 $p=$p->[0]->[1]; 972 } 973 } 974 } 975 } 976 } 977 } 978 } 979 elsif (lc($xprm[0]) eq 'pdf:') 980 { 981 if (lc($xprm[1]) eq 'import') 982 { 983 my $fil=$xprm[2]; 984 my $llx=$xprm[3]; 985 my $lly=$xprm[4]; 986 my $urx=$xprm[5]; 987 my $ury=$xprm[6]; 988 my $wid=$xprm[7]; 989 my $hgt=$xprm[8]||-1; 990 my $mat=[1,0,0,1,0,0]; 991 992 if (!exists($incfil{$fil})) 993 { 994 if ($fil=~m/\.pdf$/) 995 { 996 $incfil{$fil}=LoadPDF($fil,$mat,$wid,$hgt,"import"); 997 } 998 elsif ($fil=~m/\.swf$/) 999 { 1000 my $xscale=$wid/($urx-$llx+1); 1001 my $yscale=($hgt<=0)?$xscale:($hgt/($ury-$lly+1)); 1002 $hgt=($ury-$lly+1)*$yscale; 1003 1004 if ($rot) 1005 { 1006 $mat->[3]=$xscale; 1007 $mat->[0]=$yscale; 1008 } 1009 else 1010 { 1011 $mat->[0]=$xscale; 1012 $mat->[3]=$yscale; 1013 } 1014 1015 $incfil{$fil}=LoadSWF($fil,[$llx,$lly,$urx,$ury],$mat); 1016 } 1017 else 1018 { 1019 Msg(0,"Unknown filetype '$fil'"); 1020 return undef; 1021 } 1022 } 1023 1024 if (defined($incfil{$fil})) 1025 { 1026 IsGraphic(); 1027 if ($fil=~m/\.pdf$/) 1028 { 1029 my $bbox=$incfil{$fil}->[1]; 1030 my $xscale=d3($wid/($bbox->[2]-$bbox->[0]+1)); 1031 my $yscale=d3(($hgt<=0)?$xscale:($hgt/($bbox->[3]-$bbox->[1]+1))); 1032 $wid=($bbox->[2]-$bbox->[0])*$xscale; 1033 $hgt=($bbox->[3]-$bbox->[1])*$yscale; 1034 $ypos+=$hgt; 1035 $stream.="q $xscale 0 0 $yscale ".PutXY($xpos,$ypos)." cm"; 1036 $stream.=" 0 1 -1 0 0 0 cm" if $rot; 1037 $stream.=" /$incfil{$fil}->[0] Do Q\n"; 1038 } 1039 elsif ($fil=~m/\.swf$/) 1040 { 1041 $stream.=PutXY($xpos,$ypos)." m /$incfil{$fil} Do\n"; 1042 } 1043 } 1044 } 1045 elsif (lc($xprm[1]) eq 'pdfpic') 1046 { 1047 my $fil=$xprm[2]; 1048 my $flag=uc($xprm[3]||'-L'); 1049 my $wid=GetPoints($xprm[4])||-1; 1050 my $hgt=GetPoints($xprm[5]||-1); 1051 my $ll=GetPoints($xprm[6]||0); 1052 my $mat=[1,0,0,1,0,0]; 1053 1054 if (!exists($incfil{$fil})) 1055 { 1056 $incfil{$fil}=LoadPDF($fil,$mat,$wid,$hgt,"pdfpic"); 1057 } 1058 1059 if (defined($incfil{$fil})) 1060 { 1061 IsGraphic(); 1062 my $bbox=$incfil{$fil}->[1]; 1063 $wid=($bbox->[2]-$bbox->[0]) if $wid <= 0; 1064 my $xscale=d3($wid/($bbox->[2]-$bbox->[0])); 1065 my $yscale=d3(($hgt<=0)?$xscale:($hgt/($bbox->[3]-$bbox->[1]))); 1066 $xscale=($wid<=0)?$yscale:$xscale; 1067 $xscale=$yscale if $yscale < $xscale; 1068 $yscale=$xscale if $xscale < $yscale; 1069 $wid=($bbox->[2]-$bbox->[0])*$xscale; 1070 $hgt=($bbox->[3]-$bbox->[1])*$yscale; 1071 1072 if ($flag eq '-C' and $ll > $wid) 1073 { 1074 $xpos=int(($ll-$wid)/2); 1075 } 1076 elsif ($flag eq '-R' and $ll > $wid) 1077 { 1078 $xpos=$ll-$wid; 1079 } 1080 1081 $ypos+=$hgt; 1082 $stream.="q $xscale 0 0 $yscale ".PutXY($xpos,$ypos)." cm"; 1083 $stream.=" 0 1 -1 0 0 0 cm" if $rot; 1084 $stream.=" /$incfil{$fil}->[0] Do Q\n"; 1085 } 1086 } 1087 elsif (lc($xprm[1]) eq 'xrev') 1088 { 1089 $xrev=!$xrev; 1090 } 1091 elsif (lc($xprm[1]) eq 'markstart') 1092 { 1093 $mark={'rst' => ($xprm[2]+$xprm[4])/$unitwidth, 'rsb' => ($xprm[3]-$xprm[4])/$unitwidth, 'xpos' => $xpos-($xprm[4]/$unitwidth), 1094 'ypos' => $ypos, 'lead' => $xprm[4]/$unitwidth, 'pdfmark' => join(' ',@xprm[5..$#xprm])}; 1095 } 1096 elsif (lc($xprm[1]) eq 'markend') 1097 { 1098 PutHotSpot($xpos) if defined($mark); 1099 $mark=undef; 1100 } 1101 elsif (lc($xprm[1]) eq 'marksuspend') 1102 { 1103 $suspendmark=$mark; 1104 $mark=undef; 1105 } 1106 elsif (lc($xprm[1]) eq 'markrestart') 1107 { 1108 $mark=$suspendmark; 1109 $suspendmark=undef; 1110 } 1111 elsif (lc($xprm[1]) eq 'pagename') 1112 { 1113 if ($pginsert > -1) 1114 { 1115 $pgnames{$xprm[2]}=$pages->{Kids}->[$pginsert]; 1116 } 1117 else 1118 { 1119 $pgnames{$xprm[2]}='top'; 1120 } 1121 } 1122 elsif (lc($xprm[1]) eq 'switchtopage') 1123 { 1124 my $ba=$xprm[2]; 1125 my $want=$xprm[3]; 1126 1127 if ($pginsert > -1) 1128 { 1129 if (!defined($want) or $want eq '') 1130 { 1131 # no before/after 1132 $want=$ba; 1133 $ba='before'; 1134 } 1135 1136 if (!defined($ba) or $ba eq '' or $want eq 'bottom') 1137 { 1138 $pginsert=$#{$pages->{Kids}}; 1139 } 1140 elsif ($want eq 'top') 1141 { 1142 $pginsert=-1; 1143 } 1144 else 1145 { 1146 if (exists($pgnames{$want})) 1147 { 1148 my $ref=$pgnames{$want}; 1149 1150 if ($ref eq 'top') 1151 { 1152 $pginsert=-1; 1153 } 1154 else 1155 { 1156 FIND: while (1) 1157 { 1158 foreach my $j (0..$#{$pages->{Kids}}) 1159 { 1160 if ($ref eq $pages->{Kids}->[$j]) 1161 { 1162 if ($ba eq 'before') 1163 { 1164 $pginsert=$j-1; 1165 last FIND; 1166 } 1167 elsif ($ba eq 'after') 1168 { 1169 $pginsert=$j; 1170 last FIND; 1171 } 1172 else 1173 { 1174 Msg(0,"Parameter must be top|bottom|before|after not '$ba'"); 1175 last FIND; 1176 } 1177 } 1178 1179 } 1180 1181 Msg(0,"Can't find page ref '$ref'"); 1182 last FIND 1183 1184 } 1185 } 1186 } 1187 else 1188 { 1189 Msg(0,"Can't find page named '$want'"); 1190 } 1191 } 1192 1193 if ($pginsert < 0) 1194 { 1195 ($curoutlev,$curoutlevno,$thislev)=(\@outlev,0,1); 1196 } 1197 else 1198 { 1199 ($curoutlev,$curoutlevno,$thislev)=(@{$outlines[$pginsert]}); 1200 } 1201 } 1202 } 1203 elsif (lc($xprm[1]) eq 'transition' and !$noslide) 1204 { 1205 if (uc($xprm[2]) eq 'PAGE' or uc($xprm[2] eq 'SLIDE')) 1206 { 1207 $transition->{PAGE}->{S}='/'.ucfirst($xprm[3]) if $xprm[3] and $xprm[3] ne '.'; 1208 $transition->{PAGE}->{D}=$xprm[4] if $xprm[4] and $xprm[4] ne '.'; 1209 $transition->{PAGE}->{Dm}='/'.$xprm[5] if $xprm[5] and $xprm[5] ne '.'; 1210 $transition->{PAGE}->{M}='/'.$xprm[6] if $xprm[6] and $xprm[6] ne '.'; 1211 $xprm[7]='/None' if $xprm[7] and uc($xprm[7]) eq 'NONE'; 1212 $transition->{PAGE}->{Di}=$xprm[7] if $xprm[7] and $xprm[7] ne '.'; 1213 $transition->{PAGE}->{SS}=$xprm[8] if $xprm[8] and $xprm[8] ne '.'; 1214 $transition->{PAGE}->{B}=$xprm[9] if $xprm[9] and $xprm[9] ne '.'; 1215 } 1216 elsif (uc($xprm[2]) eq 'BLOCK') 1217 { 1218 $transition->{BLOCK}->{S}='/'.ucfirst($xprm[3]) if $xprm[3] and $xprm[3] ne '.'; 1219 $transition->{BLOCK}->{D}=$xprm[4] if $xprm[4] and $xprm[4] ne '.'; 1220 $transition->{BLOCK}->{Dm}='/'.$xprm[5] if $xprm[5] and $xprm[5] ne '.'; 1221 $transition->{BLOCK}->{M}='/'.$xprm[6] if $xprm[6] and $xprm[6] ne '.'; 1222 $xprm[7]='/None' if $xprm[7] and uc($xprm[7]) eq 'NONE'; 1223 $transition->{BLOCK}->{Di}=$xprm[7] if $xprm[7] and $xprm[7] ne '.'; 1224 $transition->{BLOCK}->{SS}=$xprm[8] if $xprm[8] and $xprm[8] ne '.'; 1225 $transition->{BLOCK}->{B}=$xprm[9] if $xprm[9] and $xprm[9] ne '.'; 1226 } 1227 1228 $present=1; 1229 } 1230 } 1231 elsif (lc(substr($xprm[0],0,9)) eq 'papersize') 1232 { 1233 my ($px,$py)=split(',',substr($xprm[0],10)); 1234 $px=GetPoints($px); 1235 $py=GetPoints($py); 1236 @mediabox=(0,0,$px,$py); 1237 my @mb=@mediabox; 1238 $matrixchg=1; 1239 $custompaper=1; 1240 $cpage->{MediaBox}=\@mb; 1241 } 1242 } 1243} 1244 1245sub FixPDFColour 1246{ 1247 my $o=shift; 1248 my $a=$o->{C}; 1249 my @r=(); 1250 my $c=$a->[0]; 1251 1252 if ($#{$a}==3) 1253 { 1254 if ($c > 1) 1255 { 1256 foreach my $j (0..2) 1257 { 1258 push(@r,sprintf("%1.3f",$a->[$j]/0xffff)); 1259 } 1260 1261 $o->{C}=\@r; 1262 } 1263 } 1264 elsif (substr($c,0,1) eq '#') 1265 { 1266 if (length($c) == 7) 1267 { 1268 foreach my $j (0..2) 1269 { 1270 push(@r,sprintf("%1.3f",hex(substr($c,$j*2+1,2))/0xff)); 1271 } 1272 1273 $o->{C}=\@r; 1274 } 1275 elsif (length($c) == 14) 1276 { 1277 foreach my $j (0..2) 1278 { 1279 push(@r,sprintf("%1.3f",hex(substr($c,$j*4+2,4))/0xffff)); 1280 } 1281 1282 $o->{C}=\@r; 1283 } 1284 } 1285} 1286 1287sub PutHotSpot 1288{ 1289 my $endx=shift; 1290 my $l=$mark->{pdfmark}; 1291 $l=~s/Color/C/; 1292 $l=~s/Action/A/; 1293 $l=~s'/Subtype /URI'/S /URI'; 1294 $l=~s(\\\[u00(..)\])(chr(hex($1)))eg; 1295 my @xwds=split(' ',"<< $l >>"); 1296 my $annotno=BuildObj(++$objct,ParsePDFValue(\@xwds)); 1297 my $annot=$obj[$objct]; 1298 $annot->{DATA}->{Type}='/Annot'; 1299 $annot->{DATA}->{Rect}=[$mark->{xpos},$mark->{ypos}-$mark->{rsb},$endx+$mark->{lead},$mark->{ypos}-$mark->{rst}]; 1300 FixPDFColour($annot->{DATA}); 1301 FixRect($annot->{DATA}->{Rect}); # Y origin to ll 1302 push(@PageAnnots,$annotno); 1303} 1304 1305sub sgn 1306{ 1307 return(1) if $_[0] > 0; 1308 return(-1) if $_[0] < 0; 1309 return(0); 1310} 1311 1312sub FixRect 1313{ 1314 my $rect=shift; 1315 1316 return if !defined($rect); 1317 $rect->[1]=GraphY($rect->[1]); 1318 $rect->[3]=GraphY($rect->[3]); 1319} 1320 1321sub GetPoints 1322{ 1323 my $val=shift; 1324 1325 $val=ToPoints($1,$2) if ($val and $val=~m/(-?[\d.]+)([cipnz])/); 1326 1327 return $val; 1328} 1329 1330# Although the PDF reference mentions XObject/Form as a way of incorporating an external PDF page into 1331# the current PDF, it seems not to work with any current PDF reader (although I am told (by Leonard Rosenthol, 1332# who helped author the PDF ISO standard) that Acroread 9 does support it, empiorical observation shows otherwise!!). 1333# So... do it the hard way - full PDF parser and merge required objects!!! 1334 1335# sub BuildRef 1336# { 1337# my $fil=shift; 1338# my $bbox=shift; 1339# my $mat=shift; 1340# my $wid=($bbox->[2]-$bbox->[0])*$mat->[0]; 1341# my $hgt=($bbox->[3]-$bbox->[1])*$mat->[3]; 1342# 1343# if (!open(PDF,"<$fil")) 1344# { 1345# Msg(0,"Failed to open '$fil'"); 1346# return(undef); 1347# } 1348# 1349# my (@f)=(<PDF>); 1350# 1351# close(PDF); 1352# 1353# $objct++; 1354# my $xonm="XO$objct"; 1355# 1356# $pages->{'Resources'}->{'XObject'}->{$xonm}=BuildObj($objct,{'Type' => '/XObject', 1357# 'Subtype' => '/Form', 1358# 'BBox' => $bbox, 1359# 'Matrix' => $mat, 1360# 'Resources' => $pages->{'Resources'}, 1361# 'Ref' => {'Page' => '1', 1362# 'F' => BuildObj($objct+1,{'Type' => '/Filespec', 1363# 'F' => "($fil)", 1364# 'EF' => {'F' => BuildObj($objct+2,{'Type' => '/EmbeddedFile'})} 1365# }) 1366# } 1367# }); 1368# 1369# $obj[$objct]->{STREAM}="q 1 0 0 1 0 0 cm 1370# q BT 1371# 1 0 0 1 0 0 Tm 1372# .5 g .5 G 1373# /F5 20 Tf 1374# (Proxy) Tj 1375# ET Q 1376# 0 0 m 72 0 l s 1377# Q\n"; 1378# 1379# # $obj[$objct]->{STREAM}=PutXY($xpos,$ypos)." m ".PutXY($xpos+$wid,$ypos)." l ".PutXY($xpos+$wid,$ypos+$hgt)." l ".PutXY($xpos,$ypos+$hgt)." l f\n"; 1380# $obj[$objct+2]->{STREAM}=join('',@f); 1381# PutObj($objct); 1382# PutObj($objct+1); 1383# PutObj($objct+2); 1384# $objct+=2; 1385# return($xonm); 1386# } 1387 1388sub LoadSWF 1389{ 1390 my $fil=shift; 1391 my $bbox=shift; 1392 my $mat=shift; 1393 my $wid=($bbox->[2]-$bbox->[0])*$mat->[0]; 1394 my $hgt=($bbox->[3]-$bbox->[1])*$mat->[3]; 1395 my (@path)=split('/',$fil); 1396 my $node=pop(@path); 1397 1398 if (!open(PDF,"<$fil")) 1399 { 1400 Msg(0,"Failed to open '$fil'"); 1401 return(undef); 1402 } 1403 1404 my (@f)=(<PDF>); 1405 1406 close(PDF); 1407 1408 $objct++; 1409 my $xonm="XO$objct"; 1410 1411 $pages->{'Resources'}->{'XObject'}->{$xonm}=BuildObj($objct,{'Type' => '/XObject', 'BBox' => $bbox, 'Matrix' => $mat, 'FormType' => 1, 'Subtype' => '/Form', 'Length' => 0, 'Type' => "/XObject"}); 1412 $obj[$objct]->{STREAM}=''; 1413 PutObj($objct); 1414 $objct++; 1415 my $asset=BuildObj($objct,{'EF' => {'F' => BuildObj($objct+1,{})}, 1416 'F' => "($node)", 1417 'Type' => '/Filespec', 1418 'UF' => "($node)"}); 1419 1420 PutObj($objct); 1421 $objct++; 1422 $obj[$objct]->{STREAM}=join('',@f); 1423 PutObj($objct); 1424 $objct++; 1425 my $config=BuildObj($objct,{'Instances' => [BuildObj($objct+1,{'Params' => { 'Binding' => '/Background'}, 'Asset' => $asset})], 1426 'Subtype' => '/Flash'}); 1427 1428 PutObj($objct); 1429 $objct++; 1430 PutObj($objct); 1431 $objct++; 1432 1433 my ($x,$y)=split(' ',PutXY($xpos,$ypos)); 1434 1435 push(@{$cpage->{Annots}},BuildObj($objct,{'RichMediaContent' => {'Subtype' => '/Flash', 'Configurations' => [$config], 'Assets' => {'Names' => [ "($node)", $asset ] }}, 1436 'P' => "$cpageno 0 R", 1437 'RichMediaSettings' => { 'Deactivation' => { 'Condition' => '/PI', 1438 'Type' => '/RichMediaDeactivation'}, 1439 'Activation' => { 'Condition' => '/PV', 1440 'Type' => '/RichMediaActivation'}}, 1441 'F' => 68, 1442 'Subtype' => '/RichMedia', 1443 'Type' => '/Annot', 1444 'Rect' => "[ $x $y ".($x+$wid)." ".($y+$hgt)." ]", 1445 'Border' => [0,0,0]})); 1446 1447 PutObj($objct); 1448 1449 return $xonm; 1450} 1451 1452sub OpenInc 1453{ 1454 my $fn=shift; 1455 my $fnm=$fn; 1456 my $F; 1457 1458 if (substr($fnm,0,1) eq '/' or substr($fnm,1,1) eq ':') # dos 1459 { 1460 if (-r $fnm and open($F,"<$fnm")) 1461 { 1462 return($F,$fnm); 1463 } 1464 } 1465 else 1466 { 1467 foreach my $dir (@idirs) 1468 { 1469 $fnm="$dir/$fn"; 1470 1471 if (-r "$fnm" and open($F,"<$fnm")) 1472 { 1473 return($F,$fnm); 1474 } 1475 } 1476 } 1477 1478 return(undef,$fn); 1479} 1480 1481sub LoadPDF 1482{ 1483 my $pdfnm=shift; 1484 my $mat=shift; 1485 my $wid=shift; 1486 my $hgt=shift; 1487 my $type=shift; 1488 my $pdf; 1489 my $pdftxt=''; 1490 my $strmlen=0; 1491 my $curobj=-1; 1492 my $instream=0; 1493 my $cont; 1494 my $adj=0; 1495 my $keepsep=$/; 1496 1497 my ($PD,$PDnm)=OpenInc($pdfnm); 1498 1499 if (!defined($PD)) 1500 { 1501 Msg(0,"Failed to open PDF '$pdfnm'"); 1502 return undef; 1503 } 1504 1505 my $hdr=<$PD>; 1506 1507 $/="\r",$adj=1 if (length($hdr) > 10); 1508 1509 while (<$PD>) 1510 { 1511 chomp; 1512 1513 s/\n//; 1514 1515 if (m/endstream(\s+.*)?$/) 1516 { 1517 $instream=0; 1518 $_="endstream"; 1519 $_.=$1 if defined($1) 1520 } 1521 1522 next if $instream; 1523 1524 if (m'/Length\s+(\d+)(\s+\d+\s+R)?') 1525 { 1526 if (!defined($2)) 1527 { 1528 $strmlen=$1; 1529 } 1530 else 1531 { 1532 $strmlen=0; 1533 } 1534 } 1535 1536 if (m'^(\d+) \d+ obj') 1537 { 1538 $curobj=$1; 1539 $pdf->[$curobj]->{OBJ}=undef; 1540 } 1541 1542 if (m'stream\s*$' and ! m/^endstream/) 1543 { 1544 if ($curobj > -1) 1545 { 1546 $pdf->[$curobj]->{STREAMPOS}=[tell($PD)+$adj,$strmlen]; 1547 seek($PD,$strmlen,1); 1548 $instream=1; 1549 } 1550 else 1551 { 1552 Msg(0,"Parsing PDF '$pdfnm' failed"); 1553 return undef; 1554 } 1555 } 1556 1557 $pdftxt.=$_.' '; 1558 } 1559 1560 close($PD); 1561 1562 open(PD,"<$PDnm"); 1563# $pdftxt=~s/\]/ \]/g; 1564 my (@pdfwds)=split(' ',$pdftxt); 1565 my $wd; 1566 1567 while ($wd=nextwd(\@pdfwds),length($wd)) 1568 { 1569 if ($wd=~m/\d+/ and defined($pdfwds[1]) and $pdfwds[1]=~m/^obj(.*)/) 1570 { 1571 $curobj=$wd; 1572 shift(@pdfwds); shift(@pdfwds); 1573 unshift(@pdfwds,$1) if defined($1) and length($1); 1574 $pdf->[$curobj]->{OBJ}=ParsePDFObj(\@pdfwds); 1575 } 1576 elsif ($wd eq 'trailer' and !exists($pdf->[0]->{OBJ})) 1577 { 1578 $pdf->[0]->{OBJ}=ParsePDFObj(\@pdfwds); 1579 } 1580 else 1581 { 1582# print "Skip '$wd'\n"; 1583 } 1584 } 1585 1586 my $catalog=${$pdf->[0]->{OBJ}->{Root}}; 1587 my $page=FindPage(1,$pdf); 1588 my $xobj=++$objct; 1589 1590 # Load the streamas 1591 1592 foreach my $o (@{$pdf}) 1593 { 1594 if (exists($o->{STREAMPOS})) 1595 { 1596 my $l; 1597 1598 $l=$o->{OBJ}->{Length} if exists($o->{OBJ}->{Length}); 1599 1600 $l=$pdf->[$$l]->{OBJ} if (defined($l) && ref($l) eq 'OBJREF'); 1601 1602 Msg(1,"Unable to determine length of stream \@$o->{STREAMPOS}->[0]") if !defined($l); 1603 1604 sysseek(PD,$o->{STREAMPOS}->[0],0); 1605 Msg(0,'Failed to read all the stream') if $l != sysread(PD,$o->{STREAM},$l); 1606 1607 if ($gotzlib and exists($o->{OBJ}->{'Filter'}) and $o->{OBJ}->{'Filter'} eq '/FlateDecode') 1608 { 1609 $o->{STREAM}=Compress::Zlib::uncompress($o->{STREAM}); 1610 delete($o->{OBJ }->{'Filter'}); 1611 } 1612 } 1613 } 1614 1615 close(PD); 1616 1617 # Find BBox 1618 my $BBox; 1619 my $insmap={}; 1620 1621 foreach my $k (qw( MediaBox ArtBox TrimBox BleedBox CropBox )) 1622 { 1623 $BBox=FindKey($pdf,$page,$k); 1624 last if $BBox; 1625 } 1626 1627 $BBox=[0,0,595,842] if !defined($BBox); 1628 1629 $wid=($BBox->[2]-$BBox->[0]+1) if $wid==0; 1630 my $xscale=d3(abs($wid)/($BBox->[2]-$BBox->[0]+1)); 1631 my $yscale=d3(($hgt<=0)?$xscale:(abs($hgt)/($BBox->[3]-$BBox->[1]+1))); 1632 $hgt=($BBox->[3]-$BBox->[1]+1)*$yscale; 1633 1634 if ($type eq "import") 1635 { 1636 $mat->[0]=$xscale; 1637 $mat->[3]=$yscale; 1638 } 1639 1640 # Find Resource 1641 1642 my $res=FindKey($pdf,$page,'Resources'); 1643 my $xonm="XO$xobj"; 1644 1645 # Map inserted objects to current PDF 1646 1647 MapInsValue($pdf,$page,'',$insmap,$xobj,$pdf->[$page]->{OBJ}); 1648# 1649# Many PDFs include 'Resources' at the 'Page' level but if 'Resources' is held at a higher level (i.e 'Pages') 1650# then we need to include its objects as well. 1651# 1652 MapInsValue($pdf,$page,'',$insmap,$xobj,$res) if !exists($pdf->[$page]->{OBJ}->{Resources}); 1653 1654 # Copy Resources 1655 1656 my %incres=%{$res}; 1657 1658 $incres{ProcSet}=['/PDF', '/Text', '/ImageB', '/ImageC', '/ImageI']; 1659 1660 ($mat->[4],$mat->[5])=split(' ',PutXY($xpos,$ypos)); 1661 $pages->{'Resources'}->{'XObject'}->{$xonm}=BuildObj($xobj,{'Type' => '/XObject', 'BBox' => $BBox, 'Name' => "/$xonm", 'FormType' => 1, 'Subtype' => '/Form', 'Length' => 0, 'Type' => "/XObject", 'Resources' => \%incres}); 1662 1663 BuildStream($xobj,$pdf,$pdf->[$page]->{OBJ}->{Contents}); 1664 1665 $/=$keepsep; 1666 return([$xonm,$BBox] ); 1667} 1668 1669sub BuildStream 1670{ 1671 my $xobj=shift; 1672 my $pdf=shift; 1673 my $val=shift; 1674 my $strm=''; 1675 my $objs; 1676 my $refval=ref($val); 1677 1678 if ($refval eq 'OBJREF') 1679 { 1680 push(@{$objs}, $val); 1681 } 1682 elsif ($refval eq 'ARRAY') 1683 { 1684 $objs=$val; 1685 } 1686 else 1687 { 1688 Msg(0,"unexpected 'Contents'"); 1689 } 1690 1691 foreach my $o (@{$objs}) 1692 { 1693 $strm.="\n" if $strm; 1694 $strm.=$pdf->[$$o]->{STREAM} if exists($pdf->[$$o]->{STREAM}); 1695 } 1696 1697 $obj[$xobj]->{STREAM}=$strm; 1698} 1699 1700 1701sub MapInsHash 1702{ 1703 my $pdf=shift; 1704 my $o=shift; 1705 my $insmap=shift; 1706 my $parent=shift; 1707 my $val=shift; 1708 1709 1710 foreach my $k (keys(%{$val})) 1711 { 1712 MapInsValue($pdf,$o,$k,$insmap,$parent,$val->{$k}) if $k ne 'Contents'; 1713 } 1714} 1715 1716sub MapInsValue 1717{ 1718 my $pdf=shift; 1719 my $o=shift; 1720 my $k=shift; 1721 my $insmap=shift; 1722 my $parent=shift; 1723 my $val=shift; 1724 my $refval=ref($val); 1725 1726 if ($refval eq 'OBJREF') 1727 { 1728 if ($k ne 'Parent') 1729 { 1730 if (!exists($insmap->{IMP}->{$$val})) 1731 { 1732 $objct++; 1733 $insmap->{CUR}->{$objct}=$$val; 1734 $insmap->{IMP}->{$$val}=$objct; 1735 $obj[$objct]->{DATA}=$pdf->[$$val]->{OBJ}; 1736 $obj[$objct]->{STREAM}=$pdf->[$$val]->{STREAM} if exists($pdf->[$$val]->{STREAM}); 1737 MapInsValue($pdf,$$val,'',$insmap,$o,$pdf->[$$val]->{OBJ}); 1738 } 1739 1740 $$val=$insmap->{IMP}->{$$val}; 1741 } 1742 else 1743 { 1744 $$val=$parent; 1745 } 1746 } 1747 elsif ($refval eq 'ARRAY') 1748 { 1749 foreach my $v (@{$val}) 1750 { 1751 MapInsValue($pdf,$o,'',$insmap,$parent,$v) 1752 } 1753 } 1754 elsif ($refval eq 'HASH') 1755 { 1756 MapInsHash($pdf,$o,$insmap,$parent,$val); 1757 } 1758 1759} 1760 1761sub FindKey 1762{ 1763 my $pdf=shift; 1764 my $page=shift; 1765 my $k=shift; 1766 1767 if (exists($pdf->[$page]->{OBJ}->{$k})) 1768 { 1769 my $val=$pdf->[$page]->{OBJ}->{$k}; 1770 $val=$pdf->[$$val]->{OBJ} if ref($val) eq 'OBJREF'; 1771 return($val); 1772 } 1773 else 1774 { 1775 if (exists($pdf->[$page]->{OBJ}->{Parent})) 1776 { 1777 return(FindKey($pdf,${$pdf->[$page]->{OBJ}->{Parent}},$k)); 1778 } 1779 } 1780 1781 return(undef); 1782} 1783 1784sub FindPage 1785{ 1786 my $wantpg=shift; 1787 my $pdf=shift; 1788 my $catalog=${$pdf->[0]->{OBJ}->{Root}}; 1789 my $pages=${$pdf->[$catalog]->{OBJ}->{Pages}}; 1790 1791 return(NextPage($pdf,$pages,\$wantpg)); 1792} 1793 1794sub NextPage 1795{ 1796 my $pdf=shift; 1797 my $pages=shift; 1798 my $wantpg=shift; 1799 my $ret; 1800 1801 if ($pdf->[$pages]->{OBJ}->{Type} eq '/Pages') 1802 { 1803 foreach my $kid (@{$pdf->[$pages]->{OBJ}->{Kids}}) 1804 { 1805 $ret=NextPage($pdf,$$kid,$wantpg); 1806 last if $$wantpg<=0; 1807 } 1808 } 1809 elsif ($pdf->[$pages]->{OBJ}->{Type} eq '/Page') 1810 { 1811 $$wantpg--; 1812 $ret=$pages; 1813 } 1814 1815 return($ret); 1816} 1817 1818sub nextwd 1819{ 1820 my $pdfwds=shift; 1821 1822 my $wd=shift(@{$pdfwds}); 1823 1824 return('') if !defined($wd); 1825 1826 if ($wd=~m/^(.*?)(<<|>>|(?:(?<!\\)\[|\]))(.*)/) 1827 { 1828 if (defined($1) and length($1)) 1829 { 1830 unshift(@{$pdfwds},$3) if defined($3) and length($3); 1831 unshift(@{$pdfwds},$2); 1832 $wd=$1; 1833 } 1834 else 1835 { 1836 unshift(@{$pdfwds},$3) if defined($3) and length($3); 1837 $wd=$2; 1838 } 1839 } 1840 1841 return($wd); 1842} 1843 1844sub ParsePDFObj 1845{ 1846 1847 my $pdfwds=shift; 1848 my $rtn; 1849 my $wd; 1850 1851 while ($wd=nextwd($pdfwds),length($wd)) 1852 { 1853 if ($wd eq 'stream' or $wd eq 'endstream') 1854 { 1855 next; 1856 } 1857 elsif ($wd eq 'endobj' or $wd eq 'startxref') 1858 { 1859 last; 1860 } 1861 else 1862 { 1863 unshift(@{$pdfwds},$wd); 1864 $rtn=ParsePDFValue($pdfwds); 1865 } 1866 } 1867 1868 return($rtn); 1869} 1870 1871sub ParsePDFHash 1872{ 1873 my $pdfwds=shift; 1874 my $rtn={}; 1875 my $wd; 1876 1877 while ($wd=nextwd($pdfwds),length($wd)) 1878 { 1879 if ($wd eq '>>') 1880 { 1881 last; 1882 } 1883 1884 my (@w)=split('/',$wd,3); 1885 1886 if ($w[0]) 1887 { 1888 Msg(0,"PDF Dict Key '$wd' does not start with '/'"); 1889 exit 1; 1890 } 1891 else 1892 { 1893 unshift(@{$pdfwds},"/$w[2]") if $w[2]; 1894 $wd=$w[1]; 1895 (@w)=split('\(',$wd,2); 1896 $wd=$w[0]; 1897 unshift(@{$pdfwds},"($w[1]") if defined($w[1]); 1898 (@w)=split('\<',$wd,2); 1899 $wd=$w[0]; 1900 unshift(@{$pdfwds},"<$w[1]") if defined($w[1]); 1901 1902 $rtn->{$wd}=ParsePDFValue($pdfwds); 1903 } 1904 } 1905 1906 return($rtn); 1907} 1908 1909sub ParsePDFValue 1910{ 1911 my $pdfwds=shift; 1912 my $rtn; 1913 my $wd=nextwd($pdfwds); 1914 1915 if ($wd=~m/^\d+$/ and $pdfwds->[0]=~m/^\d+$/ and $pdfwds->[1]=~m/^R(\]|\>|\/)?/) 1916 { 1917 shift(@{$pdfwds}); 1918 if (defined($1) and length($1)) 1919 { 1920 $pdfwds->[0]=substr($pdfwds->[0],1); 1921 } 1922 else 1923 { 1924 shift(@{$pdfwds}); 1925 } 1926 return(bless(\$wd,'OBJREF')); 1927 } 1928 1929 if ($wd eq '<<') 1930 { 1931 return(ParsePDFHash($pdfwds)); 1932 } 1933 1934 if ($wd eq '[') 1935 { 1936 return(ParsePDFArray($pdfwds)); 1937 } 1938 1939 if ($wd=~m/(.*?)(\(.*)$/) 1940 { 1941 if (defined($1) and length($1)) 1942 { 1943 unshift(@{$pdfwds},$2); 1944 $wd=$1; 1945 } 1946 else 1947 { 1948 return(ParsePDFString($wd,$pdfwds)); 1949 } 1950 } 1951 1952 if ($wd=~m/(.*?)(\<.*)$/) 1953 { 1954 if (defined($1) and length($1)) 1955 { 1956 unshift(@{$pdfwds},$2); 1957 $wd=$1; 1958 } 1959 else 1960 { 1961 return(ParsePDFHexString($wd,$pdfwds)); 1962 } 1963 } 1964 1965 if ($wd=~m/(.+?)(\/.*)$/) 1966 { 1967 if (defined($2) and length($2)) 1968 { 1969 unshift(@{$pdfwds},$2); 1970 $wd=$1; 1971 } 1972 } 1973 1974 return($wd); 1975} 1976 1977sub ParsePDFString 1978{ 1979 my $wd=shift; 1980 my $rtn=''; 1981 my $pdfwds=shift; 1982 my $lev=0; 1983 1984 while (length($wd)) 1985 { 1986 $rtn.=' ' if length($rtn); 1987 1988 while ($wd=~m/(?<!\\)\(/g) {$lev++;} 1989 while ($wd=~m/(?<!\\)\)/g) {$lev--;} 1990 1991 1992 if ($lev<=0 and $wd=~m/^(.*?\))([^)]+)$/) 1993 { 1994 unshift(@{$pdfwds},$2) if defined($2) and length($2); 1995 $wd=$1; 1996 } 1997 1998 $rtn.=$wd; 1999 2000 last if $lev <= 0; 2001 2002 $wd=nextwd($pdfwds); 2003 } 2004 2005 return($rtn); 2006} 2007 2008sub ParsePDFHexString 2009{ 2010 my $wd=shift; 2011 my $rtn=''; 2012 my $pdfwds=shift; 2013 my $lev=0; 2014 2015 if ($wd=~m/^(<.+?>)(.*)/) 2016 { 2017 unshift(@{$pdfwds},$2) if defined($2) and length($2); 2018 $rtn=$1; 2019 } 2020 2021 return($rtn); 2022} 2023 2024sub ParsePDFArray 2025{ 2026 my $pdfwds=shift; 2027 my $rtn=[]; 2028 my $wd; 2029 2030 while (1) 2031 { 2032 $wd=ParsePDFValue($pdfwds); 2033 last if $wd eq ']' or length($wd)==0; 2034 push(@{$rtn},$wd); 2035 } 2036 2037 return($rtn); 2038} 2039 2040sub Msg 2041{ 2042 my ($lev,$msg)=@_; 2043 2044 print STDERR "$env{SourceFile}: " if exists($env{SourceFile}); 2045 print STDERR "$msg\n"; 2046 exit 1 if $lev; 2047} 2048 2049sub PutXY 2050{ 2051 my ($x,$y)=(@_); 2052 2053 if ($frot) 2054 { 2055 return(d3($y)." ".d3($x)); 2056 } 2057 else 2058 { 2059 $y=$mediabox[3]-$y; 2060 return(d3($x)." ".d3($y)); 2061 } 2062} 2063 2064sub GraphY 2065{ 2066 my $y=shift; 2067 2068 if ($frot) 2069 { 2070 return($y); 2071 } 2072 else 2073 { 2074 return($mediabox[3]-$y); 2075 } 2076} 2077 2078sub Put 2079{ 2080 my $msg=shift; 2081 2082 print $msg; 2083 $fct+=length($msg); 2084} 2085 2086sub PutObj 2087{ 2088 my $ono=shift; 2089 my $msg="$ono 0 obj "; 2090 $obj[$ono]->{XREF}=$fct; 2091 if (exists($obj[$ono]->{STREAM})) 2092 { 2093 if ($gotzlib && !$debug && !exists($obj[$ono]->{DATA}->{'Filter'})) 2094 { 2095 $obj[$ono]->{STREAM}=Compress::Zlib::compress($obj[$ono]->{STREAM}); 2096 $obj[$ono]->{DATA}->{'Filter'}='/FlateDecode'; 2097 } 2098 2099 $obj[$ono]->{DATA}->{'Length'}=length($obj[$ono]->{STREAM}); 2100 } 2101 PutField(\$msg,$obj[$ono]->{DATA}); 2102 PutStream(\$msg,$ono) if exists($obj[$ono]->{STREAM}); 2103 Put($msg."endobj\n"); 2104} 2105 2106sub PutStream 2107{ 2108 my $msg=shift; 2109 my $ono=shift; 2110 2111 # We could 'flate' here 2112 $$msg.="stream\n$obj[$ono]->{STREAM}endstream\n"; 2113} 2114 2115sub PutField 2116{ 2117 my $pmsg=shift; 2118 my $fld=shift; 2119 my $term=shift||"\n"; 2120 my $typ=ref($fld); 2121 2122 if ($typ eq '') 2123 { 2124 $$pmsg.="$fld$term"; 2125 } 2126 elsif ($typ eq 'ARRAY') 2127 { 2128 $$pmsg.='['; 2129 foreach my $cell (@{$fld}) 2130 { 2131 PutField($pmsg,$cell,' '); 2132 } 2133 $$pmsg.="]$term"; 2134 } 2135 elsif ($typ eq 'HASH') 2136 { 2137 $$pmsg.='<< '; 2138 foreach my $key (sort keys %{$fld}) 2139 { 2140 $$pmsg.="/$key "; 2141 PutField($pmsg,$fld->{$key}); 2142 } 2143 $$pmsg.=">>$term"; 2144 } 2145 elsif ($typ eq 'OBJREF') 2146 { 2147 $$pmsg.="$$fld 0 R$term"; 2148 } 2149} 2150 2151sub BuildObj 2152{ 2153 my $ono=shift; 2154 my $val=shift; 2155 2156 $obj[$ono]->{DATA}=$val; 2157 2158 return("$ono 0 R "); 2159} 2160 2161sub LoadFont 2162{ 2163 my $fontno=shift; 2164 my $fontnm=shift; 2165 my $ofontnm=$fontnm; 2166 2167 return $fontlst{$fontno}->{OBJ} if (exists($fontlst{$fontno})); 2168 2169 my $f; 2170 OpenFile(\$f,$fontdir,"$fontnm"); 2171 2172 if (!defined($f) and $Foundry) 2173 { 2174 # Try with no foundry 2175 $fontnm=~s/.*?-//; 2176 OpenFile(\$f,$fontdir,$fontnm); 2177 } 2178 2179 Msg(1,"Failed to open font '$ofontnm'") if !defined($f); 2180 2181 my $foundry=''; 2182 $foundry=$1 if $fontnm=~m/^(.*?)-/; 2183 my $stg=1; 2184 my %fnt; 2185 my @fntbbox=(0,0,0,0); 2186 my $capheight=0; 2187 my $lastchr=0; 2188 my $lastnm; 2189 my $t1flags=0; 2190 my $fixwid=-1; 2191 my $ascent=0; 2192 my $charset=''; 2193 2194 while (<$f>) 2195 { 2196 chomp; 2197 2198 s/^ +//; 2199 s/^#.*// if $stg == 1; 2200 next if $_ eq ''; 2201 2202 if ($stg == 1) 2203 { 2204 my ($key,$val)=split(' ',$_,2); 2205 2206 $key=lc($key); 2207 $stg=2,next if $key eq 'kernpairs'; 2208 $stg=3,next if lc($_) eq 'charset'; 2209 2210 $fnt{$key}=$val 2211 } 2212 elsif ($stg == 2) 2213 { 2214 $stg=3,next if lc($_) eq 'charset'; 2215 2216 my ($ch1,$ch2,$k)=split; 2217# $fnt{KERN}->{$ch1}->{$ch2}=$k; 2218 } 2219 else 2220 { 2221 my (@r)=split; 2222 my (@p)=split(',',$r[1]); 2223 2224 if ($r[1] eq '"') 2225 { 2226 $fnt{NAM}->{$r[0]}=$fnt{NAM}->{$lastnm}; 2227 next; 2228 } 2229 2230 $r[0]='u0020' if $r[3] == 32; 2231 $r[0]="u00".hex($r[3]) if $r[0] eq '---'; 2232# next if $r[3] >255; 2233 $fnt{NAM}->{$r[0]}=[$p[0],$r[3],'/'.$r[4],$r[3],0]; 2234 $fnt{NO}->[$r[3]]=[$r[0],$r[0]]; 2235 $lastnm=$r[0]; 2236 $lastchr=$r[3] if $r[3] > $lastchr; 2237 $fixwid=$p[0] if $fixwid == -1; 2238 $fixwid=-2 if $fixwid > 0 and $p[0] != $fixwid; 2239 2240 $fntbbox[1]=-$p[2] if defined($p[2]) and -$p[2] < $fntbbox[1]; 2241 $fntbbox[2]=$p[0] if $p[0] > $fntbbox[2]; 2242 $fntbbox[3]=$p[1] if defined($p[1]) and $p[1] > $fntbbox[3]; 2243 $ascent=$p[1] if defined($p[1]) and $p[1] > $ascent and $r[3] >= 32 and $r[3] < 128; 2244 $charset.='/'.$r[4] if defined($r[4]); 2245 $capheight=$p[1] if length($r[4]) == 1 and $r[4] ge 'A' and $r[4] le 'Z' and $p[1] > $capheight; 2246 } 2247 } 2248 2249 close($f); 2250 2251 foreach my $j (0..$lastchr) 2252 { 2253 $fnt{NO}->[$j]=['',''] if !defined($fnt{NO}->[$j]); 2254 } 2255 2256 my $fno=0; 2257 my $slant=0; 2258 $fnt{DIFF}=[]; 2259 $fnt{WIDTH}=[]; 2260 $fnt{NAM}->{''}=[0,-1,'/.notdef',-1,0]; 2261 $slant=-$fnt{'slant'} if exists($fnt{'slant'}); 2262 $fnt{'spacewidth'}=700 if !exists($fnt{'spacewidth'}); 2263 2264 $t1flags|=2**0 if $fixwid > -1; 2265 $t1flags|=(exists($fnt{'special'}))?2**2:2**5; 2266 $t1flags|=2**6 if $slant != 0; 2267 my $fontkey="$foundry $fnt{internalname}"; 2268 2269 if (exists($download{$fontkey})) 2270 { 2271 # Not a Base Font 2272 my ($l1,$l2,$l3,$t1stream)=GetType1($download{$fontkey}); 2273 Msg(0,"Incorrect font format for '$fontkey' ($l1)") if !defined($t1stream); 2274 $fno=++$objct; 2275 $fontlst{$fontno}->{OBJ}=BuildObj($objct, 2276 {'Type' => '/Font', 2277 'Subtype' => '/Type1', 2278 'BaseFont' => '/'.$fnt{internalname}, 2279 'Widths' => $fnt{WIDTH}, 2280 'FirstChar' => 0, 2281 'LastChar' => $lastchr, 2282 'Encoding' => BuildObj($objct+1, 2283 {'Type' => '/Encoding', 2284 'Differences' => $fnt{DIFF} 2285 } 2286 ), 2287 'FontDescriptor' => BuildObj($objct+2, 2288 {'Type' => '/FontDescriptor', 2289 'FontName' => '/'.$fnt{internalname}, 2290 'Flags' => $t1flags, 2291 'FontBBox' => \@fntbbox, 2292 'ItalicAngle' => $slant, 2293 'Ascent' => $ascent, 2294 'Descent' => $fntbbox[1], 2295 'CapHeight' => $capheight, 2296 'StemV' => 0, 2297# 'CharSet' => "($charset)", 2298 'FontFile' => BuildObj($objct+3, 2299 {'Length1' => $l1, 2300 'Length2' => $l2, 2301 'Length3' => $l3 2302 } 2303 ) 2304 } 2305 ) 2306 } 2307 ); 2308 2309 $objct+=3; 2310 $fontlst{$fontno}->{NM}='/F'.$fontno; 2311 $pages->{'Resources'}->{'Font'}->{'F'.$fontno}=$fontlst{$fontno}->{OBJ}; 2312 $fontlst{$fontno}->{FNT}=\%fnt; 2313 $obj[$objct]->{STREAM}=$t1stream; 2314 2315 } 2316 else 2317 { 2318 $fno=++$objct; 2319 $fontlst{$fontno}->{OBJ}=BuildObj($objct, 2320 {'Type' => '/Font', 2321 'Subtype' => '/Type1', 2322 'BaseFont' => '/'.$fnt{internalname}, 2323 'Widths' => $fnt{WIDTH}, 2324 'FirstChar' => 0, 2325 'LastChar' => $lastchr, 2326 'Encoding' => BuildObj($objct+1, 2327 {'Type' => '/Encoding', 2328 'Differences' => $fnt{DIFF} 2329 } 2330 ), 2331 'FontDescriptor' => BuildObj($objct+2, 2332 {'Type' => '/FontDescriptor', 2333 'FontName' => '/'.$fnt{internalname}, 2334 'Flags' => $t1flags, 2335 'FontBBox' => \@fntbbox, 2336 'ItalicAngle' => $slant, 2337 'Ascent' => $ascent, 2338 'Descent' => $fntbbox[1], 2339 'CapHeight' => $capheight, 2340 'StemV' => 0, 2341 'CharSet' => "($charset)", 2342 } 2343 ) 2344 } 2345 ); 2346 2347 $objct+=2; 2348 $fontlst{$fontno}->{NM}='/F'.$fontno; 2349 $pages->{'Resources'}->{'Font'}->{'F'.$fontno}=$fontlst{$fontno}->{OBJ}; 2350 $fontlst{$fontno}->{FNT}=\%fnt; 2351 } 2352 2353 if (defined($fnt{encoding}) and $fnt{encoding} eq 'text.enc' and $ucmap ne '') 2354 { 2355 if ($textenccmap eq '') 2356 { 2357 $textenccmap = BuildObj($objct+1,{}); 2358 $objct++; 2359 $obj[$objct]->{STREAM}=$ucmap; 2360 } 2361 $obj[$fno]->{DATA}->{'ToUnicode'}=$textenccmap; 2362 } 2363 2364# PutObj($fno); 2365# PutObj($fno+1); 2366# PutObj($fno+2) if defined($obj[$fno+2]); 2367# PutObj($fno+3) if defined($obj[$fno+3]); 2368} 2369 2370sub GetType1 2371{ 2372 my $file=shift; 2373 my ($l1,$l2,$l3); # Return lengths 2374 my ($head,$body,$tail); # Font contents 2375 my $f; 2376 2377 OpenFile(\$f,$fontdir,"$file"); 2378 Msg(1,"Failed to open '$file'") if !defined($f); 2379 2380 $head=GetChunk($f,1,"currentfile eexec"); 2381 $body=GetChunk($f,2,"00000000") if !eof($f); 2382 $tail=GetChunk($f,3,"cleartomark") if !eof($f); 2383 2384 $l1=length($head); 2385 $l2=length($body); 2386 $l3=length($tail); 2387 2388 return($l1,$l2,$l3,"$head$body$tail"); 2389} 2390 2391sub GetChunk 2392{ 2393 my $F=shift; 2394 my $segno=shift; 2395 my $ascterm=shift; 2396 my ($type,$hdr,$chunk,@msg); 2397 binmode($F); 2398 my $enc="ascii"; 2399 2400 while (1) 2401 { 2402 # There may be multiple chunks of the same type 2403 2404 my $ct=read($F,$hdr,2); 2405 2406 if ($ct==2) 2407 { 2408 if (substr($hdr,0,1) eq "\x80") 2409 { 2410 # binary chunk 2411 2412 my $chunktype=ord(substr($hdr,1,1)); 2413 $enc="binary"; 2414 2415 if (defined($type) and $type != $chunktype) 2416 { 2417 seek($F,-2,1); 2418 last; 2419 } 2420 2421 $type=$chunktype; 2422 return if $chunktype == 3; 2423 2424 $ct=read($F,$hdr,4); 2425 2426 Msg(1,"Failed to read binary segment length"), return if $ct != 4; 2427 2428 my $sl=unpack('V',$hdr); 2429 my $data; 2430 my $chk=read($F,$data,$sl); 2431 2432 Msg(1 ,"Failed to read binary segment"), return if $chk != $sl; 2433 2434 $chunk.=$data; 2435 } 2436 else 2437 { 2438 # ascii chunk 2439 2440 my $hex=0; 2441 seek($F,-2,1); 2442 my $ct=0; 2443 2444 while (1) 2445 { 2446 my $lin=<$F>; 2447 2448 last if !$lin; 2449 2450 $hex=1,$enc.=" hex" if $segno == 2 and !$ct and $lin=~m/^[A-F0-9a-f]{4,4}/; 2451 2452 if ($segno !=2 and $lin=~m/^(.*$ascterm\n?)(.*)/) 2453 { 2454 $chunk.=$1; 2455 seek($F,-length($2)-1,1) if $2; 2456 last; 2457 } 2458 elsif ($segno == 2 and $lin=~m/^(.*?)($ascterm.*)/) 2459 { 2460 $chunk.=$1; 2461 seek($F,-length($2)-1,1) if $2; 2462 last; 2463 } 2464 2465 chomp($lin), $lin=pack('H*',$lin) if $hex; 2466 $chunk.=$lin; $ct++; 2467 } 2468 2469 last; 2470 } 2471 } 2472 else 2473 { 2474 push(@msg,"Failed to read 2 header bytes"); 2475 } 2476 } 2477 2478 return $chunk; 2479} 2480 2481sub OutStream 2482{ 2483 my $ono=shift; 2484 2485 IsGraphic(); 2486 $stream.="Q\n"; 2487 $obj[$ono]->{STREAM}=$stream; 2488 $obj[$ono]->{DATA}->{Length}=length($stream); 2489 $stream=''; 2490 PutObj($ono); 2491} 2492 2493sub do_p 2494{ 2495 my $trans='BLOCK'; 2496 2497 $trans='PAGE' if $firstpause; 2498 NewPage($trans); 2499 @XOstream=(); 2500 @PageAnnots=(); 2501 $firstpause=1; 2502} 2503 2504sub FixTrans 2505{ 2506 my $t=shift; 2507 my $style=$t->{S}; 2508 2509 if ($style) 2510 { 2511 delete($t->{Dm}) if $style ne '/Split' and $style ne '/Blinds'; 2512 delete($t->{M}) if !($style eq '/Split' or $style eq '/Box' or $style eq '/Fly'); 2513 delete($t->{Di}) if !($style eq '/Wipe' or $style eq '/Glitter' or $style eq '/Fly' or $style eq '/Cover' or $style eq '/Uncover' or $style eq '/Push') or ($style eq '/Fly' and $t->{Di} eq '/None' and $t->{SS} != 1); 2514 delete($t->{SS}) if !($style eq '/Fly'); 2515 delete($t->{B}) if !($style eq '/Fly'); 2516 } 2517 2518 return($t); 2519} 2520 2521sub NewPage 2522{ 2523 my $trans=shift; 2524 # Start of pages 2525 2526 if ($cpageno > 0) 2527 { 2528 if ($#XOstream>=0) 2529 { 2530 MakeXO() if $stream; 2531 $stream=join("\n",@XOstream,''); 2532 } 2533 2534 my %t=%{$transition->{$trans}}; 2535 $cpage->{MediaBox}=\@mediabox if $custompaper; 2536 $cpage->{Trans}=FixTrans(\%t) if $t{S}; 2537 2538 if ($#PageAnnots >= 0) 2539 { 2540 @{$cpage->{Annots}}=@PageAnnots; 2541 } 2542 2543 PutObj($cpageno); 2544 OutStream($cpageno+1); 2545 } 2546 2547 $cpageno=++$objct; 2548 2549 my $thispg=BuildObj($objct, 2550 {'Type' => '/Page', 2551 'Group' => {'CS' => '/DeviceRGB', 'S' => '/Transparency'}, 2552 'Parent' => '2 0 R', 2553 'Contents' => [ BuildObj($objct+1, 2554 {'Length' => 0} 2555 ) ], 2556 } 2557 ); 2558 2559 splice(@{$pages->{Kids}},++$pginsert,0,$thispg); 2560 splice(@outlines,$pginsert,0,[$curoutlev,$#{$curoutlev}+1,$thislev]); 2561 2562 $objct+=1; 2563 $cpage=$obj[$cpageno]->{DATA}; 2564 $pages->{'Count'}++; 2565 $stream="q 1 0 0 1 0 0 cm\n$linejoin J\n$linecap j\n0.4 w\n"; 2566 $stream.=$strkcol."\n", $curstrk=$strkcol if $strkcol ne ''; 2567 $mode='g'; 2568 $curfill=''; 2569# @mediabox=@defaultmb; 2570} 2571 2572sub MakeXO 2573{ 2574 $stream.="%mode=$mode\n"; 2575 IsGraphic(); 2576 $stream.="Q\n"; 2577 my $xobj=++$objct; 2578 my $xonm="XO$xobj"; 2579 $pages->{'Resources'}->{'XObject'}->{$xonm}=BuildObj($xobj,{'Type' => '/XObject', 'BBox' => \@mediabox, 'Name' => "/$xonm", 'FormType' => 1, 'Subtype' => '/Form', 'Length' => 0, 'Type' => "/XObject"}); 2580 $obj[$xobj]->{STREAM}=$stream; 2581 $stream=''; 2582 push(@XOstream,"q") if $#XOstream==-1; 2583 push(@XOstream,"/$xonm Do"); 2584} 2585 2586sub do_f 2587{ 2588 my $par=shift; 2589 my $fnt=$fontlst{$par}->{FNT}; 2590 2591# IsText(); 2592 $cft="$par"; 2593 $fontchg=1; 2594# $stream.="/F$cft $cftsz Tf\n" if $cftsz; 2595 $widtbl=CacheWid($par); 2596 $origwidtbl=[]; 2597 2598 foreach my $w (@{$fnt->{NO}}) 2599 { 2600 push(@{$origwidtbl},$fnt->{NAM}->{$w->[1]}->[WIDTH]); 2601 } 2602 2603# $krntbl=$fnt->{KERN}; 2604} 2605 2606sub CacheWid 2607{ 2608 my $par=shift; 2609 2610 if (!defined($fontlst{$par}->{CACHE}->{$cftsz})) 2611 { 2612 $fontlst{$par}->{CACHE}->{$cftsz}=BuildCache($fontlst{$par}->{FNT}); 2613 } 2614 2615 return($fontlst{$par}->{CACHE}->{$cftsz}); 2616} 2617 2618sub BuildCache 2619{ 2620 my $fnt=shift; 2621 my @cwid; 2622 $origwidtbl=[]; 2623 2624 foreach my $w (@{$fnt->{NO}}) 2625 { 2626 my $wid=(defined($w) and defined($w->[1]))?$fnt->{NAM}->{$w->[1]}->[WIDTH]:0; 2627 push(@cwid,$wid*$cftsz); 2628 push(@{$origwidtbl},$wid); 2629 } 2630 2631 return(\@cwid); 2632} 2633 2634sub IsText 2635{ 2636 if ($mode eq 'g') 2637 { 2638 $xpos+=$pendmv/$unitwidth; 2639 $stream.="q BT\n$matrix ".PutXY($xpos,$ypos)." Tm\n"; 2640 $poschg=0; 2641 $fontchg=0; 2642 $pendmv=0; 2643 $matrixchg=0; 2644 $tmxpos=$xpos; 2645 $stream.=$textcol."\n", $curfill=$textcol if $textcol ne $curfill; 2646 if (defined($cft)) 2647 { 2648 $whtsz=$fontlst{$cft}->{FNT}->{spacewidth}*$cftsz; 2649 $stream.="/F$cft $cftsz Tf\n"; 2650 } 2651 $stream.="$curkern Tc\n"; 2652 } 2653 2654 if ($poschg or $matrixchg) 2655 { 2656 PutLine(0) if $matrixchg; 2657 $stream.="$matrix ".PutXY($xpos,$ypos)." Tm\n", $poschg=0; 2658 $tmxpos=$xpos; 2659 $matrixchg=0; 2660 $stream.="$curkern Tc\n"; 2661 } 2662 2663 if ($fontchg) 2664 { 2665 PutLine(0); 2666 $whtsz=$fontlst{$cft}->{FNT}->{spacewidth}*$cftsz; 2667 $stream.="/F$cft $cftsz Tf\n" if $cftsz and defined($cft); 2668 $fontchg=0; 2669 } 2670 2671 $mode='t'; 2672} 2673 2674sub IsGraphic 2675{ 2676 if ($mode eq 't') 2677 { 2678 PutLine(); 2679 $stream.="ET Q\n"; 2680 $xpos+=($pendmv-$nomove)/$unitwidth; 2681 $pendmv=0; 2682 $nomove=0; 2683 $stream.=$strkcol."\n", $curstrk=$strkcol if $strkcol ne $curstrk; 2684 $curfill=$fillcol; 2685 } 2686 $mode='g'; 2687} 2688 2689sub do_s 2690{ 2691 my $par=shift; 2692 $par/=$unitwidth; 2693 2694 if ($par != $cftsz and defined($cft)) 2695 { 2696 PutLine(); 2697 $cftsz=$par; 2698 Set_LWidth() if $lwidth < 1; 2699# $stream.="/F$cft $cftsz Tf\n"; 2700 $fontchg=1; 2701 $widtbl=CacheWid($cft); 2702 } 2703 else 2704 { 2705 $cftsz=$par; 2706 Set_LWidth() if $lwidth < 1; 2707 } 2708} 2709 2710sub Set_LWidth 2711{ 2712 IsGraphic(); 2713 $stream.=((($desc{res}/(72*$desc{sizescale}))*$linewidth*$cftsz)/1000)." w\n"; 2714 return; 2715} 2716 2717sub do_m 2718{ 2719 # Groff uses /m[] for text & graphic stroke, and /M[] (DF?) for graphic fill. 2720 # PDF uses G/RG/K for graphic stroke, and g/rg/k for text & graphic fill. 2721 # 2722 # This means that we must maintain g/rg/k state separately for text colour & graphic fill (this is 2723 # probably why 'gs' maintains seperate graphic states for text & graphics when distilling PS -> PDF). 2724 # 2725 # To facilitate this:- 2726 # 2727 # $textcol = current groff stroke colour 2728 # $fillcol = current groff fill colour 2729 # $curfill = current PDF fill colour 2730 2731 my $par=shift; 2732 my $mcmd=substr($par,0,1); 2733 2734 $par=substr($par,1); 2735 $par=~s/^ +//; 2736 2737# IsGraphic(); 2738 2739 $textcol=set_col($mcmd,$par,0); 2740 $strkcol=set_col($mcmd,$par,1); 2741 2742 if ($mode eq 't') 2743 { 2744 PutLine(); 2745 $stream.=$textcol."\n"; 2746 $curfill=$textcol; 2747 } 2748 else 2749 { 2750 $stream.="$strkcol\n"; 2751 $curstrk=$strkcol; 2752 } 2753} 2754 2755sub set_col 2756{ 2757 my $mcmd=shift; 2758 my $par=shift; 2759 my $upper=shift; 2760 my @oper=('g','k','rg'); 2761 2762 @oper=('G','K','RG') if $upper; 2763 2764 if ($mcmd eq 'd') 2765 { 2766 # default colour 2767 return("0 $oper[0]"); 2768 } 2769 2770 my (@c)=split(' ',$par); 2771 2772 if ($mcmd eq 'c') 2773 { 2774 # Text CMY 2775 return(d3($c[0]/65535).' '.d3($c[1]/65535).' '.d3($c[2]/65535)." 0 $oper[1]"); 2776 } 2777 elsif ($mcmd eq 'k') 2778 { 2779 # Text CMYK 2780 return(d3($c[0]/65535).' '.d3($c[1]/65535).' '.d3($c[2]/65535).' '.d3($c[3]/65535)." $oper[1]"); 2781 } 2782 elsif ($mcmd eq 'g') 2783 { 2784 # Text Grey 2785 return(d3($c[0]/65535)." $oper[0]"); 2786 } 2787 elsif ($mcmd eq 'r') 2788 { 2789 # Text RGB0 2790 return(d3($c[0]/65535).' '.d3($c[1]/65535).' '.d3($c[2]/65535)." $oper[2]"); 2791 } 2792} 2793 2794sub do_D 2795{ 2796 my $par=shift; 2797 my $Dcmd=substr($par,0,1); 2798 2799 $par=substr($par,1); 2800 $xpos+=$pendmv/$unitwidth; 2801 $pendmv=0; 2802 2803 IsGraphic(); 2804 2805 if ($Dcmd eq 'F') 2806 { 2807 my $mcmd=substr($par,0,1); 2808 2809 $par=substr($par,1); 2810 $par=~s/^ +//; 2811 2812 $fillcol=set_col($mcmd,$par,0); 2813 $stream.="$fillcol\n"; 2814 $curfill=$fillcol; 2815 } 2816 elsif ($Dcmd eq 'f') 2817 { 2818 my $mcmd=substr($par,0,1); 2819 2820 $par=substr($par,1); 2821 $par=~s/^ +//; 2822 ($par)=split(' ',$par); 2823 2824 if ($par >= 0 and $par <= 1000) 2825 { 2826 $fillcol=set_col('g',int((1000-$par)*65535/1000),0); 2827 } 2828 else 2829 { 2830 $fillcol=lc($textcol); 2831 } 2832 2833 $stream.="$fillcol\n"; 2834 $curfill=$fillcol; 2835 } 2836 elsif ($Dcmd eq '~') 2837 { 2838 # B-Spline 2839 my (@p)=split(' ',$par); 2840 my ($nxpos,$nypos); 2841 2842 foreach my $p (@p) { $p/=$unitwidth; } 2843 $stream.=PutXY($xpos,$ypos)." m\n"; 2844 $xpos+=($p[0]/2); 2845 $ypos+=($p[1]/2); 2846 $stream.=PutXY($xpos,$ypos)." l\n"; 2847 2848 for (my $i=0; $i < $#p-1; $i+=2) 2849 { 2850 $nxpos=(($p[$i]*$tnum)/(2*$tden)); 2851 $nypos=(($p[$i+1]*$tnum)/(2*$tden)); 2852 $stream.=PutXY(($xpos+$nxpos),($ypos+$nypos))." "; 2853 $nxpos=($p[$i]/2 + ($p[$i+2]*($tden-$tnum))/(2*$tden)); 2854 $nypos=($p[$i+1]/2 + ($p[$i+3]*($tden-$tnum))/(2*$tden)); 2855 $stream.=PutXY(($xpos+$nxpos),($ypos+$nypos))." "; 2856 $nxpos=(($p[$i]-$p[$i]/2) + $p[$i+2]/2); 2857 $nypos=(($p[$i+1]-$p[$i+1]/2) + $p[$i+3]/2); 2858 $stream.=PutXY(($xpos+$nxpos),($ypos+$nypos))." c\n"; 2859 $xpos+=$nxpos; 2860 $ypos+=$nypos; 2861 } 2862 2863 $xpos+=($p[$#p-1]-$p[$#p-1]/2); 2864 $ypos+=($p[$#p]-$p[$#p]/2); 2865 $stream.=PutXY($xpos,$ypos)." l\nS\n"; 2866 $poschg=1; 2867 } 2868 elsif ($Dcmd eq 'p' or $Dcmd eq 'P') 2869 { 2870 # Polygon 2871 my (@p)=split(' ',$par); 2872 my ($nxpos,$nypos); 2873 2874 foreach my $p (@p) { $p/=$unitwidth; } 2875 $stream.=PutXY($xpos,$ypos)." m\n"; 2876 2877 for (my $i=0; $i < $#p; $i+=2) 2878 { 2879 $xpos+=($p[$i]); 2880 $ypos+=($p[$i+1]); 2881 $stream.=PutXY($xpos,$ypos)." l\n"; 2882 } 2883 2884 if ($Dcmd eq 'p') 2885 { 2886 $stream.="s\n"; 2887 } 2888 else 2889 { 2890 $stream.="f\n"; 2891 } 2892 $poschg=1; 2893 } 2894 elsif ($Dcmd eq 'c') 2895 { 2896 # Stroke circle 2897 $par=substr($par,1); 2898 my (@p)=split(' ',$par); 2899 2900 DrawCircle($p[0],$p[0]); 2901 $stream.="s\n"; 2902 $poschg=1; 2903 } 2904 elsif ($Dcmd eq 'C') 2905 { 2906 # Fill circle 2907 $par=substr($par,1); 2908 my (@p)=split(' ',$par); 2909 2910 DrawCircle($p[0],$p[0]); 2911 $stream.="f\n"; 2912 $poschg=1; 2913 } 2914 elsif ($Dcmd eq 'e') 2915 { 2916 # Stroke ellipse 2917 $par=substr($par,1); 2918 my (@p)=split(' ',$par); 2919 2920 DrawCircle($p[0],$p[1]); 2921 $stream.="s\n"; 2922 $poschg=1; 2923 } 2924 elsif ($Dcmd eq 'E') 2925 { 2926 # Fill ellipse 2927 $par=substr($par,1); 2928 my (@p)=split(' ',$par); 2929 2930 DrawCircle($p[0],$p[1]); 2931 $stream.="f\n"; 2932 $poschg=1; 2933 } 2934 elsif ($Dcmd eq 'l') 2935 { 2936 # Line To 2937 $par=substr($par,1); 2938 my (@p)=split(' ',$par); 2939 2940 foreach my $p (@p) { $p/=$unitwidth; } 2941 $stream.=PutXY($xpos,$ypos)." m\n"; 2942 $xpos+=$p[0]; 2943 $ypos+=$p[1]; 2944 $stream.=PutXY($xpos,$ypos)." l\n"; 2945 2946 $stream.="S\n"; 2947 $poschg=1; 2948 } 2949 elsif ($Dcmd eq 't') 2950 { 2951 # Line Thickness 2952 $par=substr($par,1); 2953 my (@p)=split(' ',$par); 2954 2955 foreach my $p (@p) { $p/=$unitwidth; } 2956 # $xpos+=$p[0]*100; # WTF!!! 2957 #int lw = ((font::res/(72*font::sizescale))*linewidth*env->size)/1000; 2958 $p[0]=(($desc{res}/(72*$desc{sizescale}))*$linewidth*$cftsz)/1000 if $p[0] < 0; 2959 $lwidth=$p[0]; 2960 $stream.="$p[0] w\n"; 2961 $poschg=1; 2962 $xpos+=$lwidth; 2963 } 2964 elsif ($Dcmd eq 'a') 2965 { 2966 # Arc 2967 $par=substr($par,1); 2968 my (@p)=split(' ',$par); 2969 my $rad180=3.14159; 2970 my $rad360=$rad180*2; 2971 my $rad90=$rad180/2; 2972 2973 foreach my $p (@p) { $p/=$unitwidth; } 2974 2975 # Documentation is wrong. Groff does not use Dh1,Dv1 as centre of the circle! 2976 2977 my $centre=adjust_arc_centre(\@p); 2978 2979 # Using formula here : http://www.tinaja.com/glib/bezcirc2.pdf 2980 # First calculate angle between start and end point 2981 2982 my ($startang,$r)=RtoP(-$centre->[0],$centre->[1]); 2983 my ($endang,$r2)=RtoP(($p[0]+$p[2])-$centre->[0],-($p[1]+$p[3]-$centre->[1])); 2984 $endang+=$rad360 if $endang < $startang; 2985 my $totang=($endang-$startang)/4; # do it in 4 pieces 2986 2987 # Now 1 piece 2988 2989 my $x0=cos($totang/2); 2990 my $y0=sin($totang/2); 2991 my $x3=$x0; 2992 my $y3=-$y0; 2993 my $x1=(4-$x0)/3; 2994 my $y1=((1-$x0)*(3-$x0))/(3*$y0); 2995 my $x2=$x1; 2996 my $y2=-$y1; 2997 2998 # Rotate to start position and draw 4 pieces 2999 3000 foreach my $j (0..3) 3001 { 3002 PlotArcSegment($totang/2+$startang+$j*$totang,$r,$xpos+$centre->[0],GraphY($ypos+$centre->[1]),$x0,$y0,$x1,$y1,$x2,$y2,$x3,$y3); 3003 } 3004 3005 $xpos+=$p[0]+$p[2]; 3006 $ypos+=$p[1]+$p[3]; 3007 3008 $poschg=1; 3009 } 3010} 3011 3012sub deg 3013{ 3014 return int($_[0]*180/3.14159); 3015} 3016 3017sub adjust_arc_centre 3018{ 3019 # Taken from geometry.cpp 3020 3021 # We move the center along a line parallel to the line between 3022 # the specified start point and end point so that the center 3023 # is equidistant between the start and end point. 3024 # It can be proved (using Lagrange multipliers) that this will 3025 # give the point nearest to the specified center that is equidistant 3026 # between the start and end point. 3027 3028 my $p=shift; 3029 my @c; 3030 my $x = $p->[0] + $p->[2]; # (x, y) is the end point 3031 my $y = $p->[1] + $p->[3]; 3032 my $n = $x*$x + $y*$y; 3033 if ($n != 0) 3034 { 3035 $c[0]= $p->[0]; 3036 $c[1] = $p->[1]; 3037 my $k = .5 - ($c[0]*$x + $c[1]*$y)/$n; 3038 $c[0] += $k*$x; 3039 $c[1] += $k*$y; 3040 return(\@c); 3041 } 3042 else 3043 { 3044 return(undef); 3045 } 3046} 3047 3048 3049sub PlotArcSegment 3050{ 3051 my ($ang,$r,$transx,$transy,$x0,$y0,$x1,$y1,$x2,$y2,$x3,$y3)=@_; 3052 my $cos=cos($ang); 3053 my $sin=sin($ang); 3054 my @mat=($cos,$sin,-$sin,$cos,0,0); 3055 my $lw=$lwidth/$r; 3056 3057 $stream.="q $r 0 0 $r $transx $transy cm ".join(' ',@mat)." cm $lw w $x0 $y0 m $x1 $y1 $x2 $y2 $x3 $y3 c S Q\n"; 3058} 3059 3060sub DrawCircle 3061{ 3062 my $hd=shift; 3063 my $vd=shift; 3064 my $hr=$hd/2/$unitwidth; 3065 my $vr=$vd/2/$unitwidth; 3066 my $kappa=0.5522847498; 3067 $hd/=$unitwidth; 3068 $vd/=$unitwidth; 3069 3070 3071 $stream.=PutXY(($xpos+$hd),$ypos)." m\n"; 3072 $stream.=PutXY(($xpos+$hd),($ypos+$vr*$kappa))." ".PutXY(($xpos+$hr+$hr*$kappa),($ypos+$vr))." ".PutXY(($xpos+$hr),($ypos+$vr))." c\n"; 3073 $stream.=PutXY(($xpos+$hr-$hr*$kappa),($ypos+$vr))." ".PutXY(($xpos),($ypos+$vr*$kappa))." ".PutXY(($xpos),($ypos))." c\n"; 3074 $stream.=PutXY(($xpos),($ypos-$vr*$kappa))." ".PutXY(($xpos+$hr-$hr*$kappa),($ypos-$vr))." ".PutXY(($xpos+$hr),($ypos-$vr))." c\n"; 3075 $stream.=PutXY(($xpos+$hr+$hr*$kappa),($ypos-$vr))." ".PutXY(($xpos+$hd),($ypos-$vr*$kappa))." ".PutXY(($xpos+$hd),($ypos))." c\n"; 3076 $xpos+=$hd; 3077 3078 $poschg=1; 3079} 3080 3081sub FindCircle 3082{ 3083 my ($x1,$y1,$x2,$y2,$x3,$y3)=@_; 3084 my ($Xo, $Yo); 3085 3086 my $x=$x2+$x3; 3087 my $y=$y2+$y3; 3088 my $n=$x**2+$y**2; 3089 3090 if ($n) 3091 { 3092 my $k=.5-($x2*$x + $y2*$y)/$n; 3093 return(sqrt($n),$x2+$k*$x,$y2+$k*$y); 3094 } 3095 else 3096 { 3097 return(-1); 3098 } 3099 3100} 3101 3102sub PtoR 3103{ 3104 my ($theta,$r)=@_; 3105 3106 return($r*cos($theta),$r*sin($theta)); 3107} 3108 3109sub RtoP 3110{ 3111 my ($x,$y)=@_; 3112 3113 return(atan2($y,$x),sqrt($x**2+$y**2)); 3114} 3115 3116sub PutLine 3117{ 3118 3119 my $f=shift; 3120 3121 IsText() if !defined($f); 3122 3123 return if (scalar(@lin) == 0) or (!defined($lin[0]->[0]) and $#lin == 0); 3124 3125# $stream.="% --- wht=$whtsz, pend=$pendmv, nomv=$nomove\n" if $debug; 3126 $pendmv-=$nomove; 3127 $lin[$#lin]->[1]=-$pendmv/$cftsz if ($pendmv != 0); 3128 3129 foreach my $wd (@lin) 3130 { 3131 next if !defined($wd->[0]); 3132 $wd->[0]=~s/\\/\\\\/g; 3133 $wd->[0]=~s/\(/\\(/g; 3134 $wd->[0]=~s/\)/\\)/g; 3135 $wd->[0]=~s/!\|!\|/\\/g; 3136 $wd->[1]=d3($wd->[1]); 3137 } 3138 3139 if (0) 3140 { 3141 if (scalar(@lin) == 1 and (!defined($lin[0]->[1]) or $lin[0]->[1] == 0)) 3142 { 3143 $stream.="($lin[0]->[0]) Tj\n"; 3144 } 3145 else 3146 { 3147 $stream.="["; 3148 3149 foreach my $wd (@lin) 3150 { 3151 $stream.="($wd->[0]) " if defined($wd->[0]); 3152 $stream.="$wd->[1] " if defined($wd->[1]) and $wd->[1] != 0; 3153 } 3154 3155 $stream.="] TJ\n"; 3156 } 3157 } 3158 else 3159 { 3160 if (scalar(@lin) == 1 and (!defined($lin[0]->[1]) or $lin[0]->[1] == 0)) 3161 { 3162 $stream.="0 Tw ($lin[0]->[0]) Tj\n"; 3163 } 3164 else 3165 { 3166 if ($wt>=-1 or $#lin == 0 or $lin[0]->[1]>=0) 3167 { 3168 $stream.="0 Tw ["; 3169 3170 foreach my $wd (@lin) 3171 { 3172 $stream.="($wd->[0]) " if defined($wd->[0]); 3173 $stream.="$wd->[1] " if defined($wd->[1]) and $wd->[1] != 0; 3174 } 3175 3176 $stream.="] TJ\n"; 3177 } 3178 else 3179 { 3180 # $stream.="\%dg 0 Tw ["; 3181 # 3182 # foreach my $wd (@lin) 3183 # { 3184 # $stream.="($wd->[0]) " if defined($wd->[0]); 3185 # $stream.="$wd->[1] " if defined($wd->[1]) and $wd->[1] != 0; 3186 # } 3187 # 3188 # $stream.="] TJ\n"; 3189 # 3190 # my $wt=$lin[0]->[1]||0; 3191 3192 # while ($wt < -$whtsz/$cftsz) 3193 # { 3194 # $wt+=$whtsz/$cftsz; 3195 # } 3196 3197 $stream.=sprintf( "%.3f Tw ",-($whtsz+$wt*$cftsz)/$unitwidth-$curkern ); 3198 if (!defined($lin[0]->[0]) and defined($lin[0]->[1])) 3199 { 3200 $stream.="[ $lin[0]->[1] ("; 3201 shift @lin; 3202 } 3203 else 3204 { 3205 $stream.="[("; 3206 } 3207 3208 foreach my $wd (@lin) 3209 { 3210 my $wwt=$wd->[1]||0; 3211 3212 while ($wwt <= $wt+.1) 3213 { 3214 $wwt-=$wt; 3215 $wd->[0].=' '; 3216 } 3217 3218 if (abs($wwt) < .1 or $wwt == 0) 3219 { 3220 $stream.="$wd->[0]" if defined($wd->[0]); 3221 } 3222 else 3223 { 3224 $wwt=sprintf("%.3f",$wwt); 3225 $stream.="$wd->[0]) $wwt (" if defined($wd->[0]); 3226 } 3227 } 3228 $stream.=")] TJ\n"; 3229 } 3230 } 3231 } 3232 3233 @lin=(); 3234 $xpos+=$pendmv/$unitwidth; 3235 $pendmv=0; 3236 $nomove=0; 3237 $wt=-1; 3238} 3239 3240sub d3 3241{ 3242 return(sprintf("%.3f",shift || 0)); 3243} 3244 3245sub LoadAhead 3246{ 3247 my $no=shift; 3248 3249 foreach my $j (1..$no) 3250 { 3251 my $lin=<>; 3252 chomp($lin); 3253 $lin=~s/\r$//; 3254 $lct++; 3255 3256 push(@ahead,$lin); 3257 $stream.="%% $lin\n" if $debug; 3258 } 3259} 3260 3261sub do_V 3262{ 3263 my $par=shift; 3264 3265 if ($mode eq 't') 3266 { 3267 PutLine(); 3268 } 3269 else 3270 { 3271 $xpos+=$pendmv/$unitwidth; 3272 $pendmv=0; 3273 } 3274 3275 $ypos=$par/$unitwidth; 3276 3277 LoadAhead(1); 3278 3279 if (substr($ahead[0],0,1) eq 'H') 3280 { 3281 $xpos=substr($ahead[0],1)/$unitwidth; 3282 3283 $nomove=$pendmv=0; 3284 @ahead=(); 3285 3286 } 3287 3288 $poschg=1; 3289} 3290 3291sub do_v 3292{ 3293 my $par=shift; 3294 3295 PutLine() if $mode eq 't'; 3296 3297 $ypos+=$par/$unitwidth; 3298 3299 $poschg=1; 3300} 3301 3302sub TextWid 3303{ 3304 my $txt=shift; 3305 my $fnt=shift; 3306 my $w=0; 3307 my $ck=0; 3308 3309 foreach my $c (split('',$txt)) 3310 { 3311 my $cn=ord($c); 3312 $widtbl->[$cn]=$origwidtbl->[$cn]*$cftsz if !defined($widtbl->[$cn]); 3313 $w+=$widtbl->[$cn]; 3314 } 3315 3316 $ck=length($txt)*$curkern; 3317 3318 return(($w/$unitwidth)+$ck); 3319} 3320 3321sub do_t 3322{ 3323 my $par=shift; 3324 my $fnt=$fontlst{$cft}->{FNT}; 3325 3326 if ($kernadjust != $curkern) 3327 { 3328 PutLine(); 3329 $stream.="$kernadjust Tc\n"; 3330 $curkern=$kernadjust; 3331 } 3332 3333 my $par2=$par; 3334 $par2=~s/^!\|!\|(\d\d\d)/chr(oct($1))/e; 3335 3336 foreach my $j (0..length($par2)-1) 3337 { 3338 my $cn=ord(substr($par2,$j,1)); 3339 my $chnm=$fnt->{NAM}->{$fnt->{NO}->[$cn]->[1]}; 3340 3341 if ($chnm->[USED]==0) 3342 { 3343 $chnm->[USED]=1; 3344 } 3345 elsif ($fnt->{NO}->[$cn]->[0] ne $fnt->{NO}->[$cn]->[1]) 3346 { 3347 # A glyph has already been remapped to this char, so find a spare 3348 3349 my $cn2=RemapChr($cn,$fnt,$fnt->{NO}->[$cn]->[0]); 3350 $stream.="% MMM Remap $cn to $cn2\n" if $debug; 3351 3352 if ($cn2) 3353 { 3354 substr($par2,$j,1)=chr($cn2); 3355 3356 if ($par=~m/^!\|!\|(\d\d\d)/) 3357 { 3358 substr($par,4,3)=sprintf("%03o",$cn2); 3359 } 3360 else 3361 { 3362 substr($par,$j,1)=chr($cn2); 3363 } 3364 } 3365 } 3366 } 3367 my $wid=TextWid($par2,$fnt); 3368 3369 $par=reverse(split('',$par)) if $xrev and $par!~m/^!\|!\|(\d\d\d)/; 3370 3371 if ($n_flg and defined($mark)) 3372 { 3373 $mark->{ypos}=$ypos; 3374 $mark->{xpos}=$xpos; 3375 } 3376 3377 $n_flg=0; 3378 IsText(); 3379 3380 $xpos+=$wid; 3381 $xpos+=($pendmv-$nomove)/$unitwidth; 3382 3383 $stream.="% == '$par'=$wid 'xpos=$xpos\n" if $debug; 3384 3385 # $pendmv = 'h' move since last 't' 3386 # $nomove = width of char(s) added by 'C', 'N' or 'c' 3387 # $w-flg = 'w' seen since last t 3388 3389 if ($fontchg) 3390 { 3391 PutLine(); 3392 $whtsz=$fontlst{$cft}->{FNT}->{spacewidth}*$cftsz; 3393 $stream.="/F$cft $cftsz Tf\n", $fontchg=0 if $fontchg && defined($cft); 3394 } 3395 3396 $gotT=1; 3397 3398 $stream.="% --- wht=$whtsz, pend=$pendmv, nomv=$nomove\n" if $debug; 3399 3400# if ($w_flg && $#lin > -1) 3401# { 3402# $lin[$#lin]->[0].=' '; 3403# $pendmv-=$whtsz; 3404# $dontglue=1 if $pendmv==0; 3405# } 3406 3407 $wt=-$pendmv/$cftsz if $w_flg and $wt==-1; 3408 $pendmv-=$nomove; 3409 $nomove=0; 3410 $w_flg=0; 3411 3412 if ($xrev) 3413 { 3414 PutLine(0) if $#lin > -1; 3415 MakeMatrix(1); 3416 $stream.="$matrix ".PutXY($xpos,$ypos)." Tm\n", $poschg=0; 3417 $stream.="$curkern Tc\n"; 3418 $stream.="0 Tw "; 3419 $stream.="($par) Tj\n"; 3420 MakeMatrix(); 3421 $stream.="$matrix ".PutXY($xpos,$ypos)." Tm\n", $poschg=0; 3422 $matrixchg=0; 3423 $stream.="$curkern Tc\n"; 3424 return; 3425 } 3426 3427 if ($pendmv) 3428 { 3429 if ($#lin == -1) 3430 { 3431 push(@lin,[undef,-$pendmv/$cftsz]); 3432 } 3433 else 3434 { 3435 $lin[$#lin]->[1]=-$pendmv/$cftsz; 3436 } 3437 3438 push(@lin,[$par,undef]); 3439# $xpos+=$pendmv/$unitwidth; 3440 $pendmv=0 3441 } 3442 else 3443 { 3444 if ($#lin == -1) 3445 { 3446 push(@lin,[$par,undef]); 3447 } 3448 else 3449 { 3450 $lin[$#lin]->[0].=$par; 3451 } 3452 } 3453} 3454 3455sub do_u 3456{ 3457 my $par=shift; 3458 3459 $par=m/([+-]?\d+) (.*)/; 3460 $kernadjust=$1/$unitwidth; 3461 do_t($2); 3462 $kernadjust=0; 3463} 3464 3465sub do_h 3466{ 3467 $pendmv+=shift; 3468} 3469 3470sub do_H 3471{ 3472 my $par=shift; 3473 3474 if ($mode eq 't') 3475 { 3476 PutLine(); 3477 } 3478 else 3479 { 3480 $xpos+=$pendmv/$unitwidth; 3481 $pendmv=0; 3482 } 3483 3484 my $newx=$par/$unitwidth; 3485 $stream.=sprintf("%.3f",$newx-$tmxpos)." 0 Td\n" if $mode eq 't'; 3486 $tmxpos=$xpos=$newx; 3487 $pendmv=$nomove=0; 3488} 3489 3490sub do_C 3491{ 3492 my $par=shift; 3493 3494 my ($par2,$nm)=FindChar($par); 3495 3496 do_t($par2); 3497 $nomove=$fontlst{$cft}->{FNT}->{NAM}->{$par}->[WIDTH]*$cftsz ; 3498} 3499 3500sub FindChar 3501{ 3502 my $chnm=shift; 3503 my $fnt=$fontlst{$cft}->{FNT}; 3504 3505 if (exists($fnt->{NAM}->{$chnm})) 3506 { 3507 my $ch=$fnt->{NAM}->{$chnm}->[ASSIGNED]; 3508 $ch=RemapChr($ch,$fnt,$chnm) if ($ch > 255); 3509 $fnt->{NAM}->{$chnm}->[USED]=0 if $fnt->{NO}->[$ch]->[1] eq $chnm; 3510 3511 return(($ch<32)?sprintf("!|!|%03o",$ch):chr($ch),$widtbl->[$ch]); 3512 } 3513 else 3514 { 3515 return(' '); 3516 } 3517} 3518 3519sub RemapChr 3520{ 3521 my $ch=shift; 3522 my $fnt=shift; 3523 my $chnm=shift; 3524 my $unused=0; 3525 3526 foreach my $un (0..$#{$fnt->{NO}}) 3527 { 3528 next if $un >= 139 and $un <= 144; 3529 $unused=$un,last if $fnt->{NO}->[$un]->[1] eq ''; 3530 } 3531 3532 if (!$unused) 3533 { 3534 foreach my $un (128..255) 3535 { 3536 next if $un >= 139 and $un <= 144; 3537 my $glyph=$fnt->{NO}->[$un]->[1]; 3538 $unused=$un,last if $fnt->{NAM}->{$glyph}->[USED] == 0; 3539 } 3540 } 3541 3542 if ($unused && $unused <= 255) 3543 { 3544 my $glyph=$fnt->{NO}->[$unused]->[1]; 3545 delete($fontlst{$cft}->{CACHE}->{$cftsz}); 3546 $fnt->{NAM}->{$chnm}->[ASSIGNED]=$unused; 3547 $fnt->{NO}->[$unused]->[1]=$chnm; 3548 $widtbl=CacheWid($cft); 3549 3550 $stream.="% AAA Assign $chnm ($ch) to $unused\n" if $debug; 3551 3552 $ch=$unused; 3553 return($ch); 3554 } 3555 else 3556 { 3557 Msg(0,"Too many glyphs used in font '$cft'"); 3558 return(32); 3559 } 3560} 3561 3562sub do_c 3563{ 3564 my $par=shift; 3565 3566 push(@ahead,substr($par,1)); 3567 $par=substr($par,0,1); 3568 my $ch=ord($par); 3569 do_N($ch); 3570} 3571 3572sub do_N 3573{ 3574 my $par=shift; 3575 my $fnt=$fontlst{$cft}->{FNT}; 3576 3577 if (!defined($fnt->{NO}->[$par])) 3578 { 3579 Msg(0,"No chr($par) in font $fnt->{internalname}"); 3580 return; 3581 } 3582 3583 my $chnm=$fnt->{NO}->[$par]->[0]; 3584 do_C($chnm); 3585} 3586 3587sub do_n 3588{ 3589 $gotT=0; 3590 PutLine(0); 3591 $pendmv=$nomove=0; 3592 $n_flg=1; 3593 @lin=(); 3594 PutHotSpot($xpos) if defined($mark); 3595} 3596 3597 35981; 3599######################################################################## 3600### Emacs settings 3601# Local Variables: 3602# mode: CPerl 3603# End: 3604