--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

with Unix;
with Parameters;
with HelperText;
with File_Operations;
with PortScan.Scan;
with PortScan.Operations;
with Ada.Characters.Latin_1;
with Ada.Directories;
with Ada.Exceptions;
with Ada.Text_IO;

package body Repository is

   package PM  renames Parameters;
   package HT  renames HelperText;
   package FOP renames File_Operations;
   package LAT renames Ada.Characters.Latin_1;
   package DIR renames Ada.Directories;
   package EX  renames Ada.Exceptions;
   package TIO renames Ada.Text_IO;

   --------------------------------------------------------------------------------------------
   --  signing_command
   --------------------------------------------------------------------------------------------
   function signing_command return String
   is
      filename : constant String := get_file_prefix & "-signing_command";
   begin
      return FOP.head_n1 (filename);
   end signing_command;

   --------------------------------------------------------------------------------------------
   --  profile_fingerprint
   --------------------------------------------------------------------------------------------
   function profile_fingerprint return String
   is
      filename : constant String := get_file_prefix & "-fingerprint";
   begin
      return FOP.head_n1 (filename);
   end profile_fingerprint;

   --------------------------------------------------------------------------------------------
   --  valid_signing_command
   --------------------------------------------------------------------------------------------
   function valid_signing_command return Boolean
   is
      file_prefix   : constant String := get_file_prefix;
      fingerprint   : constant String := file_prefix & "fingerprint";
      ext_command   : constant String := file_prefix & "signing_command";
      found_finger  : constant Boolean := DIR.Exists (fingerprint);
      found_command : constant Boolean := DIR.Exists (ext_command);
   begin
      if found_finger and then found_command then
         if HT.IsBlank (FOP.head_n1 (fingerprint)) or else
           HT.IsBlank (FOP.head_n1 (ext_command))
         then
            TIO.Put_Line ("At least one of the profile signing command files is blank");
            TIO.Put_Line (sorry);
            return False;
         end if;
         return True;
      end if;

      if found_finger then
         TIO.Put_Line ("The profile fingerprint was found but not the signing command");
         TIO.Put_Line (sorry);
      elsif found_command then
         TIO.Put_Line ("The profile signing command was found but not the fingerprint");
         TIO.Put_Line (sorry);
      end if;

      return False;
   end valid_signing_command;

   --------------------------------------------------------------------------------------------
   --  acceptable_RSA_signing_support
   --------------------------------------------------------------------------------------------
   function acceptable_RSA_signing_support return Boolean
   is
      file_prefix   : constant String := get_file_prefix;
      key_private   : constant String := file_prefix & "private.key";
      key_public    : constant String := file_prefix & "public.key";
      found_private : constant Boolean := DIR.Exists (key_private);
      found_public  : constant Boolean := DIR.Exists (key_public);
   begin
      if not found_private and then not found_public then
         return True;
      end if;
      if found_public and then not found_private then
         TIO.Put_Line ("A public RSA key file has been found without a " &
                         "corresponding private key file.");
         TIO.Put_Line (sorry);
         return True;
      end if;
      if found_private and then not found_public then
         TIO.Put_Line ("A private RSA key file has been found without a " &
                         "corresponding public key file.");
         TIO.Put_Line (sorry);
         return True;
      end if;
      declare
         mode : constant String := file_permissions (key_private);
      begin
         if mode /= "400" then
            TIO.Put_Line ("The private RSA key file has insecure file permissions (" & mode & ")");
            TIO.Put_Line ("Please change the file mode of " & key_private &
                            " to 400 before continuing.");
            return False;
         end if;
      end;
      return True;
   end acceptable_RSA_signing_support;

   --------------------------------------------------------------------------------------------
   --  set_raven_conf_with_RSA
   --------------------------------------------------------------------------------------------
   function set_raven_conf_with_RSA return Boolean
   is
      file_prefix   : constant String := get_file_prefix;
      key_private   : constant String := file_prefix & "private.key";
      key_public    : constant String := file_prefix & "public.key";
      found_private : constant Boolean := DIR.Exists (key_private);
      found_public  : constant Boolean := DIR.Exists (key_public);
   begin
      return
        found_public and then
        found_private and then
        file_permissions (key_private) = "400";
   end set_raven_conf_with_RSA;

   --------------------------------------------------------------------------------------------
   --  get_file_prefix
   --------------------------------------------------------------------------------------------
   function get_file_prefix return String is
   begin
      return PM.raven_confdir & "/" & HT.USS (PM.configuration.profile) & "-";
   end get_file_prefix;

   --------------------------------------------------------------------------------------------
   --  file_permissions
   --------------------------------------------------------------------------------------------
   function file_permissions (full_path : String) return String
   is
      command : constant String := HT.USS (PM.configuration.dir_sysroot) &
                                   "/usr/bin/stat -f %Lp " & full_path;
      content  : HT.Text;
      status   : Integer;
   begin
      content := Unix.piped_command (command, status);
      if status /= 0 then
         return "000";
      end if;
      return HT.first_line (HT.USS (content));
   end file_permissions;

   --------------------------------------------------------------------------------------------
   --  host_pkg8_conservative_upgrade_set
   --------------------------------------------------------------------------------------------
   function host_pkg8_conservative_upgrade_set return Boolean
   is
      command : constant String := host_pkg8 & " config CONSERVATIVE_UPGRADE";
      content : HT.Text;
      status  : Integer;
   begin
      content := Unix.piped_command (command, status);
      return (HT.first_line (HT.USS (content)) = "yes");
   end host_pkg8_conservative_upgrade_set;

   --------------------------------------------------------------------------------------------
   --  get_repos_dir
   --------------------------------------------------------------------------------------------
   function get_repos_dir return String
   is
      command : String := host_pkg8 & " config repos_dir";
      status  : Integer;
      markers : HT.Line_Markers;
      repdirs : String := HT.USS (Unix.piped_command (command, status));
      default : constant String := host_localbase & "/etc/pkg/repos";
   begin
      if status /= 0 then
         --  command failed, use default
         return default;
      end if;

      HT.initialize_markers (repdirs, markers);
      loop
         exit when not HT.next_line_present (repdirs, markers);
         declare
            line : constant String := HT.extract_line (repdirs, markers);
         begin
            if line /= "/etc/pkg" then
               return line;
            end if;
         end;
      end loop;

      --  fallback, use default
      return default;
   end get_repos_dir;

   --------------------------------------------------------------------------------------------
   --  write_pkg_repos_configuration_file
   --------------------------------------------------------------------------------------------
   function write_pkg_repos_configuration_file return Boolean
   is
      repdir : constant String := get_repos_dir;
      target : constant String := repdir & "/00_raven.conf";
      pkgdir : constant String := HT.USS (PM.configuration.dir_packages);
      pubkey : constant String := get_file_prefix & "-public.key";
      keydir : constant String := PM.raven_confdir & "/keys";
      tstdir : constant String := keydir & "/trusted";
      autgen : constant String := "# Automatically generated." & LAT.LF;
      fpfile : constant String := tstdir & "/fingerprint." & HT.USS (PM.configuration.profile);
      handle : TIO.File_Type;
      vscmd  : Boolean := False;
   begin
      if DIR.Exists (target) then
         DIR.Delete_File (target);
      elsif not DIR.Exists (repdir) then
         DIR.Create_Path (repdir);
      end if;
      TIO.Create (File => handle, Mode => TIO.Out_File, Name => target);
      TIO.Put_Line (handle, autgen);
      TIO.Put_Line (handle, "Raven: {");
      TIO.Put_Line (handle, "  url      : file://" & pkgdir & ",");
      TIO.Put_Line (handle, "  priority : 0,");
      TIO.Put_Line (handle, "  enabled  : yes,");
      if valid_signing_command then
         vscmd := True;
         TIO.Put_Line (handle, "  signature_type : FINGERPRINTS,");
         TIO.Put_Line (handle, "  fingerprints   : " & keydir);
      elsif set_raven_conf_with_RSA then
         TIO.Put_Line (handle, "  signature_type : PUBKEY,");
         TIO.Put_Line (handle, "  pubkey         : " & LAT.Quotation & pubkey & LAT.Quotation);
      end if;
      TIO.Put_Line (handle, "}");
      TIO.Close (handle);
      if vscmd then
         if DIR.Exists (fpfile) then
            DIR.Delete_File (fpfile);
         elsif not DIR.Exists (tstdir) then
            DIR.Create_Path (tstdir);
         end if;
         TIO.Create (File => handle, Mode => TIO.Out_File, Name => fpfile);
         TIO.Put_Line (handle, autgen);
         TIO.Put_Line (handle, "function    : sha256");
         TIO.Put_Line (handle, "fingerprint : " & profile_fingerprint);
         TIO.Close (handle);
      end if;
      return True;
   exception
      when others =>
         TIO.Put_Line ("Error: failed to create " & target);
         if TIO.Is_Open (handle) then
            TIO.Close (handle);
         end if;
         return False;
   end write_pkg_repos_configuration_file;

   --------------------------------------------------------------------------------------------
   --  rebuild_local_respository
   --------------------------------------------------------------------------------------------
   procedure preclean_repository (repository : String)
   is
   begin
      if PortScan.Scan.scan_repository (repository) then
         PortScan.Operations.eliminate_obsolete_packages;
      end if;
   end preclean_repository;

   --------------------------------------------------------------------------------------------
   --  rebuild_local_respository
   --------------------------------------------------------------------------------------------
   procedure rebuild_local_respository (remove_invalid_packages : Boolean)
   is
      ------------------------------------------------------------
      --  fully_scan_tree must be executed before this routine  --
      ------------------------------------------------------------
      repo       : constant String := HT.USS (PM.configuration.dir_repository);
      main       : constant String := HT.USS (PM.configuration.dir_packages);
      xz_meta    : constant String := main & "/meta.tzst";
      xz_digest  : constant String := main & "/digests.tzst";
      xz_pkgsite : constant String := main & "/packagesite.tzst";
      bs_error   : constant String := "Rebuild Repository: Failed to bootstrap builder";
      build_res  : Boolean;
   begin
      if remove_invalid_packages then
         preclean_repository (repo);
      end if;

      if DIR.Exists (xz_meta) then
         DIR.Delete_File (xz_meta);
      end if;
      if DIR.Exists (xz_digest) then
         DIR.Delete_File (xz_digest);
      end if;
      if DIR.Exists (xz_pkgsite) then
         DIR.Delete_File (xz_pkgsite);
      end if;
      if valid_signing_command then
         build_res := build_repository (signing_command);
      elsif acceptable_RSA_signing_support then
         build_res := build_repository;
      else
         build_res := False;
      end if;
      if build_res then
         TIO.Put_Line ("Local repository successfully rebuilt.");
      else
         TIO.Put_Line ("Failed to rebuild repository.");
      end if;
   end rebuild_local_respository;

   --------------------------------------------------------------------------------------------
   --  silent_exec
   --------------------------------------------------------------------------------------------
   procedure silent_exec (command : String)
   is
      cmd_output : HT.Text;
      success    : Boolean := Unix.piped_mute_command (command, cmd_output);
   begin
      if not success then
         raise bad_command with command & " => failed: " & HT.USS (cmd_output);
      end if;
   end silent_exec;

   --------------------------------------------------------------------------------------------
   --  build_repository
   --------------------------------------------------------------------------------------------
   function build_repository (sign_command : String := "") return Boolean
   is
      key_private : constant String := get_file_prefix & "private.key";
      use_key : constant Boolean := DIR.Exists (key_private);
      use_cmd : constant Boolean := (sign_command /= "");
      pkgdir  : constant String := HT.USS (PM.configuration.dir_packages);
      command : constant String := host_pkg8 & " repo -q " & pkgdir;
      sc_cmd  : constant String := command & " signing_command: " & sign_command;
      cmd_out : HT.Text;
   begin
      if use_key then
         TIO.Put_Line ("Rebuilding RSA-signed local repository ...");
         silent_exec (command & " " & key_private);
      elsif use_cmd then
         TIO.Put_Line ("Rebuilding externally-signed local repository ...");
         silent_exec (sc_cmd);
      else
         TIO.Put_Line ("Rebuilding local repository ...");
         silent_exec (command);
      end if;
      return True;
   exception
      when quepaso : others =>
         TIO.Put_Line (EX.Exception_Message (quepaso));
         return False;
   end build_repository;

