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