Source file : zipada.adb
1 ------------------------------------------------------------------------------
2 -- File: ZipAda.adb
3 -- Description: A minimal standalone command-line zip archiving utility
4 -- using the Zip-Ada library.
5 -- Author: Gautier de Montmollin
6 ------------------------------------------------------------------------------
7 -- Important changes:
8 --
9 -- ZA v. 49: password can be set
10 -- ZA v. 28: uses the Zip.Create package
11 -- ZA v. 26: modified for the new Zip_Stream package
12
13 with Ada.Calendar,
14 Ada.Command_Line,
15 Ada.Directories,
16 Ada.Text_IO,
17 Ada.Wide_Text_IO,
18 Ada.Float_Text_IO,
19 Ada.Strings.Fixed,
20 Ada.Strings.UTF_Encoding.Conversions,
21 Ada.Strings.Unbounded,
22 Ada.Strings.Wide_Fixed,
23 Ada.Characters.Handling;
24
25 with Interfaces;
26
27 with Zip_Streams;
28
29 with Zip.Compress,
30 Zip.Create;
31
32 with Zip_Console_IO;
33 with Show_License;
34
35 procedure ZipAda is
36
37 T0, T1 : Ada.Calendar.Time;
38 seconds_elapsed : Duration;
39
40 use Ada.Calendar, Ada.Characters.Handling, Ada.Command_Line,
41 Ada.Directories, Ada.Float_Text_IO,
42 Ada.Strings.Unbounded, Ada.Text_IO;
43
44 use Zip_Streams;
45 use Zip.Create;
46
47 procedure Blurb is
48 begin
49 Put_Line ("ZipAda * minimalistic standalone zipping tool.");
50 Put_Line ("Demo for Zip-Ada library, by G. de Montmollin");
51 Put_Line ("Library version " & Zip.version & " dated " & Zip.reference);
52 Put_Line ("URL: " & Zip.web);
53 Show_License (Current_Output, "zip.ads");
54 end Blurb;
55
56 function Cut_name (n : Wide_String; l : Natural) return Wide_String is
57 dots : constant Wide_String := "...";
58 begin
59 if n'Length > l then
60 return dots & n (n'Last - (l - 1) + dots'Length .. n'Last);
61 else
62 return n;
63 end if;
64 end Cut_name;
65
66 -- Final zipfile stream
67 MyStream : aliased File_Zipstream;
68 Info : Zip_Create_Info;
69 password, password_confirm : Unbounded_String;
70
71 procedure Add_1_Stream (Stream : in out Root_Zipstream_Type'Class) is
72 Compressed_Size : Zip.Zip_64_Data_Size_Type;
73 Final_Method : Natural;
74 use Interfaces;
75 begin
76 Put (" Adding ");
77 declare
78 maxlen : constant := 24;
79 Unicode_name : constant Wide_String :=
80 Ada.Strings.UTF_Encoding.Conversions.Convert (Get_Name (Stream));
81 cut : constant Wide_String := Cut_name (Unicode_name, maxlen);
82 use Ada.Strings.Wide_Fixed;
83 begin
84 Ada.Wide_Text_IO.Put (cut & (1 + maxlen - cut'Length) * ' ');
85 end;
86 --
87 Add_Stream
88 (Info, Stream,
89 Zip_Console_IO.My_feedback'Access,
90 To_String (password), Compressed_Size, Final_Method);
91 --
92 if Size (Stream) = 0 then
93 Put (" ");
94 end if;
95 Put (' ');
96 declare
97 meth : constant String := Zip.Image (Zip.Method_from_Code (Final_Method));
98 use Ada.Strings.Fixed;
99 begin
100 Put (meth & (Zip.PKZip_method'Width - meth'Length) * ' ');
101 end;
102 if Size (Stream) > 0 then
103 Put (", to ");
104 Put (100.0 * Float (Compressed_Size) / Float (Size (Stream)), 3, 2, 0);
105 Put ('%');
106 end if;
107 Put_Line (", done.");
108 end Add_1_Stream;
109
110 function Add_zip_ext (s : String) return String is
111 begin
112 if s'Length < 4 or else
113 To_Upper (s (s'Last - 3 .. s'Last)) /= ".ZIP"
114 then
115 return s & ".zip";
116 else
117 return s;
118 end if;
119 end Add_zip_ext;
120
121 use Zip.Compress;
122
123 method : Compression_Method := Deflate_1;
124 zip_name_set : Boolean := False;
125
126 procedure Zip_a_file (arg : String) is
127 InStream : File_Zipstream;
128 begin
129 Set_Name (InStream, arg);
130 Set_Time (InStream, Ada.Directories.Modification_Time (arg));
131 Set_Unicode_Name_Flag (InStream, True);
132 Open (InStream, In_File);
133 Add_1_Stream (InStream);
134 Close (InStream);
135 exception
136 when Ada.Text_IO.Use_Error =>
137 Put_Line (" ** Warning: skipping invalid entry: " & arg);
138 end Zip_a_file;
139
140 len : Natural := 0; -- absolute directory prefix, to be skipped.
141
142 -- Recursive directory scan expanded from this example:
143 --
144 -- http://rosettacode.org/wiki/Walk_a_directory/Recursively#Ada
145
146 procedure Walk (Directory_Or_File_Name : String; Pattern : String; Level : Natural; Recursive : Boolean) is
147 --
148 procedure Process_file (Item : Directory_Entry_Type) is
149 begin
150 if Simple_Name (Item) /= "." and then Simple_Name (Item) /= ".." then
151 declare
152 fn : constant String := Full_Name (Item);
153 begin
154 Zip_a_file (fn (fn'First + len .. fn'Last));
155 end;
156 end if;
157 end Process_file;
158 --
159 procedure Walk_subdirectory (Item : Directory_Entry_Type) is
160 begin
161 if Simple_Name (Item) /= "." and then Simple_Name (Item) /= ".." then
162 Walk (Full_Name (Item), Pattern, Level + 1, True);
163 end if;
164 exception
165 when Ada.Directories.Name_Error => null;
166 end Walk_subdirectory;
167 --
168 begin
169 if Level = 0 then -- Figure out the length of the absolute path
170 len := Full_Name (".")'Length + 1;
171 end if;
172 -- Process files
173 Search (Directory_Or_File_Name, Pattern, (Directory => False, others => True), Process_file'Access);
174 -- Process subdirectories
175 if Recursive then
176 Search (Directory_Or_File_Name, "", (Directory => True, others => False), Walk_subdirectory'Access);
177 end if;
178 exception
179 when Ada.Directories.Name_Error => -- "unknown directory" -> probably a file.
180 if Level = 0 then
181 if Zip.Exists (Directory_Or_File_Name) then
182 Zip_a_file (Directory_Or_File_Name);
183 else
184 Put_Line (" ** Warning [a]: name not matched: " & Directory_Or_File_Name);
185 end if;
186 Zip_a_file (Directory_Or_File_Name);
187 end if;
188 end Walk;
189
190 type Scan_mode is (
191 files_only,
192 files_and_dirs,
193 files_and_dirs_recursive,
194 patterns_recursive
195 );
196 scan : Scan_mode := files_only;
197
198 procedure Enter_password (title : String; pwd : out Unbounded_String) is
199 c : Character;
200 begin
201 Put_Line (title);
202 loop
203 Get_Immediate (c);
204 exit when c < ' ';
205 pwd := pwd & c;
206 end loop;
207 end Enter_password;
208
209 Wrong_password, Overwrite_disallowed : exception;
210
211 procedure Process_argument (i : Positive) is
212 arg : constant String := Argument (i);
213 arg_zip : constant String := Add_zip_ext (arg);
214 answer : Character;
215 begin
216 if arg (arg'First) = '-' or arg (arg'First) = '/' then
217 -- Options
218 declare
219 -- Spaces to avoid too short slices
220 opt : constant String := arg (arg'First + 1 .. arg'Last) & " ";
221 eX : constant String := opt (opt'First .. opt'First + 1);
222 begin
223 if eX = "e0" then
224 method := Store;
225 elsif eX = "er" then
226 case opt (opt'First + 2) is
227 when '1' => method := Reduce_1;
228 when '2' => method := Reduce_2;
229 when '3' => method := Reduce_3;
230 when others => method := Reduce_4;
231 end case;
232 elsif eX = "es" then
233 method := Shrink;
234 elsif eX = "ed" then
235 case opt (opt'First + 2) is
236 when 'f' => method := Deflate_Fixed;
237 when '0' => method := Deflate_0;
238 when '1' => method := Deflate_1;
239 when '2' => method := Deflate_2;
240 when 'r' => method := Deflate_R;
241 when others => method := Deflate_3;
242 end case;
243 elsif eX = "eb" then
244 case opt (opt'First + 2) is
245 when '1' => method := BZip2_1;
246 when '2' => method := BZip2_2;
247 when others => method := BZip2_3;
248 end case;
249 elsif eX = "el" then
250 case opt (opt'First + 2) is
251 when '0' => method := LZMA_0;
252 when '1' => method := LZMA_1;
253 when '2' => method := LZMA_2;
254 when others => method := LZMA_3;
255 end case;
256 elsif eX = "ep" then
257 case opt (opt'First + 2) is
258 when '1' => method := Preselection_1;
259 when others => method := Preselection_2;
260 end case;
261 elsif opt (opt'First .. opt'First + 3) = "dir " then
262 scan := Scan_mode'Max (scan, files_and_dirs);
263 elsif eX = "r " then
264 scan := files_and_dirs_recursive;
265 elsif eX = "r2" then
266 scan := patterns_recursive;
267 elsif opt (opt'First) = 'p' or opt (opt'First) = 's' then
268 -- The "-s" variant is kept for compatibility.
269 if arg'Length > 2 then -- Password is appended to the option
270 password := To_Unbounded_String (arg (arg'First + 2 .. arg'Last));
271 else
272 Enter_password ("Enter password", password);
273 Enter_password ("Confirm password", password_confirm);
274 if password /= password_confirm then
275 Put_Line ("Password mismatch.");
276 raise Wrong_password;
277 end if;
278 end if;
279 end if;
280 end;
281 elsif not zip_name_set then
282 zip_name_set := True;
283 if Zip.Exists (arg_zip) then
284 Put ("Archive " & arg_zip & " already exists! Overwrite (y/n) ?");
285 Get_Immediate (answer);
286 answer := To_Upper (answer);
287 Put_Line (" -> " & answer);
288 if answer /= 'Y' then
289 Put_Line ("Stopped.");
290 raise Overwrite_disallowed;
291 end if;
292 end if;
293 Put_Line ("Creating archive " & arg_zip);
294 Put_Line ("Method: " & Compression_Method'Image (method));
295 T0 := Clock;
296 Create_Archive (Info, MyStream'Unchecked_Access, arg_zip, method, Zip.error_on_duplicate);
297 else -- First real argument has already been used for archive's name
298 if To_Upper (arg) = To_Upper (Name (Info)) then
299 Put_Line (" ** Warning: skipping archive's name as entry: " & arg);
300 -- avoid zipping the archive itself!
301 -- NB: case insensitive
302 else
303 case scan is
304 when files_only =>
305 if Zip.Exists (arg) then
306 Zip_a_file (arg);
307 else
308 Put_Line (" ** Warning [b]: name not matched: " & arg);
309 end if;
310 when files_and_dirs =>
311 Walk (arg, "*", 0, False);
312 when files_and_dirs_recursive =>
313 Walk (arg, "*", 0, True);
314 when patterns_recursive =>
315 Walk (".", arg, 0, True);
316 end case;
317 end if;
318 end if;
319 end Process_argument;
320
321 begin
322 Blurb;
323 -- Set the file name encoding as UTF-8.
324 -- NB: GNAT (as of version CE 2019) doesn't seem to need it.
325 Zip_Streams.Form_For_IO_Open_and_Create := To_Unbounded_String ("encoding=utf8");
326 --
327 for i in 1 .. Argument_Count loop
328 Process_argument (i);
329 end loop;
330 --
331 -- We are done, or no archive was created.
332 --
333 if Is_Created (Info) then
334 Finish (Info);
335 T1 := Clock;
336 seconds_elapsed := T1 - T0;
337 Put ("Time elapsed : ");
338 Put (Float (seconds_elapsed), 4, 2, 0);
339 Put_Line (" sec");
340 else
341 Put_Line ("Usage: zipada [options] archive[.zip] name(s)");
342 New_Line;
343 Put_Line ("Options: -e0 : ""Store"": zero compression, archiving only (like tar)");
344 Put_Line (" -erN : ""Reduce"" 2-pass method, factor N = 1 .. 4");
345 Put_Line (" -es : ""Shrink"" method (LZW algorithm)");
346 Put_Line (" -edf : ""Deflate"" method, with one ""fixed"" block (weak)");
347 Put_Line (" -edN : ""Deflate"" method, ""dynamic"" compression, strength N = 0 .. 3");
348 Put_Line (" -ebN : ""BZip2"" method, strength N = 1 .. 3");
349 Put_Line (" -elN : ""LZMA"" method, strength N = 0 .. 3");
350 Put_Line (" -epN : preselection of an appropriate method, strength N = 1 .. 2");
351 New_Line;
352 Put_Line (" NB: default method is ""Deflate"", strength 1 (-ed1)");
353 New_Line;
354 Put_Line (" -dir : name(s) may be also directories,");
355 Put_Line (" whose entire contents will be archived");
356 Put_Line (" -r : same as ""-dir"", but recursively archives full subdirectories");
357 Put_Line (" of the named directories as well");
358 Put_Line (" -r2 : search name(s) in current and all subdirectories as well;");
359 Put_Line (" please enclose name(s) that have wildcards with");
360 Put_Line (" single quotes, for example: '*.adb'");
361 Put_Line (" -p : define a password for encryption (user is prompted)");
362 Put_Line (" -pPwd : define a password for encryption (e.g. ""Pwd"")");
363 New_Line;
364 Put ("Press Return");
365 Skip_Line;
366 end if;
367 end ZipAda;
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.