end Repository;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

with Unix;
with Parameters;
with HelperText;
with File_Operations;
with PortScan.Scan;
with PortScan.Operations;
with Ada.Characters.Latin_1;
with Ada.Directories;
with Ada.Exceptions;
with Ada.Text_IO;

package body Repository is

   package PM  renames Parameters;
   package HT  renames HelperText;
   package FOP renames File_Operations;
   package LAT renames Ada.Characters.Latin_1;
   package DIR renames Ada.Directories;
   package EX  renames Ada.Exceptions;
   package TIO renames Ada.Text_IO;

   --------------------------------------------------------------------------------------------
   --  signing_command
   --------------------------------------------------------------------------------------------
   function signing_command return String
   is
      filename : constant String := get_file_prefix & "-signing_command";
   begin
      return FOP.head_n1 (filename);
   end signing_command;

   --------------------------------------------------------------------------------------------
   --  profile_fingerprint
   --------------------------------------------------------------------------------------------
   function profile_fingerprint return String
   is
      filename : constant String := get_file_prefix & "-fingerprint";
   begin
      return FOP.head_n1 (filename);
   end profile_fingerprint;

   --------------------------------------------------------------------------------------------
   --  valid_signing_command
   --------------------------------------------------------------------------------------------
   function valid_signing_command return Boolean
   is
      file_prefix   : constant String := get_file_prefix;
      fingerprint   : constant String := file_prefix & "fingerprint";
      ext_command   : constant String := file_prefix & "signing_command";
      found_finger  : constant Boolean := DIR.Exists (fingerprint);
      found_command : constant Boolean := DIR.Exists (ext_command);
   begin
      if found_finger and then found_command then
         if HT.IsBlank (FOP.head_n1 (fingerprint)) or else
           HT.IsBlank (FOP.head_n1 (ext_command))
         then
            TIO.Put_Line ("At least one of the profile signing command files is blank");
            TIO.Put_Line (sorry);
            return False;
         end if;
         return True;
      end if;

      if found_finger then
         TIO.Put_Line ("The profile fingerprint was found but not the signing command");
         TIO.Put_Line (sorry);
      elsif found_command then
         TIO.Put_Line ("The profile signing command was found but not the fingerprint");
         TIO.Put_Line (sorry);
      end if;

      return False;
   end valid_signing_command;

   --------------------------------------------------------------------------------------------
   --  acceptable_RSA_signing_support
   --------------------------------------------------------------------------------------------
   function acceptable_RSA_signing_support return Boolean
   is
      file_prefix   : constant String := get_file_prefix;
      key_private   : constant String := file_prefix & "private.key";
      key_public    : constant String := file_prefix & "public.key";
      found_private : constant Boolean := DIR.Exists (key_private);
      found_public  : constant Boolean := DIR.Exists (key_public);
   begin
      if not found_private and then not found_public then
         return True;
      end if;
      if found_public and then not found_private then
         TIO.Put_Line ("A public RSA key file has been found without a " &
                         "corresponding private key file.");
         TIO.Put_Line (sorry);
         return True;
      end if;
      if found_private and then not found_public then
         TIO.Put_Line ("A private RSA key file has been found without a " &
                         "corresponding public key file.");
         TIO.Put_Line (sorry);
         return True;
      end if;
      declare
         mode : constant String := file_permissions (key_private);
      begin
         if mode /= "400" then
            TIO.Put_Line ("The private RSA key file has insecure file permissions (" & mode & ")");
            TIO.Put_Line ("Please change the file mode of " & key_private &
                            " to 400 before continuing.");
            return False;
         end if;
      end;
      return True;
   end acceptable_RSA_signing_support;

   --------------------------------------------------------------------------------------------
   --  set_raven_conf_with_RSA
   --------------------------------------------------------------------------------------------
   function set_raven_conf_with_RSA return Boolean
   is
      file_prefix   : constant String := get_file_prefix;
      key_private   : constant String := file_prefix & "private.key";
      key_public    : constant String := file_prefix & "public.key";
      found_private : constant Boolean := DIR.Exists (key_private);
      found_public  : constant Boolean := DIR.Exists (key_public);
   begin
      return
        found_public and then
        found_private and then
        file_permissions (key_private) = "400";
   end set_raven_conf_with_RSA;

   --------------------------------------------------------------------------------------------
   --  get_file_prefix
   --------------------------------------------------------------------------------------------
   function get_file_prefix return String is
   begin
      return PM.raven_confdir & "/" & HT.USS (PM.configuration.profile) & "-";
   end get_file_prefix;

   --------------------------------------------------------------------------------------------
   --  file_permissions
   --------------------------------------------------------------------------------------------
   function file_permissions (full_path : String) return String
   is
      function OS_command return String;

      content  : HT.Text;
      status   : Integer;

      function OS_command return String is
      begin
         case platform_type is
            when dragonfly |
                 freebsd   |
                 netbsd    |
                 openbsd   |
                 macos     => return "/usr/bin/stat -f %Lp ";
            when linux     |
                 sunos     => return "/usr/bin/stat -L --format=%a ";
         end case;
      end OS_command;

      command : constant String := HT.USS (PM.configuration.dir_sysroot) & OS_command & full_path;

   begin
      content := Unix.piped_command (command, status);
      if status /= 0 then
         return "000";
      end if;
      return HT.first_line (HT.USS (content));
   end file_permissions;

   --------------------------------------------------------------------------------------------
   --  host_pkg8_conservative_upgrade_set
   --------------------------------------------------------------------------------------------
   function host_pkg8_conservative_upgrade_set return Boolean
   is
      command : constant String := host_pkg8 & " config CONSERVATIVE_UPGRADE";
      content : HT.Text;
      status  : Integer;
   begin
      content := Unix.piped_command (command, status);
      return (HT.first_line (HT.USS (content)) = "yes");
   end host_pkg8_conservative_upgrade_set;

   --------------------------------------------------------------------------------------------
   --  get_repos_dir
   --------------------------------------------------------------------------------------------
   function get_repos_dir return String
   is
      command : String := host_pkg8 & " config repos_dir";
      status  : Integer;
      markers : HT.Line_Markers;
      repdirs : String := HT.USS (Unix.piped_command (command, status));
      default : constant String := host_localbase & "/etc/pkg/repos";
   begin
      if status /= 0 then
         --  command failed, use default
         return default;
      end if;

      HT.initialize_markers (repdirs, markers);
      loop
         exit when not HT.next_line_present (repdirs, markers);
         declare
            line : constant String := HT.extract_line (repdirs, markers);
         begin
            if line /= "/etc/pkg" then
               return line;
            end if;
         end;
      end loop;

      --  fallback, use default
      return default;
   end get_repos_dir;

   --------------------------------------------------------------------------------------------
   --  write_pkg_repos_configuration_file
   --------------------------------------------------------------------------------------------
   function write_pkg_repos_configuration_file return Boolean
   is
      repdir : constant String := get_repos_dir;
      target : constant String := repdir & "/00_raven.conf";
      pkgdir : constant String := HT.USS (PM.configuration.dir_packages);
      pubkey : constant String := get_file_prefix & "-public.key";
      keydir : constant String := PM.raven_confdir & "/keys";
      tstdir : constant String := keydir & "/trusted";
      autgen : constant String := "# Automatically generated." & LAT.LF;
      fpfile : constant String := tstdir & "/fingerprint." & HT.USS (PM.configuration.profile);
      handle : TIO.File_Type;
      vscmd  : Boolean := False;
   begin
      if DIR.Exists (target) then
         DIR.Delete_File (target);
      elsif not DIR.Exists (repdir) then
         DIR.Create_Path (repdir);
      end if;
      TIO.Create (File => handle, Mode => TIO.Out_File, Name => target);
      TIO.Put_Line (handle, autgen);
      TIO.Put_Line (handle, "Raven: {");
      TIO.Put_Line (handle, "  url      : file://" & pkgdir & ",");
      TIO.Put_Line (handle, "  priority : 0,");
      TIO.Put_Line (handle, "  enabled  : yes,");
      if valid_signing_command then
         vscmd := True;
         TIO.Put_Line (handle, "  signature_type : FINGERPRINTS,");
         TIO.Put_Line (handle, "  fingerprints   : " & keydir);
      elsif set_raven_conf_with_RSA then
         TIO.Put_Line (handle, "  signature_type : PUBKEY,");
         TIO.Put_Line (handle, "  pubkey         : " & LAT.Quotation & pubkey & LAT.Quotation);
      end if;
      TIO.Put_Line (handle, "}");
      TIO.Close (handle);
      if vscmd then
         if DIR.Exists (fpfile) then
            DIR.Delete_File (fpfile);
         elsif not DIR.Exists (tstdir) then
            DIR.Create_Path (tstdir);
         end if;
         TIO.Create (File => handle, Mode => TIO.Out_File, Name => fpfile);
         TIO.Put_Line (handle, autgen);
         TIO.Put_Line (handle, "function    : sha256");
         TIO.Put_Line (handle, "fingerprint : " & profile_fingerprint);
         TIO.Close (handle);
      end if;
      return True;
   exception
      when others =>
         TIO.Put_Line ("Error: failed to create " & target);
         if TIO.Is_Open (handle) then
            TIO.Close (handle);
         end if;
         return False;
   end write_pkg_repos_configuration_file;

   --------------------------------------------------------------------------------------------
   --  rebuild_local_respository
   --------------------------------------------------------------------------------------------
   procedure preclean_repository (repository : String)
   is
   begin
      if PortScan.Scan.scan_repository (repository) then
         PortScan.Operations.eliminate_obsolete_packages;
      end if;
   end preclean_repository;

   --------------------------------------------------------------------------------------------
   --  rebuild_local_respository
   --------------------------------------------------------------------------------------------
   procedure rebuild_local_respository (remove_invalid_packages : Boolean)
   is
      ------------------------------------------------------------
      --  fully_scan_tree must be executed before this routine  --
      ------------------------------------------------------------
      repo       : constant String := HT.USS (PM.configuration.dir_repository);
      main       : constant String := HT.USS (PM.configuration.dir_packages);
      xz_meta    : constant String := main & "/meta.tzst";
      xz_digest  : constant String := main & "/digests.tzst";
      xz_pkgsite : constant String := main & "/packagesite.tzst";
      bs_error   : constant String := "Rebuild Repository: Failed to bootstrap builder";
      build_res  : Boolean;
   begin
      if remove_invalid_packages then
         preclean_repository (repo);
      end if;

      if DIR.Exists (xz_meta) then
         DIR.Delete_File (xz_meta);
      end if;
      if DIR.Exists (xz_digest) then
         DIR.Delete_File (xz_digest);
      end if;
      if DIR.Exists (xz_pkgsite) then
         DIR.Delete_File (xz_pkgsite);
      end if;
      if valid_signing_command then
         build_res := build_repository (signing_command);
      elsif acceptable_RSA_signing_support then
         build_res := build_repository;
      else
         build_res := False;
      end if;
      if build_res then
         TIO.Put_Line ("Local repository successfully rebuilt.");
      else
         TIO.Put_Line ("Failed to rebuild repository.");
      end if;
   end rebuild_local_respository;

   --------------------------------------------------------------------------------------------
   --  silent_exec
   --------------------------------------------------------------------------------------------
   procedure silent_exec (command : String)
   is
      cmd_output : HT.Text;
      success    : Boolean := Unix.piped_mute_command (command, cmd_output);
   begin
      if not success then
         raise bad_command with command & " => failed: " & HT.USS (cmd_output);
      end if;
   end silent_exec;

   --------------------------------------------------------------------------------------------
   --  build_repository
   --------------------------------------------------------------------------------------------
   function build_repository (sign_command : String := "") return Boolean
   is
      key_private : constant String := get_file_prefix & "private.key";
      use_key : constant Boolean := DIR.Exists (key_private);
      use_cmd : constant Boolean := (sign_command /= "");
      pkgdir  : constant String := HT.USS (PM.configuration.dir_packages);
      command : constant String := host_pkg8 & " repo -q " & pkgdir;
      sc_cmd  : constant String := command & " signing_command: " & sign_command;
      cmd_out : HT.Text;
   begin
      if use_key then
         TIO.Put_Line ("Rebuilding RSA-signed local repository ...");
         silent_exec (command & " " & key_private);
      elsif use_cmd then
         TIO.Put_Line ("Rebuilding externally-signed local repository ...");
         silent_exec (sc_cmd);
      else
         TIO.Put_Line ("Rebuilding local repository ...");
         silent_exec (command);
      end if;
      return True;
   exception
      when quepaso : others =>
         TIO.Put_Line (EX.Exception_Message (quepaso));
         return False;
   end build_repository;

