Back to... Zip-Ada

Source file : zipada.adb


------------------------------------------------------------------------------
--  File:            ZipAda.adb
--  Description:     A minimal standalone command-line zip archiving utility
--                     using the Zip-Ada library.
--  Author:          Gautier de Montmollin
------------------------------------------------------------------------------
-- Important changes:
--
-- ZA v. 49: password can be set
-- ZA v. 28: uses Zip.Create
-- ZA v. 26: modified for new Zip_Stream

with Ada.Calendar;                      use Ada.Calendar;
with Ada.Command_Line;                  use Ada.Command_Line;
with Ada.Directories;                   use Ada.Directories;
with Ada.Text_IO;                       use Ada.Text_IO;
with Ada.Float_Text_IO;                 use Ada.Float_Text_IO;
with Ada.Strings.Fixed;                 use Ada.Strings.Fixed;
with Ada.Strings.Unbounded;             use Ada.Strings.Unbounded;
with Ada.Characters.Handling;           use Ada.Characters.Handling;

with Zip_Streams;                       use Zip_Streams;
with Zip.Compress, Zip.Create;          use Zip.Create;

with My_feedback;
with Zip;

procedure ZipAda is

  T0, T1 : Ada.Calendar.Time;
  seconds: Duration;

  procedure Blurb is
  begin
    Put_Line("ZipAda * minimalistic standalone zipping tool.");
    Put_Line("Demo for Zip-Ada library, by G. de Montmollin");
    Put_Line("Library version " & Zip.version & " dated " & Zip.reference );
    Put_Line("URL: " & Zip.web);
    New_Line;
  end Blurb;

  function CutName(n:String; l:Natural) return String is
    dots: constant String:= "...";
  begin
    if n'Length > l then
      return dots & n( n'Last - (l-1) + dots'Length .. n'Last );
    else
      return n;
    end if;
  end CutName;

  --  Final zipfile stream
  MyStream: aliased File_Zipstream;
  Info: Zip_Create_info;
  password, password_confirm: Unbounded_String;

  procedure Add_1_Stream(Stream : in out Root_Zipstream_Type'Class) is
    Compressed_Size: Zip.File_size_type;
    Final_Method   : Natural;
  begin
    Put("  Adding ");
    declare
      maxlen: constant:= 24;
      cut: constant String:= CutName( Get_Name(Stream), maxlen );
    begin
      Put( cut & (1 + maxlen - cut'Length) * ' ');
    end;
    --
    Add_Stream(
      Info, Stream, My_feedback'Access, To_String(password), Compressed_Size, Final_Method
    );
    --
    if Size(Stream) = 0 then
      Put("          ");
    end if;
    Put(' ');
    declare
      meth: constant String:= Zip.Image(Zip.Method_from_code(Final_Method));
    begin
      Put( meth & (Zip.PKZip_method'Width - meth'Length) * ' ');
    end;
    if Size(Stream) > 0 then
      Put(", to ");
      Put(100.0 * Float(Compressed_Size) / Float(Size(Stream)), 3,2,0 );
      Put('%');
    end if;
    Put_Line(", done.");
  end Add_1_Stream;

  function Add_zip_ext(s: String) return String is
  begin
    if s'Length < 4 or else
       To_Upper(s(s'Last-3..s'Last)) /= ".ZIP"
    then
      return s & ".zip";
    else
      return s;
    end if;
  end Add_zip_ext;

  use Zip.Compress;

  method: Compression_Method:= Deflate_1;
  zip_name_set: Boolean:= False;

  procedure Zip_a_file(arg: String) is
    InStream: File_Zipstream;
  begin
    Set_Name (InStream, arg);
    Set_Time (InStream, Ada.Directories.Modification_Time(arg));
    Open (InStream, In_File);
    Add_1_Stream (InStream);
    Close (InStream);
  exception
    when Ada.Text_IO.Use_Error =>
      Put_Line("  ** Warning: skipping invalid entry: " & arg);
  end Zip_a_file;

  len: Natural:= 0;  --  absolute directory prefix, to be skipped.

  -- Recursive directory scan expanded from this example:
  --
  -- http://rosettacode.org/wiki/Walk_a_directory/Recursively#Ada

  procedure Walk (Name : String; Pattern : String; Level: Natural; Recursive: Boolean) is
    --
    procedure Process_file (Item : Directory_Entry_Type) is
    begin
      if Simple_Name (Item) /= "." and then Simple_Name (Item) /= ".." then
        declare
          fn: constant String:= Full_Name (Item);
        begin
          Zip_a_file (fn(fn'First+len..fn'Last));
        end;
      end if;
    end Process_file;
    --
    procedure Walk_subdirectory (Item : Directory_Entry_Type) is
    begin
      if Simple_Name (Item) /= "." and then Simple_Name (Item) /= ".." then
        Walk (Full_Name (Item), Pattern, Level+1, True);
      end if;
    exception
      when Ada.Directories.Name_Error => null;
    end Walk_subdirectory;
    --
  begin
    if Level = 0 then  --  Figure out the length of the absolute path
      len:= Full_Name(".")'Length + 1;
    end if;
    -- Process files
    Search (Name, Pattern, (Directory => False, others => True), Process_file'Access);
    -- Process subdirectories
    if Recursive then
      Search (Name, "", (Directory => True, others => False), Walk_subdirectory'Access);
    end if;
  exception
    when Ada.Directories.Name_Error => -- "unknown directory" -> probably a file.
      if Level = 0 then
            if Zip.Exists(Name) then
              Zip_a_file(Name);
            else
              Put_Line("  ** Warning [a]: name not matched: " & Name);
            end if;
        Zip_a_file(Name);
      end if;
  end Walk;

  type Scan_mode is (
    files_only,
    files_and_dirs,
    files_and_dirs_recursive,
    patterns_recursive
  );
  scan: Scan_mode:= files_only;

  procedure Enter_password(title: String; pwd: out Unbounded_String) is
    c: Character;
  begin
    Put_Line(title);
    loop
      Get_Immediate(c);
      exit when c < ' ';
      pwd:= pwd & c;
    end loop;
  end Enter_password;

  Wrong_password, Overwrite_disallowed: exception;

  procedure Process_argument(i: Positive) is
    arg    : constant String:= Argument(i);
    arg_zip: constant String:= Add_zip_ext(arg);
    answer : Character;
  begin
    if arg(arg'First) = '-' or arg(arg'First) = '/' then
      -- Options
      declare
        --  Spaces to avoid too short slices
        opt : constant String:= arg(arg'First+1..arg'Last) & "    ";
        eX  : constant String:= opt(opt'First..opt'First+1);
      begin
        if eX = "er" then
          case opt(opt'First+2) is
            when '1'    => method:= Reduce_1;
            when '2'    => method:= Reduce_2;
            when '3'    => method:= Reduce_3;
            when others => method:= Reduce_4;
          end case;
        elsif eX = "es" then
          method:= Shrink;
        elsif eX = "ed" then
          case opt(opt'First+2) is
            when 'f'    => method:= Deflate_Fixed;
            when '1'    => method:= Deflate_1;
            when '2'    => method:= Deflate_2;
            when others => method:= Deflate_3;
          end case;
        elsif eX = "el" then
          case opt(opt'First+2) is
            when '1'    => method:= LZMA_1;
            when '2'    => method:= LZMA_2;
            when others => method:= LZMA_3;
          end case;
        elsif eX = "ep" then
          case opt(opt'First+2) is
            when '1'    => method:= Preselection_1;
            when others => method:= Preselection_2;
          end case;
        elsif opt(opt'First..opt'First+3) = "dir " then
          scan:= Scan_mode'Max(scan, files_and_dirs);
        elsif eX = "r " then
          scan:= files_and_dirs_recursive;
        elsif eX = "r2" then
          scan:= patterns_recursive;
        elsif opt(opt'First) = 's' then
          if arg'Length > 2 then  --  Password is appended to the option
            password:= To_Unbounded_String(arg(arg'First+2..arg'Last));
          else
            Enter_password("Enter password", password);
            Enter_password("Confirm password", password_confirm);
            if password /= password_confirm then
              Put_Line("Password mismatch.");
              raise Wrong_password;
            end if;
          end if;
        end if;
      end;
    elsif not zip_name_set then
      zip_name_set:= True;
      if Zip.Exists(arg_zip) then
        Put("Archive " & arg_zip & " already exists! Overwrite (y/n) ?");
        Get_Immediate(answer);
        answer:= To_Upper(answer);
        Put_Line(" -> " & answer);
        if answer /= 'Y' then
          Put_Line("Stopped.");
          raise Overwrite_disallowed;
        end if;
      end if;
      Put_Line("Creating archive " & arg_zip);
      Put_Line("Method: " & Compression_Method'Image(method));
      T0:= Clock;
      Create(Info, MyStream'Unchecked_Access, arg_zip, method, Zip.error_on_duplicate);
    else -- First real argument has already been used for archive's name
      if To_Upper(arg) = To_Upper(Name(Info)) then
        Put_Line("  ** Warning: skipping archive's name as entry: " & arg);
        -- avoid zipping the archive itself!
        -- NB: case insensitive
      else
        case scan is
          when files_only =>
            if Zip.Exists(arg) then
              Zip_a_file(arg);
            else
              Put_Line("  ** Warning [b]: name not matched: " & arg);
            end if;
          when files_and_dirs =>
            Walk (arg, "*", 0, False);
          when files_and_dirs_recursive =>
            Walk (arg, "*", 0, True);
          when patterns_recursive =>
            Walk (".", arg, 0, True);
        end case;
      end if;
    end if;
  end Process_argument;

begin
  Blurb;
  for i in 1..Argument_Count loop
    Process_argument(i);
  end loop;
  if Is_Created (Info) then
    Finish (Info);
    T1:= Clock;
    seconds:= T1-T0;
    Put("Time elapsed : ");
    Put( Float( seconds ), 4, 2, 0 );
    Put_Line( " sec");
  else
    Put_Line("Usage: zipada [options] archive[.zip] name(s)");
    New_Line;
    Put_Line("Options:  -erN   : use the 2-pass ""Reduce"" method, factor N = 1..4");
    Put_Line("          -es    : ""Shrink"" method (LZW algorithm)");
    Put_Line("          -edf   : ""Deflate"" method, with one ""fixed"" block (weak)");
    Put_Line("          -edN   : ""Deflate"" method, ""dynamic"" compression, strength N = 1..3");
    Put_Line("          -elN   : ""LZMA"" method, strength N = 1..3");
    Put_Line("          -epN   : preselection of an appropriate method, strength N = 1..2");
    New_Line;
    Put_Line("      NB: default method is ""Deflate"", strength 1 (-ed1)");
    New_Line;
    Put_Line("          -dir   : name(s) may be also directories,");
    Put_Line("                      whose entire contents will be archived");
    Put_Line("          -r     : same as ""-dir"", but recursively archives full subdirectories");
    Put_Line("                      of the named directories as well");
    Put_Line("          -r2    : search name(s) in current and all subdirectories as well;");
    Put_Line("                      please enclose name(s) that have wildcards with");
    Put_Line("                      single quotes, for example: '*.adb'");
    Put_Line("          -s[X]  : set password X");
  end if;
end ZipAda;

Zip-Ada: Ada library for zip archive files (.zip). Ada programming.
Some news about Zip-Ada and other related Ada projects on Gautier's blog.