File Coverage

blib/lib/PDF/Reuse.pm
Criterion Covered Total %
statement 405 922 43.9
branch 74 354 20.9
condition 20 164 12.2
subroutine 58 88 65.9
pod 10 20 50.0
total 567 1548 36.6


line stmt bran cond sub pod time code
1             package PDF::Reuse;
2              
3 2     2   26720 use 5.006;
  2         4  
4 2     2   7 use strict;
  2         2  
  2         28  
5 2     2   5 use warnings;
  2         9  
  2         66  
6              
7             require Exporter;
8             require Digest::MD5;
9 2         8 use autouse 'Carp' => qw(carp
10             cluck
11 2     2   723 croak);
  2         1064  
12              
13 2     2   1509 use Compress::Zlib qw(compress inflateInit);
  2         93628  
  2         148  
14              
15 2     2   12 use autouse 'Data::Dumper' => qw(Dumper);
  2         2  
  2         10  
16 2     2   1005 use AutoLoader qw(AUTOLOAD);
  2         2012  
  2         9  
17              
18             our $VERSION = '0.37';
19             our @ISA = qw(Exporter);
20             our @EXPORT = qw(prFile
21             prPage
22             prId
23             prIdType
24             prInitVars
25             prEnd
26             prExtract
27             prForm
28             prImage
29             prAltJpeg
30             prJpeg
31             prDoc
32             prDocForm
33             prFont
34             prFontSize
35             prGraphState
36             prGetLogBuffer
37             prAdd
38             prBar
39             prText
40             prDocDir
41             prLogDir
42             prLog
43             prVers
44             prCid
45             prJs
46             prInit
47             prField
48             prTouchUp
49             prCompress
50             prMbox
51             prBookmark
52             prStrWidth
53             prLink
54             prTTFont
55             prSinglePage);
56              
57             our ($utfil, $slutNod, $formCont, $imSeq, $duplicateInits, $page, $sidObjNr, $sida,
58             $interActive, $NamesSaved, $AARootSaved, $AAPageSaved, $root,
59             $AcroFormSaved, $id, $ldir, $checkId, $formNr, $imageNr,
60             $filnamn, $interAktivSida, $taInterAkt, $type, $runfil, $checkCs,
61             $confuseObj, $compress, $pos, $fontNr, $objNr, $docProxy,
62             $defGState, $gSNr, $pattern, $shading, $colorSpace, $totalCount);
63              
64             our (@kids, @counts, @formBox, @objekt, @parents, @aktuellFont, @skapa,
65             @jsfiler, @inits, @bookmarks, @annots);
66              
67             our ( %old, %oldObject, %resurser, %form, %image, %objRef, %nyaFunk, %fontSource,
68             %sidFont, %sidXObject, %sidExtGState, %font, %intAct, %fields, %script,
69             %initScript, %sidPattern, %sidShading, %sidColorSpace, %knownToFile,
70             %processed, %embedded, %dummy, %behandlad, %unZipped, %links, %prefs);
71              
72             our $stream = '';
73             our $idTyp = '';
74             our $ddir = '';
75             our $log = '';
76              
77             #########################
78             # Konstanter för objekt
79             #########################
80              
81 2     2   688 use constant oNR => 0;
  2         3  
  2         91  
82 2     2   9 use constant oPOS => 1;
  2         3  
  2         81  
83 2     2   6 use constant oSTREAMP => 2;
  2         2  
  2         66  
84 2     2   5 use constant oKIDS => 3;
  2         2  
  2         59  
85 2     2   6 use constant oFORM => 4;
  2         2  
  2         68  
86 2     2   6 use constant oIMAGENR => 5;
  2         2  
  2         68  
87 2     2   6 use constant oWIDTH => 6;
  2         2  
  2         57  
88 2     2   6 use constant oHEIGHT => 7;
  2         1  
  2         77  
89 2     2   6 use constant oTYPE => 8;
  2         2  
  2         58  
90 2     2   4 use constant oNAME => 9;
  2         5  
  2         65  
91              
92             ###################################
93             # Konstanter för formulär
94             ###################################
95              
96 2     2   5 use constant fOBJ => 0;
  2         2  
  2         88  
97 2     2   7 use constant fRESOURCE => 1;
  2         3  
  2         78  
98 2     2   6 use constant fBBOX => 2;
  2         2  
  2         69  
99 2     2   5 use constant fIMAGES => 3;
  2         2  
  2         57  
100 2     2   4 use constant fMAIN => 4;
  2         2  
  2         61  
101 2     2   6 use constant fKIDS => 5;
  2         1  
  2         57  
102 2     2   6 use constant fNOKIDS => 6;
  2         2  
  2         68  
103 2     2   5 use constant fID => 7;
  2         6  
  2         65  
104 2     2   5 use constant fVALID => 8;
  2         2  
  2         57  
105              
106             ####################################
107             # Konstanter för images
108             ####################################
109              
110 2     2   6 use constant imWIDTH => 0;
  2         2  
  2         67  
111 2     2   5 use constant imHEIGHT => 1;
  2         2  
  2         59  
112 2     2   6 use constant imXPOS => 2;
  2         2  
  2         61  
113 2     2   6 use constant imYPOS => 3;
  2         2  
  2         55  
114 2     2   18 use constant imXSCALE => 4;
  2         3  
  2         64  
115 2     2   5 use constant imYSCALE => 5;
  2         2  
  2         62  
116 2     2   6 use constant imIMAGENO => 6;
  2         2  
  2         69  
117              
118             #####################################
119             # Konstanter för interaktiva objekt
120             #####################################
121              
122 2     2   6 use constant iNAMES => 1;
  2         2  
  2         58  
123 2     2   16 use constant iACROFORM => 2;
  2         2  
  2         58  
124 2     2   6 use constant iAAROOT => 3;
  2         2  
  2         62  
125 2     2   6 use constant iANNOTS => 4;
  2         2  
  2         58  
126 2     2   6 use constant iSTARTSIDA => 5;
  2         1  
  2         58  
127 2     2   5 use constant iAAPAGE => 6;
  2         2  
  2         56  
128              
129             #####################################
130             # Konstanter för fonter
131             #####################################
132              
133 2     2   6 use constant foREFOBJ => 0;
  2         1  
  2         64  
134 2     2   6 use constant foINTNAMN => 1;
  2         2  
  2         63  
135 2     2   6 use constant foEXTNAMN => 2;
  2         2  
  2         66  
136 2     2   8 use constant foORIGINALNR => 3;
  2         2  
  2         72  
137 2     2   11 use constant foSOURCE => 4;
  2         3  
  2         62  
138 2     2   6 use constant foTYP => 5;
  2         2  
  2         79  
139 2     2   5 use constant foFONTOBJ => 6;
  2         3  
  2         102  
140              
141             ##########
142             # Övrigt
143             ##########
144              
145 2     2   6 use constant IS_MODPERL => $ENV{MOD_PERL}; # For mod_perl 1.
  2         2  
  2         5422  
