File Coverage

blib/lib/App/paperback.pm
Criterion Covered Total %
statement 5 432 1.1
branch 0 184 0.0
condition 0 48 0.0
subroutine 2 32 6.2
pod 0 29 0.0
total 7 725 0.9


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