-
+ AFD665D979FE64DFDCC2D99A515A887B8C32E961AFA20201755A80DCCB64713DB2942BF7828748A41C8B88859BE4BFA917CB50134A0D3F4FEF403FCFB26463EF
vtools/src/vpatch.adb

(0 . 0)(1 . 619)
with Bits; use Bits;
with Interfaces.C;
with Interfaces.C.Strings;
with Ada.Text_IO;  use Ada.Text_IO;
with Ada.Integer_Text_IO; use  Ada.Integer_Text_IO;
with Ada.Strings.Fixed;
with Ada.Directories;
with Ada.Characters;
with Ada.Characters.Handling;
with Ada.Characters.Latin_1;
with Ada.Sequential_IO;
with SMG_Keccak; use SMG_Keccak;

procedure VPatch is
   package Latin_1 renames Ada.Characters.Latin_1;
   package Dirs renames Ada.Directories;

   -- Utilities

   function Starts_With(S: String; Prefix: String) return Boolean is
   begin
      if S'Length < Prefix'Length then
         return False;
      end if;
      return S(S'First..S'First+Prefix'Length-1) = Prefix;
   end;

   function Path_Prefix(Pathname: String;
                        Suffix: Positive) return String is
      Pos: Natural := Pathname'Last;
   begin
      for I in 1..Suffix loop
         Pos := Ada.Strings.Fixed.Index(Pathname, "/",
                                        From => Pos,
                                        Going => Ada.Strings.Backward);
         if Pos = 0 then
            return Pathname;
         end if;
         Pos := Pos - 1;
      end loop;
      return Pathname(Pathname'First .. Pos);
   end;

   function Path_Without_Prefix(Pathname: String;
                                Prefix: Positive) return String is
      Pos: Natural := 1;
   begin
      for I in 1..Prefix loop
         Pos := Ada.Strings.Fixed.Index(Pathname, "/", From => Pos);
         if Pos = 0 then
            return Pathname;
         end if;
         Pos := Pos + 1;
      end loop;
      return Pathname(Pos .. Pathname'Last);
   end;

   -- Temporary File

   procedure MkTemp(Template: Interfaces.C.Strings.Chars_Ptr);
   pragma Import(C, mktemp);

   function Temp_File_Name(Template: String) return String is
      X: Interfaces.C.Strings.Chars_Ptr
        := Interfaces.C.Strings.New_String(Template);
   begin
      MkTemp(X);
      declare
         Result: String := Interfaces.C.Strings.Value(X);
      begin
         Interfaces.C.Strings.Free(X);
         return Result;
      end;
   end;

   procedure Create_Temp(File : in out File_Type;
                         Mode : in File_Mode := Out_File;
                         Template : in String := "vpatch.XXX";
                         Form : in String := "") is
      Name: String := Temp_File_Name(Template);
   begin
      Create(File, Mode, Name, Form);
   end;

   -- VPatch data structures

   type Patch_Op is (Op_Create, Op_Delete, Op_Patch);

   Hash_Length: constant Positive := 128;
   type Hash_Type is (Empty, Value);
   type Hash(The_Type: Hash_Type := Empty) is record
      case The_Type is
         when Value =>
            Value: String(1..Hash_Length);
         when Empty =>
            null;
      end case;
   end record;

   function "=" (Left, Right: in Hash) return Boolean is
   begin
      if Left.The_Type = Empty and Right.The_Type = Empty then
         return True;
      elsif Left.The_Type = Empty or Right.The_Type = Empty then
         return False;
      elsif Left.Value /= Right.Value then
         return False;
      else
         return True;
      end if;
   end "=";

   type Header (From_L, To_L: Natural) Is record
      From_Hash: Hash;
      From_File: String(1..From_L);
      To_Hash: Hash;
      To_File: String(1..To_L);
   end record;

   function Operation(A_Header: Header) return Patch_Op is
   begin
      if A_Header.From_Hash.The_Type = Empty then
         return Op_Create;
      elsif A_Header.To_Hash.The_Type = Empty then
         return Op_Delete;
      else
         return Op_Patch;
      end if;
   end;

   function Press_Name(A_Header: Header) return String is
   begin
      return Path_Without_Prefix(A_Header.From_File, 1);
   end;

   type Line_Numbers is record
      Start: Natural;
      Count: Natural;
   end record;

   type Hunk is record
      From_File_Line_Numbers: Line_Numbers;
      To_File_Line_Numbers: Line_Numbers;
   end record;

   -- VPatch debug output routines

   procedure Put(A_Line_Numbers: Line_Numbers) is
   begin
      Put(A_Line_Numbers.Start);
      Put(A_Line_Numbers.Count);
   end;

   procedure Put(A_Hash: Hash) is
   begin
      case A_Hash.The_Type is
         when Value =>
            Put(A_Hash.Value);
         when Empty =>
            Put("no value");
      end case;
   end;

   procedure Put(A_Header: Header) is
   begin
      Put("from file: ");
      Put(A_Header.From_File);
      New_Line;
      Put("to file: ");
      Put(A_Header.To_File);
      New_Line;
      Put("from hash: ");
      Put(A_Header.From_Hash);
      New_Line;
      Put("to hash: ");
      Put(A_Header.To_Hash);
      New_Line;
   end;

   procedure Put(A_Hunk: Hunk) is
   begin
      Put("from file line numbers: ");
      Put(A_Hunk.From_File_Line_Numbers);
      New_Line;
      Put("to file line numbers: ");
      Put(A_Hunk.To_File_Line_Numbers);
      New_Line;
   end;

   -- VPatch parser

   Parse, State: exception;

   procedure Skip_Whitespace is
      EOL: Boolean;
      C: Character;
   begin
  Skip_Loop:
      loop
         Look_Ahead(C, EOL);
         exit Skip_Loop when EOL;
         exit Skip_Loop when
           C /= Latin_1.Space and
           C /= Latin_1.HT;
         Get(C);
      end loop Skip_Loop;
   end;

   procedure Looking_At(Expected: String) is
      Actual: String(Expected'Range);
   begin
      Get(Actual);
      if Expected /= Actual then
         raise Parse with "expected " & Expected & ", got " & Actual;
      end if;
   end;

   procedure Next_Line is
   begin
      if not End_Of_Line then
         raise Parse with "expected end of line";
      end if;
      Skip_Line;
   end;

   procedure Get(A_Hash: out Hash) is
      No_Hash_Label: constant String := "false";
      V: String(1..Hash_Length);
   begin
      Get(V(1..No_Hash_Label'Length));
      if V(1..No_Hash_Label'Length) = No_Hash_Label then
         A_Hash := (The_Type => Empty);
         return;
      end if;
      Get(V(No_Hash_Label'Length + 1..V'Last));
      A_Hash := (The_Type => Value,
                 Value => V);
   end;

   procedure Get(A_Line_Numbers: out Line_Numbers) is
      C: Character;
      Eol: Boolean;
   begin
      Get(A_Line_Numbers.Start);
      Look_Ahead(C, Eol);
      if Eol then
         raise Parse;
      end if;
      case C is
         when ' ' =>
            -- If a hunk contains just one line, only its start line
            --  number appears.
            A_Line_Numbers.Count := 1;
         when ',' =>
            -- Otherwise its line numbers look like `start,count'. An
            --  empty hunk is considered to start at the line that
            --  follows the hunk.
            Get(C);
            Get(A_Line_Numbers.Count);
         when others =>
            raise Parse;
      end case;
   end;

   function Get_Header_Filename return String is
      EOL: Boolean;
      Buffer: String(1..1000);
      C: Character;
      I: Natural := 0;
   begin
  Read_Loop:
      loop
         Look_Ahead(C, EOL);
         exit Read_Loop when EOL;
         exit Read_Loop when
           C = Latin_1.Space or C = Latin_1.HT;
         Get(C);
         I := I + 1;
         Buffer(I) := C;
      end loop Read_Loop;
      return Buffer(1..I);
   end;

   function Get_Header return Header is
      From_Hash: Hash;
      To_Hash: Hash;
   begin
      Looking_At("--- ");
      declare
         From_File: String := Get_Header_Filename;
      begin
         Skip_Whitespace;
         Get(From_Hash);
         Looking_At("+++ ");
         declare
            To_File: String := Get_Header_Filename;
         begin
            Skip_Whitespace;
            Get(To_Hash);
            Next_Line;
            declare
               H: Header := (From_L => From_File'Length,
                             To_L => To_File'Length,
                             From_File => From_File,
                             To_File => To_File,
                             From_Hash => From_Hash,
                             To_Hash => To_Hash);
            begin
               return H;
            end;
         end;
      end;
   end;

   procedure Get(A_Hunk: out Hunk) is
   begin
      Looking_At("@@ -");
      Get(A_Hunk.From_File_Line_Numbers);
      Looking_At(" +");
      Get(A_Hunk.To_File_Line_Numbers);
      Looking_At(" @@");
      Next_Line;
   end;

   procedure Process_Hunks_For_Header(A_Header: Header) Is
      EOL: Boolean;
      C: Character;
      A_Hunk: Hunk;
      -- ensure valid line counts
      From_Count: Natural := 0;
      To_Count: Natural := 0;
      Has_Input_File: Boolean;
      In_F: File_Type;
      To_F: File_Type;
      Line: Positive := 1;
      In_Ctx: Keccak_Context;
      To_Ctx: Keccak_Context;
      In_Hash: Bitstream(1..64*8);
      To_Hash: Bitstream(1..64*8);
      To_F_Name: constant String := Press_Name(A_Header);
      Op: Patch_Op;

      procedure Hash_Line(Ctx: in out Keccak_Context; S: String) is
         B: Bitstream(1..S'Length*8);
         LF_B: constant Bitstream(1..8) := (0, 1, 0, 1, 0, 0, 0, 0);
      begin
         ToBitstream(S, B);
         KeccakHash(Ctx, B);
         KeccakHash(Ctx, LF_B);
      end;

      procedure Check_Input_File_Hash is
      begin
         if Has_Input_File then
            begin
           Catch_Up_Loop:
               loop
                  declare
                     In_Line: String := Get_Line(In_F);
                  begin
                     Put_Line(To_F, In_Line);
                     Hash_Line(In_Ctx, In_Line);
                     Hash_Line(To_Ctx, In_Line);
                  end;
               end loop Catch_Up_Loop;
            exception
               when End_Error =>
                  null;
            end;
            KeccakEnd(In_Ctx, In_Hash);

            declare
               Hex_Hash: String := ToHex(In_Hash);
               H: Hash := (Value => Hex_Hash,
                           The_Type => Value);
            begin
               if A_Header.From_Hash /= (Value => Hex_Hash,
                                         The_Type => Value)  then
                  raise State with "from hash doesn't match";
               end if;
            end;
         end if;
      end Check_Input_File_Hash;

      procedure Check_Output_File_Hash is
      begin
         KeccakEnd(To_Ctx, To_Hash);
         declare
            H_Hex: String := ToHex(To_Hash);
            H: Hash;
         begin
            case Op is
               when Op_Create | Op_Patch =>
                  H := (Value => H_Hex,
                        The_Type => Value);
               when Op_Delete =>
                  H := (The_Type => Empty);
            end case;
            if A_Header.To_Hash /= H then
               raise State with "to hash doesn't match";
            end if;
         end;
      end Check_Output_File_Hash;

      procedure Cleanup is
      begin
         if Is_Open(To_F) then
            Dirs.Delete_File(Name(To_F));
         end if;
      end Cleanup;

   begin
      Op := Operation(A_Header);

      -- log
      case Op is
         when Op_Create => Put_Line("creating " & To_F_Name);
         when Op_Delete => Put_Line("deleting " & To_F_Name);
         when Op_Patch  => Put_Line("patching " & To_F_Name);
      end case;

      -- check the file system state
      case Op is
         when Op_Delete | Op_Patch =>
            if not Dirs.Exists(To_F_Name) then
               raise State with "attempt to "
                 & Patch_Op'Image(Op)
                 & " non existing file " & To_F_Name;
            end if;
         when Op_Create =>
            if Dirs.Exists(To_F_Name) then
               raise State with "attempt to create a file, but file already exists";
            end if;
      end case;

      -- prepare keccak and open files
      KeccakBegin(To_Ctx);
      Create_Temp(To_F, Out_File, "tmp.XXX");
      case Op is
         when Op_Create =>
            Has_Input_File := False;
         when Op_Delete | Op_Patch =>
            Has_Input_File := True;
            KeccakBegin(In_Ctx);
            Open(In_F, In_File, To_F_Name);
      end case;

  Hunk_Loop:
      loop
         Look_Ahead(C, EOL);
         exit Hunk_Loop when EOL;
         exit Hunk_Loop when C /= '@';
         Get(A_Hunk);
         From_Count := A_Hunk.From_File_Line_Numbers.Count;
         To_Count := A_Hunk.To_File_Line_Numbers.Count;
         -- Hunk is not at the beginning of the file, copy lines up to
         --  start.
         if Line < A_Hunk.From_File_Line_Numbers.Start then
            if not Has_Input_File then
               raise State with "hunk requires before context lines, "
                 & "but there's no input file";
            end if;
            while Line < A_Hunk.From_File_Line_Numbers.Start loop
               if End_Of_File(In_F) then
                  raise State with "hunk requires before context lines, "
                    & "but the file has ended";
               end if;
               declare
                  In_Line: String := Get_Line(In_F);
               begin
                  Hash_Line(In_Ctx, In_Line);
                  Hash_Line(To_Ctx, In_Line);
                  Put_Line(To_F, In_Line);
                  Line := Line + 1;
               end;
            end loop;
         end if;
     Hunk_Body_Loop:
         loop
            exit Hunk_Body_Loop when From_Count = 0 and To_Count = 0;
            Look_Ahead(C, EOL);
            if EOL then
               raise Parse with "blank line in hunk";
            end if;
            case C is
               when '+' => -- line added
                  Get(C);
                  case Op is
                     when Op_Create | Op_Patch => null;
                     when Op_Delete => raise State with "hunk trying to add lines, "
                        & "but the operation is deletion";
                  end case;
                  if To_Count = 0 then
                     raise State with "hunk trying to add lines, "
                       & "but the line count is not valid";
                  end if;
                  declare
                     Patch_Line: String := Get_Line;
                  begin
                     Put_Line(To_F, Patch_Line);
                     Hash_Line(To_Ctx, Patch_Line);
                  end;
                  To_Count := To_Count - 1;
               when '-' => -- line deleted
                  Get(C);
                  case Op is
                     when Op_Delete | Op_Patch => null;
                     when Op_Create => raise State;
                  end case;
                  if not Has_Input_File then
                     raise State with "hunk trying to remove lines, "
                       & "but the input file doesn't exist";
                  end if;
                  if From_Count = 0 then
                     raise State with "hunk trying to remove lines, "
                       & "when the input file already ended";
                  end if;
                  declare
                     In_Line: String := Get_Line(In_F);
                     Patch_Line: String := Get_Line;
                  begin
                     if In_Line /= Patch_Line then
                        raise State with "lines don't match";
                     end if;
                     Hash_Line(In_Ctx, In_Line);
                  end;
                  Line := Line + 1;
                  From_Count := From_Count - 1;
               when ' ' => -- line stays the same
                  Get(C);
                  if not Has_Input_File then
                     raise State with "hunk claims identical lines, "
                       & "but the input file doesn't exist";
                  end if;
                  if End_Of_File(In_F) then
                     raise State with "hunk claims identical lines, "
                       & "but the input file has ended";
                  end if;
                  if From_Count = 0 then
                     raise State with "hunk claims identical lines, "
                       & "when input file already ended";
                  end if;
                  declare
                     In_Line: String := Get_Line(In_F);
                     Patch_Line: String := Get_Line;
                  begin
                     if In_Line /= Patch_Line then
                        raise State with "lines don't match";
                     end if;
                     Put_Line(To_F, Patch_Line);
                     Hash_Line(In_Ctx, In_Line);
                     Hash_Line(To_Ctx, In_Line);
                  end;
                  Line := Line + 1;
                  From_Count := From_Count - 1;
                  To_Count := To_Count - 1;
               when others =>
                  raise Parse with "unexpected character "
                    & Character'Image(C)
                    & " at beginning of line in hunk body";
            end case;
         end loop Hunk_Body_Loop;
      end loop Hunk_Loop;

      Check_Input_File_Hash;
      Check_Output_File_Hash;

      declare
         Tmp_Name: String := Name(To_F);
      begin
         Close(To_F);
         if Has_Input_File then
            Close(In_F);
            Dirs.Delete_File(To_F_Name);
         else
            if not Dirs.Exists(Path_Prefix(To_F_Name, 1)) then
               Dirs.Create_Path(Path_Prefix(To_F_Name, 1));
            end if;
         end if;
         case Op is
            when Op_Create | Op_Patch =>
               Dirs.Rename(Tmp_Name, To_F_Name);
            when Op_Delete =>
               Dirs.Delete_File(Tmp_Name);
         end case;
      end;

   exception
      when E : State =>
         -- we've encountered state issue,
         --   check first that the input hash is valid
         Cleanup;
         Check_Input_File_Hash;
         raise;

      when E : others =>
         Cleanup;
         raise;
   end Process_Hunks_For_Header;

begin
Read_Loop:
    loop
       declare
          S: String := Get_Line;
       begin
          if Starts_With(S, "diff ") then
             declare
                H: Header := Get_Header;
             begin
                Process_Hunks_For_Header(H);
                exit Read_Loop when End_Of_File;
             end;
          else
             Put_Line("Prelude: " & S);
          end if;
       end;
    end loop Read_Loop;
end;