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   65516 use v5.10;
  1         3  
4 1     1   4 use strict;
  1         2  
  1         5193  
5             # use warnings;
6             $^W = 0;
7             our $VERSION = "1.31";
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 = (000,$CW,$CW,$AW,000,$CW,$CW,$AW,000,$CW,$CW,$AW,000,$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 = (000,$FW,$FW,$DW,000,$FW,$FW,$DW,000,$FW,$FW,$DW,000,$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 = (000,$IW,$IW,$GW,000,$IW,$IW,$GW,000,$IW,$IW,$GW,000,$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,000,000,$BH,$BH,000,000,$BH,$BH,000,000,$BH,$BH,000,000);
77             my @Y_A5_ON_A4 = ($BG,000,$AH,$BG,$BG,000,$AH,$BG,$BG,000,$AH,$BG,$BG,000,$AH,$BG);
78             my @X_HT_ON_LT = ($EH,$EH,000,000,$EH,$EH,000,000,$EH,$EH,000,000,$EH,$EH,000,000);
79             my @Y_HT_ON_LT = ($EW,000,$DH,$EW,$EW,000,$DH,$EW,$EW,000,$DH,$EW,$EW,000,$DH,$EW);
80             my @X_HG_ON_LG = ($HH,$HH,000,000,$HH,$HH,000,000,$HH,$HH,000,000,$HH,$HH,000,000);
81             my @Y_HG_ON_LG = ($HW,000,$GH,$HW,$HW,000,$GH,$HW,$HW,000,$GH,$HW,$HW,000,$GH,$HW);
82             my @X_LT_ON_TA = ($DH,$DH,000,000,$DH,$DH,000,000,$DH,$DH,000,000,$DH,$DH,000,000);
83             my @Y_LT_ON_TA = ($DW,000,$KH,$DW,$DW,000,$KH,$DW,$DW,000,$KH,$DW,$DW,000,$KH,$DW);
84             my @X_A4_ON_A3 = ($AH,$AH,000,000,$AH,$AH,000,000,$AH,$AH,000,000,$AH,$AH,000,000);
85             my @Y_A4_ON_A3 = ($AW,000,$JH,$AW,$AW,000,$JH,$AW,$AW,000,$JH,$AW,$AW,000,$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, 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. Encrypted PDFs are not supported.
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 0           for ( my $i = $min; $i < $si; ++$i ) {
400 0 0         if ( defined $Gparents[$i] ) { # Only defined if there are kids
401             # Find parent of current parent:
402 0           my $node;
403 0           for ( my $j = $i + 1 ; ( !$node ) ; ++$j ) {
404 0 0         if ( $Gparents[$j] ) {
405 0           $node = $Gparents[$j];
406 0           $Gcounts[$j] += $Gcounts[$i];
407 0           push @{ $Gkids[$j] }, $Gparents[$i];
  0            
408             }
409             }
410              
411 0           $nodeObj = "${Gparents[$i]} 0 obj<
412 0           $nodeObj .= "${_} 0 R " for @{ $Gkids[$i] };
  0            
413 0           $nodeObj .= "]/Count ${Gcounts[$i]}>>endobj\n";
414 0           $Gobject[ $Gparents[$i] ] = $Gpos;
415 0           $Gpos += syswrite $OUT_FILE, $nodeObj;
416             }
417             }
418              
419             # Arrange and print the end node:
420 0           $nodeObj = "${endNode} 0 obj<
421 0           $nodeObj .= "${_} 0 R " for @{ $Gkids[$si] };
  0            
422 0           $nodeObj .= "]/Count ${Gcounts[$si]}/MediaBox [0 0 ${GoWid} ${GoHei}]>>endobj\n";
423 0           $Gobject[$endNode] = $Gpos;
424 0           $Gpos += syswrite $OUT_FILE, $nodeObj;
425 0           return $endNode;
426             }
427              
428              
429             ##########################################################
430             sub calcRotateMatrix {
431             ##########################################################
432 0     0 0   my $str = "1 0 0 1 ${_[0]} ${_[1]} cm\n";
433 0           my $rotate = $_[2];
434              
435 0 0         if ($rotate) {
436 0           my $upperX = 0; my $upperY = 0;
  0            
437 0           my $radian = sprintf( "%.6f", $rotate / 57.2957795 ); # approx.
438 0           my $Cos = sprintf( "%.6f", cos($radian) );
439 0           my $Sin = sprintf( "%.6f", sin($radian) );
440 0           my $negSin = $Sin * -1;
441 0           $str .= "${Cos} ${Sin} ${negSin} ${Cos} ${upperX} ${upperY} cm\n";
442             }
443 0           return $str;
444             }
445              
446              
447             ##########################################################
448             sub getRootAndMapGobjects {
449             ##########################################################
450 0     0 0   my ( $xref, $tempRoot, $buf, $buf2 );
451              
452 0           sysseek $IN_FILE, -150, 2;
453 0           sysread $IN_FILE, $buf, 200;
454 0 0         die "[!] File '${GinFile}' is encrypted, cannot be used. Aborting.\n"
455             if $buf =~ m'Encrypt';
456              
457 0 0         if ($buf =~ m'/Prev\s+\d') { # "Versioned" PDF file (several xref sections)
    0          
458 0           while ($buf =~ m'/Prev\s+(\d+)') {
459 0           $xref = $1;
460 0           sysseek $IN_FILE, $xref, 0;
461 0           sysread $IN_FILE, $buf, 200;
462             # Reading 200 bytes may NOT be enough. Read on till we find 1st %%EOF:
463 0           until ($buf =~ m'%%EOF') {
464 0           sysread $IN_FILE, $buf2, 200;
465 0           $buf .= $buf2;
466             }
467             }
468             } elsif ( $buf =~ m'\bstartxref\s+(\d+)' ) { # Non-versioned PDF file
469 0           $xref = $1;
470             } else {
471 0           return 0;
472             }
473              
474             # stat[7] = filesize
475 0 0         die "[!] Invalid XREF. Aborting.\n" if $xref > &getInputFileWeight;
476 0           populateGobjects($xref);
477 0           $tempRoot = &getRootFromTraditionalXrefSection;
478 0 0         return 0 unless $tempRoot; # No Root object in ${GinFile}, aborting
479 0           return $tempRoot;
480             }
481              
482              
483             ##########################################################
484             sub mapGobjectsFromTraditionalXref {
485             ##########################################################
486 0     0 0   my ( $idx, $qty, $readBytes );
487 0           sysseek $IN_FILE, $_[0], 0;
488 0           ($qty, $idx) = &extractXrefSection;
489 0           while ($qty) {
490 0           for (1..$qty) {
491 0           sysread $IN_FILE, $readBytes, 20;
492 0 0         $GObjects{$idx} = $1 if $readBytes =~ m'^\s?(\d{10}) \d{5} n';
493 0           ++$idx;
494             }
495 0           ($qty, $idx) = &extractXrefSection;
496             }
497 0           return;
498             }
499              
500              
501             ##########################################################
502             sub populateGobjects {
503             ##########################################################
504 0     0 0   my $xrefPos = $_[0];
505 0           my $readBytes;
506              
507 0           sysseek $IN_FILE, $xrefPos, 0;
508 0           sysread $IN_FILE, $readBytes, 22;
509              
510 0 0         if ($readBytes =~ /^(xref$cr)/) { # Input PDF is v1.4 or lower
    0          
511 0           mapGobjectsFromTraditionalXref($xrefPos + length($1));
512             } elsif ($readBytes =~ m'^\d+\s+\d+\s+obj') { # Input PDF is v1.5 or higher
513 0           die "[!] File '${GinFile}' uses xref streams (not a v1.4 PDF file).\n";
514             } else {
515 0           die "[!] File '${GinFile}' has a malformed xref table.\n";
516             }
517              
518 0           &addSizeToGObjects;
519 0           return;
520             }
521              
522              
523             ##########################################################
524             sub getRootFromTraditionalXrefSection {
525             ##########################################################
526 0     0 0   my $readBytes = " ";
527 0           my $buf;
528 0           while ($readBytes) {
529 0           sysread $IN_FILE, $readBytes, 200;
530 0           $buf .= $readBytes;
531 0 0         return $1 if $buf =~ m'\/Root\s+(\d+)\s+\d+\s+R';
532             }
533 0           return;
534             }
535              
536              
537             ##########################################################
538             sub getContentOfObjectNr {
539             ##########################################################
540 0     0 0   my $index = $_[0];
541              
542 0 0         return 0 if (! defined $GObjects{$index}); # A non-1.4 PDF
543 0           my $buf;
544 0           my ($offset, $size) = @{ $GObjects{$index} };
  0            
545 0           sysseek $IN_FILE, $offset, 0;
546 0           sysread $IN_FILE, $buf, $size;
547 0           return $buf;
548             }
549              
550              
551             ##########################################################
552             sub writePageObjectsToOutputFile {
553             ##########################################################
554 0     0 0   my ($objectContent, $out_line, $part, $strPos, $old_one, $new_one);
555              
556 0           for (@Gto_be_created) {
557 0           $old_one = $_->[0];
558 0           $new_one = $_->[1];
559 0           $objectContent = getContentOfObjectNr($old_one);
560 0 0         if ( $objectContent =~ m'^(\d+ \d+ obj\s*<<)(.+)(>>\s*stream)'s ) {
561 0           $part = $2;
562 0           $strPos = length($1) + length($2) + length($3);
563 0           update_references_and_populate_to_be_created($part);
564 0           $out_line = "${new_one} 0 obj\n<<${part}>>stream";
565 0           $out_line .= substr( $objectContent, $strPos );
566             } else {
567 0 0         $objectContent = substr( $objectContent, length($1) )
568             if $objectContent =~ m'^(\d+ \d+ obj)\b';
569 0           update_references_and_populate_to_be_created($objectContent);
570 0           $out_line = "${new_one} 0 obj ${objectContent}";
571             }
572 0           $Gobject[$new_one] = $Gpos;
573 0           $Gpos += syswrite $OUT_FILE, $out_line;
574             }
575 0           undef @Gto_be_created;
576 0           return;
577             }
578              
579              
580             ##########################################################
581             sub setOutputPageDimensionAndSchema {
582             ##########################################################
583 0 0   0 0   die "[!] File '${GinFile}' is not a valid v1.4 PDF.\n"
584             unless &getPageSizeAndSetMediabox;
585              
586 0           my $surface = $GmediaBox[2]*$GmediaBox[3];
587 0           my $measuresInMm =
588             int($GmediaBox[2] / 72 * 25.4) . " x " . int($GmediaBox[3] / 72 * 25.4) . " mm";
589              
590 0           for ($surface) {
591 0 0         if (alike($_, $Gpaper{QuarterLetter})) {$GoWid = $DW; $GoHei = $DH; return "QT"};
  0            
  0            
  0            
592 0 0         if (alike($_, $Gpaper{A6})) {$GoWid = $AW; $GoHei = $AH; return "A6"};
  0            
  0            
  0            
593 0 0         if (alike($_, $Gpaper{HalfLetter})) {$GoWid = $DW; $GoHei = $DH; return "HT"};
  0            
  0            
  0            
594 0 0         if (alike($_, $Gpaper{QuarterLegal})) {$GoWid = $GW; $GoHei = $GH; return "QG"};
  0            
  0            
  0            
595 0 0         if (alike($_, $Gpaper{A5})) {$GoWid = $AW; $GoHei = $AH; return "A5"};
  0            
  0            
  0            
596 0 0         if (alike($_, $Gpaper{HalfLegal})) {$GoWid = $GW; $GoHei = $GH; return "HG"};
  0            
  0            
  0            
597 0 0         if (alike($_, $Gpaper{Letter})) {$GoWid = $KW; $GoHei = $KH; return "LT"};
  0            
  0            
  0            
598 0 0         if (alike($_, $Gpaper{A4})) {$GoWid = $JW; $GoHei = $JH; return "A4"};
  0            
  0            
  0            
599 0 0         if (alike($_, $Gpaper{Legal})) {return "USlegal, ${measuresInMm}"};
  0            
600 0 0         if (alike($_, $Gpaper{Tabloid})) {return "UStabloid, ${measuresInMm}"};
  0            
601 0 0         if (alike($_, $Gpaper{A3})) {return "A3, ${measuresInMm}"};
  0            
602             }
603 0           return "unknown, ${measuresInMm}";
604             }
605              
606              
607             ##########################################################
608             sub alike {
609             ##########################################################
610 0     0 0   my $hxw = $_[0]; my $namedHxw = $_[1];
  0            
611 0           my $tolerance = 1500;
612 0 0 0       return 0 if $hxw > $namedHxw + $tolerance or $hxw < $namedHxw - $tolerance;
613 0           return 1;
614             }
615              
616              
617             ##########################################################
618             sub getPage {
619             ##########################################################
620 0     0 0   my $pagenumber = $_[0];
621 0 0         die "[!] Page requested (${pagenumber}) does not exist. Aborting.\n"
622             if $pagenumber > &getInputPageCount;
623 0           my ($formRes, $formCont);
624              
625             # Find root:
626 0           my $objectContent = getContentOfObjectNr($GrootNr);
627              
628             # Find pages:
629 0 0         die "[!] Didn't find Pages section in '${GinFile}'. Aborting.\n"
630             unless $objectContent =~ m'/Pages\s+(\d+)\s+\d+\s+R';
631 0           $objectContent = getContentOfObjectNr($1);
632 0           $objectContent = xformObjForThisPage($objectContent, $pagenumber);
633 0           ($formRes, $formCont) = parseAsResourcesAndContentRef($objectContent);
634 0           return ($formRes, $formCont);
635             }
636              
637              
638             ##########################################################
639             sub writeRes {
640             ##########################################################
641 0     0 0   my ($formRes, $objNr) = ($_[0], $_[1]);
642              
643 0           my $objectContent = getContentOfObjectNr($objNr);
644 0           $objectContent =~ m'^(\d+ \d+ obj\s*<<)(.+)(>>\s*stream)'s;
645 0           my $strPos = length($1) + length($2) + length($3);
646 0           my $newPart = "<
647             . "/BBox [@{GmediaBox}] ${2}";
648              
649 0           ++$GobjNr;
650 0           $Gobject[$GobjNr] = $Gpos;
651 0           my $reference = $GobjNr;
652 0           update_references_and_populate_to_be_created($newPart);
653 0           my $out_line = "${reference} 0 obj\n${newPart}>>\nstream";
654 0           $out_line .= substr( $objectContent, $strPos );
655 0           $Gpos += syswrite $OUT_FILE, $out_line;
656 0           return $reference;
657             }
658              
659              
660             ##########################################################
661             sub xformObjForThisPage {
662             ##########################################################
663 0     0 0   my ($objectContent, $pagenumber) = ($_[0], $_[1]);
664 0           my ($vector, @pageObj, @pageObjBackup, $pageAccumulator);
665              
666 0 0         return 0 unless $objectContent =~ m'/Kids\s*\[([^\]]+)';
667 0           $vector = $1;
668              
669 0           $pageAccumulator = 0;
670              
671 0           push @pageObj, $1 while $vector =~ m'(\d+)\s+\d+\s+R'g;
672 0           while ( $pageAccumulator < $pagenumber ) {
673 0           @pageObjBackup = @pageObj;
674 0           undef @pageObj;
675 0 0         last if ! @pageObjBackup; # $pagenumber is > than number of pages in PDF
676 0           for (@pageObjBackup) {
677 0           $objectContent = getContentOfObjectNr($_);
678 0 0         if ( $objectContent =~ m'/Count\s+(\d+)' ) {
679 0 0         if ( ( $pageAccumulator + $1 ) < $pagenumber ) {
680 0           $pageAccumulator += $1;
681             } else {
682 0 0         $vector = $1 if $objectContent =~ m'/Kids\s*\[([^\]]+)' ;
683 0           push @pageObj, $1 while $vector =~ m'(\d+)\s+\d+\s+R'g;
684 0           last;
685             }
686             } else {
687 0           ++$pageAccumulator;
688             }
689 0 0         last if $pageAccumulator == $pagenumber;
690             }
691             }
692 0           return $objectContent;
693             }
694              
695              
696             ##########################################################
697             sub getPageSizeAndSetMediabox {
698             ##########################################################
699             # Find root:
700 0     0 0   my $objectContent = getContentOfObjectNr($GrootNr);
701              
702             # Find pages:
703 0 0         return 0 unless $objectContent =~ m'/Pages\s+(\d+)\s+\d+\s+R';
704 0           $objectContent = getContentOfObjectNr($1);
705 0 0         $objectContent = xformObjForThisPage($objectContent, 1)
706             unless $objectContent =~ m'MediaBox';
707              
708             # Assume all input PDF pages have the same dimensions as first MediaBox found:
709 0 0         if (! @GmediaBox) {
710 0           for ($objectContent) {
711 0 0         if (m'MediaBox\s*\[\s*([\S]+)\s+([\S]+)\s+([\S]+)\s+([\S]+)\s*\]') {
    0          
712 0           @GmediaBox = ($1, $2, $3, $4);
713             } elsif (m'MediaBox\s*(\d+)\s+\d+\s+R\b') { # Size to be found in reference
714 0           my $ref = getContentOfObjectNr($1);
715 0 0         if ($ref =~ m'\[\s*([\S]+)\s+([\S]+)\s+([\S]+)\s+([\S]+)\s*\]') {
716 0           @GmediaBox = ($1, $2, $3, $4)
717             } else {
718 0           return 0; # Meaning "failure"
719             }
720             } else {
721 0           return 0; # Meaning "failure"
722             }
723             }
724             }
725 0           return 1; # Meaning "success"
726             }
727              
728              
729             ##########################################################
730             sub parseAsResourcesAndContentRef {
731             ##########################################################
732 0     0 0   my $objContent = $_[0];
733 0           my ($resources, $formCont);
734              
735 0 0         if ( $objContent =~ m'/Contents\s+(\d+)' ) {
    0          
736 0           $formCont = $1;
737             } elsif ( $objContent =~ m'/Contents\s*\[\s*(\d+)\s+\d+\s+R\s*\]' ) {
738 0           $formCont = $1;
739             }
740 0           $resources = getResourcesFromObj($objContent);
741 0           return ($resources, $formCont);
742             }
743              
744              
745             ##########################################################
746             sub getResourcesFromObj {
747             ##########################################################
748 0     0 0   my $objContent = $_[0];
749 0           my $resources;
750              
751 0 0         return $1 if $objContent =~ m'Resources\s+(\d+\s+\d+\s+R)'; # Reference (95%)
752 0 0         if ( $objContent =~ m'^.+/Resources's ) {
753             # The resources are a dictionary. The whole is copied (morfologia.pdf):
754 0           my $k;
755 0           ( undef, $objContent ) = split /\/Resources/, $objContent;
756 0           $objContent =~ s/<
757 0           $objContent =~ s/>>/>>#/g;
758 0           for ( split /#/, $objContent ) {
759 0 0         if ( m'\S' ) {
760 0           $resources .= $_;
761 0 0         ++$k if m'<<';
762 0 0         --$k if m'>>';
763 0 0         last if $k == 0;
764             }
765             }
766             }
767 0           return $resources;
768             }
769              
770              
771             ##########################################################
772             sub getInputPageCount {
773             ##########################################################
774 0     0 0   state $maxPages;
775 0 0         return $maxPages if defined $maxPages;
776 0           my $objectContent;
777              
778 0 0         return 0 unless eval { $objectContent = getContentOfObjectNr($GrootNr); 1; };
  0            
  0            
779 0 0         if ( $objectContent =~ m'/Pages\s+(\d+)\s+\d+\s+R' ) {
780 0           $objectContent = getContentOfObjectNr($1);
781 0 0         $maxPages = $1 if $objectContent =~ m'/Count\s+(\d+)';
782             }
783 0           return $maxPages;
784             }
785              
786              
787             ##########################################################
788             sub openInputFile {
789             ##########################################################
790 0     0 0   $GinFile = $_[0];
791 0           my ( $inputPageSize, $inputPageCount, $c );
792 0 0         die "[!] File '${GinFile}' is empty.\n" if ! &getInputFileWeight;
793              
794 0 0         open($IN_FILE, q{<}, $GinFile) or die "[!] Couldn't open '${GinFile}'.\n";
795 0           binmode $IN_FILE;
796              
797 0           sysread $IN_FILE, $c, 5;
798 0 0         die "[!] File '${GinFile}' is not a valid PDF file.\n" if $c ne "%PDF-";
799              
800             # Find root
801 0           $GrootNr = &getRootAndMapGobjects;
802 0 0         die "[!] File '${GinFile}' is not a valid v1.4 PDF file.\n" unless $GrootNr > 0;
803              
804 0           $inputPageSize = &setOutputPageDimensionAndSchema;
805 0           $inputPageCount = &getInputPageCount;
806              
807 0           return ($inputPageCount, $inputPageSize);
808             }
809              
810              
811             ##########################################################
812             sub getInputFileWeight {
813             ##########################################################
814 0     0 0   state $known;
815 0 0         $known = (stat($GinFile))[7] if ! $known;
816 0           return $known;
817             }
818              
819              
820             ##########################################################
821             sub addSizeToGObjects {
822             ##########################################################
823 0     0 0   my $size = &getInputFileWeight;
824             # Objects are sorted numerically (<=>) and in reverse order ($b $a)
825             # according to their offset in the file: last first
826 0           my @offset = sort { $GObjects{$b} <=> $GObjects{$a} } keys %GObjects;
  0            
827 0           my $pos;
828              
829 0           for (@offset) {
830 0           $pos = $GObjects{$_};
831 0           $size -= $pos;
832 0           $GObjects{$_} = [ $pos, $size ];
833 0           $size = $pos;
834             }
835 0           return;
836             }
837              
838              
839             ##########################################################
840             sub update_references_and_populate_to_be_created {
841             ##########################################################
842 0     0 0   $_[0] =~ s/\b(\d+)\s+\d+\s+R\b/&xform . " 0 R"/eg;
  0            
843 0           return;
844             }
845              
846              
847             # xform translates an old object reference to a new one
848             # and populates a table with what objects must be created
849             ##########################################################
850             sub xform {
851             ##########################################################
852 0     0 0   state %known;
853 0 0         return $known{$1} if exists $known{$1};
854 0           push @Gto_be_created, [ $1, ++$GobjNr ];
855 0           $known{$1} = $GobjNr; # implicit return value (faster)
856             }
857              
858              
859             ##########################################################
860             sub extractXrefSection {
861             ##########################################################
862 0     0 0   my $readBytes = ""; my ($qty, $idx, $c);
  0            
863              
864 0           sysread $IN_FILE, $c, 1;
865 0           sysread $IN_FILE, $c, 1 while $c =~ m'\s';
866 0           while ( $c =~ /[\d ]/ ) {
867 0           $readBytes .= $c;
868 0           sysread $IN_FILE, $c, 1;
869             }
870 0 0         ($idx, $qty) = ($1, $2) if $readBytes =~ m'^(\d+)\s+(\d+)';
871 0           return ($qty, $idx);
872             }
873              
874              
875             ##########################################################
876             sub openOutputFile {
877             ##########################################################
878 0 0   0 0   &closeOutputFile if $Gpos;
879              
880 0           my $outputfile = $_[0];
881 0           my $pdf_signature = "%PDF-1.4\n%\â\ã\Ï\Ó\n"; # Keep it far from file beginning!
882              
883 0 0         open( $OUT_FILE, q{>}, $outputfile )
884             or die "[!] Couldn't open file '${outputfile}'.\n";
885 0           binmode $OUT_FILE;
886 0           $Gpos = syswrite $OUT_FILE, $pdf_signature;
887              
888 0           $GobjNr = 2; # Objeto reservado 1 para raíz y 2 para nodo de pág. inicial
889 0           $Gparents[0] = 2;
890              
891 0           &setInitGrState;
892 0           return;
893             }
894              
895              
896             ##########################################################
897             sub closeInputFile {
898             ##########################################################
899 0     0 0   close $IN_FILE;
900             }
901              
902             1;
903              
904             __END__