Source file : rezip_lib.adb
1 ------------------------------------------------------------------------------
2 -- File: rezip_lib.adb
3 -- Description: Recompression tool to make archives smaller.
4 -- Core moved from Rezip (main). Still Q&D !
5 -- Author: Gautier de Montmollin
6 ------------------------------------------------------------------------------
7 --
8 -- To do:
9 -- * In order to facilitate customization, ReZip could have a config file
10 -- ( http://sf.net/projects/ini-files/ ) to store external packer
11 -- program names. See ZipMax as an example...
12 --
13 -- External programs used (feel free to customize/add/remove):
14 -- 7-Zip, KZip, Zip (info-zip), AdvZip, DeflOpt
15 -- Web URL's: see Zipper_specification below or run ReZip without arguments.
16
17 with Zip.Create,
18 Zip.Compress,
19 Zip.Headers;
20
21 with Flexible_temp_files;
22 with UnZip;
23 with Zip_Streams;
24 with Zip_Console_IO;
25
26 with Ada.Calendar,
27 Ada.Characters.Handling,
28 Ada.Directories,
29 Ada.Float_Text_IO,
30 Ada.Integer_Text_IO,
31 Ada.IO_Exceptions,
32 Ada.Numerics.Discrete_Random,
33 Ada.Numerics.Elementary_Functions,
34 Ada.Numerics.Float_Random,
35 Ada.Streams.Stream_IO,
36 Ada.Strings.Fixed,
37 Ada.Strings.Unbounded,
38 Ada.Text_IO,
39 Ada.Unchecked_Deallocation;
40
41 with Dual_IO;
42
43 with Interfaces;
44
45 with GNAT.OS_Lib;
46
47 package body Rezip_lib is
48
49 function S (Source : Ada.Strings.Unbounded.Unbounded_String) return String
50 renames Ada.Strings.Unbounded.To_String;
51 function U (Source : String) return Ada.Strings.Unbounded.Unbounded_String
52 renames Ada.Strings.Unbounded.To_Unbounded_String;
53
54 use Ada.Strings.Unbounded;
55 use Interfaces;
56
57 -- This info might be better read from a config file...
58 --
59 type Zipper_Specification is record
60 name, title, URL, options : Unbounded_String;
61 expanded_options : Unbounded_String;
62 -- ^ Options with dynamically expanded tokens
63 made_by_version : Unsigned_16;
64 pkzm : Zip.PKZip_method;
65 limit : Zip.Zip_64_Data_Size_Type;
66 -- ^ Compression is considered too slow or unefficient beyond limit (if not 0).
67 -- E.g., kzip's algorithm might be O(N^2) or worse; on large files,
68 -- deflate_e or other methods are better anyway
69 randomized : Boolean;
70 end record;
71
72 NN : constant Unbounded_String := Null_Unbounded_String;
73
74 -- Give up recompression above a certain data size for some external packers like KZip
75 -- or Zopfli.
76 --
77 kzip_zopfli_limit : constant := 2_000_000;
78
79 type Approach is
80 (original,
81 presel_2, presel_1,
82 shrink,
83 reduce_4,
84 deflate_3,
85 deflate_r,
86 bzip2_3, bzip2_2, bzip2_1,
87 lzma_3, lzma_2,
88 external_01, external_02, external_03, external_04,
89 external_05, external_06, external_07, external_08,
90 external_09, external_10, external_11, external_12,
91 external_13, external_14, external_15);
92
93 subtype Internal is Approach
94 range Approach'Succ (Approach'First) .. Approach'Pred (external_01);
95 subtype External is Approach
96 range external_01 .. Approach'Last;
97
98 ext : array (External) of Zipper_Specification :=
99 ( -- Zip 2.32 or later:
100 (U ("zip"), U ("Zip"), U ("http://info-zip.org/"),
101 U ("-9"), NN, 20, Zip.deflate, 0, False),
102 -- 7-Zip 4.64 or later; Deflate:
103 (U ("7z"),
104 U ("7-Zip"), U ("http://7-zip.org/"),
105 U ("a -tzip -mm=deflate -mfb=258 -mpass=#RAND#(7,15) -mmc=10000"),
106 NN, 20, Zip.deflate, 0, True),
107 (U ("7z"),
108 U ("7-Zip"), NN,
109 U ("a -tzip -mm=deflate64 -mfb=257 -mpass=15 -mmc=10000"),
110 NN, 21, Zip.deflate_e, 0, False),
111 -- KZip:
112 (U ("kzip"), U ("KZIP"), U ("http://www.advsys.net/ken/utils.htm"),
113 U ("/rn /b0"), NN, 20, Zip.deflate, kzip_zopfli_limit, True),
114 (U ("kzip"), U ("KZIP"), NN,
115 U ("/rn /b#RAND_EXP#(1,2048)"), NN, 20, Zip.deflate, kzip_zopfli_limit, True),
116 -- Zip 3.0 or later; BZip2:
117 (U ("zip"), U ("Zip"), NN,
118 U ("-#RAND#(1,9) -Z bzip2"), NN, 46, Zip.bzip2_meth, 0, True),
119 -- 7z:
120 (U ("7z"), U ("7-Zip"), NN,
121 U ("a -tzip -mm=BZip2:d=#RAND#(1,9)00k:pass=7"), NN, 46, Zip.bzip2_meth, 0, True),
122 -- 7-Zip 9.20 or later; LZMA:
123 (U ("7z"), U ("7-Zip"), NN,
124 U ("a -tzip -mm=LZMA -mx=9"), NN, 63, Zip.lzma_meth, 0, False),
125 (U ("7z"), U ("7-Zip"), NN, -- LZ77: BT3 or BT4, dictionary size 2**19 = 512 KiB
126 U ("a -tzip -mm=LZMA:a=2:d=19:mf=bt#RAND#(3,5):fb=273:lc=0:lp=2"), NN, 63, Zip.lzma_meth, 0, False),
127 (U ("7z"), U ("7-Zip"), NN, -- LZ77: BT3 or BT4, dictionary size 2**25 = 32 MiB
128 U ("a -tzip -mm=LZMA:a=2:d=25:mf=bt#RAND#(3,5):fb=273:lc=7"), NN, 63, Zip.lzma_meth, 0, False),
129 (U ("7z"), U ("7-Zip"), NN, -- LZ77: BT3 or BT4, dictionary size 2**26 = 64 MiB
130 U ("a -tzip -mm=LZMA:a=2:d=26:mf=bt#RAND#(3,5):fb=273:lc=8:lp0:pb1"), NN, 63, Zip.lzma_meth, 0, False),
131 (U ("7z"), U ("7-Zip"), NN, -- Super-randomized version
132 U ("a -tzip -mm=LZMA:a=2:d=#RAND_EXP#(1,65535)k:mf=bt#RAND#(2,5):fb=#RAND#(128,273):" &
133 "lc=#RAND#(0,8):lp#RAND#(0,4):pb#RAND#(0,4)"),
134 NN, 63, Zip.lzma_meth, 0, True),
135 -- AdvZip: advancecomp v1.19+ interesting for the Zopfli algorithm
136 (U ("advzip"), U ("AdvZip"), U ("http://advancemame.sf.net/comp-readme.html"),
137 U ("-a -2"), NN, 20, Zip.deflate, 0, False),
138 (U ("advzip"), U ("AdvZip"), NN,
139 U ("-a -3"), NN, 20, Zip.deflate, 0, False),
140 (U ("advzip"), U ("AdvZip"), NN,
141 U ("-a -4"), NN, 20, Zip.deflate, kzip_zopfli_limit, False));
142
143 defl_opt : constant Zipper_Specification :=
144 (U ("deflopt"), U ("DeflOpt"), U ("http://www.walbeehm.com/download/"),
145 NN, NN, 0, Zip.deflate, 0, False);
146
147 use Ada.Strings.Fixed, Ada.Strings;
148
149 procedure Rezip (
150 from_zip_file : String;
151 to_zip_file : String;
152 format_choice : Zip_format_set := all_formats; -- force output into selected format set
153 touch : Boolean := False; -- set time stamps to now
154 lower : Boolean := False; -- set full file names to lower case
155 delete_comment : Boolean := False; -- delete zip comment
156 randomized_stable : Positive := 1;
157 log_file : String := "";
158 html_report : String := "";
159 alt_tmp_file_radix : String := ""; -- e.g. "X:\temp\rz_"
160 internal_only : Boolean := False -- Zip-Ada algorithms only, no ext. call
161 )
162 is
163
164 use Zip.Create;
165 use Zip_Streams;
166
167 use Ada.Calendar, Ada.Characters.Handling, Ada.Directories, Ada.Text_IO;
168
169 package DFIO is new Dual_IO.Float_IO (Float);
170
171 procedure Rip_data (
172 archive : Zip.Zip_Info; -- from this archive...
173 input : in out Root_Zipstream_Type'Class;
174 data_name : String; -- extract this data
175 rip_rename : String; -- to this file (compressed)
176 unzip_rename : String; -- and this one (uncompressed)
177 header : out Zip.Headers.Local_File_Header
178 )
179 is
180 file_index : Zip_Streams.ZS_Index_Type;
181 comp_size : Zip.Zip_64_Data_Size_Type;
182 uncomp_size : Zip.Zip_64_Data_Size_Type;
183 file_out : Ada.Streams.Stream_IO.File_Type;
184 dummy_encoding : Zip.Zip_Name_Encoding;
185 dummy_crc : Unsigned_32;
186 mem : Zip_Streams.ZS_Index_Type;
187 head_extra : Zip.Headers.Local_File_Header_Extension;
188 dummy_offset : Unsigned_64 := 0; -- Initialized for avoiding random value = 16#FFFF_FFFF#
189
190 use UnZip, Ada.Streams.Stream_IO;
191 begin
192 Zip.Find_Offset (
193 info => archive,
194 name => data_name,
195 name_encoding => dummy_encoding,
196 file_index => file_index,
197 comp_size => comp_size,
198 uncomp_size => uncomp_size,
199 crc_32 => dummy_crc
200 );
201 Set_Index (input, file_index);
202 Zip.Headers.Read_and_Check (input, header);
203 -- Skip name
204 Set_Index (input,
205 Index (input) + Zip_Streams.ZS_Size_Type (header.filename_length)
206 );
207 mem := Index (input);
208 if header.extra_field_length >= 4 then
209 Zip.Headers.Read_and_Check (input, head_extra);
210 Zip.Headers.Interpret
211 (head_extra,
212 header.dd.uncompressed_size,
213 header.dd.compressed_size,
214 dummy_offset);
215 end if;
216 -- Skip extra field
217 Set_Index (input, mem + Zip_Streams.ZS_Size_Type (header.extra_field_length));
218 -- * Get the data, compressed
219 Ada.Streams.Stream_IO.Create (file_out, Out_File, rip_rename);
220 Zip.Copy_Chunk (input, Stream (file_out).all, Integer (comp_size));
221 Close (file_out);
222 if unzip_rename /= "" then
223 -- * Get the data, uncompressed
224 Extract (
225 from => archive,
226 what => data_name,
227 rename => unzip_rename,
228 options =>
229 (test_only => False,
230 junk_directories => False,
231 case_sensitive_match => True,
232 extract_as_text => False
233 )
234 );
235 end if;
236 end Rip_data;
237
238 Approach_to_Method : constant array (Internal) of Zip.Compress.Compression_Method :=
239 (shrink => Zip.Compress.Shrink,
240 reduce_4 => Zip.Compress.Reduce_4,
241 deflate_3 => Zip.Compress.Deflate_3,
242 deflate_r => Zip.Compress.Deflate_R,
243 bzip2_1 => Zip.Compress.BZip2_1,
244 bzip2_2 => Zip.Compress.BZip2_2,
245 bzip2_3 => Zip.Compress.BZip2_3,
246 lzma_2 => Zip.Compress.LZMA_2,
247 lzma_3 => Zip.Compress.LZMA_3,
248 presel_1 => Zip.Compress.Preselection_1,
249 presel_2 => Zip.Compress.Preselection_2);
250
251 type Packer_info is record
252 size : Zip.Zip_64_Data_Size_Type;
253 zfm : Unsigned_16;
254 count : Natural;
255 saved : Integer_64; -- Number of bytes saved by chosen method
256 -- NB: can be negative if -defl chosen: suboptimal recompression,
257 -- but compatible method.
258 saved_ex_aequo : Integer_64; -- Number of bytes saved if method is as good as
259 -- the winning method.
260 uncomp_size : Unsigned_64;
261 -- summed uncompressed sizes might be more than 2**32
262 expanded_options : Unbounded_String;
263 iter : Positive; -- iterations needed
264 LZMA_EOS : Boolean;
265 end record;
266
267 type Packer_info_array is array (Approach) of Packer_info;
268
269 type Dir_entry;
270 type p_Dir_entry is access Dir_entry;
271 --
272 type Dir_entry is record
273 head : Zip.Headers.Central_File_Header;
274 name : Unbounded_String;
275 next : p_Dir_entry := null;
276 chosen_approach : Approach := original;
277 info : Packer_info_array;
278 end record;
279
280 function Radix return String is
281 begin
282 if alt_tmp_file_radix = "" then
283 return Flexible_temp_files.Radix;
284 else
285 return alt_tmp_file_radix;
286 end if;
287 end Radix;
288
289 function Temp_name (
290 is_compressed : Boolean;
291 appr : Approach
292 )
293 return String
294 is
295 initial : constant array (Boolean) of Character := ('u', 'c');
296 begin
297 return
298 Radix &
299 "_!" & initial (is_compressed) &
300 '!' & Trim (Integer'Image (Approach'Pos (appr)), Left) &
301 "!_.tmp";
302 end Temp_name;
303
304 function Img (a : Approach; html : Boolean) return String is
305 function Repl (s : String) return String is
306 t : String := s;
307 begin
308 for i in t'Range loop
309 if html and t (i) = ':' then t (i) := ' '; end if; -- Break too long texts within a cell.
310 end loop;
311 return t;
312 end Repl;
313 begin
314 if a in External then
315 return "External: " & S (ext (a).title) & ", " & Repl (S (ext (a).expanded_options));
316 else
317 declare
318 s : constant String := Approach'Image (a);
319 begin
320 return s (s'First) & To_Lower (s (s'First + 1 .. s'Last) & (Approach'Width - s'Length + 1) * ' ');
321 end;
322 end if;
323 end Img;
324
325 -- From AZip_Common...
326 function Image_1000 (r : Zip.Zip_64_Data_Size_Type; separator : Character := ''') return String is
327 s : constant String := Zip.Zip_64_Data_Size_Type'Image (r);
328 t : String (s'First .. s'First + (s'Length * 4) / 3);
329 j, c : Natural;
330 begin
331 -- For signed integers
332 -- if r < 0 then
333 -- return '-' & Image_1000(abs r, separator);
334 -- end if;
335 --
336 -- We build result string t from right to left
337 j := t'Last + 1;
338 c := 0;
339 for i in reverse s'First .. s'Last loop
340 exit when s (i) = ' ' or s (i) = '-';
341 if c > 0 and then c mod 3 = 0 then
342 j := j - 1;
343 t (j) := separator;
344 end if;
345 j := j - 1;
346 t (j) := s (i);
347 c := c + 1;
348 end loop;
349 return t (j .. t'Last);
350 end Image_1000;
351
352 function Image_1000 (r : Integer_64; separator : Character := ''') return String is
353 s : constant String := Integer_64'Image (r);
354 t : String (s'First .. s'First + (s'Length * 4) / 3);
355 j, c : Natural;
356 begin
357 -- For signed integers
358 if r < 0 then
359 return '-' & Image_1000 (abs r, separator);
360 end if;
361 -- We build result string t from right to left
362 j := t'Last + 1;
363 c := 0;
364 for i in reverse s'First .. s'Last loop
365 exit when s (i) = ' ' or s (i) = '-';
366 if c > 0 and then c mod 3 = 0 then
367 j := j - 1;
368 t (j) := separator;
369 end if;
370 j := j - 1;
371 t (j) := s (i);
372 c := c + 1;
373 end loop;
374 return t (j .. t'Last);
375 end Image_1000;
376
377 procedure Call_External
378 (packer : String;
379 args : String;
380 is_tool_needed : Boolean)
381 is
382 use GNAT.OS_Lib;
383 procedure Dispose is
384 new Ada.Unchecked_Deallocation (Argument_List, Argument_List_Access);
385 list : Argument_List_Access;
386 ok : Boolean;
387 begin
388 Dual_IO.Put_Line (packer & " [" & args & ']');
389 list := Argument_String_To_List (args);
390 GNAT.OS_Lib.Spawn (packer, list.all, ok);
391 Dispose (list);
392 if not ok then
393 declare
394 msg : constant String := " cannot call external tool """ & packer &
395 """, or it has returned an error.";
396 begin
397 Dual_IO.New_Line;
398 Dual_IO.Put_Line ("**************");
399 if is_tool_needed then
400 Dual_IO.Put_Line ("ReZip ERROR:" & msg);
401 raise External_Tool_Failed;
402 else
403 Dual_IO.Put_Line ("ReZip warning:" & msg);
404 end if;
405 end;
406 end if;
407 end Call_External;
408
409 seed_iterator : Natural;
410
411 procedure Call_External_Expanded
412 (packer : String;
413 options : String;
414 other_args : String;
415 expand : in out Unbounded_String) -- expanded arguments
416 is
417 type Token is (rand, rand_exp);
418 begin
419 expand := U (options);
420 for t in Token loop
421 -- Replace all tokens: #<t>#(a,b)
422 loop
423 declare
424 tok : constant String := '#' & Token'Image (t) & '#';
425 idx : constant Natural := Index (expand, tok);
426 par : Natural;
427 replace_by : Unbounded_String;
428 begin
429 -- put_line("Token: " & Token'Image(t) & " " & S(expand));
430 exit when idx = 0; -- No more of token t to replace
431 par := Index (expand, ")", idx);
432 declare
433 opt : constant String := S (expand); -- partially processed option string
434 curr : constant String := opt (idx + 1 .. opt'Last); -- current option
435 par_a : constant Natural := Index (curr, "(");
436 par_z : constant Natural := Index (curr, ")");
437 comma : constant Natural := Index (curr, ",");
438 n1, n2, n : Integer;
439 begin
440 n1 := Integer'Value (curr (par_a + 1 .. comma - 1));
441 n2 := Integer'Value (curr (comma + 1 .. par_z - 1));
442 case t is
443 when rand =>
444 -- Replace #RAND#(n1,n2) by a number between n1 and n2.
445 -- Uniform distribution: U(n1,n2).
446 declare
447 subtype rng is Integer range n1 .. n2;
448 package Rnd is new Ada.Numerics.Discrete_Random (rng);
449 gen : Rnd.Generator;
450 begin
451 Rnd.Reset (gen, seed_iterator); -- seed_iterator is itself randomized.
452 seed_iterator := seed_iterator + 1;
453 n := Rnd.Random (gen);
454 end;
455 replace_by := U (Trim (Integer'Image (n), Left));
456 when rand_exp =>
457 -- Replace #RAND_EXP#(n1,n2) by a number between n1 and n2.
458 -- Strong bias towards small numbers (rather close to n1 than to n2).
459 --
460 -- Example (k=1, n1=1, n2=100): P(X in [1;10]) = 1/2; P(X in [10;100]) = 1/2.
461 --
462 -- The CDF is: F(x) = ((log x - log n1) / (log n2 - log n1)) ^ (1/k).
463 --
464 declare
465 use Ada.Numerics.Float_Random, Ada.Numerics.Elementary_Functions;
466 gen : Generator;
467 l1, l2, l, u : Float;
468 k : constant := 2;
469 begin
470 Reset (gen, seed_iterator); -- seed_iterator is itself randomized.
471 seed_iterator := seed_iterator + 1;
472 u := Random (gen); -- u is Uniform in [0;1]
473 l1 := Log (Float (n1));
474 l2 := Log (Float (n2));
475 l := l1 + (l2 - l1) * (u ** k);
476 n := Integer (Exp (l));
477 end;
478 replace_by := U (Trim (Integer'Image (n), Left));
479 end case;
480 Replace_Slice (expand, idx, par, S (replace_by));
481 end;
482 end;
483 end loop;
484 end loop;
485 Call_External (packer, S (expand) & ' ' & other_args, is_tool_needed => True);
486 end Call_External_Expanded;
487
488 function Temp_Zip_Name return String is
489 begin
490 return Simple_Name (Radix) & "_$temp$.zip";
491 end Temp_Zip_Name;
492
493 procedure Try_deleting_Temp_Zip_File is
494 begin
495 if Exists (Temp_Zip_Name) then
496 Delete_File (Temp_Zip_Name);
497 end if;
498 exception
499 when Ada.IO_Exceptions.Use_Error =>
500 null;
501 end Try_deleting_Temp_Zip_File;
502
503 procedure Process_External
504 (packer : String;
505 options : String;
506 out_name : String;
507 is_rand : Boolean;
508 is_deflate : Boolean;
509 info : out Packer_info)
510 is
511 rand_winner : constant String := Simple_Name (Radix) & "_$rand$.tmp";
512 options_winner : Unbounded_String;
513 data_name : constant String := Simple_Name (Temp_name (False, original));
514 header : Zip.Headers.Local_File_Header;
515 MyStream : aliased File_Zipstream;
516 cur_dir : constant String := Current_Directory;
517 size_memory : array (1 .. randomized_stable) of Zip.Zip_64_Data_Size_Type := (others => 0);
518 current_size : Zip.Zip_64_Data_Size_Type := 0;
519 zfm : Unsigned_16;
520 attempt : Positive := 1;
521 dummy_exp_opt : Unbounded_String;
522 zi_ext : Zip.Zip_Info;
523 begin
524 -- We jump into the TEMP directory, to avoid putting pathes into the
525 -- temporary zip file.
526 Set_Directory (Containing_Directory (Radix));
527 loop
528 Try_deleting_Temp_Zip_File; -- remove (eventually broken) zip
529 Call_External_Expanded (
530 packer,
531 options,
532 Temp_Zip_Name & ' ' & data_name,
533 info.expanded_options
534 );
535 if (not Exists (Temp_Zip_Name)) and then Ada.Directories.Size (data_name) = 0 then
536 -- ADVZip 1.19 doesn't create a zip file for a 0-size entry; we call Zip instead...
537 Call_External_Expanded ("zip", "", Temp_Zip_Name & ' ' & data_name, dummy_exp_opt);
538 end if;
539 if is_deflate then
540 -- Post processing of "deflated" entry with DeflOpt:
541 Call_External (S (defl_opt.name), Temp_Zip_Name, is_tool_needed => False);
542 end if;
543 -- Now, rip
544 Set_Name (MyStream, Temp_Zip_Name);
545 Open (MyStream, In_File);
546 Zip.Load (zi_ext, MyStream, True);
547 Rip_data (
548 archive => zi_ext,
549 input => MyStream,
550 data_name => data_name,
551 rip_rename => out_name,
552 unzip_rename => "",
553 header => header
554 );
555 Close (MyStream);
556 Try_deleting_Temp_Zip_File;
557 --
558 if randomized_stable = 1 or not is_rand then -- normal behaviour (1 attempt)
559 current_size := header.dd.compressed_size;
560 zfm := header.zip_type;
561 info.iter := 1;
562 exit;
563 end if;
564 --
565 -- Here, we process the cases where compressed sizes need
566 -- to be reduced and we expect a stable size over n=randomized_stable
567 -- attempts.
568 --
569 if attempt = 1 or else
570 header.dd.compressed_size < current_size -- better size
571 then
572 current_size := header.dd.compressed_size;
573 zfm := header.zip_type;
574 if Exists (rand_winner) then
575 Delete_File (rand_winner);
576 end if;
577 Rename (out_name, rand_winner);
578 options_winner := info.expanded_options;
579 end if;
580 --
581 -- Manage the array of last n=randomized_stable sizes
582 --
583 if attempt > size_memory'Last then
584 for i in size_memory'First + 1 .. size_memory'Last loop
585 size_memory (i - 1) := size_memory (i);
586 end loop;
587 size_memory (size_memory'Last) := current_size;
588 else
589 size_memory (attempt) := current_size;
590 end if;
591 --
592 -- Check stability over n=randomized_stable attempts
593 --
594 if attempt >= randomized_stable then
595 if size_memory (randomized_stable) = size_memory (1) then
596 if Exists (out_name) then
597 Delete_File (out_name);
598 end if;
599 Rename (rand_winner, out_name);
600 info.expanded_options := options_winner;
601 info.iter := attempt;
602 exit;
603 end if;
604 end if;
605 attempt := attempt + 1;
606 end loop;
607 info.size := current_size;
608 info.uncomp_size := header.dd.uncompressed_size;
609 -- uncomp_size should not matter (always the same).
610 info.zfm := zfm;
611 info.LZMA_EOS := (zfm = 14) and (header.bit_flag and Zip.Headers.LZMA_EOS_Flag_Bit) /= 0;
612 -- We jump back to the startup directory.
613 Set_Directory (cur_dir);
614 end Process_External;
615
616 -- Compress data as raw compressed data
617 procedure Process_Internal_Raw (a : Approach; e : in out Dir_entry) is
618 File_in : aliased File_Zipstream;
619 File_out : aliased File_Zipstream;
620 begin
621 Set_Name (File_in, Temp_name (False, original));
622 Open (File_in, In_File);
623 Set_Name (File_out, Temp_name (True, a));
624 Create (File_out, Out_File);
625 Zip.Compress.Compress_Data
626 (
627 input => File_in,
628 output => File_out,
629 input_size_known => True,
630 input_size => e.head.short_info.dd.uncompressed_size,
631 method => Approach_to_Method (a),
632 feedback => Zip_Console_IO.My_feedback'Access,
633 password => "",
634 content_hint => Zip.Compress.Guess_Type_from_Name (S (e.name)),
635 CRC => e.head.short_info.dd.crc_32,
636 -- we take the occasion to compute the CRC if not
637 -- yet available (e.g. JAR)
638 output_size => e.info (a).size,
639 zip_type => e.info (a).zfm
640 );
641 e.info (a).LZMA_EOS := e.info (a).zfm = 14;
642 Close (File_in);
643 Close (File_out);
644 end Process_Internal_Raw;
645
646 -- Compress data as a temp Zip archive (like external methods), then call post-processing.
647 -- Currently, only the DeflOpt post-processor is considered.
648 --
649 procedure Process_Internal_as_Zip (a : Approach; e : in out Dir_entry) is
650 zip_file : aliased File_Zipstream;
651 archive : Zip_Create_Info;
652 data_name : constant String := Simple_Name (Temp_name (False, original));
653 zi_ext : Zip.Zip_Info;
654 header : Zip.Headers.Local_File_Header;
655 MyStream : aliased File_Zipstream;
656 cur_dir : constant String := Current_Directory;
657 begin
658 Set_Directory (Containing_Directory (Radix));
659 Create_Archive (archive, zip_file'Unchecked_Access, Temp_Zip_Name);
660 Set (archive, Approach_to_Method (a));
661 Add_File (archive, data_name);
662 Finish (archive);
663 -- Post processing of "deflated" entry with DeflOpt:
664 Call_External (S (defl_opt.name), Temp_Zip_Name, is_tool_needed => False);
665 -- Now, rip
666 Set_Name (MyStream, Temp_Zip_Name);
667 Open (MyStream, In_File);
668 Zip.Load (zi_ext, MyStream, True);
669 Rip_data (
670 archive => zi_ext,
671 input => MyStream,
672 data_name => data_name,
673 rip_rename => Temp_name (True, a),
674 unzip_rename => "",
675 header => header
676 );
677 e.info (a).size := header.dd.compressed_size;
678 e.info (a).zfm := header.zip_type;
679 e.info (a).LZMA_EOS :=
680 (header.zip_type = 14) and (header.bit_flag and Zip.Headers.LZMA_EOS_Flag_Bit) /= 0;
681 Close (MyStream);
682 Try_deleting_Temp_Zip_File;
683 Set_Directory (cur_dir);
684 end Process_Internal_as_Zip;
685
686 time_0 : constant Ada.Calendar.Time := Clock;
687
688 procedure Repack_contents (orig_name, repacked_name, html_report_name : String)
689 is
690 zi : Zip.Zip_Info;
691 MyStream : aliased File_Zipstream;
692
693 list, e, curr : p_Dir_entry := null;
694 repacked_zip_file : aliased File_Zipstream;
695 null_packer_info : constant Packer_info := (0, 0, 0, 0, 0, 0, NN, 1, False);
696 total : Packer_info_array := (others => null_packer_info);
697 -- total(a).count counts the files where approach 'a' was optimal
698 -- total(a).saved counts the saved bytes when approach 'a' was optimal
699 total_choice : Packer_info := null_packer_info;
700 summary : Ada.Text_IO.File_Type;
701 T0, T1 : Ada.Calendar.Time;
702 repack_duration : Duration;
703 --
704 type Approach_Filtering is array (Approach) of Boolean;
705 consider_a_priori : Approach_Filtering;
706 --
707 lightred : constant String := "#ff8696";
708 lightorange : constant String := "#ffe0b0";
709
710 color_for_original : constant String := lightorange;
711 color_for_winner : constant String := "lightgreen";
712
713 use Ada.Float_Text_IO, Ada.Integer_Text_IO;
714
715 procedure Process_one (unique_name : String) is
716 comp_size : Zip.Zip_64_Data_Size_Type;
717 uncomp_size : Zip.Zip_64_Data_Size_Type;
718 choice : Approach := original;
719 deco : constant String := "-->-->-->" & (20 + unique_name'Length) * '-';
720 mth : Zip.PKZip_method;
721 consider : Approach_Filtering;
722 gain, gain_a : Integer_64;
723 --
724 procedure Winner_Color is
725 begin
726 if e.info (choice).size < e.info (original).size then
727 Put (summary, "<td bgcolor=" & color_for_winner & "><b>");
728 -- We were able to reduce the size. :-)
729 elsif e.info (choice).size = e.info (original).size then
730 if choice = original then
731 Put (summary, "<td bgcolor=" & color_for_original & "><b>");
732 else
733 -- Something else with exactly the same size as the
734 -- original was chosen.
735 -- Happens only if we force another format.
736 Put (summary, "<td bgcolor=lightblue><b>");
737 end if;
738 -- Original was already the best.
739 else
740 Put (summary, "<td bgcolor=" & lightred & "><b>");
741 -- Forced to a format with a less efficient compression. :-(
742 end if;
743 end Winner_Color;
744 --
745 use Zip;
746 needs_zip64 : Boolean;
747 fh_extra : Zip.Headers.Local_File_Header_Extension;
748 ex_aequo : Boolean;
749 begin
750 -- Start with the set of approaches that has been decided for all entries.
751 consider := consider_a_priori;
752 if unique_name = "" or else
753 (unique_name (unique_name'Last) = '\'
754 or unique_name (unique_name'Last) = '/'
755 )
756 then
757 return; -- directories are useless entries!
758 end if;
759 total_choice.count := total_choice.count + 1;
760 Dual_IO.Close_and_Append_Log; -- have an up to date copy on file system
761 Dual_IO.Put_Line (deco);
762 Dual_IO.Put_Line (
763 ' ' &
764 Integer'Image ((100 * total_choice.count) / Zip.Entries (zi)) &
765 "% - Processing " &
766 unique_name & ',' &
767 Integer'Image (total_choice.count) &
768 " of" &
769 Integer'Image (Zip.Entries (zi))
770 );
771 Dual_IO.Put_Line (deco);
772 Dual_IO.New_Line;
773 --
774 e := new Dir_entry;
775 if curr = null then
776 curr := e;
777 list := e;
778 else
779 curr.next := e;
780 curr := e;
781 end if;
782 e.name := U (unique_name);
783 e.head.made_by_version := 20; -- version 2.0
784 e.head.comment_length := 0;
785 e.head.disk_number_start := 0;
786 e.head.internal_attributes := 0; -- 0: seems binary; 1, text
787 e.head.external_attributes := 0;
788 --
789 Dual_IO.Put (" Phase 1: dump & unzip -");
790 Rip_data (
791 archive => zi,
792 input => MyStream,
793 data_name => unique_name,
794 rip_rename => Temp_name (True, original),
795 unzip_rename => Temp_name (False, original),
796 header => e.head.short_info
797 );
798 --
799 if touch then
800 e.head.short_info.file_timedate := Zip.Convert (time_0);
801 end if;
802 if lower then
803 e.name := U (To_Lower (S (e.name)));
804 end if;
805 -- Get reliable data from zi
806 Zip.Get_Sizes (
807 info => zi,
808 name => unique_name,
809 comp_size => comp_size,
810 uncomp_size => uncomp_size
811 );
812 Dual_IO.Put_Line (" done");
813 --
814 -- Apply limitations: skip some methods if certain conditions are met.
815 -- For instance:
816 -- Shrink may in rare cases be better, but only for tiny files.
817 -- KZip and Zopfli are excellent but really too slow on large files.
818 --
819 for a in Approach loop
820 case a is
821 when original =>
822 null;
823 when shrink =>
824 consider (a) := consider (a) and uncomp_size <= 6000;
825 when reduce_4 =>
826 consider (a) := consider (a) and uncomp_size <= 9000;
827 when External =>
828 consider (a) := consider (a) and (ext (a).limit = 0 or uncomp_size <= ext (a).limit);
829 when others =>
830 null;
831 end case;
832 end loop;
833 Dual_IO.Put_Line (" Phase 2: try different tactics...");
834 --
835 Try_all_approaches :
836 --
837 for a in Approach loop
838 if consider (a) then
839 Dual_IO.Put (" -o-> " & Img (a, html => False));
840 e.info (a).iter := 1;
841 case a is
842 --
843 when original =>
844 -- This is from the original .zip - just record size and method
845 e.info (a).size := comp_size;
846 e.info (a).zfm := e.head.short_info.zip_type;
847 e.info (a).LZMA_EOS :=
848 (e.info (a).zfm = 14) and
849 (e.head.short_info.bit_flag and Zip.Headers.LZMA_EOS_Flag_Bit) /= 0;
850 mth := Zip.Method_from_Code (e.info (a).zfm);
851 --
852 when Internal =>
853 if Approach_to_Method (a) in Zip.Compress.Deflation_Method
854 and not internal_only
855 then
856 -- We will post-process our internal Deflate with DeflOpt.
857 Process_Internal_as_Zip (a, e.all);
858 else
859 Process_Internal_Raw (a, e.all);
860 end if;
861 when External =>
862 Dual_IO.New_Line;
863 Process_External (
864 S (ext (a).name),
865 S (ext (a).options),
866 Temp_name (True, a),
867 ext (a).randomized,
868 ext (a).pkzm = Zip.deflate,
869 e.info (a)
870 );
871 e.head.made_by_version := ext (a).made_by_version;
872 ext (a).expanded_options := e.info (a).expanded_options;
873 --
874 end case;
875 total (a).size := total (a).size + e.info (a).size;
876 if e.info (a).size < e.info (choice).size then
877 -- Hurra, we found a smaller size than previous choice!
878 choice := a;
879 end if;
880 if choice = original and not format_choice (mth) then
881 -- This occurs if we want to make an archive with only a certain set of formats,
882 -- for instance deflate_or_store, which is the most compatible.
883 -- Since approach _a_ uses a format in the desired set, the choice will be
884 -- forced out of original, even with a worse size.
885 choice := a;
886 end if;
887 Dual_IO.New_Line;
888 end if;
889 end loop Try_all_approaches;
890 --
891 total_choice.size := total_choice.size + e.info (choice).size;
892 total (choice).count := total (choice).count + 1;
893 total_choice.uncomp_size :=
894 total_choice.uncomp_size + Unsigned_64 (uncomp_size);
895 gain := Integer_64 (e.info (original).size) - Integer_64 (e.info (choice).size);
896 total (choice).saved := total (choice).saved + gain;
897 -- We award now the ex-aequo's. Caution: multiple counting if you take the sum of totals
898 -- over all approachs, but it is good for knowing the strength of an individual approach.
899 for a in Approach loop
900 if consider (a) then
901 gain_a := Integer_64 (e.info (original).size) - Integer_64 (e.info (a).size);
902 if gain_a = gain then
903 total (a).saved_ex_aequo := total (a).saved_ex_aequo + gain;
904 end if;
905 end if;
906 end loop;
907 total_choice.saved := total_choice.saved + gain;
908 --
909 Dual_IO.New_Line;
910 Dual_IO.Put (
911 " Phase 3: Winner is " & Img (choice, html => False) &
912 "; gain in bytes:" & Integer_64'Image (gain) &
913 "; writing data -"
914 );
915 -- * Summary outputs
916 Put (summary,
917 "<tr><td>" &
918 Trim (Integer'Image (total_choice.count), Left) &
919 -- '/' &
920 -- Trim(Integer'Image(Zip.Entries(zi)),Left) &
921 "</td>" &
922 "<td bgcolor=lightgrey><tt>" & unique_name & "</tt>, " &
923 Image_1000 (uncomp_size) & "</td>");
924 for a in Approach loop
925 if consider_a_priori (a) then
926 ex_aequo := e.info (a).size = e.info (choice).size;
927 if not consider (a) then
928 Put (summary, "<td bgcolor=lightgray>skipped");
929 elsif a = choice then
930 Winner_Color;
931 elsif ex_aequo then
932 Put (summary, "<td bgcolor=lightblue><b>");
933 elsif a = original then
934 Put (summary, "<td bgcolor=" & color_for_original & '>');
935 else
936 Put (summary, "<td>");
937 end if;
938 if consider (a) then
939 Put (summary, Image_1000 (e.info (a).size));
940 end if;
941 if ex_aequo then
942 Put (summary, "</b>");
943 end if;
944 Put (summary, "</td>");
945 end if;
946 end loop;
947 -- Recall winner approach:
948 Put
949 (summary,
950 "<td" &
951 (if choice = original then " bgcolor=" & color_for_original else "") & '>' &
952 Img (choice, html => True) & "</td>");
953 -- Recall winner format:
954 Put
955 (summary,
956 "<td" &
957 (if choice = original then
958 " bgcolor=" & color_for_original
959 elsif e.info (choice).size < e.info (original).size then
960 " bgcolor=" & color_for_winner
961 elsif e.info (choice).size > e.info (original).size then
962 " bgcolor=" & lightred
963 else
964 "") &
965 '>' & Zip.Image (Zip.Method_from_Code (e.info (choice).zfm)) & "</td>");
966 -- Recall original format:
967 Put
968 (summary,
969 "<td bgcolor=" & color_for_original & '>' &
970 Zip.Image (Zip.Method_from_Code (e.info (original).zfm)) & "</td>");
971 -- Recall winner size:
972 Winner_Color;
973 Put (summary, Image_1000 (e.info (choice).size));
974 Put (summary, "</b></td><td>");
975 if e.info (original).size > 0 then
976 Put (
977 summary,
978 100.0 * Float (e.info (choice).size) / Float (e.info (original).size),
979 3, 2, 0
980 );
981 Put (summary, "%");
982 end if;
983 Put (summary, "</td><td>");
984 if uncomp_size > 0 then
985 Put (
986 summary,
987 100.0 * Float (e.info (choice).size) / Float (uncomp_size),
988 3, 2, 0
989 );
990 Put (summary, "%");
991 end if;
992 Put (summary, "</td><td>");
993 Put (summary, Image_1000 (uncomp_size));
994 Put (summary, "</td><td>");
995 Put (summary, Integer'Image (e.info (choice).iter));
996 Put_Line (summary, "</td></tr>");
997 --
998 -- Write winning data:
999 --
1000 e.head.short_info.extra_field_length := 0; -- We choose to ignore it...
1001 -- No data descriptor after data (bit 3); no EOS for LZMA (bit 1):
1002 e.head.short_info.bit_flag :=
1003 e.head.short_info.bit_flag and (2#1111_1111_1111_0101#);
1004 -- Set the LZMA EOS flag if present in winner entry (checked by 7-Zip v.17.01):
1005 if e.info (choice).LZMA_EOS then
1006 e.head.short_info.bit_flag := e.head.short_info.bit_flag or Zip.Headers.LZMA_EOS_Flag_Bit;
1007 end if;
1008 -- Set or adjust the pre-data data descriptor:
1009 -- NB: even if missing pre-data, CRC will have been computed
1010 -- at least with one internal method
1011 e.head.short_info.dd.uncompressed_size := uncomp_size;
1012 -- Put the winning size and method
1013 e.head.short_info.dd.compressed_size := e.info (choice).size;
1014 e.head.short_info.zip_type := e.info (choice).zfm;
1015 e.head.local_header_offset := Unsigned_64 (Index (repacked_zip_file)) - 1;
1016 needs_zip64 :=
1017 Zip.Headers.Needs_Local_Zip_64_Header_Extension
1018 (e.head.short_info, e.head.local_header_offset);
1019 Zip.Headers.Write
1020 (repacked_zip_file, e.head.short_info,
1021 (if needs_zip64 then Zip.Headers.force_zip_64 else Zip.Headers.force_empty));
1022 String'Write (repacked_zip_file'Access, S (e.name));
1023 if needs_zip64 then
1024 fh_extra.tag := 1;
1025 fh_extra.size := Zip.Headers.local_header_extension_short_length - 4;
1026 fh_extra.value_64 (1) := e.head.short_info.dd.uncompressed_size;
1027 fh_extra.value_64 (2) := e.head.short_info.dd.compressed_size;
1028 fh_extra.value_64 (3) := e.head.local_header_offset; -- Not actually written.
1029 Zip.Headers.Write (repacked_zip_file, fh_extra, True);
1030 end if;
1031 -- Copy the compressed data
1032 Zip.Copy_File (Temp_name (True, choice), repacked_zip_file);
1033 Dual_IO.Put_Line (" done");
1034 Dual_IO.New_Line;
1035 end Process_one;
1036
1037 procedure Process_all is new Zip.Traverse (Process_one);
1038
1039 ed : Zip.Headers.End_of_Central_Dir;
1040
1041 function Webcolor (a : Approach) return String is
1042 v : Float;
1043 sr, sg, sb : String (1 .. 10);
1044 begin
1045 if a = original then
1046 return color_for_original;
1047 end if;
1048 if total_choice.saved > 0 and
1049 -- with options like -defl ot -fast_dec, we may have
1050 -- negative values or other strange things:
1051 total (a).saved >= 0
1052 then
1053 v := Float (total (a).saved) / Float (total_choice.saved);
1054 -- ^ contribution of approach 'a'
1055 else
1056 v := 0.0;
1057 end if;
1058 Put (sr, 512 + Integer (144.0 + 111.0 * (1.0 - v)), 16);
1059 sb := sr;
1060 Put (sg, 512 + Integer (238.0 + 17.0 * (1.0 - v)), 16);
1061 return
1062 '#' &
1063 sr (sr'Last - 2 .. sr'Last - 1) &
1064 sg (sg'Last - 2 .. sg'Last - 1) &
1065 sb (sb'Last - 2 .. sb'Last - 1);
1066 end Webcolor;
1067
1068 meth : Zip.Compress.Compression_Method;
1069
1070 begin -- Repack_contents
1071 T0 := Clock;
1072 for a in Approach loop
1073 case a is
1074 when original =>
1075 consider_a_priori (a) := True;
1076 when Internal =>
1077 meth := Approach_to_Method (a);
1078 case meth is
1079 when Zip.Compress.Single_Method =>
1080 consider_a_priori (a) := format_choice (Zip.Compress.Method_to_Format (meth));
1081 when Zip.Compress.Multi_Method =>
1082 -- For the sake of simplicity, we consider the Multi_Method's
1083 -- only when all formats are admitted.
1084 consider_a_priori (a) := format_choice = all_formats;
1085 end case;
1086 when External =>
1087 consider_a_priori (a) := format_choice (ext (a).pkzm) and not internal_only;
1088 end case;
1089 end loop;
1090 Set_Name (MyStream, orig_name);
1091 Open (MyStream, In_File);
1092 Zip.Load (zi, MyStream, True);
1093
1094 Set_Name (repacked_zip_file, repacked_name);
1095 Create (repacked_zip_file, Out_File);
1096 Create (summary, Out_File, html_report_name);
1097 --
1098 -- HTML Report begins here.
1099 --
1100 Put_Line (summary,
1101 "<html><head><title>ReZip summary for file "
1102 & orig_name & "</title></head>"
1103 );
1104 Put_Line (summary, "<style>.container { overflow-y: auto; height: 87%; }");
1105 Put_Line (summary, "td_approach { width:115px; }");
1106 Put_Line (summary, "</style><body>");
1107 Put_Line (summary, "<font face=""Calibri, Arial, Tahoma""> <!-- Set font for the whole page !-->");
1108 Put_Line (summary,
1109 "<h2><a target=_blank href=" & Zip.web &
1110 ">ReZip</a> summary for file " & orig_name & "</h2>"
1111 );
1112 Put_Line (summary,
1113 "ReZip - Zip-Ada Library version " & Zip.version & " dated " & Zip.reference
1114 );
1115 if format_choice /= all_formats then
1116 Put_Line (summary,
1117 "<br><table border=0 cellpadding=0 cellspacing=0>" &
1118 "<tr bgcolor=" & lightred &
1119 "><td><b>An option that filters methods is on, " &
1120 "result(s) may be sub-optimal - see details at bottom.</b></td></tr></table><br>"
1121 );
1122 end if;
1123 Put_Line (summary, "<div class=""container""><table border=1 cellpadding=1 cellspacing=1>");
1124 Put (summary,
1125 "<tr bgcolor=lightyellow><td></td>" &
1126 "<td align=right valign=top><b>Approach:</b></td>"
1127 );
1128 for a in Approach loop
1129 if consider_a_priori (a) then
1130 if a in External then
1131 ext (a).expanded_options := ext (a).options;
1132 end if;
1133 Put
1134 (summary,
1135 "<td valign=top class=""td_approach""" &
1136 (if a = original then " bgcolor=" & color_for_original else "") & '>' &
1137 Img (a, html => True) & "</td>");
1138 end if;
1139 end loop;
1140 Put_Line (summary, "</tr>");
1141 Put (summary,
1142 "<tr bgcolor=lightyellow><td></td>" &
1143 "<td bgcolor=lightgrey valign=bottom><b>File name, uncompressed size:</b></td>"
1144 );
1145 -- Additionally, we show a row with the Approach's Compression_Method's output format (the
1146 -- Zip.PKZip_method). If it is not unique, we mention it.
1147 for a in Approach loop
1148 if consider_a_priori (a) then
1149 case a is
1150 when original =>
1151 Put (summary, "<td align=right bgcolor=#dddd00 class=""td_approach"">Approach's<br>format →</td>");
1152 when Internal =>
1153 Put (summary, "<td bgcolor=#fafa64>");
1154 meth := Approach_to_Method (a);
1155 case meth is
1156 when Zip.Compress.Single_Method =>
1157 Put (summary, Zip.Image (Zip.Compress.Method_to_Format (meth)));
1158 when Zip.Compress.Multi_Method =>
1159 Put (summary, "(Various formats)");
1160 end case;
1161 Put (summary, "</td>");
1162 when External =>
1163 Put (summary, "<td bgcolor=#fafa64>" & Zip.Image (ext (a).pkzm) & "</td>");
1164 end case;
1165 end if;
1166 end loop;
1167 Put_Line (summary,
1168 "<td><b>Choice</b></td>" &
1169 "<td bgcolor=#dddd00>Choice's<br>method/<br>format</td>" &
1170 "<td>Original<br>method/<br>format</td>" &
1171 "<td>Smallest<br>size</td>" &
1172 "<td>% of<br>original</td>" &
1173 "<td>% of<br>uncompressed</td>" &
1174 "<td>Uncompressed<br>size</td>" &
1175 "<td>Iterations</td></tr>"
1176 );
1177 --
1178 -- 1/ Recompress each file into the new archive:
1179 --
1180 Process_all (zi);
1181 --
1182 -- 2/ Almost done - write Central Directory:
1183 --
1184 ed.central_dir_offset := Unsigned_64 (Index (repacked_zip_file)) - 1;
1185 ed.total_entries := 0;
1186 ed.central_dir_size := 0;
1187 ed.main_comment_length := 0;
1188 declare
1189 comment : constant String := Zip.Zip_Comment (zi);
1190 needs_64, needs_local_zip64 : Boolean;
1191 fh_extra : Zip.Headers.Local_File_Header_Extension;
1192 ed64l : Zip.Headers.Zip64_End_of_Central_Dir_Locator;
1193 ed64 : Zip.Headers.Zip64_End_of_Central_Dir;
1194 begin
1195 if not delete_comment then
1196 ed.main_comment_length := comment'Length;
1197 end if;
1198 -- Restart at the beginning of the list
1199 e := list;
1200 needs_64 := False;
1201 while e /= null loop
1202 ed.total_entries := ed.total_entries + 1;
1203 needs_local_zip64 :=
1204 Zip.Headers.Needs_Local_Zip_64_Header_Extension
1205 (e.head.short_info, e.head.local_header_offset);
1206 if needs_local_zip64 then
1207 e.head.short_info.extra_field_length := Zip.Headers.local_header_extension_length;
1208 fh_extra.tag := 1;
1209 fh_extra.size := Zip.Headers.local_header_extension_length - 4;
1210 fh_extra.value_64 (1) := e.head.short_info.dd.uncompressed_size;
1211 fh_extra.value_64 (2) := e.head.short_info.dd.compressed_size;
1212 fh_extra.value_64 (3) := e.head.local_header_offset;
1213 e.head.short_info.dd.uncompressed_size := 16#FFFF_FFFF#;
1214 e.head.short_info.dd.compressed_size := 16#FFFF_FFFF#;
1215 e.head.local_header_offset := 16#FFFF_FFFF#;
1216 needs_64 := True;
1217 end if;
1218 Zip.Headers.Write (repacked_zip_file, e.head);
1219 String'Write (repacked_zip_file'Access, S (e.name));
1220 if needs_local_zip64 then
1221 Zip.Headers.Write (repacked_zip_file, fh_extra, False);
1222 end if;
1223 ed.central_dir_size :=
1224 ed.central_dir_size +
1225 Zip.Headers.central_header_length +
1226 Unsigned_64 (e.head.short_info.filename_length) +
1227 Unsigned_64 (e.head.short_info.extra_field_length);
1228 e := e.next;
1229 end loop;
1230 ed.disknum := 0;
1231 ed.disknum_with_start := 0;
1232 ed.disk_total_entries := ed.total_entries;
1233 if needs_64 then
1234 ed64l.number_of_the_disk_with_the_start_of_the_zip64_end_of_central_dir := 0;
1235 ed64l.relative_offset_of_the_zip64_end_of_central_dir_record :=
1236 Unsigned_64 (Index (repacked_zip_file) - 1);
1237 ed64l.total_number_of_disks := 1;
1238 --
1239 ed64.size := 44;
1240 ed64.version_made_by := 16#2D#;
1241 ed64.version_needed_to_extract := 16#2D#;
1242 ed64.number_of_this_disk := ed.disknum;
1243 ed64.number_of_the_disk_with_the_start_of_the_central_directory := ed.disknum_with_start;
1244 ed64.total_number_of_entries_in_the_central_directory_on_this_disk := ed.disk_total_entries;
1245 ed64.total_number_of_entries_in_the_central_directory := ed.total_entries;
1246 ed64.size_of_the_central_directory := ed.central_dir_size;
1247 ed64.offset_of_start_of_central_directory := ed.central_dir_offset;
1248 Zip.Headers.Write (repacked_zip_file, ed64);
1249 --
1250 Zip.Headers.Write (repacked_zip_file, ed64l);
1251 --
1252 ed.disk_total_entries := 16#FFFF#;
1253 ed.total_entries := 16#FFFF#;
1254 ed.central_dir_size := 16#FFFF_FFFF#;
1255 ed.central_dir_offset := 16#FFFF_FFFF#;
1256 end if;
1257 Zip.Headers.Write (repacked_zip_file, ed);
1258 if not delete_comment then
1259 String'Write (repacked_zip_file'Access, comment);
1260 end if;
1261 end;
1262 Close (repacked_zip_file);
1263 Close (MyStream);
1264 --
1265 -- Cleanup.
1266 --
1267 for a in Approach loop
1268 if consider_a_priori (a) then
1269 if Exists (Temp_name (True, a)) then
1270 Delete_File (Temp_name (True, a));
1271 end if;
1272 if a = original then -- also an uncompressed data file to delete
1273 Delete_File (Temp_name (False, a));
1274 end if;
1275 end if;
1276 end loop;
1277 --
1278 -- Report total files per approach.
1279 --
1280 Put (summary, "<tr><td></td><td><b>T<small>OTAL FILES (of chosen optimal approach)</small></b></td>");
1281 for a in Approach loop
1282 if consider_a_priori (a) then
1283 Put (summary, "<td bgcolor=" & Webcolor (a) & '>' & total (a).count'Image & "</td>");
1284 end if;
1285 end loop;
1286 Put
1287 (summary,
1288 "<td></td><td></td><td></td><td bgcolor=" & color_for_winner & "><b>" &
1289 total_choice.count'Image &
1290 "</b></td>" &
1291 "<td>");
1292 Put_Line (summary, "</td><td></td><td></td><td></td></tr>");
1293 --
1294 -- Report total compressed bytes.
1295 --
1296 Put (summary, "<tr><td></td><td><b>T<small>OTAL COMPRESSED BYTES</small></b></td>");
1297 for a in Approach loop
1298 if consider_a_priori (a) then
1299 Put
1300 (summary,
1301 "<td bgcolor=" & Webcolor (a) & ">" &
1302 Image_1000 (total (a).size) & "</td>");
1303 end if;
1304 end loop;
1305 Put
1306 (summary,
1307 "<td></td><td></td><td></td><td bgcolor=" & color_for_winner & "><b>" &
1308 Image_1000 (total_choice.size) &
1309 "</b></td><td>");
1310 if total (original).size > 0 then
1311 Put (summary,
1312 100.0 * Float (total_choice.size) / Float (total (original).size),
1313 3, 2, 0
1314 );
1315 Put (summary, "%");
1316 end if;
1317 Put (summary, "</td><td>");
1318 if total_choice.uncomp_size > 0 then
1319 Put (summary,
1320 100.0 * Float (total_choice.size) / Float (total_choice.uncomp_size),
1321 3, 2, 0
1322 );
1323 Put (summary, "%");
1324 end if;
1325 Put_Line (summary, "</td><td></td><td></td></tr>");
1326 --
1327 -- Report total saved bytes per approach.
1328 --
1329 Put (summary, "<tr><td></td><td><b>T<small>OTAL BYTES SAVED (by chosen optimal approach)</small></b></td>");
1330 for a in Approach loop
1331 if consider_a_priori (a) then
1332 Put (summary, "<td bgcolor=" & Webcolor (a) & '>' & Image_1000 (total (a).saved) & "</td>");
1333 end if;
1334 end loop;
1335 Put
1336 (summary,
1337 "<td></td><td></td><td></td><td" &
1338 (if total_choice.saved > 0 then
1339 " bgcolor=" & color_for_winner
1340 elsif total_choice.saved < 0 then
1341 " bgcolor=" & lightred
1342 else
1343 "") &
1344 "><b>" & Image_1000 (total_choice.saved) & "</b></td>" &
1345 "<td>");
1346 if total (original).size > 0 then
1347 Put
1348 (summary,
1349 100.0 * Float (total_choice.saved) / Float (total (original).size),
1350 3, 2, 0);
1351 Put (summary, "%");
1352 end if;
1353 Put (summary, "</td><td>");
1354 if total_choice.uncomp_size > 0 then
1355 Put (summary,
1356 100.0 * Float (total_choice.saved) / Float (total_choice.uncomp_size),
1357 3, 2, 0
1358 );
1359 Put (summary, "%");
1360 end if;
1361 Put_Line (summary, "</td><td></td><td></td></tr>");
1362 --
1363 -- Report total saved bytes per approach, *including ex-aequos*.
1364 --
1365 Put
1366 (summary,
1367 "<tr><td></td><td><b>T<small>OTAL BYTES SAVED (by chosen or " &
1368 "ex-aequo optimal approach)</small></b></td>");
1369 for a in Approach loop
1370 if consider_a_priori (a) then
1371 Put
1372 (summary,
1373 "<td bgcolor=" & Webcolor (a) & ">" &
1374 Image_1000 (total (a).saved_ex_aequo) & "</td>");
1375 end if;
1376 end loop;
1377 Put (summary, "<td></td><td></td><td></td><td></td><td></td><td>");
1378 Put_Line (summary, "</td><td></td><td></td></tr>");
1379 Put_Line (summary, "</table></div><div><br><br>");
1380 Put_Line (summary, "<dt>Options used for ReZip</dt>");
1381 Put_Line (summary, "<dd>Randomized_stable =" & Integer'Image (randomized_stable) & "<br>");
1382 Put_Line (summary, " Formats allowed:<br><table border=1 cellpadding=1 cellspacing=1>");
1383 for f in format_choice'Range loop
1384 Put_Line (summary,
1385 " <tr><td>" & Zip.Image (f) & "</td><td>" &
1386 Boolean'Image (format_choice (f)) & "</td></tr>");
1387 end loop;
1388 Put_Line (summary, " </table>");
1389 Put_Line (summary, "</dd></div>");
1390 T1 := Clock;
1391 repack_duration := T1 - T0;
1392 Put (summary, "Time elapsed : ");
1393 Put (summary, Float (repack_duration), 4, 2, 0);
1394 Put (summary, " seconds, or");
1395 Put (summary, Float (repack_duration) / 60.0, 4, 2, 0);
1396 Put (summary, " minutes, or");
1397 Put (summary, Float (repack_duration) / 3600.0, 4, 2, 0);
1398 Put_Line (summary, " hours.</font></body></html>");
1399 Close (summary);
1400 Dual_IO.Put ("Time elapsed : ");
1401 DFIO.Put (Float (repack_duration), 4, 2, 0);
1402 Dual_IO.Put_Line (" sec");
1403 Dual_IO.Put_Line ("All details for " & orig_name & " in " & html_report_name);
1404 end Repack_contents;
1405
1406 -- This is for randomizing the above seed_iterator.
1407 -- On GNAT the clock-based Reset is too coarse: it gives many times
1408 -- the same seed when called with small time intervals.
1409 --
1410 subtype Seed_Range is Integer range 1 .. 1_000_000;
1411 package Rnd_seed is new Ada.Numerics.Discrete_Random (Seed_Range);
1412 gen_seed : Rnd_seed.Generator;
1413
1414 begin
1415 Rnd_seed.Reset (gen_seed); -- 1x clock-based randomization
1416 seed_iterator := Rnd_seed.Random (gen_seed);
1417 if alt_tmp_file_radix = "" then
1418 Flexible_temp_files.Initialize;
1419 end if;
1420 Dual_IO.Create_Log (log_file);
1421 Repack_contents (from_zip_file, to_zip_file, html_report);
1422 Dual_IO.Close_Log;
1423 if alt_tmp_file_radix = "" then
1424 Flexible_temp_files.Finalize;
1425 end if;
1426 exception
1427 when External_Tool_Failed =>
1428 Dual_IO.Put_Line (" Is that tool callable through the ""path"" ?");
1429 Dual_IO.Put_Line (" In doubt, re-run ReZip with the ""-int"" (internal only) option.");
1430 Dual_IO.Close_Log;
1431 raise;
1432 end Rezip;
1433
1434 procedure Show_external_packer_list is
1435 procedure Display (p : Zipper_Specification) is
1436 fix : String (1 .. 8) := (others => ' ');
1437 begin
1438 Insert (fix, fix'First, S (p.title));
1439 Ada.Text_IO.Put (" " & fix);
1440 fix := (others => ' ');
1441 Insert (fix, fix'First, S (p.name));
1442 Ada.Text_IO.Put_Line (" Executable: " & fix & " URL: " & S (p.URL));
1443 end Display;
1444 name_is_new : Boolean;
1445 begin
1446 for e in External loop
1447 name_is_new := True;
1448 for ee in External'First .. External'Pred (e) loop
1449 name_is_new := name_is_new and ext (e).name /= ext (ee).name;
1450 end loop;
1451 if name_is_new then
1452 Display (ext (e));
1453 end if;
1454 end loop;
1455 Display (defl_opt);
1456 end Show_external_packer_list;
1457
1458 end Rezip_lib;
Web view of Ada source code generated by GNATHTML, project: ALI_Parse version 1.0.
Zip-Ada: Ada library for zip archive files (.zip).
Ada programming.
Some news about Zip-Ada and other Ada projects
on Gautier's blog.
