File Coverage

blib/lib/App/paperback.pm
Criterion Covered Total %
statement 5 475 1.0
branch 0 208 0.0
condition 0 9 0.0
subroutine 2 38 5.2
pod 0 36 0.0
total 7 766 0.9


line stmt bran cond sub pod time code
1             package App::paperback;
2              
3 1     1   57847 use v5.10;
  1         3  
4 1     1   5 use strict;
  1         2  
  1         5688  
5             # use warnings;
6             $^W = 0;
7             our $VERSION = "1.30";
8              
9             my ($GinFile, $GpageObjNr, $GrootNr, $Gpos, $GobjNr, $Gstream, $GoWid, $GoHei);
10             my (@Gkids, @Gcounts, @GmediaBox, @Gobject, @Gparents, @Gto_be_created);
11             my (%GpageXObject, %GObjects, %Gpaper);
12              
13             my $cr = '\s*(?:\015|\012|(?:\015\012))';
14              
15             # ISO 216 paper sizes in pt (four decimals will do):
16             my $JH = 1190.5512; # [J] A3 ~ 420 mm (H)
17             my $JW = 841.8898; # [J] A3 ~ 297 mm (W)
18             my $AH = $JW; # [A] A4 ~ 297 mm (H)
19             my $AW = 595.2756; # [A] A4 ~ 210 mm (W)
20             my $BH = $AW; # [B] A5 ~ 210 mm (H)
21             my $BW = 419.5276; # [B] A5 ~ 148 mm (W)
22             my $CH = $BW; # [C] A6 ~ 148 mm (H)
23             my $CW = 297.6378; # [C] A6 ~ 105 mm (W)
24             # + 1 mm (2.8346 pt) to account for rounding in ISO 216 (148+148=296):
25             my $CG = 422.3622; # [C] A6 $CH + 1 mm (H)
26             my $BG = $CG; # [B] A5 $BW + 1 mm (W)
27              
28             # US paper sizes in pt:
29             my $DH = 792; # [D] US Letter Full (H)
30             my $DW = 612; # [D] US Letter Full (W)
31             my $EH = $DW; # [E] US Letter Half (H)
32             my $EW = 396; # [E] US Letter Half (W)
33             my $FH = $EW; # [F] US Letter Quarter (H)
34             my $FW = 306; # [F] US Letter Quarter (W)
35             my $GH = 1008; # [G] US Legal Full (H)
36             my $GW = $DW; # [G] US Legal Full (W)
37             my $HH = $DW; # [H] US Legal Half (H)
38             my $HW = 504; # [H] US Legal Half (W)
39             my $IH = $HW; # [I] US Legal Quarter (H)
40             my $IW = $FW; # [I] US Legal Quarter (W)
41             my $KH = 1224; # [K] US Tabloid (H)
42             my $KW = $DH; # [K] US Tabloid (W)
43              
44             # Paper surfaces in square pts (expressed as HxW in points):
45             %Gpaper = (
46             QuarterLetter => $FH*$FW, # = 121_176
47             A6 => $CH*$CW, # ~ 124_867
48             QuarterLegal => $IH*$IW, # = 154_224
49             HalfLetter => $EH*$EW, # = 242_352
50             A5 => $BH*$BW, # ~ 249_735
51             HalfLegal => $HH*$HW, # = 308_448
52             Letter => $DH*$DW, # = 484_704
53             A4 => $AH*$AW, # ~ 501_156
54             Legal => $GH*$GW, # = 616_896
55             Tabloid => $KH*$KW, # = 969_408
56             A3 => $JH*$JW, # ~ 1_002_312
57             );
58              
59             # Page reordering and position offset schemas for "4 up":
60             my @P_4UP_13PLUS = (16,1,13,4,2,15,3,14,12,5,9,8,6,11,7,10);
61             my @P_4UP_9PLUS = (12,1,9,4,2,11,3,10,6,7,9999,9999,8,5);
62             my @P_4UP_5PLUS = (8,1,5,4,2,7,3,6);
63             my @P_4UP_1PLUS = (4,1,9999,9999,2,3);
64             my @X_A6_ON_A4 = (0,$CW,$CW,$AW,0,$CW,$CW,$AW,0,$CW,$CW,$AW,0,$CW,$CW,$AW);
65             my @Y_A6_ON_A4 = ($CG,$CG,$CH,$CH,$CG,$CG,$CH,$CH,$CG,$CG,$CH,$CH,$CG,$CG,$CH,$CH);
66             my @X_QT_ON_LT = (0,$FW,$FW,$DW,0,$FW,$FW,$DW,0,$FW,$FW,$DW,0,$FW,$FW,$DW);
67             my @Y_QT_ON_LT = ($FH,$FH,$FH,$FH,$FH,$FH,$FH,$FH,$FH,$FH,$FH,$FH,$FH,$FH,$FH,$FH);
68             my @X_QG_ON_LG = (0,$IW,$IW,$GW,0,$IW,$IW,$GW,0,$IW,$IW,$GW,0,$IW,$IW,$GW);
69             my @Y_QG_ON_LG = ($IH,$IH,$IH,$IH,$IH,$IH,$IH,$IH,$IH,$IH,$IH,$IH,$IH,$IH,$IH,$IH);
70              
71             # Page reordering and position offset schemas for "2 up":
72             my @P_2UP_13PLUS = (1,16,2,15,3,14,4,13,5,12,6,11,7,10,8,9);
73             my @P_2UP_9PLUS = (1,12,2,11,3,10,4,9,5,8,6,7);
74             my @P_2UP_5PLUS = (1,8,2,7,3,6,4,5);
75             my @P_2UP_1PLUS = (1,4,2,3);
76             my @X_A5_ON_A4 = ($BH,$BH,0,0,$BH,$BH,0,0,$BH,$BH,0,0,$BH,$BH,0,0);
77             my @Y_A5_ON_A4 = ($BG,0,$AH,$BG,$BG,0,$AH,$BG,$BG,0,$AH,$BG,$BG,0,$AH,$BG);
78             my @X_HT_ON_LT = ($EH,$EH,0,0,$EH,$EH,0,0,$EH,$EH,0,0,$EH,$EH,0,0);
79             my @Y_HT_ON_LT = ($EW,0,$DH,$EW,$EW,0,$DH,$EW,$EW,0,$DH,$EW,$EW,0,$DH,$EW);
80             my @X_HG_ON_LG = ($HH,$HH,0,0,$HH,$HH,0,0,$HH,$HH,0,0,$HH,$HH,0,0);
81             my @Y_HG_ON_LG = ($HW,0,$GH,$HW,$HW,0,$GH,$HW,$HW,0,$GH,$HW,$HW,0,$GH,$HW);
82             my @X_LT_ON_TA = ($DH,$DH,0,0,$DH,$DH,0,0,$DH,$DH,0,0,$DH,$DH,0,0);
83             my @Y_LT_ON_TA = ($DW,0,$KH,$DW,$DW,0,$KH,$DW,$DW,0,$KH,$DW,$DW,0,$KH,$DW);
84             my @X_A4_ON_A3 = ($AH,$AH,0,0,$AH,$AH,0,0,$AH,$AH,0,0,$AH,$AH,0,0);
85             my @Y_A4_ON_A3 = ($AW,0,$JH,$AW,$AW,0,$JH,$AW,$AW,0,$JH,$AW,$AW,0,$JH,$AW);
86              
87             my ( $IN_FILE, $OUT_FILE );
88              
89              
90             ##########################################################
91             sub main {
92             ##########################################################
93 0     0 0   my $input = $ARGV[0];
94 0           my ($inpPgNum, $inpPgSize);
95 0           my $numPagImposed = 0;
96 0           my $sayUsage = "Usage: paperback file.pdf (will produce 'file-paperback.pdf').";
97 0           my $sayVersion = "This is paperback v${VERSION}, (c) 2022 Hector M. Monacci.";
98 0           my $sayHelp = <<"END_MESSAGE";
99              
100             ${sayUsage}
101              
102             All pages in the input PDF file will be imposed on a new PDF with
103             bigger paper size, ready to be duplex-printed, folded and put together
104             into signatures, according to its original page size. Input PDF is
105             always assumed to be composed of vertical pages of the same size.
106              
107             Input page sizes allowed are A4, A5, A6, Letter, Half Letter, Quarter
108             Letter, Half Legal and Quarter Legal. Other sizes give an error message.
109              
110             Only PDF v1.4 is supported as input, although many higher-labeled
111             PDF files are correctly handled since they are essentially v1.4 PDF
112             files stamped as something more modern.
113              
114             ISO 216 normalised (international) page sizes:
115              
116             Input page sizes A6 (105 x 148 mm) and A5 (148 x 210 mm) produce an
117             output page size of A4 (210 x 297 mm). Input page size A4 (210 x 297 mm)
118             produces an output page size of A3 (297 x 420 mm). Four A6 pages will
119             be put on each A4 page, two A5 pages will be put on each A4 page, or
120             two A4 pages will be put on each A3 page. Before that, input pages will
121             be reordered and reoriented so as to produce a final PDF fit for duplex
122             'long-edge-flip' printing.
123              
124             ANSI normalised (US) page sizes:
125              
126             Input page sizes Quarter Letter (4.25 x 5.5 in) and Half Letter (5.5
127             x 8.5 in) produce a Letter output page size (8.5 x 11 in). Input
128             page sizes Quarter Legal (4.25 x 7 in) and Half Legal (7 x 8.5 in)
129             produce a Legal output page size (8.5 x 14 in). Input page size Letter
130             (8.5 x 11 in) produces a Tabloid output page size (11 x 17 in).
131              
132             Four Quarter-Letter pages will be put on each Letter page, two Half-Letter
133             pages will be put on each Letter page, four Quarter-Legal pages will be
134             put on each Legal page, two Half-Legal pages will be put on each Legal page,
135             or two Letter pages will be put on each Tabloid page. Before that, input
136             pages will be reordered and reoriented so as to produce a final PDF fit for
137             duplex 'long-edge-flip' printing.
138              
139             For further details, please try 'perldoc paperback'.
140              
141             ${sayVersion}
142             END_MESSAGE
143              
144 0 0         die "[!] ${sayUsage}\n" if ! defined $input;
145 0 0 0       do {print STDERR "${sayHelp}" and exit}
  0 0          
146             if $input =~ "^-h\$" or $input =~ "^--help\$";
147 0 0 0       do {print STDERR "${sayVersion}\n" and exit}
  0 0          
148             if $input =~ "^-v\$" or $input =~ "^--version\$";
149 0           ($inpPgNum, $inpPgSize) = openInputFile($input);
150              
151 0           my ($pgPerOutputPage, @x, @y);
152 0           for ($inpPgSize) {
153 0 0         if ($_ eq "A6") { $pgPerOutputPage = 4; @x = @X_A6_ON_A4; @y = @Y_A6_ON_A4; }
  0 0          
  0 0          
  0 0          
    0          
    0          
    0          
    0          
154 0           elsif ($_ eq "A5") { $pgPerOutputPage = 2; @x = @X_A5_ON_A4; @y = @Y_A5_ON_A4; }
  0            
  0            
155 0           elsif ($_ eq "QT") { $pgPerOutputPage = 4; @x = @X_QT_ON_LT; @y = @Y_QT_ON_LT; }
  0            
  0            
156 0           elsif ($_ eq "QG") { $pgPerOutputPage = 4; @x = @X_QG_ON_LG; @y = @Y_QG_ON_LG; }
  0            
  0            
157 0           elsif ($_ eq "HT") { $pgPerOutputPage = 2; @x = @X_HT_ON_LT; @y = @Y_HT_ON_LT; }
  0            
  0            
158 0           elsif ($_ eq "HG") { $pgPerOutputPage = 2; @x = @X_HG_ON_LG; @y = @Y_HG_ON_LG; }
  0            
  0            
159 0           elsif ($_ eq "LT") { $pgPerOutputPage = 2; @x = @X_LT_ON_TA; @y = @Y_LT_ON_TA; }
  0            
  0            
160 0           elsif ($_ eq "A4") { $pgPerOutputPage = 2; @x = @X_A4_ON_A3; @y = @Y_A4_ON_A3; }
  0            
  0            
161 0           else {die "[!] Bad page size (${inpPgSize}). Try 'paperback -h' for more info.\n"}
162             }
163              
164 0           my ($name) = $input =~ /(.+)\.[^.]+$/;
165 0           openOutputFile("${name}-paperback.pdf");
166 0           my ($rot_extra, @p);
167 0 0         if ($pgPerOutputPage == 4) {
168 0           $rot_extra = 0;
169 0           for ($inpPgNum) {
170 0 0         if ($_ >= 13) { @p = @P_4UP_13PLUS; }
  0 0          
    0          
171 0           elsif ($_ >= 9 ) { @p = @P_4UP_9PLUS; }
172 0           elsif ($_ >= 5 ) { @p = @P_4UP_5PLUS; }
173 0           else { @p = @P_4UP_1PLUS; }
174             }
175             } else {
176 0           $rot_extra = 90;
177 0           for ($inpPgNum) {
178 0 0         if ($_ >= 13) { @p = @P_2UP_13PLUS; }
  0 0          
    0          
179 0           elsif ($_ >= 9 ) { @p = @P_2UP_9PLUS; }
180 0           elsif ($_ >= 5 ) { @p = @P_2UP_5PLUS; }
181 0           else { @p = @P_2UP_1PLUS; }
182             }
183             }
184 0           my $lastSignature = $inpPgNum >> 4;
185 0           my ($rotation, $target_page);
186 0           for (my $thisSignature = 0; $thisSignature <= $lastSignature; ++$thisSignature) {
187 0           for (0..15) {
188 0 0         &newPageInOutputFile if $_ % $pgPerOutputPage == 0;
189 0           $target_page = $p[$_] + 16 * $thisSignature;
190 0 0         next if $target_page > $inpPgNum;
191              
192 0 0         $rotation = $_ % 4 > 1 ? $rot_extra + 180 : $rot_extra;
193 0           copyPageFromInputToOutput ({page => $target_page,
194             rotate => $rotation, x => $x[$_], y => $y[$_]});
195 0           ++$numPagImposed;
196 0 0         last if $numPagImposed == $inpPgNum;
197             }
198             }
199 0           &closeInputFile;
200 0           &closeOutputFile;
201             }
202              
203             &main if not caller();
204              
205              
206             ##########################################################
207             sub newPageInOutputFile {
208             ##########################################################
209 0 0   0 0   die "[!] No output file, you must call openOutputFile first.\n" if !$Gpos;
210 0 0         &writePage if $Gstream;
211              
212 0           ++$GobjNr;
213 0           $GpageObjNr = $GobjNr;
214 0           undef %GpageXObject;
215              
216 0           return;
217             }
218              
219              
220             ##########################################################
221             sub copyPageFromInputToOutput {
222             ##########################################################
223 0 0   0 0   die "[!] No output file, you have to call openOutputFile first.\n" if !$Gpos;
224 0           my $param = $_[0];
225 0 0         my $pagenumber = $param->{'page'} or 1;
226 0 0         my $x = $param->{'x'} or 0;
227 0 0         my $y = $param->{'y'} or 0;
228 0 0         my $rotate = $param->{'rotate'} or 0;
229              
230 0           state $formNr; # Este uso de "state" requiere v5.10 (que salió en 2007)
231 0           ++$formNr;
232              
233 0           my $name = "Fm${formNr}";
234 0           my ($formRes, $formCont) = getPage($pagenumber);
235 0           my $refNr = writeRes($formRes, $formCont);
236 0 0         die "[!] Page ${pagenumber} in ${GinFile} can't be used. Concatenate streams!\n"
237             if !defined $refNr;
238 0 0         die "[!] Page ${pagenumber} doesn't exist in file ${GinFile}.\n" if !$refNr;
239 0           &writePageObjectsToOutputFile;
240              
241 0           $Gstream .= "q\n". calcRotateMatrix($x, $y, $rotate) ."\n/Gs0 gs\n/${name} Do\nQ\n";
242 0           $GpageXObject{$name} = $refNr;
243              
244 0           return;
245             }
246              
247              
248             ##########################################################
249             sub setInitGrState {
250             ##########################################################
251 0     0 0   ++$GobjNr;
252              
253 0           $Gobject[$GobjNr] = $Gpos;
254 0           $Gpos += syswrite $OUT_FILE,
255             "${GobjNr} 0 obj<>endobj\n";
256 0           return;
257             }
258              
259              
260             ##########################################################
261             sub createPageResourceDict {
262             ##########################################################
263 0     0 0   my $resourceDict = "/ProcSet[/PDF/Text]/XObject<<";
264 0           $resourceDict .= "/${_} ${GpageXObject{${_}}} 0 R" for keys %GpageXObject;
265 0           $resourceDict .= ">>/ExtGState<>";
266 0           return $resourceDict;
267             }
268              
269              
270             ##########################################################
271             sub writePageResourceDict {
272             ##########################################################
273 0     0 0   my $resourceDict = $_[0];
274              
275 0           state %resources;
276              
277             # Found one identical, use it:
278 0 0         return $resources{$resourceDict} if exists $resources{$resourceDict};
279 0           ++$GobjNr;
280             # Save first 10 resources:
281 0 0         $resources{$resourceDict} = $GobjNr if keys(%resources) < 10;
282 0           $Gobject[$GobjNr] = $Gpos;
283 0           $resourceDict = "${GobjNr} 0 obj<<${resourceDict}>>endobj\n";
284 0           $Gpos += syswrite $OUT_FILE, $resourceDict;
285 0           return $GobjNr;
286             }
287              
288              
289             ##########################################################
290             sub writePageStream {
291             ##########################################################
292 0     0 0   ++$GobjNr;
293 0           $Gobject[$GobjNr] = $Gpos;
294 0           $Gpos += syswrite $OUT_FILE, "${GobjNr} 0 obj<
295             . ">>stream\n${Gstream}\nendstream\nendobj\n";
296 0           $Gobject[$GpageObjNr] = $Gpos;
297 0           $Gstream = "";
298 0           return;
299             }
300              
301              
302             ##########################################################
303             sub writePageResources {
304             ##########################################################
305 0     0 0   my ($parent, $resourceObject) = ($_[0], $_[1]);
306 0           $Gpos += syswrite $OUT_FILE, "${GpageObjNr} 0 obj<
307             . "R/Contents ${GobjNr} 0 R/Resources ${resourceObject} 0 R>>endobj\n";
308 0           push @{ $Gkids[0] }, $GpageObjNr;
  0            
309 0           return;
310             }
311              
312              
313             ##########################################################
314             sub writePage {
315             ##########################################################
316 0 0   0 0   if ( !$Gparents[0] ) {
317 0           ++$GobjNr;
318 0           $Gparents[0] = $GobjNr;
319             }
320 0           my $parent = $Gparents[0];
321 0           my $resourceObjectNr = writePageResourceDict(&createPageResourceDict);
322 0           &writePageStream;
323 0           writePageResources($parent, $resourceObjectNr);
324 0           ++$Gcounts[0];
325 0 0         writePageNodes(8) if $Gcounts[0] > 9;
326 0           return;
327             }
328              
329              
330             ##########################################################
331             sub closeOutputFile {
332             ##########################################################
333 0 0   0 0   return if !$Gpos;
334              
335 0 0         &writePage if $Gstream;
336 0           my $endNode = &writeEndNode;
337              
338 0           my $out_line = "1 0 obj<>endobj\n";
339 0           $Gobject[1] = $Gpos;
340 0           $Gpos += syswrite $OUT_FILE, $out_line;
341 0           my $qty = $#Gobject;
342 0           my $startxref = $Gpos;
343 0           my $xrefQty = $qty + 1;
344 0           $out_line = "xref\n0 ${xrefQty}\n0000000000 65535 f \n";
345 0           $out_line .= sprintf "%.10d 00000 n \n", $_ for @Gobject[1..$qty];
346 0           $out_line .= "trailer\n<<\n/Size ${xrefQty}\n/Root 1 0 R\n"
347             . ">>\nstartxref\n${startxref}\n%%EOF\n";
348              
349 0           syswrite $OUT_FILE, $out_line;
350 0           close $OUT_FILE;
351              
352 0           $Gpos = 0;
353 0           return;
354             }
355              
356              
357             ##########################################################
358             sub writePageNodes {
359             ##########################################################
360 0     0 0   my $qtyChildren = $_[0];
361 0           my $i = 0;
362 0           my $j = 1;
363 0           my $nodeObj;
364              
365 0           while ( $qtyChildren < $#{ $Gkids[$i] } ) {
  0            
366             # Imprimir padre actual y pasar al siguiente nivel:
367 0 0         if ( !$Gparents[$j] ) {
368 0           ++$GobjNr;
369 0           $Gparents[$j] = $GobjNr;
370             }
371              
372             $nodeObj =
373 0           "${Gparents[$i]} 0 obj<
374 0           $nodeObj .= "${_} 0 R " for @{ $Gkids[$i] };
  0            
375 0           $nodeObj .= "]\n/Count ${Gcounts[$i]}>>endobj\n";
376 0           $Gobject[ $Gparents[$i] ] = $Gpos;
377 0           $Gpos += syswrite $OUT_FILE, $nodeObj;
378              
379 0           $Gcounts[$j] += $Gcounts[$i];
380 0           $Gcounts[$i] = 0;
381 0           $Gkids[$i] = [];
382 0           push @{ $Gkids[$j] }, $Gparents[$i];
  0            
383 0           undef $Gparents[$i];
384 0           ++$i;
385 0           ++$j;
386             }
387 0           return;
388             }
389              
390              
391             ##########################################################
392             sub writeEndNode {
393             ##########################################################
394 0     0 0   my $nodeObj;
395 0           my $endNode = $Gparents[-1]; # content of the last element
396 0           my $si = $#Gparents; # index of the last element
397              
398 0 0         my $min = defined $Gparents[0] ? 0 : 1;
399             # for ( my $i = $min ; $Gparents[$i] ne $endNode; ++$i ) {
400 0           for ( my $i = $min; $i < $si; ++$i ) {
401 0 0         if ( defined $Gparents[$i] ) { # Only defined if there are kids
402             # Find parent of current parent:
403 0           my $node;
404 0           for ( my $j = $i + 1 ; ( !$node ) ; ++$j ) {
405 0 0         if ( $Gparents[$j] ) {
406 0           $node = $Gparents[$j];
407 0           $Gcounts[$j] += $Gcounts[$i];
408 0           push @{ $Gkids[$j] }, $Gparents[$i];
  0            
409             }
410             }
411              
412 0           $nodeObj = "${Gparents[$i]} 0 obj<
413 0           $nodeObj .= "${_} 0 R " for @{ $Gkids[$i] };
  0            
414 0           $nodeObj .= "]/Count ${Gcounts[$i]}>>endobj\n";
415 0           $Gobject[ $Gparents[$i] ] = $Gpos;
416 0           $Gpos += syswrite $OUT_FILE, $nodeObj;
417             }
418             }
419              
420             # Arrange and print the end node:
421 0           $nodeObj = "${endNode} 0 obj<
422 0           $nodeObj .= "${_} 0 R " for @{ $Gkids[$si] };
  0            
423 0           $nodeObj .= "]/Count ${Gcounts[$si]}/MediaBox [0 0 ${GoWid} ${GoHei}]>>endobj\n";
424 0           $Gobject[$endNode] = $Gpos;
425 0           $Gpos += syswrite $OUT_FILE, $nodeObj;
426 0           return $endNode;
427             }
428              
429              
430             ##########################################################
431             sub calcRotateMatrix {
432             ##########################################################
433 0     0 0   my $str = "1 0 0 1 ${_[0]} ${_[1]} cm\n";
434 0           my $rotate = $_[2];
435              
436 0 0         if ($rotate) {
437 0           my $upperX = 0; my $upperY = 0;
  0            
438 0           my $radian = sprintf( "%.6f", $rotate / 57.2957795 ); # approx.
439 0           my $Cos = sprintf( "%.6f", cos($radian) );
440 0           my $Sin = sprintf( "%.6f", sin($radian) );
441 0           my $negSin = $Sin * -1;
442 0           $str .= "${Cos} ${Sin} ${negSin} ${Cos} ${upperX} ${upperY} cm\n";
443             }
444 0           return $str;
445             }
446              
447              
448             ##########################################################
449             sub getRootAndMapGobjects {
450             ##########################################################
451 0     0 0   my ( $xref, $tempRoot, $buf, $buf2 );
452              
453 0           sysseek $IN_FILE, -150, 2;
454 0           sysread $IN_FILE, $buf, 200;
455 0 0         die "[!] File '${GinFile}' is encrypted, cannot be used. Aborting.\n"
456             if $buf =~ m'Encrypt';
457              
458 0 0         if ($buf =~ m'/Prev\s+\d') { # "Versioned" PDF file (several xref sections)
    0          
459 0           while ($buf =~ m'/Prev\s+(\d+)') {
460 0           $xref = $1;
461 0           sysseek $IN_FILE, $xref, 0;
462 0           sysread $IN_FILE, $buf, 200;
463             # Reading 200 bytes may NOT be enough. Read on till we find 1st %%EOF:
464 0           until ($buf =~ m'%%EOF') {
465 0           sysread $IN_FILE, $buf2, 200;
466 0           $buf .= $buf2;
467             }
468             }
469             } elsif ( $buf =~ m'\bstartxref\s+(\d+)' ) { # Non-versioned PDF file
470 0           $xref = $1;
471             } else {
472 0           return 0;
473             }
474              
475             # stat[7] = filesize
476 0 0         die "[!] Invalid XREF. Aborting.\n" if $xref > &getInputFileWeight;
477 0           populateGobjects($xref);
478 0           $tempRoot = &getRootFromTraditionalXrefSection;
479 0 0         return 0 unless $tempRoot; # No Root object in ${GinFile}, aborting
480 0           return $tempRoot;
481             }
482              
483              
484             ##########################################################
485             sub mapGobjectsFromTraditionalXref {
486             ##########################################################
487 0     0 0   my ( $idx, $qty, $readBytes );
488 0           sysseek $IN_FILE, $_[0], 0;
489 0           ($qty, $idx) = &extractXrefSection;
490 0           while ($qty) {
491 0           for (1..$qty) {
492 0           sysread $IN_FILE, $readBytes, 20;
493 0 0         $GObjects{$idx} = $1 if $readBytes =~ m'^\s?(\d{10}) \d{5} n';
494 0           ++$idx;
495             }
496 0           ($qty, $idx) = &extractXrefSection;
497             }
498 0           return;
499             }
500              
501              
502             ##########################################################
503             sub populateGobjects {
504             ##########################################################
505 0     0 0   my $xrefPos = $_[0];
506 0           my $readBytes;
507              
508 0           sysseek $IN_FILE, $xrefPos, 0;
509 0           sysread $IN_FILE, $readBytes, 22;
510              
511 0 0         if ($readBytes =~ /^(xref$cr)/) { # Input PDF is v1.4 or lower
    0          
512 0           mapGobjectsFromTraditionalXref($xrefPos + length($1));
513             } elsif ($readBytes =~ m'^\d+\s+\d+\s+obj') { # Input PDF is v1.5 or higher
514 0           die "[!] File '${GinFile}' uses xref streams (not a v1.4 PDF file).\n";
515             } else {
516 0           die "[!] File '${GinFile}' has a malformed xref table.\n";
517             }
518              
519 0           &addSizeToGObjects;
520 0           return;
521             }
522              
523              
524             ##########################################################
525             sub getRootFromTraditionalXrefSection {
526             ##########################################################
527 0     0 0   my $readBytes = " ";
528 0           my $buf;
529 0           while ($readBytes) {
530 0           sysread $IN_FILE, $readBytes, 200;
531 0           $buf .= $readBytes;
532 0 0         return $1 if $buf =~ m'\/Root\s+(\d+)\s+\d+\s+R';
533             }
534 0           return;
535             }
536              
537              
538             ##########################################################
539             sub getContentOfObjectNr {
540             ##########################################################
541 0     0 0   my $index = $_[0];
542              
543 0 0         return 0 if (! defined $GObjects{$index}); # A non-1.4 PDF
544 0           my $buf;
545 0           my ($offset, $size) = @{ $GObjects{$index} };
  0            
546 0           sysseek $IN_FILE, $offset, 0;
547 0           sysread $IN_FILE, $buf, $size;
548 0           return $buf;
549             }
550              
551              
552             ##########################################################
553             sub writePageObjectsToOutputFile {
554             ##########################################################
555 0     0 0   my ($objectContent, $out_line, $part, $strPos, $old_one, $new_one);
556              
557 0           for (@Gto_be_created) {
558 0           $old_one = $_->[0];
559 0           $new_one = $_->[1];
560 0           $objectContent = getContentOfObjectNr($old_one);
561 0 0         if ( $objectContent =~ m'^(\d+ \d+ obj\s*<<)(.+)(>>\s*stream)'s ) {
562 0           $part = $2;
563 0           $strPos = length($1) + length($2) + length($3);
564 0           update_references_and_populate_to_be_created($part);
565 0           $out_line = "${new_one} 0 obj\n<<${part}>>stream";
566 0           $out_line .= substr( $objectContent, $strPos );
567             } else {
568 0 0         $objectContent = substr( $objectContent, length($1) )
569             if $objectContent =~ m'^(\d+ \d+ obj)\b';
570 0           update_references_and_populate_to_be_created($objectContent);
571 0           $out_line = "${new_one} 0 obj ${objectContent}";
572             }
573 0           $Gobject[$new_one] = $Gpos;
574 0           $Gpos += syswrite $OUT_FILE, $out_line;
575             }
576 0           undef @Gto_be_created;
577 0           return;
578             }
579              
580              
581             ##########################################################
582             sub setOutputPageDimensionAndSchema {
583             ##########################################################
584 0 0   0 0   die "[!] File '${GinFile}' is not a valid v1.4 PDF.\n"
585             unless &getPageSizeAndSetMediabox;
586              
587 0           my $surface = $GmediaBox[2]*$GmediaBox[3];
588 0           my $measuresInMm =
589             int($GmediaBox[2] / 72 * 25.4) . " x " . int($GmediaBox[3] / 72 * 25.4) . " mm";
590              
591 0           for ($surface) {
592 0 0         if (alike($_, $Gpaper{QuarterLetter})) {$GoWid = $DW; $GoHei = $DH; return "QT"};
  0            
  0            
  0            
593 0 0         if (alike($_, $Gpaper{A6})) {$GoWid = $AW; $GoHei = $AH; return "A6"};
  0            
  0            
  0            
594 0 0         if (alike($_, $Gpaper{HalfLetter})) {$GoWid = $DW; $GoHei = $DH; return "HT"};
  0            
  0            
  0            
595 0 0         if (alike($_, $Gpaper{QuarterLegal})) {$GoWid = $GW; $GoHei = $GH; return "QG"};
  0            
  0            
  0            
596 0 0         if (alike($_, $Gpaper{A5})) {$GoWid = $AW; $GoHei = $AH; return "A5"};
  0            
  0            
  0            
597 0 0         if (alike($_, $Gpaper{HalfLegal})) {$GoWid = $GW; $GoHei = $GH; return "HG"};
  0            
  0            
  0            
598 0 0         if (alike($_, $Gpaper{Letter})) {$GoWid = $KW; $GoHei = $KH; return "LT"};
  0            
  0            
  0            
599 0 0         if (alike($_, $Gpaper{A4})) {$GoWid = $JW; $GoHei = $JH; return "A4"};
  0            
  0            
  0            
600 0 0         if (alike($_, $Gpaper{Legal})) {return "USlegal, ${measuresInMm}"};
  0            
601 0 0         if (alike($_, $Gpaper{Tabloid})) {return "UStabloid, ${measuresInMm}"};
  0            
602 0 0         if (alike($_, $Gpaper{A3})) {return "A3, ${measuresInMm}"};
  0            
603             }
604 0           return "unknown, ${measuresInMm}";
605             }
606              
607              
608             ##########################################################
609             sub alike {
610             ##########################################################
611 0     0 0   my $hxw = $_[0]; my $namedHxw = $_[1];
  0            
612 0           my $tolerance = 1500;
613 0 0 0       return 0 if $hxw > $namedHxw + $tolerance or $hxw < $namedHxw - $tolerance;
614 0           return 1;
615             }
616              
617              
618             ##########################################################
619             sub getPage {
620             ##########################################################
621 0     0 0   my $pagenumber = $_[0];
622 0 0         die "[!] Page requested (${pagenumber}) does not exist. Aborting.\n"
623             if $pagenumber > &getInputPageCount;
624 0           my ($formRes, $formCont);
625              
626             # Find root:
627 0           my $objectContent = getContentOfObjectNr($GrootNr);
628              
629             # Find pages:
630 0 0         die "[!] Didn't find Pages section in '${GinFile}'. Aborting.\n"
631             unless $objectContent =~ m'/Pages\s+(\d+)\s+\d+\s+R';
632 0           $objectContent = getContentOfObjectNr($1);
633 0           $objectContent = xformObjForThisPage($objectContent, $pagenumber);
634 0           ($formRes, $formCont) = parseAsResourcesAndContentRef($objectContent);
635 0           return ($formRes, $formCont);
636             }
637              
638              
639             ##########################################################
640             sub writeRes {
641             ##########################################################
642 0     0 0   my ($formRes, $objNr) = ($_[0], $_[1]);
643              
644 0           my $objectContent = getContentOfObjectNr($objNr);
645 0           $objectContent =~ m'^(\d+ \d+ obj\s*<<)(.+)(>>\s*stream)'s;
646 0           my $strPos = length($1) + length($2) + length($3);
647 0           my $newPart = "<
648             . "/BBox [@{GmediaBox}] ${2}";
649              
650 0           ++$GobjNr;
651 0           $Gobject[$GobjNr] = $Gpos;
652 0           my $reference = $GobjNr;
653 0           update_references_and_populate_to_be_created($newPart);
654 0           my $out_line = "${reference} 0 obj\n${newPart}>>\nstream";
655 0           $out_line .= substr( $objectContent, $strPos );
656 0           $Gpos += syswrite $OUT_FILE, $out_line;
657 0           return $reference;
658             }
659              
660              
661             ##########################################################
662             sub xformObjForThisPage {
663             ##########################################################
664 0     0 0   my ($objectContent, $pagenumber) = ($_[0], $_[1]);
665 0           my ($vector, @pageObj, @pageObjBackup, $pageAccumulator);
666              
667 0 0         return 0 unless $objectContent =~ m'/Kids\s*\[([^\]]+)';
668 0           $vector = $1;
669              
670 0           $pageAccumulator = 0;
671              
672 0           push @pageObj, $1 while $vector =~ m'(\d+)\s+\d+\s+R'g;
673 0           while ( $pageAccumulator < $pagenumber ) {
674 0           @pageObjBackup = @pageObj;
675 0           undef @pageObj;
676 0 0         last if ! @pageObjBackup; # $pagenumber is > than number of pages in PDF
677 0           for (@pageObjBackup) {
678 0           $objectContent = getContentOfObjectNr($_);
679 0 0         if ( $objectContent =~ m'/Count\s+(\d+)' ) {
680 0 0         if ( ( $pageAccumulator + $1 ) < $pagenumber ) {
681 0           $pageAccumulator += $1;
682             } else {
683 0 0         $vector = $1 if $objectContent =~ m'/Kids\s*\[([^\]]+)' ;
684 0           push @pageObj, $1 while $vector =~ m'(\d+)\s+\d+\s+R'g;
685 0           last;
686             }
687             } else {
688 0           ++$pageAccumulator;
689             }
690 0 0         last if $pageAccumulator == $pagenumber;
691             }
692             }
693 0           return $objectContent;
694             }
695              
696              
697             ##########################################################
698             sub getPageSizeAndSetMediabox {
699             ##########################################################
700             # Find root:
701 0     0 0   my $objectContent = getContentOfObjectNr($GrootNr);
702              
703             # Find pages:
704 0 0         return 0 unless $objectContent =~ m'/Pages\s+(\d+)\s+\d+\s+R';
705 0           $objectContent = getContentOfObjectNr($1);
706 0 0         $objectContent = xformObjForThisPage($objectContent, 1)
707             unless $objectContent =~ m'MediaBox';
708              
709             # Assume all input PDF pages have the same dimensions as first MediaBox found:
710 0 0         if (! @GmediaBox) {
711 0           for ($objectContent) {
712 0 0         if (m'MediaBox\s*\[\s*([\S]+)\s+([\S]+)\s+([\S]+)\s+([\S]+)\s*\]') {
    0          
713 0           @GmediaBox = ($1, $2, $3, $4);
714             } elsif (m'MediaBox\s*(\d+)\s+\d+\s+R\b') { # Size to be found in reference
715 0           my $ref = getContentOfObjectNr($1);
716 0 0         if ($ref =~ m'\[\s*([\S]+)\s+([\S]+)\s+([\S]+)\s+([\S]+)\s*\]') {
717 0           @GmediaBox = ($1, $2, $3, $4)
718             } else {
719 0           return 0; # Meaning "failure"
720             }
721             } else {
722 0           return 0; # Meaning "failure"
723             }
724             }
725             }
726 0           return 1; # Meaning "success"
727             }
728              
729              
730             ##########################################################
731             sub parseAsResourcesAndContentRef {
732             ##########################################################
733 0     0 0   my $objContent = $_[0];
734 0           my ($resources, $formCont);
735              
736 0 0         if ( $objContent =~ m'/Contents\s+(\d+)' ) {
    0          
737 0           $formCont = $1;
738             } elsif ( $objContent =~ m'/Contents\s*\[\s*(\d+)\s+\d+\s+R\s*\]' ) {
739 0           $formCont = $1;
740             }
741 0           $resources = getResourcesFromObj($objContent);
742 0           return ($resources, $formCont);
743             }
744              
745              
746             ##########################################################
747             sub getResourcesFromObj {
748             ##########################################################
749 0     0 0   my $objContent = $_[0];
750 0           my $resources;
751              
752 0 0         return $1 if $objContent =~ m'Resources\s+(\d+\s+\d+\s+R)'; # Reference (95%)
753 0 0         if ( $objContent =~ m'^.+/Resources's ) {
754             # The resources are a dictionary. The whole is copied (morfologia.pdf):
755 0           my $k;
756 0           ( undef, $objContent ) = split /\/Resources/, $objContent;
757 0           $objContent =~ s/<
758 0           $objContent =~ s/>>/>>#/g;
759 0           for ( split /#/, $objContent ) {
760 0 0         if ( m'\S' ) {
761 0           $resources .= $_;
762 0 0         ++$k if m'<<';
763 0 0         --$k if m'>>';
764 0 0         last if $k == 0;
765             }
766             }
767             }
768 0           return $resources;
769             }
770              
771              
772             ##########################################################
773             sub getInputPageCount {
774             ##########################################################
775 0     0 0   state $maxPages;
776 0 0         return $maxPages if defined $maxPages;
777 0           my $objectContent;
778              
779 0 0         return 0 unless eval { $objectContent = getContentOfObjectNr($GrootNr); 1; };
  0            
  0            
780 0 0         if ( $objectContent =~ m'/Pages\s+(\d+)\s+\d+\s+R' ) {
781 0           $objectContent = getContentOfObjectNr($1);
782 0 0         $maxPages = $1 if $objectContent =~ m'/Count\s+(\d+)';
783             }
784 0           return $maxPages;
785             }
786              
787              
788             ##########################################################
789             sub openInputFile {
790             ##########################################################
791 0     0 0   $GinFile = $_[0];
792 0           my ( $inputPageSize, $inputPageCount, $c );
793 0 0         die "[!] File '${GinFile}' is empty.\n" if ! &getInputFileWeight;
794              
795 0 0         open($IN_FILE, q{<}, $GinFile) or die "[!] Couldn't open '${GinFile}'.\n";
796 0           binmode $IN_FILE;
797              
798 0           sysread $IN_FILE, $c, 5;
799 0 0         die "[!] File '${GinFile}' is not a valid v1.4 PDF file.\n" if $c ne "%PDF-";
800              
801             # Find root
802 0           $GrootNr = &getRootAndMapGobjects;
803 0 0         die "[!] File '${GinFile}' is not a valid v1.4 PDF file.\n" unless $GrootNr > 0;
804              
805 0           $inputPageSize = &setOutputPageDimensionAndSchema;
806 0           $inputPageCount = &getInputPageCount;
807              
808 0           return ($inputPageCount, $inputPageSize);
809             }
810              
811              
812             ##########################################################
813             sub getInputFileWeight {
814             ##########################################################
815 0     0 0   state $known;
816 0 0         $known = (stat($GinFile))[7] if ! $known;
817 0           return $known;
818             }
819              
820              
821             ##########################################################
822             sub addSizeToGObjects {
823             ##########################################################
824 0     0 0   my $size = &getInputFileWeight;
825             # Objects are sorted numerically (<=>) and in reverse order ($b $a)
826             # according to their offset in the file: last first
827 0           my @offset = sort { $GObjects{$b} <=> $GObjects{$a} } keys %GObjects;
  0            
828 0           my $pos;
829              
830 0           for (@offset) {
831 0           $pos = $GObjects{$_};
832 0           $size -= $pos;
833 0           $GObjects{$_} = [ $pos, $size ];
834 0           $size = $pos;
835             }
836 0           return;
837             }
838              
839              
840             ##########################################################
841             sub update_references_and_populate_to_be_created {
842             ##########################################################
843 0     0 0   $_[0] =~ s/\b(\d+)\s+\d+\s+R\b/&xform . " 0 R"/eg;
  0            
844 0           return;
845             }
846              
847              
848             # xform translates an old object reference to a new one
849             # and populates a table with what objects must be created
850             ##########################################################
851             sub xform {
852             ##########################################################
853 0     0 0   state %known;
854 0 0         return $known{$1} if exists $known{$1};
855 0           push @Gto_be_created, [ $1, ++$GobjNr ];
856 0           $known{$1} = $GobjNr; # implicit return value (faster)
857             }
858              
859              
860             ##########################################################
861             sub extractXrefSection {
862             ##########################################################
863 0     0 0   my $readBytes = ""; my ($qty, $idx, $c);
  0            
864              
865 0           sysread $IN_FILE, $c, 1;
866 0           sysread $IN_FILE, $c, 1 while $c =~ m'\s';
867 0           while ( $c =~ /[\d ]/ ) {
868 0           $readBytes .= $c;
869 0           sysread $IN_FILE, $c, 1;
870             }
871 0 0         ($idx, $qty) = ($1, $2) if $readBytes =~ m'^(\d+)\s+(\d+)';
872 0           return ($qty, $idx);
873             }
874              
875              
876             ##########################################################
877             sub openOutputFile {
878             ##########################################################
879 0 0   0 0   &closeOutputFile if $Gpos;
880              
881 0           my $outputfile = $_[0];
882 0           my $pdf_signature = "%PDF-1.4\n%\â\ã\Ï\Ó\n"; # Keep it far from file beginning!
883              
884 0 0         open( $OUT_FILE, q{>}, $outputfile )
885             or die "[!] Couldn't open file '${outputfile}'.\n";
886 0           binmode $OUT_FILE;
887 0           $Gpos = syswrite $OUT_FILE, $pdf_signature;
888              
889 0           $GobjNr = 2; # Objeto reservado 1 para raíz y 2 para nodo de pág. inicial
890 0           $Gparents[0] = 2;
891              
892 0           &setInitGrState;
893 0           return;
894             }
895              
896              
897             ##########################################################
898             sub closeInputFile {
899             ##########################################################
900 0     0 0   close $IN_FILE;
901             }
902              
903             1;
904              
905             __END__