matreshka_league_21.0.0_0c8f4d47/source/sql/firebird/matreshka-internals-sql_drivers-firebird-queries.adb

------------------------------------------------------------------------------
--                                                                          --
--                            Matreshka Project                             --
--                                                                          --
--                           SQL Database Access                            --
--                                                                          --
--                        Runtime Library Component                         --
--                                                                          --
------------------------------------------------------------------------------
--                                                                          --
-- Copyright © 2011-2014, Vadim Godunko <vgodunko@gmail.com>                --
-- All rights reserved.                                                     --
--                                                                          --
-- Redistribution and use in source and binary forms, with or without       --
-- modification, are permitted provided that the following conditions       --
-- are met:                                                                 --
--                                                                          --
--  * Redistributions of source code must retain the above copyright        --
--    notice, this list of conditions and the following disclaimer.         --
--                                                                          --
--  * 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.  --
--                                                                          --
--  * Neither the name of the Vadim Godunko, IE 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 THE COPYRIGHT HOLDERS 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 THE COPYRIGHT     --
-- HOLDER 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.             --
--                                                                          --
------------------------------------------------------------------------------
--  $Revision: 4467 $ $Date: 2014-02-19 22:35:33 +0400 (Ср, 19 фев 2014) $
------------------------------------------------------------------------------
with Ada.Numerics.Discrete_Random;

with Matreshka.Internals.SQL_Drivers.Firebird.Fields;
with Matreshka.Internals.SQL_Parameter_Rewriters.Firebird;

