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