src/devices/gropdf/gropdf.pl

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