end Repository;

Fix file mode detection on linux and sunos


with Ada.Command_Line;
with Ada.Exceptions;
with Ada.Text_IO;
with Ada.IO_Exceptions;
with Core;
with Envs;
with Evaluation;
with Printer;
with Reader;
with Types;

procedure Step8_Macros is

   function Read (Param : String) return Types.Mal_Handle is
   begin
      return Reader.Read_Str (Param);
   end Read;

   -- Eval can't be here because there are function pointers that point
   -- at it.  Thus it must be at library level.  See evaluation.ads

   function Print (Param : Types.Mal_Handle) return String is
   begin
      return Printer.Pr_Str (Param);
   end Print;

   function Rep (Param : String) return String is
     AST, Evaluated_AST : Types.Mal_Handle;
   begin

     AST := Read (Param);

     if Types.Is_Null (AST) then
        return "";
     else
        Evaluated_AST := Evaluation.Eval (AST, Envs.Get_Current);
        return Print (Evaluated_AST);
     end if;

   end Rep;

   S : String (1..Reader.Max_Line_Len);
   Last : Natural;
   Cmd_Args : Natural;
   Command_Args : Types.Mal_Handle;
   Command_List : Types.List_Ptr;
   File_Processed : Boolean := False;

begin

   -- Core init also creates the first environment.
   -- This is needed for the def!'s below.
   Core.Init;

   declare
      Not_S : String :=
        Rep ("(def! not (fn* (a) (if a false true)))");
      LF_S : String :=
        Rep ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) "")"")))))");
      pragma Unreferenced (Not_S, LF_S);
   begin
      null;
   end;

   Cmd_Args := 0;
   Command_Args := Types.New_List_Mal_Type (Types.List_List);
   Command_List := Types.Deref_List (Command_Args);

   while Ada.Command_Line.Argument_Count > Cmd_Args loop

     Cmd_Args := Cmd_Args + 1;
     if Ada.Command_Line.Argument (Cmd_Args) = "-d" then
        Evaluation.Debug := True;
     elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then
        Envs.Debug := True;
     else
        if not File_Processed then