146             # For mod_perl 2 pass $r to prFile()
147             our $touchUp = 1;
148              
149             our %stdFont =
150             ('Times-Roman' => 'Times-Roman',
151             'Times-Bold' => 'Times-Bold',
152             'Times-Italic' => 'Times-Italic',
153             'Times-BoldItalic' => 'Times-BoldItalic',
154             'Courier' => 'Courier',
155             'Courier-Bold' => 'Courier-Bold',
156             'Courier-Oblique' => 'Courier-Oblique',
157             'Courier-BoldOblique' => 'Courier-BoldOblique',
158             'Helvetica' => 'Helvetica',
159             'Helvetica-Bold' => 'Helvetica-Bold',
160             'Helvetica-Oblique' => 'Helvetica-Oblique',
161             'Helvetica-BoldOblique' => 'Helvetica-BoldOblique',
162             'Symbol' => 'Symbol',
163             'ZapfDingbats' => 'ZapfDingbats',
164             'TR' => 'Times-Roman',
165             'TB' => 'Times-Bold',
166             'TI' => 'Times-Italic',
167             'TBI' => 'Times-BoldItalic',
168             'C' => 'Courier',
169             'CB' => 'Courier-Bold',
170             'CO' => 'Courier-Oblique',
171             'CBO' => 'Courier-BoldOblique',
172             'H' => 'Helvetica',
173             'HB' => 'Helvetica-Bold',
174             'HO' => 'Helvetica-Oblique',
175             'HBO' => 'Helvetica-BoldOblique',
176             'S' => 'Symbol',
177             'Z' => 'ZapfDingbats');
178              
179             our $genLowerX = 0;
180             our $genLowerY = 0;
181             our $genUpperX = 595,
182             our $genUpperY = 842;
183             our $genFont = 'Helvetica';
184             our $fontSize = 12;
185              
186             keys(%resurser) = 10;
187              
188             sub prFont
189 1     1 1 262 { my $nyFont = shift;
190 1         2 my ($intnamn, $extnamn, $objektnr, $oldIntNamn, $oldExtNamn);
191              
192 1 50       3 if (! $pos)
193 0         0 { errLog("No output file, you have to call prFile first");
194             }
195 1         2 $oldIntNamn = $aktuellFont[foINTNAMN];
196 1         1 $oldExtNamn = $aktuellFont[foEXTNAMN];
197 1 50       4 if ($nyFont)
198 1         2 { ($intnamn, $extnamn, $objektnr) = findFont($nyFont);
199             }
200             else
201 0         0 { $intnamn = $aktuellFont[foINTNAMN];
202 0         0 $extnamn = $aktuellFont[foEXTNAMN];
203             }
204 1 50       4 if ($runfil)
205 0         0 { $log .= "Font~$nyFont\n";
206             }
207 1 50       3 if (wantarray)
208 0         0 { return ($intnamn, $extnamn, $oldIntNamn, $oldExtNamn, \%font);
209             }
210             else
211 1         3 { return $intnamn;
212             }
213             }
214              
215             sub prFontSize
216 0   0 0 1 0 { my $fSize = shift || 12;
217 0         0 my $oldFontSize = $fontSize;
218 0 0       0 if ($fSize =~ m'\d+\.?\d*'o)
219 0         0 { $fontSize = $fSize;
220 0 0       0 if ($runfil)
221 0         0 { $log .= "FontSize~$fontSize\n";
222             }
223             }
224 0 0       0 if (! $pos)
225 0         0 { errLog("No output file, you have to call prFile first");
226             }
227              
228 0         0 return ($fontSize, $oldFontSize);
229             }
230              
231             sub prFile
232 1 50   1 1 19 { if ($pos)
233 0         0 { prEnd();
234 0         0 close UTFIL;
235             }
236 1         2 %prefs = ();
237 1         2 my $param = shift;
238 1 50       3 if (ref($param) eq 'HASH')
239 0         0 { $filnamn = '-';
240 0         0 for (keys %{$param})
  0         0  
241 0         0 { my $key = lc($_);
242 0 0 0     0 if ($key eq 'name')
    0 0        
      0        
      0        
243 0         0 { $filnamn = $param->{$_}; }
244             elsif (($key eq 'hidetoolbar')
245             || ($key eq 'hidemenubar')
246             || ($key eq 'hidewindowui')
247             || ($key eq 'fitwindow')
248             || ($key eq 'centerwindow'))
249 0         0 { $prefs{$key} = $param->{$_};
250             }
251             }
252             }
253             else
254 1   50     3 { $filnamn = $param || '-';
255 1 50       3 $prefs{hidetoolbar} = $_[1] if defined $_[1];
256 1 50       3 $prefs{hidemenubar} = $_[2] if defined $_[2];
257 1 50       3 $prefs{hidewindowui} = $_[3] if defined $_[3];
258 1 50       2 $prefs{fitwindow} = $_[4] if defined $_[4];
259 1 50       3 $prefs{centerwindow} = $_[5] if defined $_[5];
260             }
261 1         1 my $kortNamn;
262 1 50       3 if ($filnamn ne '-')
263 1         2 { my $ri = rindex($filnamn,'/');
264 1 50       3 if ($ri > 0)
265 1         4 { $kortNamn = substr($filnamn, ($ri + 1));
266 1 50       4 $utfil = $ddir ? $ddir . $kortNamn : $filnamn;
267             }
268             else
269 0 0       0 { $utfil = $ddir ? $ddir . $filnamn : $filnamn;
270             }
271 1         3 $ri = rindex($utfil,'/');
272 1 50       3 if ($ri > 0)
273 1         3 { my $dirdel = substr($utfil,0,$ri);
274 1 50       18 if (! -e $dirdel)
275 0   0     0 { mkdir $dirdel || errLog("Couldn't create dir $dirdel, $!");
276             }
277             }
278             else
279 0         0 { $ri = rindex($utfil,'\\');
280 0 0       0 if ($ri > 0)
281 0         0 { my $dirdel = substr($utfil,0,$ri);
282 0 0       0 if (! -e $dirdel)
283 0   0     0 { mkdir $dirdel || errLog("Couldn't create dir $dirdel, $!");
284             }
285             }
286             }
287             }
288             else
289 0         0 { $utfil = $filnamn;
290             }
291              
292 1         2 my $utfil_ref = ref $utfil;
293 1 50 33     11 if ($utfil_ref and ($utfil_ref eq 'Apache2::RequestRec') or
    50 33        
      33        
294             ($utfil_ref eq 'Apache::RequestRec') ) # mod_perl 2
295 0         0 { tie *UTFIL, $utfil;
296             }
297             elsif (IS_MODPERL && $utfil eq '-') # mod_perl 1
298             { tie *UTFIL, 'Apache';
299             }
300             elsif ($utfil_ref and $utfil_ref eq 'IO::String')
301 0         0 { tie *UTFIL, $utfil;
302             }
303             else
304 1 50       79 { open (UTFIL, ">$utfil") || errLog("Couldn't open file $utfil, $!");
305             }
306 1         2 binmode UTFIL;
307 1         2 my $utrad = "\%PDF-1.4\n\%\â\ã\Ï\Ó\n";
308              
309 1         31 $pos = syswrite UTFIL, $utrad;
310              
311 1 50       3 if (defined $ldir)
312 0 0       0 { if ($utfil eq '-')
313 0         0 { $kortNamn = 'stdout';
314             }
315 0 0       0 if ($kortNamn)
316 0         0 { $runfil = $ldir . $kortNamn . '.dat';
317             }
318             else
319 0         0 { $runfil = $ldir . $filnamn . '.dat';
320             }
321 0 0       0 open (RUNFIL, ">>$runfil") || errLog("Couldn't open logfile $runfil, $!");
322 0         0 $log .= "Vers~$VERSION\n";
323             }
324              
325              
326 1         3 @parents = ();
327 1         1 @kids = ();
328 1         32 @counts = ();
329 1         2 @objekt = ();
330 1         2 $objNr = 2; # Reserverat objekt 1 för root och 2 för initial sidnod
331 1         2 $parents[0] = 2;
332 1         1 $page = 0;
333 1         1 $formNr = 0;
334 1         1 $imageNr = 0;
335 1         1 $fontNr = 0;
336 1         2 $gSNr = 0;
337 1         1 $pattern = 0;
338 1         1 $shading = 0;
339 1         1 $colorSpace = 0;
340 1         1 $sida = 0;
341 1         2 %font = ();
342 1         2 %resurser = ();
343 1         1 %fields = ();
344 1         2 @jsfiler = ();
345 1         1 @inits = ();
346 1         2 %nyaFunk = ();
347 1         1 %objRef = ();
348 1         1 %knownToFile = ();
349 1         1 @aktuellFont = ();
350 1         2 %old = ();
351 1         2 %behandlad = ();
352 1         1 @bookmarks = ();
353 1         1 %links = ();
354 1         1 undef $defGState;
355 1         1 undef $interActive;
356 1         1 undef $NamesSaved;
357 1         2 undef $AARootSaved;
358 1         1 undef $AcroFormSaved;
359 1         1 $checkId = '';
360 1         1 undef $duplicateInits;
361 1         1 undef $confuseObj;
362 1         1 $fontSize = 12;
363 1         1 $genLowerX = 0;
364 1         1 $genLowerY = 0;
365 1         1 $genUpperX = 595,
366             $genUpperY = 842;
367              
368 1         2 prPage(1);
369 1         2 $stream = ' ';
370 1 50       2 if ($runfil)
371 0         0 { $filnamn = prep($filnamn);
372 0         0 $log .= "File~$filnamn";
373 0 0       0 $log .= (exists $prefs{hidetoolbar}) ? "~$prefs{hidetoolbar}" : '~';
374 0 0       0 $log .= (exists $prefs{hidemenubar}) ? "~$prefs{hidemenubar}" : '~';
375 0 0       0 $log .= (exists $prefs{hidewindowui}) ? "~$prefs{hidewindowui}" : '~';
376 0 0       0 $log .= (exists $prefs{fitwindow}) ? "~$prefs{fitwindow}" : '~';
377 0 0       0 $log .= (exists $prefs{centerwindow}) ? "~$prefs{centerwindow}" : "~\n";
378             }
379 1         2 1;
380             }
381              
382              
383             sub prPage
384 1     1 1 2 { my $noLogg = shift;
385 1 50 33     6 if ((defined $stream) && (length($stream) > 0))
386 0         0 { skrivSida();
387             }
388              
389 1         1 $page++;
390 1         1 $objNr++;
391 1         1 $sidObjNr = $objNr;
392              
393             #
394             # Resurserna nollställs
395             #
396              
397 1         1 %sidXObject = ();
398 1         1 %sidExtGState = ();
399 1         1 %sidFont = ();
400 1         2 %sidPattern = ();
401 1         1 %sidShading = ();
402 1         1 %sidColorSpace = ();
403 1         2 @annots = ();
404              
405 1         1 undef $interAktivSida;
406 1         4 undef $checkCs;
407 1 50 33     2 if (($runfil) && (! $noLogg))
408 0         0 { $log .= "Page~\n";
409 0         0 print RUNFIL $log;
410 0         0 $log = '';
411             }
412 1 50       3 if (! $pos)
413 0         0 { errLog("No output file, you have to call prFile first");
414             }
415 1         1 1;
416              
417             }
418              
419             sub prText
420 1     1 1 1608 { my $xPos = shift;
421 1         1 my $yPos = shift;
422 1         2 my $TxT = shift;
423 1   50     5 my $align = shift || 'left';
424 1   50     6 my $rot = shift || '0';
425              
426 1         1 my $width = 0;
427 1         1 my $x_align_offset = 0;
428              
429 1 50       3 if (! defined $TxT)
430 0         0 { $TxT = '';
431             }
432              
433 1 50 33     6 if (($xPos !~ m'\-?[\d\.]+'o) || (! defined $xPos))
434 0         0 { errLog("Illegal x-position for text: $xPos");
435             }
436 1 50 33     6 if (($yPos !~ m'\-?[\d\.]+'o) || (! defined $yPos))
437 0         0 { errLog("Illegal y-position for text: $yPos");
438             }
439              
440 1 50       3 if ($runfil)
441 0         0 { my $Texten = prep($TxT);
442 0         0 $log .= "Text~$xPos~$yPos~$Texten~$align~$rot\n";
443             }
444              
445 1 50       3 if (length($stream) < 3)
446 1         1 { $stream = "0 0 0 rg\n 0 g\nf\n";
447             }
448              
449              
450 1 50       3 if (! $aktuellFont[foINTNAMN])
451 0         0 { findFont();
452             }
453 1         1 my $Font = $aktuellFont[foINTNAMN]; # Namn i strömmen
454 1         2 $sidFont{$Font} = $aktuellFont[foREFOBJ];
455 1         1 my $fontname = $aktuellFont[foEXTNAMN];
456 1 50       3 my $ttfont = $font{$fontname} ? $font{$fontname}[foFONTOBJ] : undef;
457              
458              
459             # define what the offset for alignment is
460              
461 1 50 33     5 if ((wantarray)
462             || ($align ne 'left'))
463 0         0 { $width = prStrWidth($TxT, $aktuellFont[foEXTNAMN], $fontSize);
464 0 0       0 if($align eq 'right')
    0          
465 0         0 { $x_align_offset = - $width;
466             }
467             elsif ($align eq 'center')
468 0         0 { $x_align_offset = -$width / 2;
469             }
470             }
471              
472 1         2 $TxT =~ s|\(|\\(|gos;
473 1         2 $TxT =~ s|\)|\\)|gos;
474              
475              
476 1 50       2 unless($rot)
477 1         3 { $stream .= "\nBT /$Font $fontSize Tf ";
478 1 50       3 if($ttfont)
    50          
479 0         0 { $TxT = $ttfont->encode_text($TxT);
480 0         0 $stream .= $xPos+$x_align_offset . " $yPos Td $TxT Tj ET\n";
481             }
482             elsif (!$aktuellFont[foTYP])
483 1         4 { $stream .= $xPos+$x_align_offset . " $yPos Td \($TxT\) Tj ET\n";
484             }
485             else
486 0         0 { my $text;
487 0         0 $TxT =~ s/\\(\d\d\d)/chr(oct($1))/eg;
  0         0  
488 0         0 for (unpack ('C*', $TxT))
489 0         0 { $text .= sprintf("%04x", ($_ - 29));
490             }
491 0         0 $stream .= $xPos+$x_align_offset . " $yPos Td \<$text\> Tj ET\n";
492             }
493             }
494             else
495 0 0       0 { if ($rot =~ m'q(\d)'oi)
496 0 0       0 { if ($1 eq '1')
    0          
497 0         0 { $rot = 270;
498             }
499             elsif ($1 eq '2')
500 0         0 { $rot = 180;
501             }
502             else
503 0         0 { $rot = 90;
504             }
505             }
506              
507 0         0 my $radian = sprintf("%.6f", $rot / 57.2957795); # approx.
508 0         0 my $Cos = sprintf("%.6f", cos($radian));
509 0         0 my $Sin = sprintf("%.6f", sin($radian));
510 0         0 my $negSin = $Sin * -1;
511              
512 0 0       0 my $encText = $ttfont ? $ttfont->encode_text($TxT) : "\($TxT\)";
513 0         0 $stream .= "\nq\n" # enter a new stack frame
514             # . "/Gs0 gs\n" # reset graphic mode
515             . "$Cos $Sin $negSin $Cos $xPos $yPos cm\n" # rotation/translation in the CM
516             . "\nBT /$Font $fontSize Tf "
517             . "$x_align_offset 0 Td $encText Tj ET\n" # text @ 0,0
518             . "Q\n"; # close the stack frame
519             }
520 1 50       3 if (! $pos)
521 0         0 { errLog("No output file, you have to call prFile first");
522             }
523              
524              
525 1 50       2 if (wantarray)
526             { # return a new "cursor" position...
527              
528 0 0       0 if($rot==0)
529 0 0       0 { if($align eq 'left')
    0          
    0          
530 0         0 { return ($xPos, $xPos + $width);
531             }
532             elsif($align eq 'center')
533 0         0 { return ($xPos - $x_align_offset, $xPos + $x_align_offset);
534             }
535             elsif($align eq 'right')
536 0         0 { return ($xPos - $width, $xPos);
537             }
538              
539             }
540             else
541             { # todo
542             # we could some trigonometry to return an x/y point
543 0         0 return 1;
544             }
545             }
546             else
547 1         2 { return 1;
548             }
549              
550             }
551              
552              
553             sub prAdd
554 0     0 1 0 { my $contents = shift;
555 0         0 $stream .= "\n$contents\n";
556 0 0       0 if ($runfil)
557 0         0 { $contents = prep($contents);
558 0         0 $log .= "Add~$contents\n";
559             }
560 0         0 $checkCs = 1;
561 0 0       0 if (! $pos)
562 0         0 { errLog("No output file, you have to call prFile first");
563             }
564 0         0 1;
565             }
566              
567             ##########################
568             # Ett grafiskt "formulär"
569             ##########################
570              
571             sub prForm
572 0     0 1 0 { my ($sidnr, $adjust, $effect, $tolerant, $infil, $x, $y, $size, $xsize,
573             $ysize, $rotate);
574 0         0 my $param = shift;
575 0 0       0 if (ref($param) eq 'HASH')
576 0         0 { $infil = $param->{'file'};
577 0   0     0 $sidnr = $param->{'page'} || 1;
578 0   0     0 $adjust = $param->{'adjust'} || '';
579 0   0     0 $effect = $param->{'effect'} || 'print';
580 0   0     0 $tolerant = $param->{'tolerant'} || '';
581 0   0     0 $x = $param->{'x'} || 0;
582 0   0     0 $y = $param->{'y'} || 0;
583 0   0     0 $rotate = $param->{'rotate'} || 0;
584 0   0     0 $size = $param->{'size'} || 1;
585 0   0     0 $xsize = $param->{'xsize'} || 1;
586 0   0     0 $ysize = $param->{'ysize'} || 1;
587             }
588             else
589 0         0 { $infil = $param;
590 0   0     0 $sidnr = shift || 1;
591 0   0     0 $adjust = shift || '';
592 0   0     0 $effect = shift || 'print';
593 0   0     0 $tolerant = shift || '';
594 0   0     0 $x = shift || 0;
595 0   0     0 $y = shift || 0;
596 0   0     0 $rotate = shift || 0;
597 0   0     0 $size = shift || 1;
598 0   0     0 $xsize = shift || 1;
599 0   0     0 $ysize = shift || 1;
600             }
601              
602 0         0 my $refNr;
603             my $namn;
604 0         0 $type = 'form';
605 0         0 my $fSource = $infil . '_' . $sidnr;
606 0 0       0 if (! exists $form{$fSource})
607 0         0 { $formNr++;
608 0         0 $namn = 'Fm' . $formNr;
609 0         0 $knownToFile{$fSource} = $namn;
610 0         0 my $action;
611 0 0       0 if ($effect eq 'load')
612 0         0 { $action = 'load'
613             }
614             else
615 0         0 { $action = 'print'
616             }
617 0         0 $refNr = getPage($infil, $sidnr, $action);
618 0 0       0 if ($refNr)
619 0         0 { $objRef{$namn} = $refNr;
620             }
621             else
622 0 0       0 { if ($tolerant)
    0          
623 0 0 0     0 { if ((defined $refNr) && ($refNr eq '0')) # Sidnumret existerar inte, men ok
624 0         0 { $namn = '0';
625             }
626             else
627 0         0 { undef $namn; # Sidan kan inte användas som form
628             }
629             }
630             elsif (! defined $refNr)
631 0         0 { my $mess = "$fSource can't be used as a form. See the documentation\n"
632             . "under prForm how to concatenate streams\n";
633 0         0 errLog($mess);
634             }
635             else
636 0         0 { errLog("File : $infil Page: $sidnr doesn't exist");
637             }
638             }
639             }
640             else
641 0 0       0 { if (exists $knownToFile{$fSource})
642 0         0 { $namn = $knownToFile{$fSource};
643             }
644             else
645 0         0 { $formNr++;
646 0         0 $namn = 'Fm' . $formNr;
647 0         0 $knownToFile{$fSource} = $namn;
648             }
649 0 0       0 if (exists $objRef{$namn})
650 0         0 { $refNr = $objRef{$namn};
651             }
652             else
653 0 0       0 { if (! $form{$fSource}[fVALID])
    0          
654 0         0 { my $mess = "$fSource can't be used as a form. See the documentation\n"
655             . "under prForm how to concatenate streams\n";
656 0 0       0 if ($tolerant)
657 0         0 { cluck $mess;
658 0         0 undef $namn;
659             }
660             else
661 0         0 { errLog($mess);
662             }
663             }
664             elsif ($effect ne 'load')
665 0         0 { $refNr = byggForm($infil, $sidnr);
666 0         0 $objRef{$namn} = $refNr;
667             }
668             }
669             }
670 0 0       0 my @BBox = @{$form{$fSource}[fBBOX]} if ($refNr);
  0         0  
671 0 0 0     0 if (($effect eq 'print') && ($form{$fSource}[fVALID]) && ($refNr))
      0        
672 0 0       0 { if (! defined $defGState)
673 0         0 { prDefaultGrState();
674             }
675              
676 0 0 0     0 if ($adjust)
    0 0        
      0        
      0        
      0        
677 0         0 { $stream .= "q\n";
678 0         0 $stream .= fillTheForm(@BBox, $adjust);
679 0         0 $stream .= "\n/Gs0 gs\n";
680 0         0 $stream .= "/$namn Do\n";
681 0         0 $stream .= "Q\n";
682             }
683             elsif (($x) || ($y) || ($rotate) || ($size != 1)
684             || ($xsize != 1) || ($ysize != 1))
685 0         0 { $stream .= "q\n";
686 0         0 $stream .= calcMatrix($x, $y, $rotate, $size,
687             $xsize, $ysize, $BBox[2], $BBox[3]);
688 0         0 $stream .= "\n/Gs0 gs\n";
689 0         0 $stream .= "/$namn Do\n";
690 0         0 $stream .= "Q\n";
691             }
692             else
693 0         0 { $stream .= "\n/Gs0 gs\n";
694 0         0 $stream .= "/$namn Do\n";
695              
696             }
697 0         0 $sidXObject{$namn} = $refNr;
698 0         0 $sidExtGState{'Gs0'} = $defGState;
699             }
700 0 0       0 if ($runfil)
701 0         0 { $infil = prep($infil);
702 0         0 $log .= "Form~$infil~$sidnr~$adjust~$effect~$tolerant";
703 0         0 $log .= "~$x~$y~$rotate~$size~$xsize~$ysize\n";
704             }
705 0 0       0 if (! $pos)
706 0         0 { errLog("No output file, you have to call prFile first");
707             }
708 0 0 0     0 if (($effect ne 'print') && ($effect ne 'add'))
709 0         0 { undef $namn;
710             }
711 0 0       0 if (wantarray)
712 0         0 { my $images = 0;
713 0 0       0 if (exists $form{$fSource}[fIMAGES])
714 0         0 { $images = scalar(@{$form{$fSource}[fIMAGES]});
  0         0  
715             }
716 0         0 return ($namn, $BBox[0], $BBox[1], $BBox[2],
717             $BBox[3], $images);
718             }
719             else
720 0         0 { return $namn;
721             }
722             }
723              
724              
725              
726             ##########################################################
727             sub prDefaultGrState
728             ##########################################################
729 0     0 0 0 { $objNr++;
730 0         0 $defGState = $objNr;
731 0 0       0 if (! $pos)
732 0         0 { errLog("No output file, you have to call prFile first");
733             }
734              
735 0         0 $objekt[$objNr] = $pos;
736 0         0 my $utrad = "$objNr 0 obj" . '<
737             . ">>endobj\n";
738 0         0 $pos += syswrite UTFIL, $utrad;
739 0         0 $objRef{'Gs0'} = $objNr;
740 0         0 return ('Gs0', $defGState);
741             }
742              
743             ######################################################
744             # En font lokaliseras och fontobjektet skrivs ev. ut
745             ######################################################
746              
747             sub findFont
748 2     2   9 { no warnings;
  2         2  
  2         4194  
749 2   100 2 0 399 my $Font = shift || '';
750              
751 2 50       5 if (! (exists $fontSource{$Font})) # Fonten måste skapas
752 2 100       5 { if (exists $stdFont{$Font})
753 1         2 { $Font = $stdFont{$Font};}
754             else
755 1         2 { $Font = $genFont; } # Helvetica sätts om inget annat finns
756 2 50       5 if (! (exists $font{$Font}))
757 2         2 { $objNr++;
758 2         2 $fontNr++;
759 2         4 my $fontAbbr = 'Ft' . $fontNr;
760 2         6 my $fontObjekt = "$objNr 0 obj<
761             "/BaseFont/$Font/Encoding/WinAnsiEncoding>>endobj\n";
762 2         8 $font{$Font}[foINTNAMN] = $fontAbbr;
763 2         3 $font{$Font}[foREFOBJ] = $objNr;
764 2         5 $objRef{$fontAbbr} = $objNr;
765 2         4 $fontSource{$Font}[foSOURCE] = 'Standard';
766 2         2 $objekt[$objNr] = $pos;
767 2         25 $pos += syswrite UTFIL, $fontObjekt;
768             }
769             }
770             else
771 0 0       0 { if (defined $font{$Font}[foREFOBJ]) # Finns redan i filen
772             { ; }
773             else
774 0 0       0 { if ($fontSource{$Font}[foSOURCE] eq 'Standard')
775 0         0 { $objNr++;
776 0         0 $fontNr++;
777 0         0 my $fontAbbr = 'Ft' . $fontNr;
778 0         0 my $fontObjekt = "$objNr 0 obj<
779             "/BaseFont/$Font/Encoding/WinAnsiEncoding>>endobj\n";
780 0         0 $font{$Font}[foINTNAMN] = $fontAbbr;
781 0         0 $font{$Font}[foREFOBJ] = $objNr;
782 0         0 $objRef{$fontAbbr} = $objNr;
783 0         0 $objekt[$objNr] = $pos;
784 0         0 $pos += syswrite UTFIL, $fontObjekt;
785             }
786             else
787 0         0 { my $fSource = $fontSource{$Font}[foSOURCE];
788 0         0 my $ri = rindex($fSource, '_');
789 0         0 my $Source = substr($fSource, 0, $ri);
790 0         0 my $Page = substr($fSource, ($ri + 1));
791              
792 0 0       0 if (! $fontSource{$Font}[foORIGINALNR])
793 0         0 { errLog("Couldn't find $Font, aborts");
794             }
795             else
796             { my $namn = extractObject($Source, $Page,
797 0         0 $fontSource{$Font}[foORIGINALNR], 'Font');
798             }
799             }
800             }
801             }
802              
803 2         3 $aktuellFont[foEXTNAMN] = $Font;
804 2         3 $aktuellFont[foREFOBJ] = $font{$Font}[foREFOBJ];
805 2         2 $aktuellFont[foINTNAMN] = $font{$Font}[foINTNAMN];
806 2         3 $aktuellFont[foTYP] = $font{$Font}[foTYP];
807              
808 2         4 $sidFont{$aktuellFont[foINTNAMN]} = $aktuellFont[foREFOBJ];
809 2 50       4 if (! $pos)
810 0         0 { errLog("No output file, you have to call prFile first");
811             }
812              
813 2         5 return ($aktuellFont[foINTNAMN], $aktuellFont[foEXTNAMN], $aktuellFont[foREFOBJ]);
814             }
815              
816             sub skrivSida
817 1     1 0 1 { my ($compressFlag, $streamObjekt, @extObj);
818 1 50       3 if ($checkCs)
819 0         0 { @extObj = ($stream =~ m'/(\S+)\s*'gso);
820 0         0 checkContentStream(@extObj);
821             }
822 1 50 33     3 if (( $compress ) && ( length($stream) > 99 ))
823 0         0 { my $output = compress($stream);
824 0 0 0     0 if ((length($output) > 25) && (length($output) < (length($stream))))
825 0         0 { $stream = $output;
826 0         0 $compressFlag = 1;
827             }
828             }
829              
830 1 50       7 if (! $parents[0])
831 0         0 { $objNr++;
832 0         0 $parents[0] = $objNr;
833             }
834 1         3 my $parent = $parents[0];
835              
836             ##########################################
837             # Interaktiva funktioner läggs ev. till
838             ##########################################
839              
840 1 50       2 if ($interAktivSida)
841 0         0 { my ($infil, $sidnr) = split(/\s+/, $interActive);
842 0         0 ($NamesSaved, $AARootSaved, $AAPageSaved, $AcroFormSaved)
843             = AcroFormsEtc($infil, $sidnr);
844             }
845              
846             ##########################
847             # Skapa resursdictionary
848             ##########################
849 1         2 my $resursDict = "/ProcSet[/PDF/Text]";
850 1 50       2 if (scalar %sidFont)
851 1         2 { $resursDict .= '/Font << ';
852 1         1 my $i = 0;
853 1         6 for (sort keys %sidFont)
854 2         5 { $resursDict .= "/$_ $sidFont{$_} 0 R";
855             }
856              
857 1         1 $resursDict .= " >>";
858             }
859 1 50       3 if (scalar %sidXObject)
860 0         0 { $resursDict .= '/XObject<<';
861 0         0 for (sort keys %sidXObject)
862 0         0 { $resursDict .= "/$_ $sidXObject{$_} 0 R";
863             }
864 0         0 $resursDict .= ">>";
865             }
866 1 50       1 if (scalar %sidExtGState)
867 0         0 { $resursDict .= '/ExtGState<<';
868 0         0 for (sort keys %sidExtGState)
869 0         0 { $resursDict .= "\/$_ $sidExtGState{$_} 0 R";
870             }
871 0         0 $resursDict .= ">>";
872             }
873 1 50       3 if (scalar %sidPattern)
874 0         0 { $resursDict .= '/Pattern<<';
875 0         0 for (sort keys %sidPattern)
876 0         0 { $resursDict .= "/$_ $sidPattern{$_} 0 R";
877             }
878 0         0 $resursDict .= ">>";
879             }
880 1 50       2 if (scalar %sidShading)
881 0         0 { $resursDict .= '/Shading<<';
882 0         0 for (sort keys %sidShading)
883 0         0 { $resursDict .= "/$_ $sidShading{$_} 0 R";
884             }
885 0         0 $resursDict .= ">>";
886             }
887 1 50       3 if (scalar %sidColorSpace)
888 0         0 { $resursDict .= '/ColorSpace<<';
889 0         0 for (sort keys %sidColorSpace)
890 0         0 { $resursDict .= "/$_ $sidColorSpace{$_} 0 R";
891             }
892 0         0 $resursDict .= ">>";
893             }
894              
895              
896 1         1 my $resursObjekt;
897              
898 1 50       3 if (exists $resurser{$resursDict})
899 0         0 { $resursObjekt = $resurser{$resursDict}; # Fanns ett identiskt,
900             } # använd det
901             else
902 1         1 { $objNr++;
903 1 50       3 if ( keys(%resurser) < 10)
904 1         2 { $resurser{$resursDict} = $objNr; # Spara 10 första resursobjekten
905             }
906 1         1 $resursObjekt = $objNr;
907 1         3 $objekt[$objNr] = $pos;
908 1         2 $resursDict = "$objNr 0 obj<<$resursDict>>endobj\n";
909 1         31 $pos += syswrite UTFIL, $resursDict ;
910             }
911 1         2 my $sidObjekt;
912              
913 1 50       3 if (! $touchUp)
914             { #
915             # Contents objektet skapas
916             #
917              
918 0         0 my $devX = "900";
919 0         0 my $devY = "900";
920              
921 0         0 my $mellanObjekt = '<
922 0 0       0 if (defined $resursObjekt)
923 0         0 { $mellanObjekt .= "/Resources $resursObjekt 0 R";
924             }
925 0         0 $mellanObjekt .= "/BBox \[$genLowerX $genLowerY $genUpperX $genUpperY\]" .
926             "/Matrix \[ 1 0 0 1 -$devX -$devY \]";
927              
928 0         0 my $langd = length($stream);
929              
930 0         0 $objNr++;
931 0         0 $objekt[$objNr] = $pos;
932 0 0       0 if (! $compressFlag)
933 0         0 { $mellanObjekt = "$objNr 0 obj\n$mellanObjekt/Length $langd>>stream\n"
934             . $stream;
935 0         0 $mellanObjekt .= "endstream\nendobj\n";
936             }
937             else
938 0         0 { $stream = "\n" . $stream . "\n";
939 0         0 $langd++;
940 0         0 $mellanObjekt = "$objNr 0 obj\n$mellanObjekt/Filter/FlateDecode"
941             . "/Length $langd>>stream" . $stream;
942 0         0 $mellanObjekt .= "endstream\nendobj\n";
943             }
944              
945 0         0 $pos += syswrite UTFIL, $mellanObjekt;
946 0         0 $mellanObjekt = $objNr;
947              
948 0 0       0 if (! defined $confuseObj)
949 0         0 { $objNr++;
950 0         0 $objekt[$objNr] = $pos;
951              
952 0         0 $stream = "\nq\n1 0 0 1 $devX $devY cm\n/Xwq Do\nQ\n";
953 0         0 $langd = length($stream);
954 0         0 $confuseObj = $objNr;
955 0         0 $stream = "$objNr 0 obj<>stream\n" . "$stream";
956 0         0 $stream .= "\nendstream\nendobj\n";
957 0         0 $pos += syswrite UTFIL, $stream;
958             }
959 0         0 $sidObjekt = "$sidObjNr 0 obj\n<
960             . "/MediaBox \[$genLowerX $genLowerY $genUpperX $genUpperY\]"
961             . "/Resources <>>>";
962             }
963             else
964 1         1 { my $langd = length($stream);
965              
966 1         1 $objNr++;
967 1         2 $objekt[$objNr] = $pos;
968 1 50       3 if (! $compressFlag)
969 1         3 { $streamObjekt = "$objNr 0 obj<>stream\n" . $stream;
970 1         2 $streamObjekt .= "\nendstream\nendobj\n";
971             }
972             else
973 0         0 { $stream = "\n" . $stream . "\n";
974 0         0 $langd++;
975              
976 0         0 $streamObjekt = "$objNr 0 obj<
977             . "/Length $langd>>stream" . $stream;
978 0         0 $streamObjekt .= "endstream\nendobj\n";
979             }
980              
981 1         7 $pos += syswrite UTFIL, $streamObjekt;
982 1         1 $streamObjekt = $objNr;
983             ##################################
984             # Så skapas och skrivs sidobjektet
985             ##################################
986              
987 1         7 $sidObjekt = "$sidObjNr 0 obj<
988             . "/MediaBox \[$genLowerX $genLowerY $genUpperX $genUpperY\]"
989             . "/Resources $resursObjekt 0 R";
990             }
991              
992 1         5 $stream = '';
993              
994 1         1 my $tSida = $sida + 1;
995 1 50 33     11 if ((@annots)
      33        
      33        
      33        
996 0         0 || (%links && @{$links{'-1'}})
997 0         0 || (%links && @{$links{$tSida}}))
998 0         0 { $sidObjekt .= '/Annots ' . mergeLinks() . ' 0 R';
999             }
1000 1 50       5 if (defined $AAPageSaved)
1001 0         0 { $sidObjekt .= "/AA $AAPageSaved";
1002 0         0 undef $AAPageSaved;
1003             }
1004 1         2 $sidObjekt .= ">>endobj\n";
1005 1         2 $objekt[$sidObjNr] = $pos;
1006 1         6 $pos += syswrite UTFIL, $sidObjekt;
1007 1         2 push @{$kids[0]}, $sidObjNr;
  1         3  
1008 1         1 $sida++;
1009 1         1 $counts[0]++;
1010 1 50       3 if ($counts[0] > 9)
1011 0         0 { ordnaNoder(8); }
1012             }
1013              
1014              
1015             sub prEnd
1016 1 50   1 1 5 { if (! $pos)
1017 0         0 { return;
1018             }
1019 1 50       3 if ($stream)
1020 1         8 { skrivSida(); }
1021 1         3 skrivUtNoder();
1022              
1023 1 50       3 if($docProxy)
1024 0         0 { $docProxy->write_objects;
1025 0         0 undef $docProxy; # Break circular refs
1026             }
1027              
1028             ###################
1029             # Skriv root
1030             ###################
1031              
1032 1 50       2 if (! defined $objekt[$objNr])
1033 0         0 { $objNr--; # reserverat sidobjektnr utnyttjades aldrig
1034             }
1035              
1036 1         3 my $utrad = "1 0 obj<
1037 1 50 50     5 if (defined $NamesSaved)
    50          
1038 0         0 { $utrad .= "\/Names $NamesSaved 0 R\n";
1039             }
1040             elsif ((scalar %fields) || (scalar @jsfiler))
1041 0         0 { $utrad .= "\/Names " . behandlaNames() . " 0 R\n";
1042             }
1043 1 50       2 if (defined $AARootSaved)
1044 0         0 { $utrad .= "/AA $AARootSaved\n";
1045             }
1046 1 50 50     7 if ((scalar @inits) || (scalar %fields))
1047 0         0 { my $nyttANr = skrivKedja();
1048 0         0 $utrad .= "/OpenAction $nyttANr 0 R";
1049             }
1050              
1051 1 50       2 if (defined $AcroFormSaved)
1052 0         0 { $utrad .= "/AcroForm $AcroFormSaved\n";
1053             }
1054              
1055 1 50       3 if (scalar @bookmarks)
1056 0         0 { my $outLine = ordnaBookmarks();
1057 0         0 $utrad .= "/Outlines $outLine 0 R/PageMode /UseOutlines\n";
1058             }
1059 1 50       3 if (scalar %prefs)
1060 0         0 { $utrad .= '/ViewerPreferences << ';
1061 0 0       0 if (exists $prefs{hidetoolbar})
1062 0 0       0 { $utrad .= ($prefs{hidetoolbar}) ? '/HideToolbar true'
1063             : '/HideToolbar false';
1064             }
1065 0 0       0 if (exists $prefs{hidemenubar})
1066 0 0       0 { $utrad .= ($prefs{hidemenubar}) ? '/HideMenubar true'
1067             : '/HideMenubar false';
1068             }
1069 0 0       0 if (exists $prefs{hidewindowui})
1070 0 0       0 { $utrad .= ($prefs{hidewindowui}) ? '/HideWindowUI true'
1071             : '/HideWindowUI false';
1072             }
1073 0 0       0 if (exists $prefs{fitwindow})
1074 0 0       0 { $utrad .= ($prefs{fitwindow}) ? '/FitWindow true'
1075             : '/FitWindow false';
1076             }
1077 0 0       0 if (exists $prefs{centerwindow})
1078 0 0       0 { $utrad .= ($prefs{centerwindow}) ? '/CenterWindow true'
1079             : '/CenterWindow false';
1080             }
1081 0         0 $utrad .= '>> ';
1082             }
1083              
1084 1         3 $utrad .= ">>endobj\n";
1085              
1086 1         2 $objekt[1] = $pos;
1087 1         6 $pos += syswrite UTFIL, $utrad;
1088 1         2 my $antal = $#objekt;
1089 1         1 my $startxref = $pos;
1090 1         1 my $xrefAntal = $antal + 1;
1091 1         5 $pos += syswrite UTFIL, "xref\n";
1092 1         6 $pos += syswrite UTFIL, "0 $xrefAntal\n";
1093 1         5 $pos += syswrite UTFIL, "0000000000 65535 f \n";
1094              
1095 1         6 for (my $i = 1; $i <= $antal; $i++)
1096 7         12 { $utrad = sprintf "%.10d 00000 n \n", $objekt[$i];
1097 7         35 $pos += syswrite UTFIL, $utrad;
1098             }
1099              
1100 1         2 $utrad = "trailer\n<<\n/Size $xrefAntal\n/Root 1 0 R\n";
1101 1 50       3 if ($idTyp ne 'None')
1102 1         2 { my ($id1, $id2) = definieraId();
1103 1         3 $utrad .= "/ID [<$id1><$id2>]\n";
1104 1         2 $log .= "IdType~rep\n";
1105 1         2 $log .= "Id~$id1\n";
1106             }
1107 1         2 $utrad .= ">>\nstartxref\n$startxref\n";
1108 1         6 $pos += syswrite UTFIL, $utrad;
1109 1         4 $pos += syswrite UTFIL, "%%EOF\n";
1110 1         7 close UTFIL;
1111              
1112 1 50       5 if ($runfil)
1113 0 0       0 { if ($log)
1114 0         0 { print RUNFIL $log;
1115             }
1116 0         0 close RUNFIL;
1117             }
1118 1         2 $log = '';
1119 1         1 $runfil = '';
1120 1         1 $pos = 0;
1121 1         1 1;
1122             }
1123              
1124             sub ordnaNoder
1125 0     0 0 0 { my $antBarn = shift;
1126 0         0 my $i = 0;
1127 0         0 my $j = 1;
1128 0         0 my $vektor;
1129              
1130 0         0 while ($antBarn < $#{$kids[$i]})
  0         0  
1131             { #
1132             # Skriv ut aktuell förälder
1133             # flytta till nästa nivå
1134             #
1135 0         0 $vektor = '[';
1136              
1137 0         0 for (@{$kids[$i]})
  0         0  
1138 0         0 { $vektor .= "$_ 0 R "; }
1139 0         0 $vektor .= ']';
1140              
1141 0 0       0 if (! $parents[$j])
1142 0         0 { $objNr++;
1143 0         0 $parents[$j] = $objNr;
1144             }
1145              
1146 0         0 my $nodObjekt;
1147 0         0 $nodObjekt = "$parents[$i] 0 obj<>endobj\n";
1148              
1149 0         0 $objekt[$parents[$i]] = $pos;
1150 0         0 $pos += syswrite UTFIL, $nodObjekt;
1151 0         0 $counts[$j] += $counts[$i];
1152 0         0 $counts[$i] = 0;
1153 0         0 $kids[$i] = [];
1154 0         0 push @{$kids[$j]}, $parents[$i];
  0         0  
1155 0         0 undef $parents[$i];
1156 0         0 $i++;
1157 0         0 $j++;
1158             }
1159             }
1160              
1161             sub skrivUtNoder
1162 2     2   9 { no warnings;
  2         2  
  2         3864  
1163 1     1 0 1 my ($i, $j, $vektor, $nodObjekt);
1164 1         1 my $si = -1;
1165             #
1166             # Hitta slutnoden
1167             #
1168 1         2 for (@parents)
1169 1         2 { $slutNod = $_;
1170 1         1 $si++;
1171             }
1172              
1173 1         4 for ($i = 0; $parents[$i] ne $slutNod; $i++)
1174 0 0       0 { if (defined $parents[$i]) # Bara definierat om det finns kids
1175 0         0 { $vektor = '[';
1176 0         0 for (@{$kids[$i]})
  0         0  
1177 0         0 { $vektor .= "$_ 0 R "; }
1178 0         0 $vektor .= ']';
1179             ########################################
1180             # Hitta förälder till aktuell förälder
1181             ########################################
1182 0         0 my $nod;
1183 0         0 for ($j = $i + 1; (! $nod); $j++)
1184 0 0       0 { if ($parents[$j])
1185 0         0 { $nod = $parents[$j];
1186 0         0 $counts[$j] += $counts[$i];
1187 0         0 push @{$kids[$j]}, $parents[$i];
  0         0  
1188             }
1189             }
1190              
1191 0         0 $nodObjekt = "$parents[$i] 0 obj<>endobj\n";
1192              
1193 0         0 $objekt[$parents[$i]] = $pos;
1194 0         0 $pos += syswrite UTFIL, $nodObjekt;
1195             }
1196             }
1197             #####################################
1198             # Så ordnas och skrivs slutnoden ut
1199             #####################################
1200 1         4 $vektor = '[';
1201 1         1 for (@{$kids[$si]})
  1         2  
1202 1         3 { $vektor .= "$_ 0 R "; }
1203 1         1 $vektor .= ']';
1204 1         3 $nodObjekt = "$slutNod 0 obj<
1205             # $nodObjekt .= "/MediaBox \[$genLowerX $genLowerY $genUpperX $genUpperY\]";
1206 1         1 $nodObjekt .= " >>endobj\n";
1207 1         2 $objekt[$slutNod] = $pos;
1208 1         6 $pos += syswrite UTFIL, $nodObjekt;
1209              
1210             }
1211              
1212             sub findGet
1213 0     0 0 0 { my ($fil, $cid) = @_;
1214 0         0 $fil =~ s|\s+$||o;
1215 0         0 my ($req, $extFil, $tempFil, $fil2, $tStamp, $res);
1216              
1217 0 0       0 if (-e $fil)
1218 0         0 { $tStamp = (stat($fil))[9];
1219 0 0       0 if ($cid)
1220             {
1221 0 0       0 if ($cid eq $tStamp)
1222 0         0 { return ($fil, $cid);
1223             }
1224             }
1225             else
1226 0         0 { return ($fil, $tStamp);
1227             }
1228             }
1229 0 0       0 if ($cid)
1230 0         0 { $fil2 = $fil . $cid;
1231 0 0       0 if (-e $fil2)
1232 0         0 { return ($fil2, $cid);
1233             }
1234             }
1235 0         0 errLog("The file $fil can't be found, aborts");
1236             }
1237              
1238             sub definieraId
1239 1 50   1 0 5 { if ($idTyp eq 'rep')
    50          
1240 0 0       0 { if (! defined $id)
1241 0         0 { errLog("Can't replicate the id if is missing, aborting");
1242             }
1243 0         0 my $tempId = $id;
1244 0         0 undef $id;
1245 0         0 return ($tempId, $tempId);
1246             }
1247             elsif ($idTyp eq 'add')
1248 0         0 { $id++;
1249 0         0 return ($id, $id);
1250             }
1251             else
1252 1         3 { my $str = time();
1253 1         2 $str .= $filnamn . $pos;
1254 1         6 $str = Digest::MD5::md5_hex($str);
1255 1         3 return ($str, $str);
1256             }
1257             }
1258              
1259             sub prStrWidth
1260 0     0 1   { require PDF::Reuse::Util;
1261 0           my $string = shift;
1262 0           my $Font = shift;
1263 0   0       my $FontSize = shift || $fontSize;
1264 0           my $w = 0;
1265              
1266             # there's no use continuing if no string is passed in
1267 0 0         if (! defined($string))
1268 0           { errLog("undefined value passed to prStrWidth");
1269             }
1270              
1271 0 0         if (length($string) == 0)
1272 0           { return 0;
1273             }
1274              
1275 0 0         if(my($width) = ttfStrWidth($string, $Font, $FontSize))
1276 0           { return $width;
1277             }
1278              
1279 0 0         if (! $Font)
1280 0 0         { if (! $aktuellFont[foEXTNAMN])
1281 0           { findFont();
1282             }
1283 0           $Font = $aktuellFont[foEXTNAMN];
1284             }
1285              
1286 0 0         if (! exists $PDF::Reuse::Util::font_widths{$Font})
1287 0 0         { if (exists $stdFont{$Font})
1288 0           { $Font = $stdFont{$Font};
1289             }
1290 0 0         if (! exists $PDF::Reuse::Util::font_widths{$Font})
1291 0           { $Font = 'Helvetica';
1292             }
1293             }
1294              
1295 0 0         if (ref($PDF::Reuse::Util::font_widths{$Font}) eq 'ARRAY')
1296 0           { my @font_table = @{ $PDF::Reuse::Util::font_widths{$Font} };
  0            
1297 0           for (unpack ("C*", $string))
1298 0           { $w += $font_table[$_];
1299             }
1300             }
1301             else
1302 0           { $w = length($string) * $PDF::Reuse::Util::font_widths{$Font};
1303             }
1304 0           $w = $w / 1000 * $FontSize;
1305              
1306 0           return $w;
1307             }
1308              
1309             sub prTTFont
1310 0 0   0 1   { return prFont() if ! @_;
1311 0           my($selector, $fontname) = @_;
1312              
1313             # Have we loaded this font already?
1314 0           my $ttfont = findTTFont($selector);
1315 0 0 0       if (! $ttfont and $font{$selector} )
1316 0           { return prFont($selector);
1317             }
1318 0 0         $fontname = $ttfont->fontname if $ttfont;
1319              
1320             # Create a new TTFont object if we haven't loaded this one before
1321 0 0         if (! $ttfont)
1322             { $docProxy ||= PDF::Reuse::DocProxy->new(
1323 0     0     next_obj => sub { ++$objNr },
1324 0   0       prObj => \&prObj,
1325             );
1326              
1327 0           my $ttfont = PDF::Reuse::TTFont->new(
1328             filename => $selector,
1329             fontname => $fontname,
1330             fontAbbr => 'Ft' . ++$fontNr,
1331             docProxy => $docProxy,
1332             );
1333 0           $fontname = $ttfont->fontname;
1334              
1335 0           $font{$fontname}[foINTNAMN] = $ttfont->fontAbbr;
1336 0           $font{$fontname}[foREFOBJ] = $ttfont->obj_num;
1337 0           $font{$fontname}[foFONTOBJ] = $ttfont;
1338 0           $objRef{$ttfont->fontAbbr} = $ttfont->obj_num;
1339 0           $fontSource{$fontname}[foSOURCE] = 'Standard';
1340             }
1341              
1342 0           my $oldIntNamn = $aktuellFont[foINTNAMN];
1343 0           my $oldExtNamn = $aktuellFont[foEXTNAMN];
1344              
1345 0           $aktuellFont[foEXTNAMN] = $fontname;
1346 0           $aktuellFont[foREFOBJ] = $font{$fontname}[foREFOBJ];
1347 0           $aktuellFont[foINTNAMN] = $font{$fontname}[foINTNAMN];
1348 0           $aktuellFont[foTYP] = $font{$fontname}[foTYP];
1349              
1350 0           $sidFont{$aktuellFont[foINTNAMN]} = $aktuellFont[foREFOBJ];
1351              
1352 0 0         if (wantarray)
1353 0           { return ($aktuellFont[foINTNAMN], $aktuellFont[foEXTNAMN], $oldIntNamn, $oldExtNamn, \%font);
1354             }
1355             else
1356 0           { return $aktuellFont[foINTNAMN];
1357             }
1358             }
1359              
1360              
1361             sub prObj
1362 0     0 0   { my($objNr, $data) = @_;
1363              
1364 0           $objekt[$objNr] = $pos;
1365 0           $pos += syswrite UTFIL, $data;
1366             }
1367              
1368              
1369             sub findTTFont
1370 0   0 0 0   { my $selector = shift || $aktuellFont[foEXTNAMN];
1371              
1372 0 0         return $font{$selector}[foFONTOBJ] if $font{$selector};
1373 0           foreach my $name (keys %font)
1374 0 0 0       { if ( $font{$name}[foINTNAMN] eq $selector
      0        
1375             or $font{$name}[foFONTOBJ] && $font{$name}[foFONTOBJ]->filename eq $selector
1376             )
1377 0           { return $font{$name}[foFONTOBJ];
1378             }
1379             }
1380 0           return;
1381             }
1382              
1383              
1384             sub ttfStrWidth
1385 0     0 0   { my($string, $selector, $fontsize) = @_;
1386              
1387 0 0         my $ttfont = findTTFont($selector) or return;
1388 0           return $ttfont->text_width($string, $fontsize);
1389             }
1390              
1391              
1392             # This 'glue' package emulates the bits of the Text::PDF::File API that are
1393             # needed by Text::PDF::TTFont0 (below) and ties them in to the PDF::Reuse API.
1394              
1395             package PDF::Reuse::DocProxy;
1396              
1397             sub new
1398 0     0     { my $class = shift;
1399              
1400 0           my $self = bless { ' version' => 3, @_, '>buffer' => '', }, $class;
1401             }
1402              
1403              
1404             sub new_obj
1405 0     0     { my $self = shift;
1406 0 0         my $obj = shift or die 'No base for new_obj';
1407              
1408 0           my $num = $self->{next_obj}->();
1409 0           my $gen = 0;
1410              
1411 0           $self->{' objcache'}{$num, $gen} = $obj;
1412 0           $self->{' objects'}{$obj->uid} = [ $num, $gen ];
1413 0           return $obj;
1414             }
1415              
1416              
1417             sub object_number
1418 0     0     { my($self, $obj) = @_;
1419 0   0       my $num = $self->{' objects'}{$obj->uid} || return;
1420 0           return $num->[0];
1421             }
1422              
1423              
1424             sub print
1425 0     0     { my($self, $data) = @_;
1426              
1427 0 0         if(my($tail, $rest) = $data =~ m{\A(.*?\nendobj\n)(.*)\z}s)
1428 0           { my($obj_num) = $self->{'>buffer'} =~ /(\d+)/;
1429             # Pass serialised object back to PDF::Reuse
1430 0           $self->{prObj}->($obj_num, $self->{'>buffer'} . $tail);
1431 0           $self->{'>buffer'} = $rest;
1432             }
1433             else
1434 0           { $self->{'>buffer'} .= $data;
1435             }
1436             }
1437              
1438              
1439             sub printf
1440 0     0     { my($self, $format, @args) = @_;;
1441 0           $self->print(sprintf($format, @args));
1442             }
1443              
1444              
1445             sub out_obj
1446 0     0     { my($self, $obj) = @_;
1447 0 0         return $self->new_obj($obj) unless defined $self->{' objects'}{$obj->uid};
1448 0           push @{ $self->{'>todo'} }, $obj->uid;
  0            
1449             }
1450              
1451              
1452             sub tell
1453 0     0     { return length shift->{'>buffer'};
1454             }
1455              
1456              
1457             sub write_objects
1458 0     0     { my($self) = @_;
1459              
1460 0           $self->{'>done'} = {};
1461 0           $self->{'>todo'} = [ sort map { $_->uid } values %{ $self->{' objcache'} } ];
  0            
  0            
1462 0           while(my $id = shift @{ $self->{'>todo'} }) {
  0            
1463 0 0         next if $self->{'>done'}{$id};
1464 0           my($num, $gen) = @{ $self->{' objects'}{$id} };
  0            
1465 0           $self->printf("%d %d obj\n", $num, $gen);
1466 0           $self->{' objcache'}{$num, $gen}->outobjdeep($self, $self);
1467 0           $self->print("\nendobj\n");
1468 0           $self->{'>done'}{$id}++;
1469             }
1470             }
1471              
1472              
1473             # This is a wrapper around Text::PDF::TTFont0, which provides support for
1474             # embedding TrueType fonts
1475              
1476             package PDF::Reuse::TTFont;
1477              
1478             sub new
1479 0     0     { my $class = shift;
1480              
1481 0           require Text::PDF::TTFont0;
1482              
1483 0           my $self = bless { 'subset' => 1, @_, }, $class;
1484              
1485             $self->{ttfont} = Text::PDF::TTFont0->new(
1486             $self->{docProxy},
1487             $self->{filename},
1488             $self->{fontAbbr},
1489             -subset => $self->{subset},
1490 0           );
1491 0           $self->{ttfont}->{' subvec'} = '';
1492              
1493 0           $self->{obj_num} = $self->{docProxy}->object_number($self->{ttfont});
1494              
1495 0   0       $self->{fontname} ||= $self->find_name();
1496              
1497 0           return $self;
1498             }
1499              
1500 0     0     sub filename { return $_[0]->{filename}; }
1501 0     0     sub fontname { return $_[0]->{fontname}; }
1502 0     0     sub obj_num { return $_[0]->{obj_num}; }
1503 0     0     sub fontAbbr { return $_[0]->{fontAbbr}; }
1504 0     0     sub docProxy { return $_[0]->{docProxy}; }
1505              
1506             sub find_name
1507 0     0     { my $self = shift;
1508 0           my($filebase) = $self->filename =~ m{.*[\\/](.*)\.};
1509 0 0         my $font = $self->{ttfont}->{' font'} or return $filebase;
1510 0 0         my $obj = $font->{'name'} or return $filebase;
1511 0 0         my $name = $obj->read->find_name(4) or return $filebase;
1512 0           $name =~ s{\W}{}g;
1513 0           return $name;
1514             }
1515              
1516             sub encode_text
1517 0     0     { my($self, $text) = @_;
1518 0           $text =~ s|\\\(|(|gos;
1519 0           $text =~ s|\\\)|)|gos;
1520 0           return $self->{ttfont}->out_text($text);
1521             }
1522              
1523             sub text_width
1524 0     0     { my($self, $text, $size) = @_;
1525 0           return $self->{ttfont}->width($text) * $size;
1526             }
1527              
1528             sub DESTROY
1529 0     0     { my $self = shift;
1530 0 0         if(my $ttfont = $self->{ttfont})
1531 0 0         { if(my $font = delete $ttfont->{' font'})
1532 0           { $font->release();
1533             }
1534 0           $ttfont->release();
1535             }
1536 0           %$self = ();
1537             }
1538              
1539              
1540             package PDF::Reuse; # Applies to the autoloaded methods below (?)
1541              
1542             1;
1543              
1544             __END__