package body Matreshka.Internals.SQL_Drivers.Firebird.Queries is

   SQL_Dialect : constant Isc_Db_Dialect := 3;

   Rewriter : SQL_Parameter_Rewriters.Firebird.Firebird_Parameter_Rewriter;

   function Random_String (Length : Interfaces.C.size_t) return Isc_String;

   ----------------
   -- Bind_Value --
   ----------------

   overriding procedure Bind_Value
    (Self      : not null access Firebird_Query;
     Name      : League.Strings.Universal_String;
     Value     : League.Holders.Holder;
     Direction : SQL.Parameter_Directions)
   is
      pragma Unreferenced (Direction);

   begin
      Self.Parameters.Set_Value (Name, Value);
   end Bind_Value;

   -----------------
   -- Bound_Value --
   -----------------

   overriding function Bound_Value
    (Self : not null access Firebird_Query;
     Name : League.Strings.Universal_String) return League.Holders.Holder
   is
      pragma Unreferenced (Self);
      pragma Unreferenced (Name);

   begin
      return League.Holders.Empty_Holder;
   end Bound_Value;

   -------------------
   -- Error_Message --
   -------------------

   overriding function Error_Message
    (Self : not null access Firebird_Query)
       return League.Strings.Universal_String is
   begin
      return Self.Error;
   end Error_Message;

   -------------
   -- Execute --
   -------------

   overriding function Execute
    (Self : not null access Firebird_Query) return Boolean
   is
      Value  : League.Holders.Holder;
      Result : Isc_Result_Code;

   begin
      --  Prepare parameter values.

      for Idx in 1 .. Self.Parameters.Number_Of_Positional loop
         Value := Self.Parameters.Value (Idx);
         Self.Sql_Params.Fields.Element
          (Isc_Valid_Field_Index (Idx)).Value (Value);
      end loop;

      Self.Sql_Record.Clear_Values;

      if Self.Sql_Type = DDL then
         return Self.Execute_Immediate;
      end if;

      case Self.Sql_Type is
         when Simple_Select | Select_For_Update =>
            Result := Isc_Dsql_Execute
              (Self.Status'Access, Databases.Firebird_Database'Class
                 (Self.Database.all).Transaction_Handle,
               Self.Stmt_Handle'Access, Sql_Dialect, Self.Sql_Params.Sqlda);

            if Result > 0 then
               Self.Error := Get_Error (Self.Status'Access);
               return False;
            end if;

            Self.State := Active;
            Self.Sql_Record.Clear_Values;

         when Exec_Procedure =>
            Result := Isc_Dsql_Execute2
              (Self.Status'Access, Databases.Firebird_Database'Class
                 (Self.Database.all).Transaction_Handle,
               Self.Stmt_Handle'Access, Sql_Dialect,
               Self.Sql_Params.Sqlda, Self.Sql_Record.Sqlda);

            if Self.Status (1) = 1
              and then Self.Status (2) > 0
            then
               Self.Error := Get_Error (Self.Status'Access);
               return False;
            end if;

         when Commit | Rollback =>
            return False;

         when Unknown       | Insert            | Update      |
              Delete        | DDL               | Get_Segment |
              Put_Segment   | Start_Transaction |
              Set_Generator | Save_Point_Operation =>

            Result := Isc_Dsql_Execute
              (Self.Status'Access, Databases.Firebird_Database'Class
                 (Self.Database.all).Transaction_Handle,
               Self.Stmt_Handle'Access, Sql_Dialect, Self.Sql_Params.Sqlda);

            if Result > 0 then
               Self.Error := Get_Error (Self.Status'Access);
               return False;
            end if;
      end case;

      Self.Is_Valid := False;
      return True;

   exception
      when others =>
         Self.Free_Handle;

         return False;
   end Execute;

   -----------------------
   -- Execute_Immediate --
   -----------------------

   function Execute_Immediate
    (Self : not null access Firebird_Query) return Boolean
   is
      Result : Isc_Result_Code;

   begin
      Self.Free_Handle;

      declare
         Statement : constant Isc_String := To_Isc_String (Self.Sql_Text);

      begin
         Result :=
           Isc_Dsql_Execute_Immediate
            (Self.Status'Access,
             Databases.Firebird_Database'Class
              (Self.Database.all).Database_Handle,
             Databases.Firebird_Database'Class
              (Self.Database.all).Transaction_Handle,
             Statement'Length, Statement,
             Sql_Dialect,
             Self.Sql_Params.Sqlda);
      end;

      if Result > 0 then
         Self.Error := Get_Error (Self.Status'Access);

         return False;
      end if;

      return True;
   end Execute_Immediate;

   ------------
   -- Finish --
   ------------

   overriding procedure Finish (Self : not null access Firebird_Query) is
      use type Isc_Long;

      EC : constant Isc_Result_Codes (1 .. 2)
        := (Isc_Bad_Stmt_Handle, Isc_Dsql_Cursor_Close_Err);

      Result : Isc_Result_Code;
      pragma Warnings (Off, Result);

   begin
      if Self.Stmt_Handle /= Null_Isc_Stmt_Handle then
         case Self.Sql_Type is
            when Simple_Select | Select_For_Update =>
               Result :=
                 Isc_Dsql_Free_Statement
                  (Self.Status'Access, Self.Stmt_Handle'Access, Isc_Sql_Close);

               if Self.Status (1) = 1
                 and then Self.Status (2) > 0
                 and then not Check_For_Error (Self.Status'Access, EC)
               then
                  Self.Error := Get_Error (Self.Status'Access);
               end if;

            when others =>
               Self.Free_Handle;
         end case;
      end if;

      Self.State := Inactive;
   end Finish;

   -----------------
   -- Free_Handle --
   -----------------

   procedure Free_Handle (Self : not null access Firebird_Query) is
      use type Isc_Long;

      Result : Isc_Result_Code;

   begin
      Self.Sql_Record.Count (0);

      if Self.Stmt_Handle /= Null_Isc_Stmt_Handle then
         Result :=
           Isc_Dsql_Free_Statement
            (Self.Status'Access, Self.Stmt_Handle'Access, Isc_Sql_Drop);

         Self.Stmt_Handle := Null_Isc_Stmt_Handle;
         Self.State       := Inactive;

         if Self.Status (1) = 1
           and then Result > 0
           and then Result /= Isc_Bad_Stmt_Handle
         then
            Self.Error := Get_Error (Self.Status'Access);
         end if;
      end if;
   end Free_Handle;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize
    (Self     : not null access Firebird_Query'Class;
     Database : not null access Databases.Firebird_Database'Class;
     Codec    : access League.Text_Codecs.Text_Codec;
     Utf      : Boolean) is
   begin
      Self.Sql_Record.Codec := Codec;
      Self.Sql_Params.Codec := Codec;
      Self.Sql_Record.Utf   := Utf;
      Self.Sql_Params.Utf   := Utf;
      Self.Is_Valid := False;

      SQL_Drivers.Initialize (Self, Database_Access (Database));
   end Initialize;

   ----------------
   -- Invalidate --
   ----------------

   overriding procedure Invalidate (Self : not null access Firebird_Query) is
   begin
      Self.Finish;

      if Self.Stmt_Handle /= Null_Isc_Stmt_Handle then
         Self.Free_Handle;
      end if;

      Self.Sql_Params.Finalize;
      Self.Sql_Record.Finalize;

      --  Call Invalidate of parent tagged type.

      Abstract_Query (Self.all).Invalidate;
   end Invalidate;

   ---------------
   -- Is_Active --
   ---------------

   overriding function Is_Active
    (Self : not null access Firebird_Query) return Boolean is
   begin
      return Self.State = Active;
   end Is_Active;

   --------------
   -- Is_Valid --
   --------------

   overriding function Is_Valid
    (Self : not null access Firebird_Query) return Boolean is
   begin
      return Self.Is_Valid;
   end Is_Valid;

   ----------
   -- Next --
   ----------

   overriding function Next
    (Self : not null access Firebird_Query) return Boolean
   is
      use type Isc_Long;

      Result : Isc_Result_Code;

   begin
      Result :=
        Isc_Dsql_Fetch
         (Self.Status'Access,
          Self.Stmt_Handle'Access,
          Sql_Dialect,
          Self.Sql_Record.Sqlda);

      if Result > 0 then
         if Result = 100 then
            Self.Is_Valid := False;
            return False;

         else
            declare
               EC : constant Isc_Result_Codes (1 .. 1)
                 := (others => Isc_Dsql_Cursor_Err);

            begin
               if Check_For_Error (Self.Status'Access, EC) then
                  Self.Is_Valid := False;
                  return False;

               else
                  Self.Error := Get_Error (Self.Status'Access);
                  Self.Finish;
                  Self.Is_Valid := False;

                  return False;
               end if;
            end;
         end if;

      else
         Self.Is_Valid := True;
         return True;
      end if;
   end Next;

   -------------
   -- Prepare --
   -------------

   overriding function Prepare
    (Self  : not null access Firebird_Query;
     Query : League.Strings.Universal_String) return Boolean
   is
      use type Records.Isc_Sqlda_Access;

      Result : Isc_Result_Code;
      Field  : Fields.Field_Access;

   begin
      Self.Finish;

      Rewriter.Rewrite (Query, Self.Sql_Text, Self.Parameters);
      Self.Sql_Params.Count
       (Isc_Field_Index (Self.Parameters.Number_Of_Positional));

      --  add params

      for Idx
        in 1 .. Isc_Field_Index (Self.Parameters.Number_Of_Positional)
      loop
         Field := Self.Sql_Params.Fields.Element (Idx);
         Field.Set_Null (True);
         Field.Sqlvar.Sqltype := Isc_Type_Empty;
      end loop;

      Result :=
        Isc_Dsql_Alloc_Statement2
         (Self.Status'Access,
          Databases.Firebird_Database'Class
           (Self.Database.all).Database_Handle,
          Self.Stmt_Handle'Access);

      if Result > 0 then
         Self.Error := Get_Error (Self.Status'Access);

         return False;
      end if;

      Self.Sql_Record.Count (1);

      declare
         Statement : constant Isc_String := To_Isc_String (Self.Sql_Text);

      begin
         Result :=
           Isc_Dsql_Prepare
            (Self.Status'Access,
             Databases.Firebird_Database'Class
              (Self.Database.all).Transaction_Handle,
             Self.Stmt_Handle'Access, 0, Statement,
             Sql_Dialect,
             Self.Sql_Record.Sqlda);

         if Result > 0 then
            Self.Error := Get_Error (Self.Status'Access);

            return False;
         end if;
      end;

      --  Get the type of the statement

      declare
         use type Interfaces.C.char;

         Len    : Isc_Long;
         Buffer : aliased Isc_String := (1 .. 9 => Interfaces.C.nul);
         Item   : Isc_String (1 .. 1);

      begin
         Item (1) := Isc_Info_Sql_Stmt_Type;

         Result :=
           Isc_Dsql_Sql_Info
            (Self.Status'Access,
             Self.Stmt_Handle'Access,
             1,
             Item,
             8,
             Buffer'Access);

         if Result > 0 then
            Self.Error := Get_Error (Self.Status'Access);

            return False;
         end if;

         if Buffer (1) /= Isc_Info_Sql_Stmt_Type then
            return False;
         end if;

         Len := Isc_Vax_Integer (Buffer (2 .. 4), 2);

         Self.Sql_Type :=
           Query_Sql_Type'Val
            (Isc_Vax_Integer (Buffer (4 .. 9), Isc_Short (Len)));
      end;

      if Self.Sql_Type = Select_For_Update then
         Self.Cursor_Name := Random_String (10);

         Result :=
           Isc_Dsql_Set_Cursor_Name
            (Self.Status'Access, Self.Stmt_Handle'Access, Self.Cursor_Name, 0);

         if Result > 0 then
            Self.Error := Get_Error (Self.Status'Access);

            return False;
         end if;
      end if;

      --  Done getting the type

      case Self.Sql_Type is
         when Get_Segment | Put_Segment | Start_Transaction =>
            Self.Free_Handle;

            return False;

         when Insert
                | Update
                | Delete
                | Simple_Select
                | Select_For_Update
                | Exec_Procedure
         =>
            if Self.Sql_Params.Sqlda /= null then
               Result :=
                 Isc_Dsql_Describe_Bind
                  (Self.Status'Access,
                   Self.Stmt_Handle'Access,
                   Sql_Dialect,
                   Self.Sql_Params.Sqlda);

               if Result > 0 then
                  Self.Error := Get_Error (Self.Status'Access);

                  return False;
               end if;
            end if;

            Self.Sql_Params.Init;

            case Self.Sql_Type is
               when Simple_Select | Select_For_Update | Exec_Procedure =>
                  if Self.Sql_Record.Sqlda.Sqld
                       > Self.Sql_Record.Sqlda.Sqln
                  then
                     Self.Sql_Record.Count (Self.Sql_Record.Sqlda.Sqld);

                     Result :=
                       Isc_Dsql_Describe
                        (Self.Status'Access,
                         Self.Stmt_Handle'Access,
                         Sql_Dialect,
                         Self.Sql_Record.Sqlda);

                     if Result > 0 then
                        Self.Error := Get_Error (Self.Status'Access);

                        return False;
                     end if;
                  else
                     if Self.Sql_Record.Sqlda.Sqld = 0 then
                        Self.Sql_Record.Count (0);
                     end if;
                  end if;

                  Self.Sql_Record.Init;

               when Unknown
                      | Insert
                      | Update
                      | Delete
                      | DDL
                      | Get_Segment
                      | Put_Segment
                      | Start_Transaction
                      | Commit
                      | Rollback
                      | Set_Generator
                      | Save_Point_Operation
               =>
                  Self.Sql_Record.Count (0);
            end case;

         when Unknown
                | DDL
                | Commit
                | Rollback
                | Set_Generator
                | Save_Point_Operation
         =>
            null;
      end case;

      return True;

   exception
      when others =>
         if Self.Stmt_Handle /= Null_Isc_Stmt_Handle then
            Self.Free_Handle;
         end if;

         return False;
   end Prepare;

   -------------------
   -- Random_String --
   -------------------

   function Random_String (Length : Interfaces.C.size_t) return Isc_String is
      use type Interfaces.C.size_t;
      use type Interfaces.C.char;

      subtype A_Z is Interfaces.C.char range '0' .. 'z';

      package Rand is new Ada.Numerics.Discrete_Random (A_Z);

      Gen  : Rand.Generator;
      Str  : Isc_String (1 .. Length);
      Char : Interfaces.C.char;

   begin
      Rand.Reset (Gen);

      for Idx in 1 .. Length - 1 loop
         loop
            Char := Rand.Random (Gen);

            exit when
             (Char >= '0' and then  Char <= '9')
                or else (Char >= 'A' and then Char <= 'Z')
                or else (Char >= 'a' and then Char <= 'z');
         end loop;

         Str (Idx) := Char;
      end loop;

      Str (Str'Last) := Interfaces.C.nul;

      return Str;
   end Random_String;

   -----------
   -- Value --
   -----------

   overriding function Value
    (Self  : not null access Firebird_Query;
     Index : Positive) return League.Holders.Holder is
   begin
      return
        Self.Sql_Record.Fields.Element (Isc_Valid_Field_Index (Index)).Value;
   end Value;

end Matreshka.Internals.SQL_Drivers.Firebird.Queries;