--           declare
--              F_S : String :=
ADa.Text_IO.Put_Line (
                Rep ("(load-file """ & Ada.Command_Line.Argument (Cmd_Args) & """)")
);
--           begin
--              null;
--           end;
           File_Processed := True;
        else
           Command_List.Append
             (Types.New_Atom_Mal_Type (Ada.Command_Line.Argument (Cmd_Args)));
        end if;
     end if;

   end loop;

   Envs.Set (Envs.Get_Current, "*ARGV*", Command_Args);

   loop
      begin
         Ada.Text_IO.Put ("user> ");
         Ada.Text_IO.Get_Line (S, Last);
         Ada.Text_IO.Put_Line (Rep (S (1..Last)));
      exception
         when Ada.IO_Exceptions.End_Error => raise;
         when E : others =>
            Ada.Text_IO.Put_Line
              (Ada.Text_IO.Standard_Error,
               Ada.Exceptions.Exception_Information (E));
      end;
   end loop;

exception
   when Ada.IO_Exceptions.End_Error => null;
   -- i.e. exit without textual output
end Step8_Macros;

with Ada.Command_Line;
with Ada.Exceptions;
with Ada.Text_IO;
with Ada.IO_Exceptions;
with Core;
with Envs;
with Evaluation;
with Printer;
with Reader;
with Types;

procedure Step8_Macros is

   function Read (Param : String) return Types.Mal_Handle is
   begin
      return Reader.Read_Str (Param);
   end Read;

   -- Eval can't be here because there are function pointers that point
   -- at it.  Thus it must be at library level.  See evaluation.ads

   function Print (Param : Types.Mal_Handle) return String is
   begin
      return Printer.Pr_Str (Param);
   end Print;

   function Rep (Param : String) return String is
     AST, Evaluated_AST : Types.Mal_Handle;
   begin

     AST := Read (Param);

     if Types.Is_Null (AST) then
        return "";
     else
        Evaluated_AST := Evaluation.Eval (AST, Envs.Get_Current);
        return Print (Evaluated_AST);
     end if;

   end Rep;

   S : String (1..Reader.Max_Line_Len);
   Last : Natural;
   Cmd_Args : Natural;
   Command_Args : Types.Mal_Handle;
   Command_List : Types.List_Ptr;
   File_Processed : Boolean := False;

begin

   -- Core init also creates the first environment.
   -- This is needed for the def!'s below.
   Core.Init;

   declare
      Not_S : String :=
        Rep ("(def! not (fn* (a) (if a false true)))");
      LF_S : String :=
        Rep ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) "")"")))))");
      Cond_S : String :=
        Rep ("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ""odd number of forms to cond"")) (cons 'cond (rest (rest xs)))))))");
      Or_S : String :=
        Rep ("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))");
      pragma Unreferenced (Not_S, LF_S, Cond_S, Or_S);
   begin
      null;
   end;

   Cmd_Args := 0;
   Command_Args := Types.New_List_Mal_Type (Types.List_List);
   Command_List := Types.Deref_List (Command_Args);

   while Ada.Command_Line.Argument_Count > Cmd_Args loop

     Cmd_Args := Cmd_Args + 1;
     if Ada.Command_Line.Argument (Cmd_Args) = "-d" then
        Evaluation.Debug := True;
     elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then
        Envs.Debug := True;
     else
        if not File_Processed then
--           declare
--              F_S : String :=
ADa.Text_IO.Put_Line (
                Rep ("(load-file """ & Ada.Command_Line.Argument (Cmd_Args) & """)")
);
--           begin
--              null;
--           end;
           File_Processed := True;
        else
           Command_List.Append
             (Types.New_Atom_Mal_Type (Ada.Command_Line.Argument (Cmd_Args)));
        end if;
     end if;

   end loop;

   Envs.Set (Envs.Get_Current, "*ARGV*", Command_Args);

   loop
      begin
         Ada.Text_IO.Put ("user> ");
         Ada.Text_IO.Get_Line (S, Last);
         Ada.Text_IO.Put_Line (Rep (S (1..Last)));
      exception
         when Ada.IO_Exceptions.End_Error => raise;
         when E : others =>
            Ada.Text_IO.Put_Line
              (Ada.Text_IO.Standard_Error,
               Ada.Exceptions.Exception_Information (E));
      end;
   end loop;

exception
   when Ada.IO_Exceptions.End_Error => null;
   -- i.e. exit without textual output
end Step8_Macros;

add Cond and Or macros

Ada: add Cond and Or macros


--                              -*- Mode: Ada -*-
--  Filename        : bare_bones.adb
--  Description     : A "hello world" style OS kernel written in Ada.
--  Author          : Luke A. Guest
--  Created On      : Thu Jun 14 11:59:53 2012
--  Licence         : See LICENCE in the root directory.
pragma Restrictions (No_Obsolescent_Features);
with VGA_Console; use VGA_Console;
with Multiboot; use Multiboot;
--  with System.Address_To_Access_Conversions;
--  with Ada.Unchecked_Conversion;

use type Multiboot.Magic_Values;

procedure Bare_Bones is
   Line : Screen_Height_Range := Screen_Height_Range'First;
begin
   null;
   Clear;

   Put ("Hello, bare bones in Ada",
        Screen_Width_Range'First,
        Line);

   Line := Line + 1;

   if Magic = Magic_Value then
      Put ("Magic numbers match!", Screen_Width_Range'First, Line);
   else
      Put ("Magic numbers don't match!", Screen_Width_Range'First, Line);

      raise Program_Error;
   end if;

   --  Line := Line + 1;

   --  if Info.Flags.Memory then
   --     Put ("Memory info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.Boot_Device then
   --     Put ("Boot device info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.Command_Line then
   --     Put ("Command line info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.Modules then
   --     Put ("Modules info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;

   --     if Info.Modules.Count = 2 then
   --        declare
   --           type My_Modules_Array is new Modules_Array
   --             (1 .. Natural (Info.Modules.Count));
   --           type My_Modules_Array_Access is access all My_Modules_Array;

   --           --  My_Modules : aliased Modules_Array
   --           --    (1 .. Natural (Info.Modules.Count));
   --           --  pragma Unreferenced (My_Modules);

   --           package To_Modules is new System.Address_To_Access_Conversions
   --             (Object => My_Modules_Array_Access);

   --           function Conv is new Ada.Unchecked_Conversion
   --             (Source => To_Modules.Object_Pointer,
   --              Target => My_Modules_Array_Access);

   --           Modules : constant My_Modules_Array_Access :=
   --             Conv (To_Modules.To_Pointer
   --                     (Info.Modules.First));

   --           M : Multiboot.Modules;
   --           pragma Unreferenced (M);
   --        begin
   --           Put ("2 modules loaded is correct",
   --                Screen_Width_Range'First, Line);

   --           for I in 1 .. Info.Modules.Count loop
   --              M := Modules (Natural (I));
   --           end loop;

   --           Line := Line + 1;
   --        end;
   --     end if;
   --  end if;

   --  if Info.Flags.Symbol_Table then
   --     Put ("Symbol table info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.Section_Header_Table then
   --     Put ("Section header table info present",
   --        Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.BIOS_Memory_Map then
   --     Put ("BIOS memory map info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;

   --     declare
   --        Map : Memory_Map_Entry_Access := Multiboot.First_Memory_Map_Entry;
   --     begin
   --        while Map /= null loop
   --           Map := Multiboot.Next_Memory_Map_Entry (Map);
   --        end loop;
   --     end;
   --  end if;

   --  if Info.Flags.Drives then
   --     Put ("Drives info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.ROM_Configuration then
   --     Put ("ROM configuration info present",
   --          Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.Boot_Loader then
   --     Put ("Boot loader info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.APM_Table then
   --     Put ("APM table info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.Graphics_Table then
   --     Put ("Graphics table info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  raise Constraint_Error;

   --  raise Console.TE;
   --  raise Constraint_Error;

   --  Put (Natural 'Image (54),
   --       Screen_Width_Range'First,
   --       Screen_Height_Range'First + 1);
   --  exception
   --     when Constraint_Error =>
   --        Put ("Constraint Error caught", 1, 15);
   --     when Program_Error =>
   --        null;
   --  when Console.TE =>
   --     Put ("TE caught", 1, 2);
end Bare_Bones;
pragma No_Return (Bare_Bones);

--                              -*- Mode: Ada -*-
--  Filename        : bare_bones.adb
--  Description     : A "hello world" style OS kernel written in Ada.
--  Author          : Luke A. Guest
--  Created On      : Thu Jun 14 11:59:53 2012
--  Licence         : See LICENCE in the root directory.
pragma Restrictions (No_Obsolescent_Features);
with VGA_Console; use VGA_Console;
with Multiboot; use Multiboot;
--  with System.Address_To_Access_Conversions;
--  with Ada.Unchecked_Conversion;

use type Multiboot.Magic_Values;

procedure Bare_Bones is
   Line : Screen_Height_Range := Screen_Height_Range'First;

   procedure T is
   begin
      Put ("T called", Screen_Width_Range'First, Line);
   end T;

   function Hello return String is
   begin
      return "hello!!";
   end Hello;
begin
   --     null;
   Clear;

   Put ("Hello, bare bones in Ada",
        Screen_Width_Range'First,
        Line);

   Line := Line + 1;

   if Magic = Magic_Value then
      Put ("Magic numbers match!", Screen_Width_Range'First, Line);
   else
      Put ("Magic numbers don't match!", Screen_Width_Range'First, Line);  --  comment

      raise Program_Error;
   end if;

   Line := Line + 1;

   T;

   Line := Line + 1;

   Put (Hello, Screen_Width_Range'First, Line);

   --  if Info.Flags.Memory then
   --     Put ("Memory info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.Boot_Device then
   --     Put ("Boot device info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.Command_Line then
   --     Put ("Command line info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.Modules then
   --     Put ("Modules info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;

   --     if Info.Modules.Count = 2 then
   --        declare
   --           type My_Modules_Array is new Modules_Array
   --             (1 .. Natural (Info.Modules.Count));
   --           type My_Modules_Array_Access is access all My_Modules_Array;

   --           --  My_Modules : aliased Modules_Array
   --           --    (1 .. Natural (Info.Modules.Count));
   --           --  pragma Unreferenced (My_Modules);

   --           package To_Modules is new System.Address_To_Access_Conversions
   --             (Object => My_Modules_Array_Access);

   --           function Conv is new Ada.Unchecked_Conversion
   --             (Source => To_Modules.Object_Pointer,
   --              Target => My_Modules_Array_Access);

   --           Modules : constant My_Modules_Array_Access :=
   --             Conv (To_Modules.To_Pointer
   --                     (Info.Modules.First));

   --           M : Multiboot.Modules;
   --           pragma Unreferenced (M);
   --        begin
   --           Put ("2 modules loaded is correct",
   --                Screen_Width_Range'First, Line);

   --           for I in 1 .. Info.Modules.Count loop
   --              M := Modules (Natural (I));
   --           end loop;

   --           Line := Line + 1;
   --        end;
   --     end if;
   --  end if;

   --  if Info.Flags.Symbol_Table then
   --     Put ("Symbol table info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.Section_Header_Table then
   --     Put ("Section header table info present",
   --        Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.BIOS_Memory_Map then
   --     Put ("BIOS memory map info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;

   --     declare
   --        Map : Memory_Map_Entry_Access := Multiboot.First_Memory_Map_Entry;
   --     begin
   --        while Map /= null loop
   --           Map := Multiboot.Next_Memory_Map_Entry (Map);
   --        end loop;
   --     end;
   --  end if;

   --  if Info.Flags.Drives then
   --     Put ("Drives info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.ROM_Configuration then
   --     Put ("ROM configuration info present",
   --          Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.Boot_Loader then
   --     Put ("Boot loader info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.APM_Table then
   --     Put ("APM table info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  if Info.Flags.Graphics_Table then
   --     Put ("Graphics table info present", Screen_Width_Range'First, Line);

   --     Line := Line + 1;
   --  end if;

   --  raise Constraint_Error;

   --  raise Console.TE;
   --  raise Constraint_Error;

   --  Put (Natural 'Image (54),
   --       Screen_Width_Range'First,
   --       Screen_Height_Range'First + 1);
   --  exception
   --     when Constraint_Error =>
   --        Put ("Constraint Error caught", 1, 15);
   --     when Program_Error =>
   --        null;
   --  when Console.TE =>
   --     Put ("TE caught", 1, 2);
end Bare_Bones;
--  pragma No_Return (Bare_Bones);

Add local function to make sure nested functions work. Add function which returns a string utilising secondary stack.


-----------------------------------------------------------------------
--  gen-artifacts-distribs-copies -- Copy based distribution artifact
--  Copyright (C) 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

--  The <b>Gen.Artifacts.Distribs.Copies</b> package provides distribution rules
--  to copy a file or a directory to the distribution area.
private package Gen.Artifacts.Distribs.Copies is

   --  Create a distribution rule to copy a set of files or directories.
   function Create_Rule (Node : in DOM.Core.Node) return Distrib_Rule_Access;

   --  ------------------------------
   --  Distribution artifact
   --  ------------------------------
   type Copy_Rule is new Distrib_Rule with private;
   type Copy_Rule_Access is access all Copy_Rule'Class;

   --  Get a name to qualify the installation rule (used for logs).
   overriding
   function Get_Install_Name (Rule : in Copy_Rule) return String;

   overriding
   procedure Install (Rule    : in Copy_Rule;
                      Path    : in String;
                      Files   : in File_Vector;
                      Context : in out Generator'Class);

private

   type Copy_Rule is new Distrib_Rule with null record;

end Gen.Artifacts.Distribs.Copies;

-----------------------------------------------------------------------
--  gen-artifacts-distribs-copies -- Copy based distribution artifact
--  Copyright (C) 2012, 2013 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

--  The <b>Gen.Artifacts.Distribs.Copies</b> package provides distribution rules
--  to copy a file or a directory to the distribution area.
private package Gen.Artifacts.Distribs.Copies is

   --  Create a distribution rule to copy a set of files or directories.
   function Create_Rule (Node : in DOM.Core.Node;
                         Copy_First_File : in Boolean) return Distrib_Rule_Access;

   --  ------------------------------
   --  Distribution artifact
   --  ------------------------------
   type Copy_Rule is new Distrib_Rule with private;
   type Copy_Rule_Access is access all Copy_Rule'Class;

   --  Get a name to qualify the installation rule (used for logs).
   overriding
   function Get_Install_Name (Rule : in Copy_Rule) return String;

   overriding
   procedure Install (Rule    : in Copy_Rule;
                      Path    : in String;
                      Files   : in File_Vector;
                      Context : in out Generator'Class);

private

   type Copy_Rule is new Distrib_Rule with record
      --  When True and there are several source files, use the first file.
      --  Otherwise, use the last file.
      Copy_First_File : Boolean := False;
   end record;

end Gen.Artifacts.Distribs.Copies;

Add a copy-first command to copy the first file found only (the default is to copy the last one since this is the reverse search path)


-----------------------------------------------------------------------
--  EL.Objects.Hash -- Hash on an object
--  Copyright (C) 2010 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Strings.Hash;
with Ada.Characters.Conversions;
with Ada.Unchecked_Conversion;
with Interfaces;
with EL.Beans;
function EL.Objects.Hash (Key : in Object) return Ada.Containers.Hash_Type is
   use Ada.Containers;
   use Ada.Strings;
   use Ada.Characters.Conversions;
   use Interfaces;
   use EL.Beans;

   type Unsigned_32_Array is array (Natural range <>) of Unsigned_32;

   subtype U32_For_Float is Unsigned_32_Array (1 .. Long_Long_Float'Size / 32);

   subtype U32_For_Long is Unsigned_32_Array (1 .. Long_Long_Integer'Size / 32);

   subtype U32_For_Access is Unsigned_32_Array (1 .. Readonly_Bean_Access'Size / 32);

   --  Hash the integer and floats using 32-bit values.
   function To_U32_For_Long is new Ada.Unchecked_Conversion (Source => Long_Long_Integer,
                                                             Target => U32_For_Long);

   --  Likewise for floats.
   function To_U32_For_Float is new Ada.Unchecked_Conversion (Source => Long_Long_Float,
                                                              Target => U32_For_Float);

   --  Likewise for the bean pointer
   function To_U32_For_Access is new Ada.Unchecked_Conversion (Source => Readonly_Bean_Access,
                                                               Target => U32_For_Access);

   Value : Unsigned_64 := 0;
begin
   case key.V.Of_Type is
      when TYPE_NULL =>
         return 0;

      when TYPE_BOOLEAN =>
         if Key.V.Bool_Value then
            return 1;
         else
            return 2;
         end if;

      when TYPE_INTEGER =>
         declare
            U32 : constant U32_For_Long :=  To_U32_For_Long (Key.V.Int_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_FLOAT =>
         declare
            U32 : constant U32_For_Float :=  To_U32_For_Float (Key.V.Float_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_STRING =>
         if Key.V.Proxy = null then
            return 0;
         else
            return Hash (Key.V.Proxy.String_Value.all);
         end if;

      when TYPE_TIME =>
         declare
            U32 : constant U32_For_Long :=  To_U32_For_Long (Key.V.Time_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_WIDE_STRING =>
         if Key.V.Proxy = null then
            return 0;
         else
            return Hash (To_String (Key.V.Proxy.Wide_String_Value.all));
         end if;

      when TYPE_BEAN =>
         if Key.V.Proxy.Bean = null then
            return 0;
         end if;
         declare
            U32 : constant U32_For_Access :=  To_U32_For_Access (Key.V.Proxy.Bean.all'Access);
            Val : Unsigned_32 := U32 (U32'First);

            --  The loop is not executed if pointers are 32-bit wide.
            pragma Warnings (Off);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

   end case;

   --  Hash the 64-bit value into a 32-bit result that fits in Hash_Type.
   Value := (Value and 16#0ffffffff#) xor (Shift_Right (Value, 32));
   return Hash_Type (Value);
end EL.Objects.Hash;

-----------------------------------------------------------------------
--  EL.Objects.Hash -- Hash on an object
--  Copyright (C) 2010 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Strings.Hash;
with Ada.Characters.Conversions;
with Ada.Unchecked_Conversion;
with Interfaces;
with EL.Beans;
function EL.Objects.Hash (Key : in Object) return Ada.Containers.Hash_Type is
   use Ada.Containers;
   use Ada.Strings;
   use Ada.Characters.Conversions;
   use Interfaces;
   use EL.Beans;

   type Unsigned_32_Array is array (Natural range <>) of Unsigned_32;

   subtype U32_For_Float is Unsigned_32_Array (1 .. Long_Long_Float'Size / 32);

   subtype U32_For_Long is Unsigned_32_Array (1 .. Long_Long_Integer'Size / 32);

   subtype U32_For_Access is Unsigned_32_Array (1 .. Readonly_Bean_Access'Size / 32);

   --  Hash the integer and floats using 32-bit values.
   function To_U32_For_Long is new Ada.Unchecked_Conversion (Source => Long_Long_Integer,
                                                             Target => U32_For_Long);

   --  Likewise for floats.
   function To_U32_For_Float is new Ada.Unchecked_Conversion (Source => Long_Long_Float,
                                                              Target => U32_For_Float);

   --  Likewise for the bean pointer
   function To_U32_For_Access is new Ada.Unchecked_Conversion (Source => Readonly_Bean_Access,
                                                               Target => U32_For_Access);

begin
   case key.V.Of_Type is
      when TYPE_NULL =>
         return 0;

      when TYPE_BOOLEAN =>
         if Key.V.Bool_Value then
            return 1;
         else
            return 2;
         end if;

      when TYPE_INTEGER =>
         declare
            U32 : constant U32_For_Long :=  To_U32_For_Long (Key.V.Int_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_FLOAT =>
         declare
            U32 : constant U32_For_Float :=  To_U32_For_Float (Key.V.Float_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_STRING =>
         if Key.V.Proxy = null then
            return 0;
         else
            return Hash (Key.V.Proxy.String_Value.all);
         end if;

      when TYPE_TIME =>
         declare
            U32 : constant U32_For_Long :=  To_U32_For_Long (Key.V.Time_Value);
            Val : Unsigned_32 := U32 (U32'First);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

      when TYPE_WIDE_STRING =>
         if Key.V.Proxy = null then
            return 0;
         else
            return Hash (To_String (Key.V.Proxy.Wide_String_Value.all));
         end if;

      when TYPE_BEAN =>
         if Key.V.Proxy.Bean = null then
            return 0;
         end if;
         declare
            U32 : constant U32_For_Access :=  To_U32_For_Access (Key.V.Proxy.Bean.all'Access);
            Val : Unsigned_32 := U32 (U32'First);

            --  The loop is not executed if pointers are 32-bit wide.
            pragma Warnings (Off);
         begin
            for I in U32'First + 1 .. U32'Last loop
               Val := Val xor U32 (I);
            end loop;
            return Hash_Type (Val);
         end;

   end case;
end EL.Objects.Hash;

Remove unreachable code

Remove unreachable code


------------------------------------------------------------------------------
--                                                                          --
--                                P G A D A                                 --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--  Copyright (c) Samuel Tardieu 2000                                       --
--  All rights reserved.                                                    --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions      --
--  are met:                                                                --
--  1. Redistributions of source code must retain the above copyright       --
--     notice, this list of conditions and the following disclaimer.        --
--  2. Redistributions in binary form must reproduce the above copyright    --
--     notice, this list of conditions and the following disclaimer in      --
--     the documentation and/or other materials provided with the           --
--     distribution.                                                        --
--  3. Neither the name of Samuel Tardieu nor the names of its contributors --
--     may be used to endorse or promote products derived from this         --
--     software without specific prior written permission.                  --
--                                                                          --
--  THIS SOFTWARE IS PROVIDED BY SAMUEL TARDIEU AND CONTRIBUTORS ``AS       --
--  IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT          --
--  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS       --
--  FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL SAMUEL      --
--  TARDIEU OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,             --
--  INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES                --
--  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR      --
--  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)      --
--  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN               --
--  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR            --
--  OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,          --
--  EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.                      --
--                                                                          --
------------------------------------------------------------------------------

package PGAda is
  pragma Pure;
end PGAda;

------------------------------------------------------------------------------
--                                                                          --
--                                P G A D A                                 --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--  Copyright (c) Samuel Tardieu 2000                                       --
--  Copyright (c) coreland       2009                                       --
--  All rights reserved.                                                    --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions      --
--  are met:                                                                --
--  1. Redistributions of source code must retain the above copyright       --
--     notice, this list of conditions and the following disclaimer.        --
--  2. Redistributions in binary form must reproduce the above copyright    --
--     notice, this list of conditions and the following disclaimer in      --
--     the documentation and/or other materials provided with the           --
--     distribution.                                                        --
--  3. Neither the name of Samuel Tardieu nor the names of its contributors --
--     may be used to endorse or promote products derived from this         --
--     software without specific prior written permission.                  --
--                                                                          --
--  THIS SOFTWARE IS PROVIDED BY SAMUEL TARDIEU AND CONTRIBUTORS ``AS       --
--  IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT          --
--  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS       --
--  FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL SAMUEL      --
--  TARDIEU OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,             --
--  INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES                --
--  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR      --
--  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)      --
--  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN               --
--  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR            --
--  OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,          --
--  EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.                      --
--                                                                          --
------------------------------------------------------------------------------

package PGAda is
  pragma Pure;
end PGAda;

Update license on header.

Update license on header.


-----------------------------------------------------------------------
--  render -- Wiki rendering example
--  Copyright (C) 2015, 2016, 2020 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Text_IO;
with Ada.IO_Exceptions;
with Ada.Strings.Unbounded;
with Ada.Directories;

with GNAT.Command_Line;

with Wiki.Documents;
with Wiki.Parsers;
with Wiki.Filters.TOC;
with Wiki.Filters.Html;
with Wiki.Filters.Autolink;
with Wiki.Plugins.Templates;
with Wiki.Render.Html;
with Wiki.Render.Text;
with Wiki.Streams.Text_IO;
with Wiki.Streams.Html.Text_IO;

procedure Render is

   use GNAT.Command_Line;
   use Ada.Strings.Unbounded;

   procedure Usage;
   procedure Render_Html (Doc   : in out Wiki.Documents.Document;
                          Style : in Unbounded_String);
   procedure Render_Text (Doc : in out Wiki.Documents.Document);

   procedure Usage is
   begin
      Ada.Text_IO.Put_Line ("Render a wiki text file into HTML (default) or text");
      Ada.Text_IO.Put_Line ("Usage: render [-t] [-m] [-M] [-d] [-c] [-s style] {wiki-file}");
      Ada.Text_IO.Put_Line ("  -t        Render to text only");
      Ada.Text_IO.Put_Line ("  -m        Render a Markdown wiki content");
      Ada.Text_IO.Put_Line ("  -M        Render a Mediawiki wiki content");
      Ada.Text_IO.Put_Line ("  -d        Render a Dotclear wiki content");
      Ada.Text_IO.Put_Line ("  -g        Render a Google wiki content");
      Ada.Text_IO.Put_Line ("  -c        Render a Creole wiki content");
      Ada.Text_IO.Put_Line ("  -s style  Use the CSS style file");
   end Usage;

   procedure Render_Html (Doc   : in out Wiki.Documents.Document;
                          Style : in Unbounded_String) is
      Output   : aliased Wiki.Streams.Html.Text_IO.Html_Output_Stream;
      Renderer : aliased Wiki.Render.Html.Html_Renderer;
   begin
      if Length (Style) > 0 then
         Output.Start_Element ("html");
         Output.Start_Element ("head");
         Output.Start_Element ("link");
         Output.Write_Attribute ("type", "text/css");
         Output.Write_Attribute ("rel", "stylesheet");
         Output.Write_Attribute ("href", To_String (Style));
         Output.End_Element ("link");
         Output.End_Element ("head");
         Output.Start_Element ("body");
      end if;
      Renderer.Set_Output_Stream (Output'Unchecked_Access);
      Renderer.Set_Render_TOC (True);
      Renderer.Render (Doc);
      if Length (Style) > 0 then
         Output.End_Element ("body");
         Output.End_Element ("html");
      end if;
   end Render_Html;

   procedure Render_Text (Doc : in out Wiki.Documents.Document) is
      Output   : aliased Wiki.Streams.Text_IO.File_Output_Stream;
      Renderer : aliased Wiki.Render.Text.Text_Renderer;
   begin
      Renderer.Set_Output_Stream (Output'Unchecked_Access);
      Renderer.Render (Doc);
   end Render_Text;

   Count     : Natural := 0;
   Html_Mode : Boolean := True;
   Syntax    : Wiki.Wiki_Syntax := Wiki.SYNTAX_MARKDOWN;
   Style     : Unbounded_String;
begin
   loop
      case Getopt ("m M d c g t s:") is
         when 'm' =>
            Syntax := Wiki.SYNTAX_MARKDOWN;

         when 'M' =>
            Syntax := Wiki.SYNTAX_MEDIA_WIKI;

         when 'c' =>
            Syntax := Wiki.SYNTAX_CREOLE;

         when 'd' =>
            Syntax := Wiki.SYNTAX_DOTCLEAR;

         when 'g' =>
            Syntax := Wiki.SYNTAX_GOOGLE;

         when 't' =>
            Html_Mode := False;

         when 's' =>
            Style := To_Unbounded_String (Parameter);

         when others =>
            exit;
      end case;
   end loop;

   loop
      declare
         Name     : constant String := GNAT.Command_Line.Get_Argument;
         Input    : aliased Wiki.Streams.Text_IO.File_Input_Stream;
         Filter   : aliased Wiki.Filters.Html.Html_Filter_Type;
         Autolink : aliased Wiki.Filters.Autolink.Autolink_Filter;
         Template : aliased Wiki.Plugins.Templates.File_Template_Plugin;
         TOC      : aliased Wiki.Filters.TOC.TOC_Filter;
         Doc      : Wiki.Documents.Document;
         Engine   : Wiki.Parsers.Parser;
      begin
         if Name = "" then
            if Count = 0 then
               Usage;
            end if;
            return;
         end if;
         Count := Count + 1;

         Template.Set_Template_Path (Ada.Directories.Containing_Directory (Name));

         --  Open the file and parse it (assume UTF-8).
         Input.Open (Name, "WCEM=8");
         Engine.Set_Plugin_Factory (Template'Unchecked_Access);
         Engine.Add_Filter (TOC'Unchecked_Access);
         Engine.Add_Filter (Autolink'Unchecked_Access);
         Engine.Add_Filter (Filter'Unchecked_Access);
         Engine.Set_Syntax (Syntax);
         Engine.Parse (Input'Unchecked_Access, Doc);

         --  Render the document in text or HTML.
         if Html_Mode then
            Render_Html (Doc, Style);
         else
            Render_Text (Doc);
         end if;

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Ada.Text_IO.Put_Line ("Cannot read file '" & Name & "'");

      end;
   end loop;

exception
   when Invalid_Switch =>
      Ada.Text_IO.Put_Line ("Invalid option.");
      Usage;
end Render;

-----------------------------------------------------------------------
--  render -- Wiki rendering example
--  Copyright (C) 2015, 2016, 2020, 2021 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Text_IO;
with Ada.IO_Exceptions;
with Ada.Strings.Unbounded;
with Ada.Directories;

with GNAT.Command_Line;

with Wiki.Documents;
with Wiki.Parsers;
with Wiki.Filters.TOC;
with Wiki.Filters.Html;
with Wiki.Filters.Autolink;
with Wiki.Plugins.Templates;
with Wiki.Render.Html;
with Wiki.Render.Text;
with Wiki.Streams.Text_IO;
with Wiki.Streams.Html.Text_IO;

procedure Render is

   use GNAT.Command_Line;
   use Ada.Strings.Unbounded;

   procedure Usage;
   procedure Render_Html (Doc   : in out Wiki.Documents.Document;
                          Style : in Unbounded_String);
   procedure Render_Text (Doc : in out Wiki.Documents.Document);

   procedure Usage is
   begin
      Ada.Text_IO.Put_Line ("Render a wiki text file into HTML (default) or text");
      Ada.Text_IO.Put_Line ("Usage: render [-t] [-m] [-M] [-H] [-d] [-c] [-s style] {wiki-file}");
      Ada.Text_IO.Put_Line ("  -t        Render to text only");
      Ada.Text_IO.Put_Line ("  -m        Render a Markdown wiki content");
      Ada.Text_IO.Put_Line ("  -M        Render a Mediawiki wiki content");
      Ada.Text_IO.Put_Line ("  -H        Render a HTML wiki content");
      Ada.Text_IO.Put_Line ("  -d        Render a Dotclear wiki content");
      Ada.Text_IO.Put_Line ("  -g        Render a Google wiki content");
      Ada.Text_IO.Put_Line ("  -c        Render a Creole wiki content");
      Ada.Text_IO.Put_Line ("  -s style  Use the CSS style file");
   end Usage;

   procedure Render_Html (Doc   : in out Wiki.Documents.Document;
                          Style : in Unbounded_String) is
      Output   : aliased Wiki.Streams.Html.Text_IO.Html_Output_Stream;
      Renderer : aliased Wiki.Render.Html.Html_Renderer;
   begin
      if Length (Style) > 0 then
         Output.Start_Element ("html");
         Output.Start_Element ("head");
         Output.Start_Element ("link");
         Output.Write_Attribute ("type", "text/css");
         Output.Write_Attribute ("rel", "stylesheet");
         Output.Write_Attribute ("href", To_String (Style));
         Output.End_Element ("link");
         Output.End_Element ("head");
         Output.Start_Element ("body");
      end if;
      Renderer.Set_Output_Stream (Output'Unchecked_Access);
      Renderer.Set_Render_TOC (True);
      Renderer.Render (Doc);
      if Length (Style) > 0 then
         Output.End_Element ("body");
         Output.End_Element ("html");
      end if;
   end Render_Html;

   procedure Render_Text (Doc : in out Wiki.Documents.Document) is
      Output   : aliased Wiki.Streams.Text_IO.File_Output_Stream;
      Renderer : aliased Wiki.Render.Text.Text_Renderer;
   begin
      Renderer.Set_Output_Stream (Output'Unchecked_Access);
      Renderer.Render (Doc);
   end Render_Text;

   Count     : Natural := 0;
   Html_Mode : Boolean := True;
   Syntax    : Wiki.Wiki_Syntax := Wiki.SYNTAX_MARKDOWN;
   Style     : Unbounded_String;
begin
   loop
      case Getopt ("m M d c g t H s:") is
         when 'm' =>
            Syntax := Wiki.SYNTAX_MARKDOWN;

         when 'M' =>
            Syntax := Wiki.SYNTAX_MEDIA_WIKI;

         when 'c' =>
            Syntax := Wiki.SYNTAX_CREOLE;

         when 'd' =>
            Syntax := Wiki.SYNTAX_DOTCLEAR;

         when 'H' =>
            Syntax := Wiki.SYNTAX_HTML;

         when 'g' =>
            Syntax := Wiki.SYNTAX_GOOGLE;

         when 't' =>
            Html_Mode := False;

         when 's' =>
            Style := To_Unbounded_String (Parameter);

         when others =>
            exit;
      end case;
   end loop;

   loop
      declare
         Name     : constant String := GNAT.Command_Line.Get_Argument;
         Input    : aliased Wiki.Streams.Text_IO.File_Input_Stream;
         Filter   : aliased Wiki.Filters.Html.Html_Filter_Type;
         Autolink : aliased Wiki.Filters.Autolink.Autolink_Filter;
         Template : aliased Wiki.Plugins.Templates.File_Template_Plugin;
         TOC      : aliased Wiki.Filters.TOC.TOC_Filter;
         Doc      : Wiki.Documents.Document;
         Engine   : Wiki.Parsers.Parser;
      begin
         if Name = "" then
            if Count = 0 then
               Usage;
            end if;
            return;
         end if;
         Count := Count + 1;

         Template.Set_Template_Path (Ada.Directories.Containing_Directory (Name));

         --  Open the file and parse it (assume UTF-8).
         Input.Open (Name, "WCEM=8");
         Engine.Set_Plugin_Factory (Template'Unchecked_Access);
         Engine.Add_Filter (TOC'Unchecked_Access);
         Engine.Add_Filter (Autolink'Unchecked_Access);
         Engine.Add_Filter (Filter'Unchecked_Access);
         Engine.Set_Syntax (Syntax);
         Engine.Parse (Input'Unchecked_Access, Doc);

         --  Render the document in text or HTML.
         if Html_Mode then
            Render_Html (Doc, Style);
         else
            Render_Text (Doc);
         end if;

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Ada.Text_IO.Put_Line ("Cannot read file '" & Name & "'");

      end;
   end loop;

exception
   when Invalid_Switch =>
      Ada.Text_IO.Put_Line ("Invalid option.");
      Usage;
end Render;

Add -H option to parse some HTML content and produce a HTML cleaned result


-----------------------------------------------------------------------
--  ADO Dialects -- Driver support for basic SQL Generation
--  Copyright (C) 2010, 2011, 2012, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

package body ADO.Drivers.Dialects is

   --  --------------------
   --  Get the quote character to escape an identifier.
   --  --------------------
   function Get_Identifier_Quote (D : in Dialect) return Character is
      pragma Unreferenced (D);
   begin
      return '`';
   end Get_Identifier_Quote;

   --  ------------------------------
   --  Append the item in the buffer escaping some characters if necessary.
   --  The default implementation only escapes the single quote ' by doubling them.
   --  ------------------------------
   procedure Escape_Sql (D      : in Dialect;
                         Buffer : in out Unbounded_String;
                         Item   : in String) is
      pragma Unreferenced (D);

      C  : Character;
   begin
      for I in Item'Range loop
         C := Item (I);
         if C = ''' then
            Append (Buffer, ''');
         end if;
         Append (Buffer, C);
      end loop;
   end Escape_Sql;

   --  ------------------------------
   --  Append the item in the buffer escaping some characters if necessary
   --  ------------------------------
   procedure Escape_Sql (D      : in Dialect;
                         Buffer : in out Unbounded_String;
                         Item   : in ADO.Blob_Ref) is
      pragma Unreferenced (D);
      use type Ada.Streams.Stream_Element;

      C    : Ada.Streams.Stream_Element;
      Blob : constant ADO.Blob_Access := Item.Value;
   begin
      for I in Blob.Data'Range loop
         C := Blob.Data (I);
         case C is
            when Character'Pos (ASCII.NUL) =>
               Append (Buffer, '\');
               Append (Buffer, '0');

            when Character'Pos (ASCII.CR) =>
               Append (Buffer, '\');
               Append (Buffer, 'r');

            when Character'Pos (ASCII.LF) =>
               Append (Buffer, '\');
               Append (Buffer, 'n');

            when Character'Pos ('\') | Character'Pos (''') | Character'Pos ('"') =>
               Append (Buffer, '\');
               Append (Buffer, Character'Val (C));

            when others =>
               Append (Buffer, Character'Val (C));
         end case;
      end loop;
   end Escape_Sql;

end ADO.Drivers.Dialects;

-----------------------------------------------------------------------
--  ADO Dialects -- Driver support for basic SQL Generation
--  Copyright (C) 2010, 2011, 2012, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

package body ADO.Drivers.Dialects is

   --  --------------------
   --  Get the quote character to escape an identifier.
   --  --------------------
   function Get_Identifier_Quote (D : in Dialect) return Character is
      pragma Unreferenced (D);
   begin
      return '`';
   end Get_Identifier_Quote;

   --  ------------------------------
   --  Append the item in the buffer escaping some characters if necessary.
   --  The default implementation only escapes the single quote ' by doubling them.
   --  ------------------------------
   procedure Escape_Sql (D      : in Dialect;
                         Buffer : in out Unbounded_String;
                         Item   : in String) is
      pragma Unreferenced (D);

      C  : Character;
   begin
      for I in Item'Range loop
         C := Item (I);
         if C = ''' then
            Append (Buffer, ''');
         end if;
         Append (Buffer, C);
      end loop;
   end Escape_Sql;

   --  ------------------------------
   --  Append the item in the buffer escaping some characters if necessary
   --  ------------------------------
   procedure Escape_Sql (D      : in Dialect;
                         Buffer : in out Unbounded_String;
                         Item   : in ADO.Blob_Ref) is
      pragma Unreferenced (D);

      C    : Ada.Streams.Stream_Element;
      Blob : constant ADO.Blob_Access := Item.Value;
   begin
      for I in Blob.Data'Range loop
         C := Blob.Data (I);
         case C is
            when Character'Pos (ASCII.NUL) =>
               Append (Buffer, '\');
               Append (Buffer, '0');

            when Character'Pos (ASCII.CR) =>
               Append (Buffer, '\');
               Append (Buffer, 'r');

            when Character'Pos (ASCII.LF) =>
               Append (Buffer, '\');
               Append (Buffer, 'n');

            when Character'Pos ('\') | Character'Pos (''') | Character'Pos ('"') =>
               Append (Buffer, '\');
               Append (Buffer, Character'Val (C));

            when others =>
               Append (Buffer, Character'Val (C));
         end case;
      end loop;
   end Escape_Sql;

end ADO.Drivers.Dialects;

Remove unecessary use clause

Remove unecessary use clause