From 597bf53d7a4a0d5eb82f21cb13969e9c2becd991 Mon Sep 17 00:00:00 2001 From: Ali Bendriss Date: Mon, 23 Mar 2009 11:25:55 +0000 Subject: [PATCH] complete rework of the library. The API as changed as well. The package pool contain a way to work with a concurent program. --- Makefile | 15 +- README | 8 +- backlit.gpr | 10 +- demo/demo.grp | 4 +- demo/simple_demo.adb | 409 +++++------ src/backlit-client-statment.adb | 420 ----------- src/backlit-client.adb | 336 --------- src/backlit-client.ads | 225 ------ src/backlit-postgres-pool.adb | 517 ++++++++++++++ src/backlit-postgres-pool.ads | 171 +++++ src/backlit-postgres.adb | 782 +++++++++++++++++++++ ...it-client-statment.ads => backlit-postgres.ads} | 311 ++++++-- src/backlit-utils.adb | 72 ++ src/backlit-utils.ads | 21 + src/backlit.ads | 2 +- 15 files changed, 2060 insertions(+), 1243 deletions(-) rewrite demo/simple_demo.adb (62%) delete mode 100644 src/backlit-client-statment.adb delete mode 100644 src/backlit-client.adb delete mode 100644 src/backlit-client.ads create mode 100644 src/backlit-postgres-pool.adb create mode 100644 src/backlit-postgres-pool.ads create mode 100644 src/backlit-postgres.adb rename src/{backlit-client-statment.ads => backlit-postgres.ads} (53%) create mode 100644 src/backlit-utils.adb create mode 100644 src/backlit-utils.ads diff --git a/Makefile b/Makefile index acb0715..9a82f33 100644 --- a/Makefile +++ b/Makefile @@ -1,24 +1,25 @@ CC = gcc GNATMAKE = gnatmake +GNATCLEAN = gnatclean RM = rm -f MKDIR = mkdir -p default: build clean: - $(RM) -r ali - $(RM) -r lib - $(RM) -r obj - $(RM) -r src-interface + $(GNATCLEAN) -P backlit.gpr +# $(RM) -r adalib adainclude +# $(RM) -r lib +# $(RM) -r obj rep: - $(MKDIR) ali lib obj src-interface + $(MKDIR) adainclude adalib obj lib build: rep $(GNATMAKE) -P backlit.gpr -check: rep +check: clean rep $(GNATMAKE) -gnatv -P backlit.gpr -style: rep +style: clean rep $(GNATMAKE) -gnaty -P backlit.gpr diff --git a/README b/README index 5dd7aad..1b2680e 100644 --- a/README +++ b/README @@ -8,9 +8,15 @@ to receive the results of these queries. backlit-thin.ads is a complete and direct mapping of the libpq C interface, but you may prefer to use the others package which are more Ada like. Please check the demo directory for some examples of the library usage. + +An experimental package offering a pool of connection is provided. +And may be used in concurent programming. For the moment the library is only able to process -text-format parameters. Binary format parameters will be added in the future. +text-format parameters. + +Fututure release may include aa way to use the bind parameter even inside a +transaction. Rather than using the transaction only inside a simple SQL query. Contact : Ali Bendriss diff --git a/backlit.gpr b/backlit.gpr index 00b5ca2..8d7e3f1 100644 --- a/backlit.gpr +++ b/backlit.gpr @@ -11,7 +11,7 @@ project Backlit is -- Library_Auto_Init := "False"; - for Library_Src_Dir use "src-interface"; + for Library_Src_Dir use "adainclude"; -- The sources of the Interface Units of the library, -- necessary to an Ada client of the library, -- will be copied to the designated directory, @@ -22,13 +22,13 @@ project Backlit is for Library_Interface use ("backlit", "backlit.thin", - "backlit.client", - "backlit.client.statment"); + "backlit.postgres", + "backlit.postgres.pool"); -- Attribute Library_Interface has a non empty string list value, -- each string in the list designating a unit contained in an immediate -- source of the project file. - for Library_Ali_Dir use "ali"; + for Library_Ali_Dir use "adalib"; -- for Library_Kind use "static"; for Library_Kind use "dynamic"; @@ -39,7 +39,7 @@ project Backlit is package Compiler is for Default_Switches ("ada") use - ("-O", "-gnatf", "-gnato", "-fstack-check", + ("-O2", "-gnatf", "-gnato", "-fstack-check", "-gnatE", "-gnat05", "-gnata"); end Compiler; diff --git a/demo/demo.grp b/demo/demo.grp index 896294b..a4f32e2 100644 --- a/demo/demo.grp +++ b/demo/demo.grp @@ -12,7 +12,7 @@ project Demo is when "Debug" => -- for Default_Switches ("ada") use ("-g", "-gnato", "-fstack-check", "-gnatVa", "-O3", "-gnat05", "-gnata"); - for Default_Switches ("ada") use ("-g", "-gnat05"); + for Default_Switches ("ada") use ("-gnato", "-fstack-check", "-gnatVa", "-O3", "-gnat05", "-gnata"); when "Production" => for Default_Switches ("ada") use ("-O2"); @@ -25,7 +25,7 @@ project Demo is for Source_Dirs use (".//**"); for Object_Dir use "obj"; for Exec_Dir use "build"; - for Main use ("simple_demo.adb"); + for Main use ("simple_demo.adb", "pool_demo.adb"); for Library_Dir use "lib"; for Library_Ali_Dir use "ali"; -- for Library_Kind use "dynamic"; diff --git a/demo/simple_demo.adb b/demo/simple_demo.adb dissimilarity index 62% index f1bd380..b4a1ece 100644 --- a/demo/simple_demo.adb +++ b/demo/simple_demo.adb @@ -1,203 +1,206 @@ -with Ada.Text_IO; use Ada.Text_IO; -with Backlit.Client; use Backlit.Client; -with Backlit.client.statment; use Backlit.client.statment; - -procedure Simple_Demo is - - use Backlit; - - C : Connection_Object_Type; - --S : Backlit.client.Statment.Statment_Object_Type; - - procedure Create_Film_Table - (C :Connection_Object_Type) - is - S : Backlit.client.Statment.Statment_Object_Type; - begin - declare - S : Backlit.client.Statment.Statment_Object_Type; - begin - -- the command can be split in more than one line, in fact - -- the command will be executed as a single command. - -- check the documentation for more info. - S.Append_Command ("DROP TABLE films;"); - S.Exec (C); - exception - when Backlit.Error => - Put_Line (Backlit.client.Statment.Error_Message (S)); - end; - S.Append_Command ("CREATE TABLE films ("); - S.Append_Command (" code char(5) CONSTRAINT firstkey PRIMARY KEY,"); - S.Append_Command (" title varchar(40) NOT NULL,"); - S.Append_Command (" did integer NOT NULL,"); - S.Append_Command (" date_prod date,"); - S.Append_Command (" kind varchar(10),"); - S.Append_Command (" len interval hour to minute);"); - S.Exec (C); - Put ("Create_Film_Table :"); - if S.Status = COMMAND_OK then - Put_Line ("Ok"); - else - Put_Line ("Failed"); - end if; - exception - when Backlit.Error => - Put_Line (Backlit.client.Statment.Error_Message (S)); - end Create_Film_Table; - - procedure Insert_Value_1 (C :Connection_Object_Type) - is - S : Backlit.client.Statment.Statment_Object_Type; - begin - S.Append_Command ("INSERT INTO films"); - S.Append_Command ("(code, title, did,date_prod, kind, len)"); - S.Append_Command ("VALUES (1, 'test1', 1, '12-24-2008', 'test', '1h35m');"); - S.Exec (C); - exception - when Backlit.Error => - Put_Line (Backlit.client.Statment.Error_Message (S)); - end Insert_Value_1; - - procedure Prepare_1 (C :Connection_Object_Type) - is - S : Backlit.client.Statment.Statment_Object_Type; - begin - Put_Line ("prepare_procedure :"); - S.Append_Command ("INSERT INTO films"); - S.Append_Command ("(code, title, did,date_prod, kind, len)"); - S.Append_Command ("VALUES ($1, $2, $3, $4, $5, $6);"); - S.Prepare (C, "films_insert", 6); - exception - when Backlit.Error => - Put_Line (Backlit.client.Statment.Error_Message (S)); - end Prepare_1; - - procedure Insert_Prepared_1 - (C : Connection_Object_Type) - is - S : Backlit.client.Statment.Statment_Object_Type; - Count : Natural := 0; - begin - for I in 1 .. 9 loop - Count := Count + 1; - Put_Line ("=> code :" & Count'Img); - S.Bind_Parameter (6, "2h45m"); - S.Bind_Parameter (4, "01-30-2007"); - S.Bind_Parameter (2, "test" & Count'Img); - S.Bind_Parameter (3, Count'img); - S.Bind_Parameter (5, "test" & Count'Img); - S.Bind_Parameter (1, Count'Img); - -- The bind parameter can be put in any order - -- thanks to Ada.Containers.Indefinite_Ordered_Maps. - S.Exec (C,"films_insert"); - -- we insert an error here : - if Count = 8 then - Put_Line ("=> We insert an error here : duplicate key"); - Count := 7; - end if; - end loop; - exception - when Backlit.Error => - Put_Line (Backlit.client.Statment.Error_Message (S)); - end Insert_Prepared_1; - - procedure Insert_Value_2 (C :Connection_Object_Type) - is - S : Backlit.client.Statment.Statment_Object_Type; - Code : Natural := 20; - begin - Put_Line ("=> We insert directly some value with code 20 named test 20"); - S.Append_Command ("INSERT INTO films"); - S.Append_Command ("(code, title, did,date_prod, kind, len)"); - S.Append_Command ("VALUES ($1, $2, $3, $4, $5, $6);"); - S.Bind_Parameter (6, "2h45m"); - S.Bind_Parameter (4, "01-30-2007"); - S.Bind_Parameter (2, "test 20"); - S.Bind_Parameter (3, "3"); - S.Bind_Parameter (5, "test 20"); - S.Bind_Parameter (1, Code'Img); - -- The bind parameter can be put in any order - -- thanks to Ada.Containers.Indefinite_Ordered_Maps. - S.Exec (C); - exception - when Backlit.Error => - Put_Line (Backlit.client.Statment.Error_Message (S)); - end Insert_Value_2; - - procedure select_1 (C :Connection_Object_Type) - is - S : Backlit.client.Statment.Statment_Object_Type; - NT : Tuples_Type; - NF : Fields_Type; - begin - S.Append_Command ("SELECT code, title FROM films"); - S.Append_Command ("WHERE did=$1 OR date_prod > $2;"); - S.Bind_Parameter (1, "1"); - S.Bind_Parameter (2, "01-30-2000"); - S.Exec (C); - if S.Status = TUPLES_OK then - NT := S.N_Tuples; - Put_Line ("number of tuples :" & NT'Img); - NF := S.N_Fields; - Put_Line ("number of fields :"& NF'Img); - end if; - for I in 0 .. NT - 1 loop - Put ('|'); - for J in 0 .. NF - 1 loop - Put (S.Get_Value (I, J)); - Put ('|'); - if J = NF - 1 then - New_Line; - end if; - end loop; - end loop; - - exception - when Backlit.Error => - Put_Line (Backlit.client.Statment.Error_Message (S)); - end Select_1; - - -begin - --------------------------- - -- Database Connection -- - --------------------------- - ---- there is two way to set the connection - ---- but you can't use both on the same connection. - - -- C.Set_Host_Name ("localhost"); - -- C.Set_Host_Address ("127.0.0.1"); - -- C.Set_User_Name ("postgres"); - -- C.Set_db_Name ("template1"); - -- C.Set_User_Password ("secret"); - -- C.Set_Port ("5432"); - ---- and then make a server connection - -- C.Connect; - - -- The other way is to pass the connection parameter - -- as a string at the connection time - C.Connect ("host=localhost user=postgres dbname=template1"); - - ------------------------- - -- command execution -- - ------------------------- - if Is_Connected (C) then - Put_Line ("Connected!"); - end if; - -- you may create your own connection procedure - -- giving the user different try for the password - -- for example. - -- check the Needs_Password and Used_Password functions. - - Create_Film_Table (C); - -- Insert_Value_1 (C); - Prepare_1 (C); - Insert_Prepared_1 (C); - Insert_Value_2 (C); - Select_1 (C); - if Is_Connected (C) then - Put_Line ("Not Connected!"); - end if; - New_Line; - -end Simple_Demo; +with Ada.Text_IO; use Ada.Text_IO; +with Backlit.Postgres; use Backlit.Postgres; + +procedure Simple_Demo is + + use Backlit; + + D,D1,D2 : DBD_Type; + + procedure Create_Film_Table + (D : in out DBD_Type) + is + R : Result_Type; + begin + Put_Line ("Create_Film_Table"); + --declare + -- D : DBD_Type; + begin + -- the command can be split in more than one line, in fact + -- the command will be executed as a single command. + -- check the documentation for more info. + D.Append_Command ("DROP TABLE films;"); + D.Exec (R); + exception + when Backlit.Query_Error => + Put_Line (Error_Message (R)); + end; + D.Append_Command ("CREATE TABLE films ("); + D.Append_Command (" code char(5) CONSTRAINT firstkey PRIMARY KEY,"); + D.Append_Command (" title varchar(40) NOT NULL,"); + D.Append_Command (" did integer NOT NULL,"); + D.Append_Command (" date_prod date,"); + D.Append_Command (" kind varchar(10),"); + D.Append_Command (" len interval hour to minute);"); + D.Exec (R); + Put ("Create_Film_Table :"); + if R.Status = COMMAND_OK then + Put_Line ("Ok"); + else + Put_Line ("Failed"); + end if; + exception + when Backlit.Query_Error => + Put_Line (Error_Message (R)); + end Create_Film_Table; + + procedure Insert_Value_1 (D : in out DBD_Type) + is + R : Result_Type; + begin + D.Append_Command ("INSERT INTO films"); + D.Append_Command ("(code, title, did,date_prod, kind, len)"); + D.Append_Command ("VALUES (1, 'test1', 1, '12-24-2008', 'test', '1h35m');"); + D.Exec (R); + exception + when Backlit.Query_Error => + Put_Line (Error_Message (R)); + end Insert_Value_1; + + procedure Prepare_1 (D : in out DBD_Type) + is + begin + Put_Line ("prepare_procedure :"); + D.Append_Command ("INSERT INTO films"); + D.Append_Command ("(code, title, did,date_prod, kind, len)"); + D.Append_Command ("VALUES ($1, $2, $3, $4, $5, $6);"); + D.Prepare ("films_insert", 6); + end Prepare_1; + + procedure Insert_Prepared_1 + (D : in out DBD_Type) + is + R : Result_Type; + Count : Natural := 0; + begin + for I in 1 .. 9 loop + Count := Count + 1; + Put_Line ("=> code :" & Count'Img); + D.Bind_Parameter (6, "2h45m"); + D.Bind_Parameter (4, "01-30-2007"); + D.Bind_Parameter (2, "test" & Count'Img); + D.Bind_Parameter (3, Count'img); + D.Bind_Parameter (5, "test" & Count'Img); + D.Bind_Parameter (1, Count'Img); + -- The bind parameter can be put in any order + -- thanks to Ada.Containers.Indefinite_Ordered_Maps. + D.Exec (R,"films_insert"); + -- we insert an error here : + if Count = 8 then + Put_Line ("=> We insert an error here : duplicate key"); + Count := 7; + end if; + end loop; + exception + when Backlit.Query_Error => + Put_Line (Error_Message (R)); + end Insert_Prepared_1; + + procedure Insert_Value_2 (D : in out DBD_Type) + is + R : Result_Type; + Code : Natural := 20; + begin + Put_Line ("=> We insert directly some value with code 20 named test 20"); + D.Append_Command ("INSERT INTO films"); + D.Append_Command ("(code, title, did,date_prod, kind, len)"); + D.Append_Command ("VALUES ($1, $2, $3, $4, $5, $6);"); + D.Bind_Parameter (6, "2h45m"); + D.Bind_Parameter (4, "01-30-2007"); + D.Bind_Parameter (2, "test 20"); + D.Bind_Parameter (3, "3"); + D.Bind_Parameter (5, "test 20"); + D.Bind_Parameter (1, Code'Img); + -- The bind parameter can be put in any order + -- thanks to Ada.Containers.Indefinite_Ordered_Maps. + D.Exec (R); + exception + when Backlit.Query_Error => + Put_Line (Error_Message (R)); + end Insert_Value_2; + + procedure select_1 (D : in out DBD_Type) + is + R : Result_Type; + NT : Tuples_Type; + NF : Fields_Type; + begin + D.Append_Command ("SELECT code, title FROM films"); + D.Append_Command ("WHERE did=$1 OR date_prod > $2;"); + D.Bind_Parameter (1, "1"); + D.Bind_Parameter (2, "01-30-2000"); + D.Exec (R); + if R.Status = TUPLES_OK then + NT := R.N_Tuples; + Put_Line ("number of tuples :" & NT'Img); + NF := R.N_Fields; + Put_Line ("number of fields :"& NF'Img); + end if; + for I in First_Tuples (R) .. Last_Tuples (R) loop + Put ('|'); + for J in First_Fields (R) .. Last_Fields (R) loop + Put (R.Get_Value (I, J)); + Put ('|'); + if J = NF - 1 then + New_Line; + end if; + end loop; + end loop; + + exception + when Backlit.Query_Error => + Put_Line (Error_Message (R)); + end Select_1; + + +begin + --------------------------- + -- Database Connection -- + --------------------------- + ---- there is two way to set the connection + ---- but you can't use both on the same connection. + + -- D.Set_Host_Name ("localhost"); + -- D.Set_Host_Address ("127.0.0.1"); + -- D.Set_User_Name ("postgres"); + -- D.Set_db_Name ("template1"); + -- D.Set_User_Password ("secret"); + -- D.Set_Port ("5432"); + ---- and then make a server connection + -- D.Connect; + + -- The other way is to pass the connection parameter + -- as a string at the connection time + Put_Line ("stating connection..."); + D.Connect ("host=localhost user=postgres dbname=template1"); + + ------------------------- + -- command execution -- + ------------------------- + if Is_Connected (D) then + Put ("Connected!"); + else + Put ("connection failure!"); + end if; + New_Line; + -- you may create your own connection procedure + -- giving the user different try for the password + -- for example. + -- check the Needs_Password and Used_Password functions. + + Create_Film_Table (D); + -- Insert_Value_1 (D); + D1 := D; + D1.Connect; + Prepare_1 (D1); + Insert_Prepared_1 (D1); + D2 := D1; + D2.Connect; + Insert_Value_2 (D2); + Select_1 (D); + New_Line; + +exception + when Backlit.Error => + Put_Line (Error_Message (D)); +end Simple_Demo; diff --git a/src/backlit-client-statment.adb b/src/backlit-client-statment.adb deleted file mode 100644 index 4886dc6..0000000 --- a/src/backlit-client-statment.adb +++ /dev/null @@ -1,420 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- Copyright 2008, Ali Bendriss -- --- -- --- This file is part of Backlit. -- --- -- --- Backlit is free software: you can redistribute it and/or modify it under -- --- the terms of the GNU Lesser General Public License as published by -- --- the Free Software Foundation, either version 3 of the License, or -- --- (at your option) any later version. -- --- -- --- Backlit is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of -- --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- --- GNU Lesser General Public License for more details. -- --- -- --- You should have received a copy of the GNU Lesser General Public License -- --- along with Backlit. If not, see . -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C.Strings; -with Ada.Exceptions; use Ada.Exceptions; --- with Ada.Text_IO; use Ada.Text_IO; - -package body Backlit.Client.Statment is - - procedure To_C_Binded_Parameter_Value - (S : Statment_Object_Type; - O : out Pg_ParamValues) is - use Interfaces.C; - use type Ada.Containers.Count_Type; - - Map_Length : Positive := Natural (Stm_Map.Length (S.Parameter)); - Index : size_t; - begin - if Stm_Map.Last_Key (S.Parameter) /= S.Param_Length then - Raise_Exception (Error'Identity, "wrong bind key parameter"); - end if; - for I in 1 .. Map_Length loop - Index := size_t (I - 1); - O (Index) := Strings.New_Char_Array - (To_C (Stm_Map.Element (S.Parameter, I))); - end loop; - end To_C_Binded_Parameter_Value; - - function Error_Message (S : Statment_Object_Type) return String - is - begin - return Interfaces.C.Strings.Value - (Thin.PQRESULTERRORMESSAGE (S.Pg_Result)); - exception - when others => - return "unknow error."; - end Error_Message; - - procedure Append_Command - (S : in out Statment_Object_Type; - Q : String) - is - use Ada.Strings.Unbounded; - begin - S.Command := S.Command & Q & " "; - end Append_Command; - - procedure Bind_Parameter - (S : in out Statment_Object_Type; - Key : Positive; - Value : String) - is - use type Interfaces.C.int; - begin - Stm_Map.Insert (S.Parameter, Key, Value); - S.Param_Length := S.Param_Length + 1; - end Bind_Parameter; - - procedure Exec - (S : in out Statment_Object_Type; - C : Connection_Object_Type) - is - use Interfaces.C; - use type Interfaces.C.Strings.chars_ptr; - use type Thin.ExecStatusType; - use type Thin.A_PGRESULT_T; - Command : Strings.chars_ptr; - begin - Command := Strings.New_Char_Array - (To_C (Ada.Strings.Unbounded.To_String (S.Command))); - if Stm_Map.Is_Empty (S.Parameter) then - -- exec without parameters - S.Pg_Result := Thin.PQEXEC (C.Real, Command); - else - -- exec with parameters - declare - Pg_Param : Pg_ParamValues (0 .. size_t (S.Param_Length - 1)) := - (others => Interfaces.C.Strings.Null_Ptr); - begin - To_C_Binded_Parameter_Value (S, Pg_Param); - S.Pg_Result := Thin.PQEXECPARAMS - (C.Real, Command, int (S.Param_Length), - null, Pg_Param (0)'Access, null, null, 0); - for I in Pg_Param'Range loop - Interfaces.C.Strings.Free (Pg_Param (I)); - end loop; - end; - end if; - - if Command /= Strings.Null_Ptr then - Interfaces.C.Strings.Free (Command); - end if; - - Stm_Map.Clear (S.Parameter); - S.Param_Length := 0; - - if S.Pg_Result = null then - Raise_Exception (Error'Identity, Error_Message (C)); - -- S.Pg_Result so we use the last Error message available - -- in the connection - end if; - if Thin.PQRESULTSTATUS (S.Pg_Result) /= Thin.PGRES_COMMAND_OK and then - Thin.PQRESULTSTATUS (S.Pg_Result) /= Thin.PGRES_TUPLES_OK then - -- FIXME test that rules with command returning data - -- and command returning no data. - Raise_Exception (Error'Identity, Error_Message (S)); - end if; - -- if Thin.PQRESULTERRORFIELD (S.Pg_Result, 0) /= - -- Strings.Null_Ptr then - -- Raise_Exception (Error'Identity, Error_Message (S)); - -- end if; - end Exec; - - procedure Initialize (S : in out Statment_Object_Type) - is - begin - S.Command := Ada.Strings.Unbounded.Null_Unbounded_String; - Stm_Map.Clear (S.Parameter); - S.Param_Length := 0; - end Initialize; - - procedure Finalize (S : in out Statment_Object_Type) - is - begin - Thin.PQCLEAR (S.Pg_Result); - Stm_Map.Clear (S.Parameter); - S.Param_Length := 0; - end Finalize; - - - procedure Prepare - (S : in out Statment_Object_Type; - C : Connection_Object_Type; - Prepared_Stm_Name : String := ""; - Number_Of_Parameter : Natural := 0) - is - use Interfaces.C; - use type Interfaces.C.Strings.chars_ptr; - use type Thin.ExecStatusType; - use type Thin.A_PGRESULT_T; - Command : Strings.chars_ptr; - Stm_Name : Strings.chars_ptr; - NParams : constant int := int (Number_Of_Parameter); - begin - Command := Strings.New_Char_Array - (To_C (Ada.Strings.Unbounded.To_String (S.Command))); - Stm_Name := Strings.New_Char_Array - (To_C (Prepared_Stm_Name)); - - S.Pg_Result := Thin.PQPREPARE (C.Real, Stm_Name, Command, - NParams, null); - - if Command /= Strings.Null_Ptr then - Interfaces.C.Strings.Free (Command); - end if; - if Stm_Name /= Strings.Null_Ptr then - Interfaces.C.Strings.Free (Stm_Name); - end if; - - if S.Pg_Result = null then - Raise_Exception (Error'Identity, Error_Message (C)); - -- S.Pg_Result so we use the last Error message available - -- in the connection - end if; - if Thin.PQRESULTSTATUS (S.Pg_Result) /= Thin.PGRES_COMMAND_OK then - Raise_Exception (Error'Identity, Error_Message (S)); - end if; - end Prepare; - - - procedure Exec - (S : in out Statment_Object_Type; - C : Connection_Object_Type; - Prepared_Stm_Name : String) - is - use Interfaces.C; - use type Interfaces.C.Strings.chars_ptr; - use type Thin.ExecStatusType; - use type Thin.A_PGRESULT_T; - Stm_Name : Strings.chars_ptr; - Param_Last : Natural := S.Param_Length; - begin - Stm_Name := Strings.New_Char_Array - (To_C (Prepared_Stm_Name)); - if Param_Last > 0 then - Param_Last := Param_Last - 1; - end if; - declare - Pg_Param : Pg_ParamValues (0 .. size_t (Param_Last)) := - (others => Interfaces.C.Strings.Null_Ptr); - begin - if S.Param_Length > 0 then - To_C_Binded_Parameter_Value (S, Pg_Param); - end if; - S.Pg_Result := Thin.PQEXECPREPARED - (C.Real, Stm_Name, int (S.Param_Length), - Pg_Param (0)'Access, null, null, 0); - for I in Pg_Param'Range loop - Interfaces.C.Strings.Free (Pg_Param (I)); - end loop; - end; - Stm_Map.Clear (S.Parameter); - S.Param_Length := 0; - if Stm_Name /= Strings.Null_Ptr then - Interfaces.C.Strings.Free (Stm_Name); - end if; - if S.Pg_Result = null then - Raise_Exception (Error'Identity, Error_Message (C)); - -- S.Pg_Result so we use the last Error message available - -- in the connection - end if; - if Thin.PQRESULTSTATUS (S.Pg_Result) /= Thin.PGRES_COMMAND_OK then - Raise_Exception (Error'Identity, Error_Message (S)); - end if; - end Exec; - - function Status (S : Statment_Object_Type) return Exec_Status_Type - is - Result : Thin.ExecStatusType := Thin.PQRESULTSTATUS (S.Pg_Result); - begin - return Exec_Status_Type'Val (Thin.ExecStatusType'Pos (Result)); - end Status; - - function N_Tuples (S : Statment_Object_Type) return Tuples_Type - is - Result : Tuples_Type := - Tuples_Type (Thin.PQNTUPLES (S.Pg_Result)); - begin - return Result; - end N_Tuples; - - function N_Fields (S : Statment_Object_Type) return Fields_Type - is - Result : Fields_Type := - Fields_Type (Thin.PQNFIELDS (S.Pg_Result)); - begin - return Result; - end N_Fields; - - function F_Name - (S : Statment_Object_Type; - Column_Number : Fields_Type) - return String - is - use Interfaces.C; - Result : String := Interfaces.C.Strings.Value - (Thin.PQFNAME (S.Pg_Result, int (Column_Number))); - begin - return Result; - end F_Name; - - function F_Number - (S : Statment_Object_Type; - Column_Name : String) - return Fields_Type - is - use Interfaces.C; - use type Interfaces.C.Strings.chars_ptr; - C_Column_Name : Strings.chars_ptr := - Strings.New_Char_Array (To_C (Column_Name)); - Result : Fields_Type := - Fields_Type (Thin.PQFNUMBER (S.Pg_Result, C_Column_Name)); - begin - if C_Column_Name /= Strings.Null_Ptr then - Interfaces.C.Strings.Free (C_Column_Name); - end if; - return Result; - end F_Number; - - function F_Table - (S : Statment_Object_Type; - Column_Number : Fields_Type) return Oid - is - use Interfaces.C; - Result : Oid := - Oid (Thin.PQFTABLE (S.Pg_Result, int (Column_Number))); - begin - return Result; - end F_Table; - - function F_Table_Col - (S : Statment_Object_Type; - Column_Number : Fields_Type) return Fields_Type - is - use Interfaces.C; - Result : Fields_Type := - Fields_Type (Thin.PQFTABLECOL (S.Pg_Result, int (Column_Number))); - begin - return Result; - end F_Table_Col; - - function F_Format - (S : Statment_Object_Type; - Column_Number : Fields_Type) return Format_Code_Type - is - use Interfaces.C; - Result : Format_Code_Type := - Format_Code_Type (Thin.PQFFORMAT (S.Pg_Result, int (Column_Number))); - begin - return Result; - end F_Format; - - function F_Type - (S : Statment_Object_Type; - Column_Number : Fields_Type) return Oid - is - use Interfaces.C; - Result : Oid := - Oid (Thin.PQFTYPE (S.Pg_Result, int (Column_Number))); - begin - return Result; - end F_Type; - - function F_Mod - (S : Statment_Object_Type; - Column_Number : Fields_Type) return Modifier_Type - is - use Interfaces.C; - Result : Modifier_Type := - Modifier_Type (Thin.PQFMOD (S.Pg_Result, int (Column_Number))); - begin - return Result; - end F_Mod; - - function F_Size - (S : Statment_Object_Type; - Column_Number : Fields_Type) return Size_Type - is - use Interfaces.C; - Result : Size_Type := - Size_Type (Thin.PQFSIZE (S.Pg_Result, int (Column_Number))); - begin - return Result; - end F_Size; - - function Get_Value - (S : Statment_Object_Type; - Row_Number : Tuples_Type; - Column_Number : Fields_Type) return String - is - use Interfaces.C; - use type Interfaces.C.Strings.chars_ptr; - C_Result : Strings.chars_ptr := - Thin.PQGETVALUE (S.Pg_Result, - int (Row_Number), - int (Column_Number)); - Result : String := Strings.Value (C_Result); - begin - -- The caller should not free the result directly. - -- It will be freed when the associated PGresult handle - -- is passed to PQclear. - return Result; - end Get_Value; - - function Get_Is_Null - (S : Statment_Object_Type; - Row_Number : Tuples_Type; - Column_Number : Fields_Type) return Boolean - is - use Interfaces.C; - C_Result : int := Thin.PQGETISNULL (S.Pg_Result, - int (Row_Number), - int (Column_Number)); - begin - return C_Result = Thin.C_True; - end Get_Is_Null; - - function Getlength - (S : Statment_Object_Type; - Row_Number : Tuples_Type; - Column_Number : Fields_Type) return Length_Type - is - use Interfaces.C; - Result : Length_Type := - Length_Type (Thin.PQGETLENGTH (S.Pg_Result, - int (Row_Number), - int (Column_Number))); - begin - return Result; - end Getlength; - - function N_Params (S : Statment_Object_Type) return Param_Number_Type - is - use Interfaces.C; - Result : Param_Number_Type := - Param_Number_Type (Thin.PQNPARAMS (S.Pg_Result)); - begin - return Result; - end N_Params; - - function Param_Type - (S : Statment_Object_Type; - Param_Number : Param_Number_Type) return Oid - is - use Interfaces.C; - Result : Oid := - Oid (Thin.PQPARAMTYPE (S.Pg_Result, int (Param_Number))); - begin - return Result; - end Param_Type; - -end Backlit.Client.Statment; diff --git a/src/backlit-client.adb b/src/backlit-client.adb deleted file mode 100644 index 05d8cd4..0000000 --- a/src/backlit-client.adb +++ /dev/null @@ -1,336 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- Copyright 2008, Ali Bendriss -- --- -- --- This file is part of Backlit. -- --- -- --- Backlit is free software: you can redistribute it and/or modify it under -- --- the terms of the GNU Lesser General Public License as published by -- --- the Free Software Foundation, either version 3 of the License, or -- --- (at your option) any later version. -- --- -- --- Backlit is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of -- --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- --- GNU Lesser General Public License for more details. -- --- -- --- You should have received a copy of the GNU Lesser General Public License -- --- along with Backlit. If not, see . -- --- -- ------------------------------------------------------------------------------- - -with Ada.Exceptions; -with Interfaces.C.Strings; -with Ada.Strings.Unbounded; --- with Ada.Text_Io; use Ada.Text_IO; -with Ada.Characters.Handling; - -package body Backlit.Client is - - use Connection_Info_Map; - use Backlit.Thin; - use Ada.Exceptions; - - function Error_Message (C : in Connection_Object_Type) return String - is - begin - return Interfaces.C.Strings.Value (PQERRORMESSAGE (C.Real)); - exception - when others => - return "unknow error."; - end Error_Message; - - procedure Connection_Map_To_C - (C : in out Connection_Object_Type; - I : out Interfaces.C.Strings.chars_ptr) - is - use Ada.Strings.Unbounded; - use Interfaces.C; - use Interfaces.C.Strings; - TMP_US : Unbounded_String; - procedure Append_Info (C : Connection_Info_Map.Cursor) is - begin - Ada.Strings.Unbounded.Append - (TMP_US, Connection_Info_Map.Element (C) & " "); - -- Put_Line (Ada.Strings.Unbounded.To_String (TMP_US)); - end Append_Info; - begin - Connection_Info_Map.Iterate (C.Map, Append_Info'Access); - Connection_Info_Map.Clear (C.Map); - I := Interfaces.C.Strings.New_Char_Array - (To_C (Ada.Strings.Unbounded.To_String (TMP_US))); - end Connection_Map_To_C; - - procedure Frozen_Check (C : in out Connection_Object_Type) - is - use Ada.Exceptions; - begin - if C.Frozen then - Raise_Exception - (Error'Identity, - "connection already done, parameters can't be changed"); - end if; - end Frozen_Check; - -- libpq doesn't permit any change in the connection_info after the - -- connection. We make it explicite by raising an exception. - - procedure Set_Host_Name - (C : in out Connection_Object_Type; Value : String) - is - begin - Frozen_Check (C); - C.Map.Insert ("host", "host=" & Value); - end Set_Host_Name; - - procedure Set_Host_Address - (C : in out Connection_Object_Type; Value : String) - is - begin - Frozen_Check (C); - C.Map.Insert ("hostaddr", "hostaddr=" & Value); - end Set_Host_Address; - - procedure Set_Port - (C : in out Connection_Object_Type; Value : String) - is - begin - Frozen_Check (C); - C.Map.Insert ("port", "port=" & Value); - end Set_Port; - - procedure Set_Db_Name - (C : in out Connection_Object_Type; Value : String) - is - begin - Frozen_Check (C); - C.Map.Insert ("dbname", "dbname=" & Value); - end Set_Db_Name; - - procedure Set_User_Name - (C : in out Connection_Object_Type; Value : String) - is - begin - Frozen_Check (C); - C.Map.Insert ("user", "user=" & Value); - end Set_User_Name; - - procedure Set_User_Password - (C : in out Connection_Object_Type; Value : String) - is - begin - Frozen_Check (C); - C.Map.Insert ("password", "password=" & Value); - end Set_User_Password; - - procedure Set_Timeout - (C : in out Connection_Object_Type; Value : Natural) - is - begin - Frozen_Check (C); - C.Map.Insert ("connect_timeout", "connect_timeout=" & Value'Img); - end Set_Timeout; - - procedure Set_Options - (C : in out Connection_Object_Type; Value : String) - is - begin - Frozen_Check (C); - C.Map.Insert ("options", "options=" & Value); - end Set_Options; - - procedure Set_SSL - (C : in out Connection_Object_Type; Value : SSL_Mode_Type) - is - function PQ_Value (SSL : SSL_Mode_Type) return String - is - begin - case SSL is - when Disable => return "disable"; - when Allow => return "allow"; - when Prefer => return "prefer"; - when Require => return "require"; - end case; - end PQ_Value; - begin - Frozen_Check (C); - C.Map.Insert ("sslmode", "sslmode=" & PQ_Value (Value)); - end Set_SSL; - - procedure Set_Krbsrvname - (C : in out Connection_Object_Type; Value : String) - is - begin - Frozen_Check (C); - C.Map.Insert ("krbsrvname", "options=" & Value); - end Set_Krbsrvname; - - procedure Set_Gssapi - (C : in out Connection_Object_Type) - is - begin - Frozen_Check (C); - C.Map.Insert ("gsslib", "gsslib=gssapi"); - end Set_Gssapi; - - procedure Set_Service_Name - (C : in out Connection_Object_Type; Value : String) - is - begin - Frozen_Check (C); - C.Map.Insert ("service", "service=" & Value); - end Set_Service_Name; - - procedure Connect - (C : in out Connection_Object_Type) - is - CI : Interfaces.C.Strings.chars_ptr; - use Interfaces.C.Strings; - begin - if Is_Connected (C) then - return; - end if; - Connection_Map_To_C (C, CI); - C.Real := Backlit.Thin.PQCONNECTDB (CI); - if CI /= Null_Ptr then - Interfaces.C.Strings.Free (CI); - end if; - if PQSTATUS (C.Real) /= CONNECTION_OK then - Raise_Exception (Error'Identity, Error_Message (C)); - end if; - C.Frozen := True; - end Connect; - - procedure Connect - (C : in out Connection_Object_Type; - C_Info : String) - is - CI : Interfaces.C.Strings.chars_ptr; - use Interfaces.C.Strings; - use Interfaces.C.Strings; - begin - if Is_Connected (C) then - return; - end if; - if not Connection_Info_Map.Is_Empty (C.Map) then - Raise_Exception - (Error'Identity, - "Only one connection methode required"); - end if; - CI := New_Char_Array (Interfaces.C.To_C (C_Info)); - C.Real := Backlit.Thin.PQCONNECTDB (CI); - if CI /= Null_Ptr then - Interfaces.C.Strings.Free (CI); - end if; - if PQSTATUS (C.Real) /= CONNECTION_OK then - Raise_Exception (Error'Identity, Error_Message (C)); - end if; - C.Frozen := True; - end Connect; - - procedure Reset - (C : in out Connection_Object_Type) - is - begin - PQRESET (C.Real); - if PQSTATUS (C.Real) /= CONNECTION_OK then - Raise_Exception (Error'Identity, Error_Message (C)); - end if; - end Reset; - - procedure Connect_Non_Blocking - (C : in out Connection_Object_Type) - is - begin - null; - end Connect_Non_Blocking; - - procedure Reset_Non_Blocking - (C : in out Connection_Object_Type) - is - begin - null; - end Reset_Non_Blocking; - - function Get - (C : Connection_Object_Type; - Q : Connection_Key_Type) return String - is - begin - case Q is - when DB_Name => - return Interfaces.C.Strings.Value (PQDB (C.Real)); - when DB_User => - return Interfaces.C.Strings.Value (PQUSER (C.Real)); - when DB_Pass => - return Interfaces.C.Strings.Value (PQPASS (C.Real)); - when DB_Host => - return Interfaces.C.Strings.Value (PQHOST (C.Real)); - when DB_Port => - return Interfaces.C.Strings.Value (PQPORT (C.Real)); - when DB_Options => - return Interfaces.C.Strings.Value (PQOPTIONS (C.Real)); - end case; - end Get; - - procedure Initalize (C : in out Connection_Object_Type) - is - begin - C.Frozen := False; - end Initalize; - - procedure Finalize (C : in out Connection_Object_Type) - is - begin - PQFINISH (C.Real); - -- FIXME - -- There is no way to check the success yet: - -- libpq doesn't set conn to NULL after a PQFINISH call. - end Finalize; - - function Current_Server_Setting - (C : Connection_Object_Type; - Key : String; - To_Lower : Boolean := True) return String - is - Param : Interfaces.C.Strings.chars_ptr; - Real_Key : String := Key; - begin - if To_Lower = True then - Real_Key := Ada.Characters.Handling.To_Lower (Key); - end if; - Param := Interfaces.C.Strings.New_Char_Array - (Interfaces.C.To_C (Real_Key)); - declare - Result : String := Interfaces.C.Strings.Value - (PQPARAMETERSTATUS (C.Real, Param)); - begin - Interfaces.C.Strings.Free (Param); - return Result; - end; - exception - when others => return ""; - end Current_Server_Setting; - - function Needs_Password - (C : Connection_Object_Type) return Boolean - is - use type Interfaces.C.int; - begin - return PQCONNECTIONNEEDSPASSWORD (C.Real) = C_True; - end Needs_Password; - - function Used_Password - (C : Connection_Object_Type) return Boolean - is - use type Interfaces.C.int; - begin - return PQCONNECTIONUSEDPASSWORD (C.Real) = C_True; - end Used_Password; - - function Is_Connected (C : Connection_Object_Type) return Boolean - is - begin - return PQSTATUS (C.Real) = CONNECTION_OK; - end Is_Connected; - -end Backlit.Client; diff --git a/src/backlit-client.ads b/src/backlit-client.ads deleted file mode 100644 index d17b99b..0000000 --- a/src/backlit-client.ads +++ /dev/null @@ -1,225 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- Copyright 2008, Ali Bendriss -- --- -- --- This file is part of Backlit. -- --- -- --- Backlit is free software: you can redistribute it and/or modify it under -- --- the terms of the GNU Lesser General Public License as published by -- --- the Free Software Foundation, either version 3 of the License, or -- --- (at your option) any later version. -- --- -- --- Backlit is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of -- --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- --- GNU Lesser General Public License for more details. -- --- -- --- You should have received a copy of the GNU Lesser General Public License -- --- along with Backlit. If not, see . -- --- -- ------------------------------------------------------------------------------- - -with Ada.Finalization; -private with Ada.Containers.Indefinite_Hashed_Maps; -private with Ada.Strings.Hash; -with Backlit.Thin; - -package Backlit.Client is - - type Connection_Object_Type is new - Ada.Finalization.Limited_Controlled with private; - - -------------------------- - -- Connection Control -- - -------------------------- - - procedure Set_Host_Name - (C : in out Connection_Object_Type; Value : String); - -- Name of Host To Connect To. - -- If this Begins with a slash, it specifies Unix-Domain Communication - -- rather than TCP/IP communication. The Value is the Name of the Directory - -- in which the socket file is stored. - -- The default behavior when host is not specified is to connect to - -- A Unix-Domain Socket in /tmp (or whatever socket directory was specified - -- when PostgreSQL was built). - -- On machines without Unix-Domain Sockets, - -- the default is to connect to localhost. - - procedure Set_Host_Address - (C : in out Connection_Object_Type; Value : String); - -- Numeric IP address of host to connect to. - -- This should be in the standard IPv4 address format, e.g., 172.28.40.9. - -- if your machine supports IPv6, you can also use those addresses. - -- TCP/IP communication is always used when a nonempty string - -- is specified for this parameter. - - procedure Set_Port - (C : in out Connection_Object_Type; - Value : String); - -- Port number to connect to at the server host, - -- or socket file name extension for Unix-Domain Connections. - - procedure Set_Db_Name - (C : in out Connection_Object_Type; Value : String); - -- The database name. Defaults to be the same as the user name. - - procedure Set_User_Name - (C : in out Connection_Object_Type; Value : String); - -- PostgreSQL user name to connect as. - -- Defaults to be the same as the operating system name of the user - -- running the application. - - procedure Set_User_Password - (C : in out Connection_Object_Type; Value : String); - -- Password to be used if the server demands password authentication. - - procedure Set_Timeout - (C : in out Connection_Object_Type; Value : Natural); - -- Maximum wait for connection, in seconds (write as a Decimal). - -- Zero or not specified means wait indefinitely. - -- It is not recommended to use a timeout of less than 2 seconds. - - procedure Set_Options - (C : in out Connection_Object_Type; Value : String); - -- Command-line options to be sent to the server. - - type SSL_Mode_Type is (Disable, Allow, Prefer, Require); - procedure Set_SSL - (C : in out Connection_Object_Type; Value : SSL_Mode_Type); - -- This option determines whether or - -- with what priority an SSL Connection will be Negotiated - -- with the server. There are four modes: - -- * Disable will attempt only an unencrypted SSL Connection; - -- * Allow will negotiate, trying first a non-SSL connection, - -- then if that fails, trying an SSL connection; - -- * Prefer (the default) will negotiate, trying first an SSL connection, - -- then if that fails, trying a regular non-SSL connection; - -- * Require will try only an SSL connection. - -- if PostgreSQL is compiled without SSL support, - -- using option Require will cause an error, - -- while options Allow and Prefer will be accepted but - -- will not in fact attempt an SSL connection. - - procedure Set_Krbsrvname - (C : in out Connection_Object_Type; Value : String); - -- Kerberos service name to use when authenticating with - -- Kerberos 5 or GSSAPI. - -- This must match the service name specified in the server - -- configuration for Kerberos authentication to Succeed. - - procedure Set_Gssapi - (C : in out Connection_Object_Type); - -- Only Used On Windows. - -- Set_Gssapi force the use the GSSAPI library for Authentication - -- instead of the default SSPI. - - procedure Set_Service_Name - (C : in out Connection_Object_Type; Value : String); - -- Service name to use for additional parameters. - -- It specifies a service name in pg_service.conf that holds additional - -- connection parameters. This allows applications to Specify only a - -- service name so connection parameters can be centrally maintained. - - procedure Connect - (C : in out Connection_Object_Type); - -- Makes a new connection to the database server. - -- return if already connected. - - procedure Connect - (C : in out Connection_Object_Type; C_Info : String); - -- Makes a new connection to the database server. - -- Take the connection info from a string like - -- "host=localhost user=postgres dbname=template1 ..." - -- rather than using the procedure Set_Host_Name or Set_Host_Address. - -- You can't mix the two ways on the same connection. - -- return if already connected. - - procedure Reset - (C : in out Connection_Object_Type); - -- This procedure will close the connection to the server and - -- attempt to reestablish a new connection to the same server, - -- using all the same parameters previously used. - -- This might be useful for error recovery if a working connection is lost. - - - procedure Connect_Non_Blocking - (C : in out Connection_Object_Type); - -- Make a connection to the database server in a nonblocking manner. - - procedure Reset_Non_Blocking - (C : in out Connection_Object_Type); - -- This procedure will close the connection to the server and - -- attempt to reestablish a new connection to the same server, - -- using all the same parameters previously used. - -- This can be useful for error recovery if a working connection is lost. - -- It differ from reset (above) in that it act in a nonblocking manner. - - - ------------------------- - -- Connection Status -- - ------------------------- - type Connection_Key_Type is - (DB_Name, DB_User, DB_Pass, DB_Host, DB_Port, DB_Options); - - function Get - (C : Connection_Object_Type; - Q : Connection_Key_Type) return String; - -- The following functions return parameter values established at - -- connection. These values are fixed for the life of the PGconn object. - - function Error_Message (C : in Connection_Object_Type) return String; - -- Returns the error message most recently generated by - -- an operation on the connection. - - function Current_Server_Setting - (C : Connection_Object_Type; - Key : String; - To_Lower : Boolean := True) return String; - -- Certain parameter values are reported by the server automatically - -- at connection startup or whenever their values change. - -- this function can be used to interrogate these settings. - -- It returns the current value of a parameter if known, - -- or an empty string if the parameter is not known. - -- key looks like : server_version, server_encoding... - -- check the doc for Parameters reported as of the current release. - - function Needs_Password - (C : Connection_Object_Type) return Boolean; - -- Returns true if the connection authentication method - -- required a password, but none was available. - -- This function can be applied after a failed connection attempt - -- to decide whether to prompt the user for a password. - - function Used_Password - (C : Connection_Object_Type) return Boolean; - -- This function detects whether a password supplied to the connection - -- function was actually used. Passwords obtained from other sources - -- (such as the .pgpass file) are not considered caller-supplied. - - function Is_Connected - (C : Connection_Object_Type) return Boolean; - -- return True is the connection status is OK. - - -private - - package Connection_Info_Map is - new Ada.Containers.Indefinite_Hashed_Maps - (String, - String, - Ada.Strings.Hash, - "="); - - type Connection_Object_Type is new - Ada.Finalization.Limited_Controlled with - record - Real : Backlit.Thin.A_PGCONN_T; - Map : Connection_Info_Map.Map; - Frozen : Boolean; - end record; - - procedure Initalize (C : in out Connection_Object_Type); - - procedure Finalize (C : in out Connection_Object_Type); - -end Backlit.Client; diff --git a/src/backlit-postgres-pool.adb b/src/backlit-postgres-pool.adb new file mode 100644 index 0000000..9daa1fd --- /dev/null +++ b/src/backlit-postgres-pool.adb @@ -0,0 +1,517 @@ +with Ada.Exceptions; +with Interfaces.C.Strings; +with System; +with Ada.Strings.Unbounded; +with Ada.Text_IO; use Ada.Text_IO; + +package body Backlit.Postgres.Pool is + + ------------- + -- Equal -- + ------------- + function "=" (Left, Right : Connection_Type) return Boolean + is + use type Backlit.Thin.A_PGCONN_T; + begin + if Left.Connection = Right.Connection + and then Left.Connection /= null then + return True; + end if; + return False; + end "="; + + --------------------- + -- Error_Message -- + --------------------- + function Error_Message (C : in Connection_Type) return String + is + begin + return Interfaces.C.Strings.Value + (Backlit.Thin.PQERRORMESSAGE (C.Connection)); + exception + when others => + return "unknow error."; + end Error_Message; + + -------------------- + -- Is_Connected -- + -------------------- + function Is_Connected (C : Connection_Type) return Boolean + is + use type Backlit.Thin.ConnStatusType; + begin + return Backlit.Thin.PQSTATUS (C.Connection) = + Backlit.Thin.CONNECTION_OK; + end Is_Connected; + + --------------- + -- Connect -- + --------------- + procedure Connect + (C : in out Connection_Type) + is + CI : Ada.Strings.Unbounded.Unbounded_String; + use Interfaces.C.Strings; + begin + if Is_Connected (C) then + return; + end if; + Connect (C, Ada.Strings.Unbounded.To_String (C.Connection_Info)); + end Connect; + + procedure Connect + (C : in out Connection_Type; Connection_Info : String) + is + CI : Interfaces.C.Strings.chars_ptr; + use Interfaces.C.Strings; + use Interfaces.C.Strings; + use type Backlit.Thin.ConnStatusType; + begin + if Is_Connected (C) then + return; + end if; + CI := New_Char_Array (Interfaces.C.To_C (Connection_Info)); + C.Connection := Backlit.Thin.PQCONNECTDB (CI); + if CI /= Null_Ptr then + Interfaces.C.Strings.Free (CI); + end if; + if not Is_Connected (C) then + Ada.Exceptions.Raise_Exception (Error'Identity, Error_Message (C)); + end if; + C.Connection_Info := + Ada.Strings.Unbounded.To_Unbounded_String (Connection_Info); + end Connect; + + ------------------ + -- Initialize -- + ------------------ + procedure Initialize (C : in out Connection_Type) + is + begin + C.Connection := null; + C.In_Use := False; + end Initialize; + +-- procedure Adjust (C : in out Connection_Type) +-- is +-- begin +-- null; +-- end Adjust; + +-- procedure Finalize (C : in out Connection_Type) +-- is +-- begin +-- null; +-- end Adjust; + + + ---------------------- + -- Protected Body -- + ---------------------- + protected body Session_DBD_Type is + + --------------- + -- Connect -- + --------------- + procedure Connect (L : in out Connection_List_Type) is + + procedure Connect (Cursor : Connection_List.Cursor) + is + begin + Connection_List.Update_Element (L.L, Cursor, Connect'Access); + end Connect; + + use type Ada.Containers.Count_Type; + C : Connection_List.Cursor; + begin + C := First (L.L); + loop + exit when C = Last (L.L); + Connect (C); + L.In_Length := L.In_Length + 1; + end loop; + -- Connection_List.Iterate (L.L, Connect'Access); + end Connect; + +-- procedure Is_Connect (L : in Connection_List_Type) is + +-- procedure Is_Connected (C : Connection_Type) +-- is +-- begin +-- if Is_Connected (C) then +-- Put_Line ("Connected"); +-- else +-- Put_Line ("NOT Connected"); +-- end if; +-- end Is_Connected; + +-- procedure Query (Cursor : Connection_List.Cursor) +-- is +-- begin +-- Query_Element (Cursor, Is_Connected'Access); +-- end Query; +-- begin +-- Connection_List.Iterate (L.L, Query'Access); +-- end Is_Connect; + + ------------ + -- Open -- + ------------ + procedure Open + (D : in DBD_Type; + Key : String; + Capacity : Positive) + is + L : Connection_List_Type; + Connection_Maps_Position : Connection_Maps.Cursor; + Insert_OK : Boolean; + C_Tab : array (1 .. Capacity) of Connection_Type; + begin + L.In_Length := 0; + L.Out_Length := 0; + L.L := Empty_List; + if not Is_Empty (Key) then + Ada.Exceptions.Raise_Exception + (Error'Identity, "Open => session already exit"); + end if; + for I in C_Tab'Range loop + C_Tab (I).Connection_Info := D.Connection_Info; + Append (L.L, C_Tab (I)); + end loop; + if Is_Connected (D) then + Connect (L); + end if; + Insert (Pool.Map, Key, L, Connection_Maps_Position, Insert_OK); + if Insert_Ok /= True then + Ada.Exceptions.Raise_Exception + (Error'Identity, "Open => init failed"); + end if; + -- Put_Line (Length (L.L)'Img); + end Open; + + ------------ + -- Open -- + ------------ + procedure Open + (Connection_Info : String; + Key : String; + Capacity : Positive) + is + L : Connection_List_Type; + Connection_Maps_Position : Connection_Maps.Cursor; + Insert_OK : Boolean; + C_Tab : array (1 .. Capacity) of Connection_Type; + use type Ada.Containers.Count_Type; + begin + L.In_Length := 0; + L.Out_Length := 0; + L.L := Empty_List; + if not Is_Empty (Key) then + Ada.Exceptions.Raise_Exception + (Error'Identity, "Open => session already exit"); + end if; + for I in C_Tab'Range loop + Connect (C_Tab (I), Connection_Info); + C_Tab (I).Connection_Info := + Ada.Strings.Unbounded.To_Unbounded_String (Connection_Info); + Append (L.L, C_Tab (I)); + L.In_Length := L.In_Length + 1; + C_Tab (I).Connection := null; + end loop; + Insert (Pool.Map, Key, L, Connection_Maps_Position, Insert_OK); + if Insert_Ok /= True then + Ada.Exceptions.Raise_Exception + (Error'Identity, "Open => init failed"); + end if; + -- Connect (L); + end Open; + + ----------- + -- Get -- + ----------- + procedure Get + (D : out DBD_Type; + Key : String; + Reserve : Positive) + is + procedure Get1 (Key : String; Element : in out Connection_List_Type) + is + Element_Found : Boolean := False; + procedure Get2 (Cursor : Connection_List.Cursor) + is + procedure Get3 (C : in out Connection_Type) + is + use type Ada.Containers.Count_Type; + begin + if C.In_Use = False then + D.Real := C.Connection; + D.Connection_Info := C.Connection_Info; + C.In_Use := True; + Element_Found := True; + Element.Out_Length := Element.Out_Length + 1; + Element.In_Length := Element.In_Length - 1; + end if; + end Get3; + begin + Connection_List.Update_Element (Element.L, Cursor, Get3'Access); + end Get2; + C : Connection_List.Cursor := First (Element.L); + begin + loop + exit when Element_Found or C = Last (Element.L); + Get2 (C); + Next (C); + end loop; + end Get1; + begin + -- Put_Line ("POOL => Get"); + D.Init; + if Contains (Pool.Map, Key) then + Connection_Maps.Update_Element + (Pool.Map, Find (Pool.Map, Key), Get1'Access); + D.Pooled := True; + D.Key := Ada.Strings.Unbounded.To_Unbounded_String (Key); + else + Ada.Exceptions.Raise_Exception + (Error'Identity, "Get => session '" & Key & "' not found"); + end if; + end Get; + + ----------- + -- Put -- + ----------- + procedure Put + (D : in out DBD_Type; + Key : String) + is + procedure Put1 (Key : String; Element : in out Connection_List_Type) + is + Element_Found : Boolean := False; + procedure Put2 (Cursor : Connection_List.Cursor) + is + procedure Put3 (C : in out Connection_Type) + is + use type System.Address; + use type Backlit.Thin.A_PGCONN_T; + use type Ada.Containers.Count_Type; + begin + if C.In_Use = True and then + Is_Connected (D) then + -- D.Real = C.Connection then + if D.Real.all'Address = C.Connection.all'Address then + D.Real := null; + C.In_Use := False; + Element_Found := True; + Element.In_Length := Element.In_Length + 1; + Element.Out_Length := Element.Out_Length - 1; + end if; + end if; + end Put3; + begin + -- if not Is_Empty (Element) then + Connection_List.Update_Element (Element.L, Cursor, Put3'Access); + -- end if; + end Put2; + C : Connection_List.Cursor; + begin + if Is_Empty (Element.L) /= True then + C := First (Element.L); + loop + exit when Element_Found or C = Last (Element.L); + Put2 (C); + Next (C); + end loop; + end if; + end Put1; + begin + if D.Pooled /= True then + Ada.Exceptions.Raise_Exception + (Error'Identity, "Put => not a valid connection"); + end if; + if Contains (Pool.Map, Key) then + Connection_Maps.Update_Element + (Pool.Map, Find (Pool.Map, Key), Put1'Access); + end if; + exception + when Error => + raise; + end Put; + + ------------- + -- Close -- + ------------- + procedure Close (Key : String) + is + procedure Close (Key : String; L : in out Connection_List_Type) is + procedure Close (Cursor : Connection_List.Cursor) + is + procedure Close (C : in out Connection_Type) + is + use type Backlit.Thin.A_PGCONN_T; + begin + if C.Connection /= null then + Backlit.Thin.PQFINISH (C.Connection); + C.Connection := null; + end if; + end Close; + begin + Connection_List.Update_Element (L.L, Cursor, Close'Access); + end Close; + begin + Connection_List.Iterate (L.L, Close'Access); + end Close; + begin + if Contains (Pool.Map, Key) then + Pool.Map.Update_Element (Pool.Map.Find (Key), Close'Access); + end if; + exception + when Error => + raise; + end Close; + + -------------- + -- Delete -- + -------------- + procedure Delete (Key : String) + is + begin + Exclude (Pool.Map, Key); + end Delete; + + ------------- + -- Close -- + ------------- + procedure Close + is + procedure Close (C : Connection_Maps.Cursor) + is + begin + Close (Key (C)); + end Close; + begin + Pool.Map.Iterate (Close'Access); + Clear (Pool.Map); + exception + when Error => + raise; + end Close; + + function Is_Empty (Key : String) return Boolean + is + begin + if Contains (Pool.Map, Key) then + return Connection_List.Is_Empty (Element (Pool.Map.Find (Key)).L); + end if; + return True; + end Is_Empty; + + function Total_Length (Key : String) return Count_Type + is + begin + return Connection_List.Length (Element (Pool.Map.Find (Key)).L); + end Total_Length; + + function In_Length (Key : String) return Count_Type + is + begin + return Element (Pool.Map.Find (Key)).In_Length; + end In_Length; + + function Out_Length (Key : String) return Count_Type + is + begin + return Element (Pool.Map.Find (Key)).Out_Length; + end Out_Length; + + end Session_DBD_Type; + + -- if Length (L) < 2 then + -- declare + -- D_Tab : array (1 .. Reserve) of DBD_Type := + -- (others => First_Element (L)); + -- begin + -- for I in D_Tab'First .. D_Tab'Last loop + -- Connect (D_Tab(I)); + -- Append (L, D_Tab(I)); + -- end loop; + -- end; + -- end if; + + ------------------------ + -- Public Interface -- + ------------------------ + + procedure Open + (D : in DBD_Type; + Key : String; + Capacity : Positive := 3) + is + begin + Session_DBD_Type.Open (D, Key, Capacity); + end Open; + + procedure Open + (Connection_Info : String; + Key : String; + Capacity : Positive := 3) + is + begin + Session_DBD_Type.Open (Connection_Info, Key, Capacity); + end Open; + + procedure Get + (D : out DBD_Type; + Key : String; + Reserve : Positive := 2) + is + begin + Session_DBD_Type.Get (D, Key, Reserve); + end Get; + + procedure Put + (D : in out DBD_Type; + Key : String) + is + begin + Session_DBD_Type.Put (D, Key); + end Put; + + procedure Close + (Key : String) + is + begin + Session_DBD_Type.Close (Key); + Session_DBD_Type.Delete (Key); + end Close; + + procedure Close + is + begin + Session_DBD_Type.Close; + end Close; + + function Is_Empty (Key : String) return Boolean + is + begin + return Session_DBD_Type.Is_Empty (Key); + end Is_Empty; + + function Total_Length (Key : String) return Count_Type + is + begin + return Session_DBD_Type.Total_Length (Key); + end Total_Length; + + function In_Length (Key : String) return Count_Type + is + begin + return Session_DBD_Type.In_Length (Key); + end In_Length; + + function Out_Length (Key : String) return Count_Type + is + begin + return Session_DBD_Type.Out_Length (Key); + end Out_Length; + +end Backlit.Postgres.Pool; diff --git a/src/backlit-postgres-pool.ads b/src/backlit-postgres-pool.ads new file mode 100644 index 0000000..027c752 --- /dev/null +++ b/src/backlit-postgres-pool.ads @@ -0,0 +1,171 @@ +private with Ada.Containers.Doubly_Linked_Lists; +private with Ada.Containers.Indefinite_Hashed_Maps; +private with Ada.Strings.Hash; +private with Ada.Strings.Unbounded; +with Ada.Containers; + +package Backlit.Postgres.Pool is + + -- Error : exception; + + subtype Count_Type is Ada.Containers.Count_Type; + + procedure Open + (D : in DBD_Type; + Key : String; + Capacity : Positive := 3); + -- create a new pool containing "Capacity" DBD_type referenced by Key + -- with the connection information provided by D. + -- If D is connected then all the pool will be connected. + -- D is left untouched so you may reuse or leave it. + -- Opening an existing session referenced by Key will raise an exception. + + procedure Open + (Connection_Info : String; + Key : String; + Capacity : Positive := 3); + -- create a new pool containing "Capacity" DBD_type referenced by Key + -- with the connection information provided by the Connection_Info. + -- All the DBD_Type will attempt a connection. + -- Opening an existing session referenced by Key will raise an exception. + + procedure Get + (D : out DBD_Type; + Key : String; + Reserve : Positive := 2); + -- get a new DBD_Type referenced by Key with all the connection + -- information initialised previously and/or + -- already connected to the database server. + + procedure Put + (D : in out DBD_Type; + Key : String); + -- The Connection embeded in D, will be put back in the pool + -- if found, otherwise the connection in D will be close + -- when D is finalized. + -- This procedure is called when D is Finalized. + -- An exception is raised if D doesn't come from the pool. + + procedure Close + (Key : String); + -- release all the connection refenced by the Key. + -- do nothing if Key is not found. + + procedure Close; + -- close the pool of connections. + + function Is_Empty (Key : String) return Boolean; + -- Return True if the Key is not found or Contains no connections + -- at all. + + function Total_Length (Key : String) return Count_Type; + -- Return the total number of connection per key. + + function In_Length (Key : String) return Count_Type; + -- Return the number of connection ready to be used. + -- (never out or put back via the put procedure or finalization) + + function Out_Length (Key : String) return Count_Type; + -- Return the number of connection already in use + -- (going out with the get procedure) + +private + + type Connection_Type is new + Ada.Finalization.Controlled with + record + Connection : Backlit.Thin.A_PGCONN_T; + Connection_Info : Ada.Strings.Unbounded.Unbounded_String; + In_Use : Boolean; + end record; + + procedure Initialize (C : in out Connection_Type); + -- procedure Adjust (C : in out Connection_Type); + -- procedure Finalize (C : in out Connection_Type); + + function "=" (Left, Right : Connection_Type) return Boolean; + + function Is_Connected + (C : Connection_Type) return Boolean; + + procedure Connect + (C : in out Connection_Type); + + procedure Connect + (C : in out Connection_Type; + Connection_Info : String); + + + package Connection_List is new Ada.Containers.Doubly_Linked_Lists + (Element_Type => Connection_Type, + "=" => "="); + use Connection_List; + + type Connection_List_Type is + record + L : Connection_List.List; + In_Length : Count_Type; + Out_Length : Count_Type; + end record; + + package Connection_Maps is + new Ada.Containers.Indefinite_Hashed_Maps + (Key_Type => String, + Element_Type => Connection_List_Type, + Hash => Ada.Strings.Hash, + Equivalent_Keys => "="); + use Connection_Maps; + + type DBD_Map_Type is new + Ada.Finalization.Limited_Controlled with + record + Map : Connection_Maps.Map; + end record; + + protected Session_DBD_Type is + + procedure Open + (D : in DBD_Type; + Key : String; + Capacity : Positive); + + procedure Open + (Connection_Info : String; + Key : String; + Capacity : Positive); + + procedure Get + (D : out DBD_Type; + Key : String; + Reserve : Positive); + + procedure Put + (D : in out DBD_Type; + Key : String); + + procedure Close + (Key : String); + + procedure Delete + (Key : String); + + procedure Close; + + function Is_Empty + (Key : String) return Boolean; + + function Total_Length + (Key : String) return Count_Type; + + function In_Length + (Key : String) return Count_Type; + + function Out_Length + (Key : String) return Count_Type; + + private + Pool : DBD_Map_Type; + + end Session_DBD_Type; + +end Backlit.Postgres.Pool; diff --git a/src/backlit-postgres.adb b/src/backlit-postgres.adb new file mode 100644 index 0000000..2a5178f --- /dev/null +++ b/src/backlit-postgres.adb @@ -0,0 +1,782 @@ +------------------------------------------------------------------------------ +-- -- +-- Copyright 2008, Ali Bendriss -- +-- -- +-- This file is part of Backlit. -- +-- -- +-- Backlit is free software: you can redistribute it and/or modify it under -- +-- the terms of the GNU Lesser General Public License as published by -- +-- the Free Software Foundation, either version 3 of the License, or -- +-- (at your option) any later version. -- +-- -- +-- Backlit is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of -- +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- +-- GNU Lesser General Public License for more details. -- +-- -- +-- You should have received a copy of the GNU Lesser General Public License -- +-- along with Backlit. If not, see . -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; +with Interfaces.C.Strings; +with Ada.Strings.Unbounded; +with Ada.Characters.Handling; +with Backlit.Postgres.Pool; +-- with Ada.Text_IO; use Ada.Text_IO; + +package body Backlit.Postgres is + + use Connection_Info_Map; + use Backlit.Thin; + use Ada.Exceptions; + + ------------------------- + -- -- + ------------------------- + procedure Connection_Map_To_Unbounded_String + (C : in out DBD_Type; + I : out Ada.Strings.Unbounded.Unbounded_String) + is + use Ada.Strings.Unbounded; + use Interfaces.C; + use Interfaces.C.Strings; + TMP_US : Unbounded_String; + procedure Append_Info (C : Connection_Info_Map.Cursor) is + begin + Ada.Strings.Unbounded.Append + (TMP_US, Connection_Info_Map.Element (C) & " "); + end Append_Info; + begin + Connection_Info_Map.Iterate (C.Map, Append_Info'Access); + --Connection_Info_Map.Clear (C.Map); + I := TMP_US; + end Connection_Map_To_Unbounded_String; + pragma Inline (Connection_Map_To_Unbounded_String); + + procedure To_C_Binded_Parameter_Value + (S : DBD_Type; + O : out Pg_ParamValues) is + use Interfaces.C; + use type Ada.Containers.Count_Type; + + Map_Length : Positive := Natural (Stm_Map.Length (S.Parameter)); + Index : size_t; + begin + if Stm_Map.Last_Key (S.Parameter) /= S.Param_Length then + Raise_Exception (Error'Identity, "wrong bind key parameter"); + end if; + for I in 1 .. Map_Length loop + Index := size_t (I - 1); + O (Index) := Strings.New_Char_Array + (To_C (Stm_Map.Element (S.Parameter, I))); + end loop; + end To_C_Binded_Parameter_Value; + pragma Inline (To_C_Binded_Parameter_Value); + + -------------------------- + -- Connection Control -- + -------------------------- + + procedure Set_Host_Name + (D : in out DBD_Type; Value : String) + is + begin + D.Map.Insert ("host", "host=" & Value); + end Set_Host_Name; + + procedure Set_Host_Address + (D : in out DBD_Type; Value : String) + is + begin + D.Map.Insert ("hostaddr", "hostaddr=" & Value); + end Set_Host_Address; + + procedure Set_Port + (D : in out DBD_Type; Value : String) + is + begin + D.Map.Insert ("port", "port=" & Value); + end Set_Port; + + procedure Set_Db_Name + (D : in out DBD_Type; Value : String) + is + begin + D.Map.Insert ("dbname", "dbname=" & Value); + end Set_Db_Name; + + procedure Set_User_Name + (D : in out DBD_Type; Value : String) + is + begin + D.Map.Insert ("user", "user=" & Value); + end Set_User_Name; + + procedure Set_User_Password + (D : in out DBD_Type; Value : String) + is + begin + D.Map.Insert ("password", "password=" & Value); + end Set_User_Password; + + procedure Set_Timeout + (D : in out DBD_Type; Value : Natural) + is + begin + D.Map.Insert ("connect_timeout", "connect_timeout=" & Value'Img); + end Set_Timeout; + + procedure Set_Options + (D : in out DBD_Type; Value : String) + is + begin + D.Map.Insert ("options", "options=" & Value); + end Set_Options; + + procedure Set_SSL + (D : in out DBD_Type; Value : SSL_Mode_Type) + is + + function PQ_Value (SSL : SSL_Mode_Type) return String + is + begin + case SSL is + when Disable => return "disable"; + when Allow => return "allow"; + when Prefer => return "prefer"; + when Require => return "require"; + end case; + end PQ_Value; + begin + D.Map.Insert ("sslmode", "sslmode=" & PQ_Value (Value)); + end Set_SSL; + + procedure Set_Krbsrvname + (D : in out DBD_Type; Value : String) + is + begin + D.Map.Insert ("krbsrvname", "options=" & Value); + end Set_Krbsrvname; + + procedure Set_Gssapi + (D : in out DBD_Type) + is + begin + D.Map.Insert ("gsslib", "gsslib=gssapi"); + end Set_Gssapi; + + procedure Set_Service_Name + (D : in out DBD_Type; Value : String) + is + begin + D.Map.Insert ("service", "service=" & Value); + end Set_Service_Name; + + procedure Connect + (D : in out DBD_Type) + is + CI : Ada.Strings.Unbounded.Unbounded_String; + use Interfaces.C.Strings; + begin + if Is_Connected (D) then + return; + end if; + if Is_Empty (D.Map) then + Connect (D, Ada.Strings.Unbounded.To_String (D.Connection_Info)); + else + Connection_Map_To_Unbounded_String (D, CI); + Connect (D, Ada.Strings.Unbounded.To_String (CI)); + end if; + end Connect; + + procedure Connect + (D : in out DBD_Type; Connection_Info : String) + is + CI : Interfaces.C.Strings.chars_ptr; + use Interfaces.C.Strings; + use Interfaces.C.Strings; + begin + if Is_Connected (D) then + return; + end if; + + CI := New_Char_Array (Interfaces.C.To_C (Connection_Info)); + D.Real := Backlit.Thin.PQCONNECTDB (CI); + if CI /= Null_Ptr then + Interfaces.C.Strings.Free (CI); + end if; + if PQSTATUS (D.Real) /= CONNECTION_OK then + Raise_Exception (Error'Identity, Error_Message (D)); + end if; + D.Connection_Info := + Ada.Strings.Unbounded.To_Unbounded_String (Connection_Info); + end Connect; + + procedure Reset + (D : in out DBD_Type) + is + begin + PQRESET (D.Real); + if PQSTATUS (D.Real) /= CONNECTION_OK then + Raise_Exception (Error'Identity, Error_Message (D)); + end if; + end Reset; + + procedure Connect_Non_Blocking + (D : in out DBD_Type) + is + begin + pragma Assert (False, "Connect_Non_Blocking not implemented"); + null; + end Connect_Non_Blocking; + + procedure Reset_Non_Blocking + (D : in out DBD_Type) + is + begin + pragma Assert (False, "Reset_Non_Blocking not implemented"); + null; + end Reset_Non_Blocking; + + ------------------------- + -- Connection Status -- + ------------------------- + + function Get + (D : DBD_Type; + Q : Connection_Key_Type) return String + is + begin + case Q is + when DB_Name => + return Interfaces.C.Strings.Value (PQDB (D.Real)); + when DB_User => + return Interfaces.C.Strings.Value (PQUSER (D.Real)); + when DB_Pass => + return Interfaces.C.Strings.Value (PQPASS (D.Real)); + when DB_Host => + return Interfaces.C.Strings.Value (PQHOST (D.Real)); + when DB_Port => + return Interfaces.C.Strings.Value (PQPORT (D.Real)); + when DB_Options => + return Interfaces.C.Strings.Value (PQOPTIONS (D.Real)); + end case; + end Get; + + function Error_Message (D : in DBD_Type) return String + is + begin + return Interfaces.C.Strings.Value (PQERRORMESSAGE (D.Real)); + exception + when others => + return "unrecognized error"; + end Error_Message; + + function Current_Server_Setting + (D : DBD_Type; + Key : String; + To_Lower : Boolean := True) return String + is + Param : Interfaces.C.Strings.chars_ptr; + Real_Key : String := Key; + begin + if To_Lower = True then + Real_Key := Ada.Characters.Handling.To_Lower (Key); + end if; + Param := Interfaces.C.Strings.New_Char_Array + (Interfaces.C.To_C (Real_Key)); + declare + Result : String := Interfaces.C.Strings.Value + (PQPARAMETERSTATUS (D.Real, Param)); + begin + Interfaces.C.Strings.Free (Param); + return Result; + end; + exception + when others => return ""; + end Current_Server_Setting; + + function Needs_Password + (D : DBD_Type) return Boolean + is + use type Interfaces.C.int; + begin + return PQCONNECTIONNEEDSPASSWORD (D.Real) = C_True; + end Needs_Password; + + function Used_Password + (D : DBD_Type) return Boolean + is + use type Interfaces.C.int; + begin + return PQCONNECTIONUSEDPASSWORD (D.Real) = C_True; + end Used_Password; + + function Is_Connected + (D : DBD_Type) return Boolean + is + begin + return PQSTATUS (D.Real) = CONNECTION_OK; + end Is_Connected; + + ------------------------- + -- Command Execution -- + ------------------------- + + + procedure Append_Command + (D : in out DBD_Type; + Q : String) + is + use Ada.Strings.Unbounded; + begin + D.Command := D.Command & Q & " "; + end Append_Command; + + procedure Bind_Parameter + (D : in out DBD_Type; + Key : Positive; + Value : String) + is + use type Interfaces.C.int; + begin + Stm_Map.Insert (D.Parameter, Key, Value); + D.Param_Length := D.Param_Length + 1; + end Bind_Parameter; + + procedure Exec + (D : in out DBD_Type; + R : out Result_Type'Class) + is + use Interfaces.C; + use type Interfaces.C.Strings.chars_ptr; + use type Thin.ExecStatusType; + use type Thin.A_PGRESULT_T; + Command : Strings.chars_ptr; + begin + Command := Strings.New_Char_Array + (To_C (Ada.Strings.Unbounded.To_String (D.Command))); + if Stm_Map.Is_Empty (D.Parameter) then + -- exec without parameters + R.Pg_Result := Thin.PQEXEC (D.Real, Command); + else + -- exec with parameters + declare + Pg_Param : Pg_ParamValues (0 .. size_t (D.Param_Length - 1)) := + (others => Interfaces.C.Strings.Null_Ptr); + begin + To_C_Binded_Parameter_Value (D, Pg_Param); + R.Pg_Result := Thin.PQEXECPARAMS + (D.Real, Command, int (D.Param_Length), + null, Pg_Param (0)'Access, null, null, 0); + for I in Pg_Param'Range loop + Interfaces.C.Strings.Free (Pg_Param (I)); + end loop; + end; + end if; + + if Command /= Strings.Null_Ptr then + Interfaces.C.Strings.Free (Command); + end if; + + Stm_Map.Clear (D.Parameter); + D.Param_Length := 0; + D.Command := Ada.Strings.Unbounded.Null_Unbounded_String; + + if R.Pg_Result = null then + Raise_Exception (Error'Identity, Error_Message (D)); + -- S.Pg_Result so we use the last Error message available + -- in the connection + end if; + if Thin.PQRESULTSTATUS (R.Pg_Result) /= Thin.PGRES_COMMAND_OK and then + Thin.PQRESULTSTATUS (R.Pg_Result) /= Thin.PGRES_TUPLES_OK then + -- FIXME test that rules with command returning data + -- and command returning no data. + Raise_Exception (Query_Error'Identity, Error_Message (R)); + end if; + end Exec; + + procedure Prepare + (D : in out DBD_Type; + Prepared_Stm_Name : String := ""; + Number_Of_Parameter : Natural := 0) + is + use Interfaces.C; + use type Interfaces.C.Strings.chars_ptr; + use type Thin.ExecStatusType; + use type Thin.A_PGRESULT_T; + Command : Strings.chars_ptr; + Stm_Name : Strings.chars_ptr; + NParams : constant int := int (Number_Of_Parameter); + R : Result_Type; + begin + Command := Strings.New_Char_Array + (To_C (Ada.Strings.Unbounded.To_String (D.Command))); + Stm_Name := Strings.New_Char_Array + (To_C (Prepared_Stm_Name)); + + R.Pg_Result := Thin.PQPREPARE (D.Real, Stm_Name, Command, NParams, null); + + D.Command := Ada.Strings.Unbounded.Null_Unbounded_String; + + if Command /= Strings.Null_Ptr then + Interfaces.C.Strings.Free (Command); + end if; + if Stm_Name /= Strings.Null_Ptr then + Interfaces.C.Strings.Free (Stm_Name); + end if; + + if R.Pg_Result = null then + Raise_Exception (Error'Identity, Error_Message (D)); + -- S.Pg_Result so we use the last Error message available + -- in the connection + end if; + if Thin.PQRESULTSTATUS (R.Pg_Result) /= Thin.PGRES_COMMAND_OK then + Raise_Exception (Query_Error'Identity, Error_Message (R)); + end if; + end Prepare; + + procedure Exec + (D : in out DBD_Type; + R : out Result_Type'Class; + Prepared_Stm_Name : String) + is + use Interfaces.C; + use type Interfaces.C.Strings.chars_ptr; + use type Thin.ExecStatusType; + use type Thin.A_PGRESULT_T; + Stm_Name : Strings.chars_ptr; + Param_Last : Natural := D.Param_Length; + begin + Stm_Name := Strings.New_Char_Array + (To_C (Prepared_Stm_Name)); + if Param_Last > 0 then + Param_Last := Param_Last - 1; + end if; + declare + Pg_Param : Pg_ParamValues (0 .. size_t (Param_Last)) := + (others => Interfaces.C.Strings.Null_Ptr); + begin + if D.Param_Length > 0 then + To_C_Binded_Parameter_Value (D, Pg_Param); + end if; + R.Pg_Result := Thin.PQEXECPREPARED + (D.Real, Stm_Name, int (D.Param_Length), + Pg_Param (0)'Access, null, null, 0); + for I in Pg_Param'Range loop + Interfaces.C.Strings.Free (Pg_Param (I)); + end loop; + end; + Stm_Map.Clear (D.Parameter); + D.Param_Length := 0; + if Stm_Name /= Strings.Null_Ptr then + Interfaces.C.Strings.Free (Stm_Name); + end if; + if R.Pg_Result = null then + Raise_Exception (Error'Identity, Error_Message (D)); + -- S.Pg_Result so we use the last Error message available + -- in the connection + end if; + if Thin.PQRESULTSTATUS (R.Pg_Result) /= Thin.PGRES_COMMAND_OK then + Raise_Exception (Query_Error'Identity, Error_Message (R)); + end if; + end Exec; + + function Error_Message (R : Result_Type) return String + is + begin + return Interfaces.C.Strings.Value + (Thin.PQRESULTERRORMESSAGE (R.Pg_Result)); + exception + when others => + return "unknow error."; + end Error_Message; + + function Status (R : Result_Type) return Exec_Status_Type + is + C_Result : ExecStatusType; + begin + C_Result := Thin.PQRESULTSTATUS (R.Pg_Result); + return Exec_Status_Type'Val (Thin.ExecStatusType'Pos (C_Result)); + end Status; + + ------------------------------------------- + -- Retrieving Query Result Information -- + ------------------------------------------- + + + function N_Tuples (R : Result_Type) return Tuples_Type + is + Result : Tuples_Type := + Tuples_Type (Thin.PQNTUPLES (R.Pg_Result)); + begin + return Result; + end N_Tuples; + + function First_Tuples (R : Result_Type) return Tuples_Type + is + begin + return 0; + end First_Tuples; + + function Last_Tuples (R : Result_Type) return Tuples_Type + is + begin + return N_Tuples (R) - 1; + end Last_Tuples; + + + function N_Fields (R : Result_Type) return Fields_Type + is + Result : Fields_Type := + Fields_Type (Thin.PQNFIELDS (R.Pg_Result)); + begin + return Result; + end N_Fields; + + function First_Fields (R : Result_Type) return Fields_Type + is + begin + return 0; + end First_Fields; + + function Last_Fields (R : Result_Type) return Fields_Type + is + begin + return N_Fields (R) - 1; + end Last_Fields; + + function F_Name + (R : Result_Type; + Column_Number : Fields_Type) + return String + is + use Interfaces.C; + Result : String := Interfaces.C.Strings.Value + (Thin.PQFNAME (R.Pg_Result, int (Column_Number))); + begin + return Result; + end F_Name; + + function F_Number + (R : Result_Type; + Column_Name : String) + return Fields_Type + is + use Interfaces.C; + use type Interfaces.C.Strings.chars_ptr; + C_Column_Name : Strings.chars_ptr := + Strings.New_Char_Array (To_C (Column_Name)); + Result : Fields_Type := + Fields_Type (Thin.PQFNUMBER (R.Pg_Result, C_Column_Name)); + begin + if C_Column_Name /= Strings.Null_Ptr then + Interfaces.C.Strings.Free (C_Column_Name); + end if; + return Result; + end F_Number; + + + function F_Table + (R : Result_Type; + Column_Number : Fields_Type) return Oid + is + use Interfaces.C; + Result : Oid := + Oid (Thin.PQFTABLE (R.Pg_Result, int (Column_Number))); + begin + return Result; + end F_Table; + + function F_Table_Col + (R : Result_Type; + Column_Number : Fields_Type) return Fields_Type + is + use Interfaces.C; + Result : Fields_Type := + Fields_Type (Thin.PQFTABLECOL (R.Pg_Result, int (Column_Number))); + begin + return Result; + end F_Table_Col; + + function F_Format + (R : Result_Type; + Column_Number : Fields_Type) return Format_Code_Type + is + use Interfaces.C; + Result : Format_Code_Type := + Format_Code_Type (Thin.PQFFORMAT (R.Pg_Result, int (Column_Number))); + begin + return Result; + end F_Format; + + function F_Type + (R : Result_Type; + Column_Number : Fields_Type) return Oid + is + use Interfaces.C; + Result : Oid := + Oid (Thin.PQFTYPE (R.Pg_Result, int (Column_Number))); + begin + return Result; + end F_Type; + + function F_Mod + (R : Result_Type; + Column_Number : Fields_Type) return Modifier_Type + is + use Interfaces.C; + Result : Modifier_Type := + Modifier_Type (Thin.PQFMOD (R.Pg_Result, int (Column_Number))); + begin + return Result; + end F_Mod; + + function F_Size + (R : Result_Type; + Column_Number : Fields_Type) return Size_Type + is + use Interfaces.C; + Result : Size_Type := + Size_Type (Thin.PQFSIZE (R.Pg_Result, int (Column_Number))); + begin + return Result; + end F_Size; + + function Get_Value + (R : Result_Type; + Row_Number : Tuples_Type; + Column_Number : Fields_Type) return String + is + use Interfaces.C; + use type Interfaces.C.Strings.chars_ptr; + C_Result : Strings.chars_ptr := + Thin.PQGETVALUE (R.Pg_Result, + int (Row_Number), + int (Column_Number)); + Result : String := Strings.Value (C_Result); + -- The caller should not free the result directly. + -- It will be freed when the associated PGresult handle + -- is passed to PQclear. + begin + return Result; + end Get_Value; + + function Get_Is_Null + (R : Result_Type; + Row_Number : Tuples_Type; + Column_Number : Fields_Type) return Boolean + is + use Interfaces.C; + C_Result : int := Thin.PQGETISNULL (R.Pg_Result, + int (Row_Number), + int (Column_Number)); + begin + return C_Result = Thin.C_True; + end Get_Is_Null; + + function Getlength + (R : Result_Type; + Row_Number : Tuples_Type; + Column_Number : Fields_Type) return Length_Type + is + use Interfaces.C; + Result : Length_Type := + Length_Type (Thin.PQGETLENGTH (R.Pg_Result, + int (Row_Number), + int (Column_Number))); + begin + return Result; + end Getlength; + + function N_Params (R : Result_Type) return Param_Number_Type + is + use Interfaces.C; + Result : Param_Number_Type := + Param_Number_Type (Thin.PQNPARAMS (R.Pg_Result)); + begin + return Result; + end N_Params; + + function Param_Type + (R : Result_Type; + Param_Number : Param_Number_Type) return Oid + is + use Interfaces.C; + Result : Oid := + Oid (Thin.PQPARAMTYPE (R.Pg_Result, int (Param_Number))); + begin + return Result; + end Param_Type; + + ---------------- + -- private -- + ---------------- + + procedure Initialize (D : in out DBD_Type) + is + begin + -- Put_Line ("Initialize"); + D.Real := null; + Connection_Info_Map.Clear (D.Map); + D.Command := Ada.Strings.Unbounded.Null_Unbounded_String; + Stm_Map.Clear (D.Parameter); + D.Param_Length := 0; + D.Connection_Info := Ada.Strings.Unbounded.Null_Unbounded_String; + D.Pooled := False; + D.Key := Ada.Strings.Unbounded.Null_Unbounded_String; + + -- D.Command := Ada.Strings.Unbounded.Null_Unbounded_String; + -- Stm_Map.Clear (D.Parameter); + -- D.Param_Length := 0; + -- Put_Line ("Initialized"); + end Initialize; + + procedure Adjust (D : in out DBD_Type) + is + Connection_Info : String := + Ada.Strings.Unbounded.To_String (D.Connection_Info); + begin + -- Put_Line ("Adjust"); + D.Real := null; + D.Pooled := False; + -- Connect (D, Connection_Info); + -- Put_Line ("Adjusted"); + end Adjust; + + procedure Finalize (D : in out DBD_Type) + is + begin + -- Put_Line ("Finalize"); + Stm_Map.Clear (D.Parameter); + D.Param_Length := 0; + if D.Real /= null then + if D.Pooled then + Backlit.Postgres.Pool.Put + (D,Ada.Strings.Unbounded.To_String (D.Key)); + else + PQFINISH (D.Real); + D.Real := null; + end if; + end if; + -- Put_Line ("Finalized"); + end Finalize; + + procedure Initalize (R : in out Result_Type) + is + begin + R.Pg_Result := null; + end Initalize; + + procedure Finalize (R : in out Result_Type) + is + begin + if R.Pg_Result /= null then + Thin.PQCLEAR (R.Pg_Result); + R.Pg_Result := null; + end if; + end Finalize; + +end Backlit.Postgres; diff --git a/src/backlit-client-statment.ads b/src/backlit-postgres.ads similarity index 53% rename from src/backlit-client-statment.ads rename to src/backlit-postgres.ads index c527cf8..19aaa96 100644 --- a/src/backlit-client-statment.ads +++ b/src/backlit-postgres.ads @@ -19,23 +19,204 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Strings.Unbounded; -with Ada.Containers.Indefinite_Ordered_Maps; +with Ada.Finalization; +private with Ada.Containers.Indefinite_Hashed_Maps; +private with Ada.Strings.Hash; +private with Ada.Strings.Unbounded; +private with Ada.Containers.Indefinite_Ordered_Maps; private with Interfaces.C; private with Interfaces.C.Strings; -package Backlit.Client.Statment is +with Backlit.Thin; + +package Backlit.Postgres is + + type DBD_Type is new + Ada.Finalization.controlled with private; + + type Result_Type is new + Ada.Finalization.Limited_Controlled with private; + + -------------------------- + -- Connection Control -- + -------------------------- + + procedure Set_Host_Name + (D : in out DBD_Type; Value : String); + -- Name of Host To Connect To. + -- If this Begins with a slash, it specifies Unix-Domain Communication + -- rather than TCP/IP communication. The Value is the Name of the Directory + -- in which the socket file is stored. + -- The default behavior when host is not specified is to connect to + -- A Unix-Domain Socket in /tmp (or whatever socket directory was specified + -- when PostgreSQL was built). + -- On machines without Unix-Domain Sockets, + -- the default is to connect to localhost. + + procedure Set_Host_Address + (D : in out DBD_Type; Value : String); + -- Numeric IP address of host to connect to. + -- This should be in the standard IPv4 address format, e.g., 172.28.40.9. + -- if your machine supports IPv6, you can also use those addresses. + -- TCP/IP communication is always used when a nonempty string + -- is specified for this parameter. + + procedure Set_Port + (D : in out DBD_Type; Value : String); + -- Port number to connect to at the server host, + -- or socket file name extension for Unix-Domain Connections. + + procedure Set_Db_Name + (D : in out DBD_Type; Value : String); + -- The database name. Defaults to be the same as the user name. + + procedure Set_User_Name + (D : in out DBD_Type; Value : String); + -- PostgreSQL user name to connect as. + -- Defaults to be the same as the operating system name of the user + -- running the application. + + procedure Set_User_Password + (D : in out DBD_Type; Value : String); + -- Password to be used if the server demands password authentication. + + procedure Set_Timeout + (D : in out DBD_Type; Value : Natural); + -- Maximum wait for connection, in seconds (write as a Decimal). + -- Zero or not specified means wait indefinitely. + -- It is not recommended to use a timeout of less than 2 seconds. + + procedure Set_Options + (D : in out DBD_Type; Value : String); + -- Command-line options to be sent to the server. + + type SSL_Mode_Type is (Disable, Allow, Prefer, Require); + + procedure Set_SSL + (D : in out DBD_Type; Value : SSL_Mode_Type); + -- This option determines whether or + -- with what priority an SSL Connection will be Negotiated + -- with the server. There are four modes: + -- * Disable will attempt only an unencrypted SSL Connection; + -- * Allow will negotiate, trying first a non-SSL connection, + -- then if that fails, trying an SSL connection; + -- * Prefer (the default) will negotiate, trying first an SSL connection, + -- then if that fails, trying a regular non-SSL connection; + -- * Require will try only an SSL connection. + -- if PostgreSQL is compiled without SSL support, + -- using option Require will cause an error, + -- while options Allow and Prefer will be accepted but + -- will not in fact attempt an SSL connection. + + procedure Set_Krbsrvname + (D : in out DBD_Type; Value : String); + -- Kerberos service name to use when authenticating with + -- Kerberos 5 or GSSAPI. + -- This must match the service name specified in the server + -- configuration for Kerberos authentication to Succeed. + + procedure Set_Gssapi + (D : in out DBD_Type); + -- Only Used On Windows. + -- Set_Gssapi force the use the GSSAPI library for Authentication + -- instead of the default SSPI. + + procedure Set_Service_Name + (D : in out DBD_Type; Value : String); + -- Service name to use for additional parameters. + -- It specifies a service name in pg_service.conf that holds additional + -- connection parameters. This allows applications to Specify only a + -- service name so connection parameters can be centrally maintained. + + procedure Connect + (D : in out DBD_Type); + -- Makes a new connection to the database server. + -- return if already connected. + + procedure Connect + (D : in out DBD_Type; Connection_Info : String); + -- Makes a new connection to the database server. + -- Take the connection info from a string like + -- "host=localhost user=postgres dbname=template1 ..." + -- rather than using the procedure Set_Host_Name or Set_Host_Address. + -- You can't mix the two ways on the same connection. + -- return if already connected. + + procedure Reset + (D : in out DBD_Type); + -- This procedure will close the connection to the server and + -- attempt to reestablish a new connection to the same server, + -- using all the same parameters previously used. + -- This might be useful for error recovery if a working connection is lost. + + + procedure Connect_Non_Blocking + (D : in out DBD_Type); + -- Make a connection to the database server in a nonblocking manner. + + procedure Reset_Non_Blocking + (D : in out DBD_Type); + -- This procedure will close the connection to the server and + -- attempt to reestablish a new connection to the same server, + -- using all the same parameters previously used. + -- This can be useful for error recovery if a working connection is lost. + -- It differ from reset (above) in that it act in a nonblocking manner. + + + ------------------------- + -- Connection Status -- + ------------------------- + type Connection_Key_Type is + (DB_Name, DB_User, DB_Pass, DB_Host, DB_Port, DB_Options); + + function Get + (D : DBD_Type; + Q : Connection_Key_Type) return String; + -- The following functions return parameter values established at + -- connection. These values are fixed for the life of the PGconn object. + + function Error_Message (D : in DBD_Type) return String; + -- Returns the error message most recently generated by + -- an operation on the connection. + + function Current_Server_Setting + (D : DBD_Type; + Key : String; + To_Lower : Boolean := True) return String; + -- Certain parameter values are reported by the server automatically + -- at connection startup or whenever their values change. + -- this function can be used to interrogate these settings. + -- It returns the current value of a parameter if known, + -- or an empty string if the parameter is not known. + -- key looks like : server_version, server_encoding... + -- check the doc for Parameters reported as of the current release. + + function Needs_Password + (D : DBD_Type) return Boolean; + -- Returns true if the connection authentication method + -- required a password, but none was available. + -- This function can be applied after a failed connection attempt + -- to decide whether to prompt the user for a password. + + function Used_Password + (D : DBD_Type) return Boolean; + -- This function detects whether a password supplied to the connection + -- function was actually used. Passwords obtained from other sources + -- (such as the .pgpass file) are not considered caller-supplied. + + function Is_Connected + (D : DBD_Type) return Boolean; + -- return True is the connection status is OK. + ------------------------- -- Command Execution -- ------------------------- - type Statment_Object_Type is new - Ada.Finalization.Limited_Controlled with private; procedure Append_Command - (S : in out Statment_Object_Type; - Q : String); + (D : in out DBD_Type; + Q : String); -- The SQL command string to be executed. -- If parameters are used, -- they are referred to in the command string as $1, $2, etc. @@ -43,7 +224,7 @@ package Backlit.Client.Statment is -- are referred as 1, 2, etc procedure Bind_Parameter - (S : in out Statment_Object_Type; + (D : in out DBD_Type; Key : Positive; Value : String); -- If paramaters a set then exec will run Thin.PQexecParams @@ -58,15 +239,14 @@ package Backlit.Client.Statment is -- against SQL-injection attacks. procedure Exec - (S : in out Statment_Object_Type; - C : Connection_Object_Type); + (D : in out DBD_Type; + R : out Result_Type'Class); -- Submits a command to the server and waits for the result, -- with the ability to pass parameters separately -- from the SQL command text by using the Bind_Parameter procedure procedure Prepare - (S : in out Statment_Object_Type; - C : Connection_Object_Type; + (D : in out DBD_Type; Prepared_Stm_Name : String := ""; Number_Of_Parameter : Natural := 0); -- Creates a prepared statement named Prepared_Stm_Name @@ -79,13 +259,13 @@ package Backlit.Client.Statment is -- as $1, $2, etc. Number_Of_Parameter is their number. procedure Exec - (S : in out Statment_Object_Type; - C : Connection_Object_Type; + (D : in out DBD_Type; + R : out Result_Type'Class; Prepared_Stm_Name : String); -- Same as the Exec procedure but take a prepared statment name -- as parameter to run a prepared statment using Prepare. - function Error_Message (S : Statment_Object_Type) return String; + function Error_Message (R : Result_Type) return String; -- Returns the error message associated with the command, -- or an empty string if there was no error. @@ -110,7 +290,7 @@ package Backlit.Client.Statment is -- A fatal error occurred. ); - function Status (S : Statment_Object_Type) return Exec_Status_Type; + function Status (R : Result_Type) return Exec_Status_Type; -- If the result status is PGRES_TUPLES_OK, then the functions described -- below can be used to retrieve the rows returned by the query. -- Note that a SELECT command that happens to retrieve zero rows @@ -127,29 +307,50 @@ package Backlit.Client.Statment is ------------------------------------------- subtype Oid is Thin.Oid range Thin.Oid'Range; + InvalidOid : constant Oid := 0; type Tuples_Type is new Integer; - function N_Tuples (S : Statment_Object_Type) return Tuples_Type; + + function N_Tuples (R : Result_Type) return Tuples_Type; -- Returns the number of rows (tuples) in the query result. -- Because it returns an integer result, -- large result sets might overflow the return value on 32-bit -- operating systems. -- FIXME change it for Long_integer for 64 Bit os ??? (in thin as well) + function First_Tuples (R : Result_Type) return Tuples_Type; + + function Last_Tuples (R : Result_Type) return Tuples_Type; + -- Returns the First/Last row (tuples) in the query result. + -- May be used to loop : + -- for First_Tuples (R) .. Last_Tuples (R) loop + -- ... + -- end loop; + type Fields_Type is new Integer; - function N_Fields (S : Statment_Object_Type) return Fields_Type; + + function N_Fields (R : Result_Type) return Fields_Type; -- Returns the number of columns (fields) in each row of the query result. + function First_Fields (R: Result_Type) return Fields_Type; + + function Last_Fields (R: Result_Type) return Fields_Type; + -- Returns the First/Last columns (fields) of the query result. + -- May be used to loop : + -- for First_Fields (R) .. Last_Fields (R) loop + -- ... + -- end loop; + function F_Name - (S : Statment_Object_Type; + (R : Result_Type; Column_Number : Fields_Type) return String; -- Returns the column name associated with the given column number. -- Column numbers start at 0. function F_Number - (S : Statment_Object_Type; + (R : Result_Type; Column_Name : String) return Fields_Type; -- Returns the column number associated with the given column name. @@ -158,7 +359,7 @@ package Backlit.Client.Statment is -- that is, it is downcased unless double-quoted. function F_Table - (S : Statment_Object_Type; + (R : Result_Type; Column_Number : Fields_Type) return Oid; -- Returns the OID of the table from which the given column was fetched. -- Column numbers start at 0. @@ -168,7 +369,7 @@ package Backlit.Client.Statment is -- to determine exactly which table is referenced. function F_Table_Col - (S : Statment_Object_Type; + (R : Result_Type; Column_Number : Fields_Type) return Fields_Type; -- Returns the column number (within its table) of the column making up the -- specified query result column. Query-result column numbers start at 0, @@ -178,8 +379,9 @@ package Backlit.Client.Statment is -- or when using pre-3.0 protocol. type Format_Code_Type is new Integer; + function F_Format - (S : Statment_Object_Type; + (R : Result_Type; Column_Number : Fields_Type) return Format_Code_Type; -- Returns the format code indicating the format of the given column. -- Column numbers start at 0. Format code zero indicates textual data @@ -187,7 +389,7 @@ package Backlit.Client.Statment is -- (Other codes are reserved for future definition.) function F_Type - (S : Statment_Object_Type; + (R : Result_Type; Column_Number : Fields_Type) return Oid; -- Returns the data type associated with the given column number. -- The value returned is the internal OID number of the type. @@ -197,8 +399,9 @@ package Backlit.Client.Statment is -- src/include/catalog/pg_type.h in the source tree. type Modifier_Type is new Integer; + function F_Mod - (S : Statment_Object_Type; + (R : Result_Type; Column_Number : Fields_Type) return Modifier_Type; -- Returns the type modifier of the column associated with the -- given column number. Column numbers start at 0. The interpretation @@ -209,10 +412,10 @@ package Backlit.Client.Statment is -- in which case the value is always -1. type Size_Type is new Integer; + function F_Size - (S : Statment_Object_Type; + (R : Result_Type; Column_Number : Fields_Type) return Size_Type; - -- Returns the size in bytes of the column associated with the given -- column number. Column numbers start at 0. Fsize returns the space -- allocated for this column in a database row, in other words the size @@ -221,63 +424,85 @@ package Backlit.Client.Statment is -- A negative value indicates the data type is variable-length. function Get_Value - (S : Statment_Object_Type; + (R : Result_Type; Row_Number : Tuples_Type; Column_Number : Fields_Type) return String; -- Returns a single field value of one row of a PGresult. -- Row and column numbers start at 0. function Get_Is_Null - (S : Statment_Object_Type; + (R : Result_Type; Row_Number : Tuples_Type; Column_Number : Fields_Type) return Boolean; -- Tests a field for a null value. Row and column numbers start at 0. type Length_Type is new Integer; function Getlength - (S : Statment_Object_Type; + (R : Result_Type; Row_Number : Tuples_Type; Column_Number : Fields_Type) return Length_Type; -- Returns the actual length of a field value in bytes. -- Row and column numbers start at 0. type Param_Number_Type is new Integer range 0 .. Integer'Last; - function N_Params (S : Statment_Object_Type) return Param_Number_Type; + + function N_Params (R : Result_Type) return Param_Number_Type; -- Returns the number of parameters of a prepared statement. -- This function is only useful when inspecting the result of -- PQdescribePrepared. For other types of queries it will return zero. function Param_Type - (S : Statment_Object_Type; + (R : Result_Type; Param_Number : Param_Number_Type) return Oid; -- Returns the data type of the indicated statement parameter. -- Parameter numbers start at 0. -- This function is only useful when inspecting the result of -- PQdescribePrepared. For other types of queries it will return zero. - - - private + package Connection_Info_Map is + new Ada.Containers.Indefinite_Hashed_Maps + (Key_Type => String, + Element_Type => String, + Hash => Ada.Strings.Hash, + Equivalent_Keys => "="); + package Stm_Map is new Ada.Containers.Indefinite_Ordered_Maps (Key_Type => Positive, Element_Type => String, "<" => "<", "=" => "="); - type Statment_Object_Type is new + type DBD_Type is new + Ada.Finalization.Controlled with + record + Real : Backlit.Thin.A_PGCONN_T; + Map : Connection_Info_Map.Map; + Command : Ada.Strings.Unbounded.Unbounded_String; + Parameter : Stm_Map.Map; + Param_Length : Natural; + Connection_Info : Ada.Strings.Unbounded.Unbounded_String; + Pooled : Boolean; + Key : Ada.Strings.Unbounded.Unbounded_String; + end record; + + procedure Initialize (D : in out DBD_Type); + procedure Adjust (D : in out DBD_Type); + procedure Finalize (D : in out DBD_Type); + + procedure Init (D : in out DBD_Type) renames Initialize; + pragma Inline (Init); + + type Result_Type is new Ada.Finalization.Limited_Controlled with record Pg_Result : Thin.A_PGRESULT_T; - Command : Ada.Strings.Unbounded.Unbounded_String; - Parameter : Stm_Map.Map; - Param_Length : Natural; end record; - procedure Initialize (S : in out Statment_Object_Type); + procedure Initalize (R : in out Result_Type); - procedure Finalize (S : in out Statment_Object_Type); + procedure Finalize (R : in out Result_Type); type Pg_ParamTypes is array (Interfaces.C.size_t range <>) of aliased Thin.Oid; @@ -298,10 +523,10 @@ private type Pg_Parameter_Type is record ParamTypes : Thin.Oid := Thin.InvalidOid; ParamValues : Interfaces.C.Strings.chars_ptr; - ParamLengths : Interfaces.C.int; + ParamLengths : Interfaces.C.Int; ParamFormats : Interfaces.C.int := 0; end record; -- only the Pg_ParamValues will be used for now as we are processing -- text-format parameters. -end Backlit.Client.Statment; +end Backlit.Postgres; diff --git a/src/backlit-utils.adb b/src/backlit-utils.adb new file mode 100644 index 0000000..27e917a --- /dev/null +++ b/src/backlit-utils.adb @@ -0,0 +1,72 @@ +with Ada.Strings.Fixed; +with Ada.Characters.Handling; + +package body Backlit.Utils is + + function Escape (S : String) return String + is + Result : String (1 .. S'Length * 2); + Last : Natural := 0; + begin + for I in S'Range loop + if S (I) = ''' then + Last := Last + 1; + Result (Last) := '\'; + end if; + Last := Last + 1; + Result (Last) := S (I); + end loop; + return ''' & Result (1 .. Last) & '''; + end Escape; + + function To_Lower (Source : String) return String + is + begin + return Ada.Characters.Handling.To_Lower (Source); + end To_Lower; + + function Trim (Source : String) return String + is + begin + return Ada.Strings.Fixed.Trim (Source, Ada.Strings.Both); + end Trim; + + function Boolean_Str (S : String) return String is + Tmp : String := Trim (To_Lower (S)); + begin + if Tmp = "true" then return "True"; + elsif Tmp = "t" then return "True"; + elsif Tmp = "yes" then return "True"; + elsif Tmp = "y" then return "True"; + elsif Tmp = "false" then return "False"; + elsif Tmp = "f" then return "False"; + elsif Tmp = "no" then return "False"; + elsif Tmp = "n" then return "False"; + end if; + return S; + end Boolean_Str; + + function Trim_Left_Zero (S: String) return String + is + use Ada.Strings.Fixed; + Tmp : String := Trim (S, Ada.Strings.Both); + Z: String (Tmp'First .. Tmp'Last) := (others => '0'); + C: Natural := 0; + L : Natural := Tmp'Last; + begin + loop + exit when L < 1; + C := Index (S, Z (Z'First .. L)); + if C = 1 then + if L = S'Length then + return S (S'First + L - 1 .. S'Last); + else + return S (S'First + L .. S'Last); + end if; + end if; + L := L - 1; + end loop; + return S; + end Trim_Left_Zero; + +end Backlit.Utils; diff --git a/src/backlit-utils.ads b/src/backlit-utils.ads new file mode 100644 index 0000000..debf949 --- /dev/null +++ b/src/backlit-utils.ads @@ -0,0 +1,21 @@ +package Backlit.Utils is + + + function Escape (S : String) return String; + -- Quote a string + + function Trim (Source : String) return String; + -- Trim both sides of a string + + function To_Lower (Source : String) return String; + + function Boolean_Str (S : String) return String; + -- return "True" if S = (true|yes|y|t) + -- return "False" if S = (false|no|n|f) + -- not case sensitive. otherwise return S unchanged + + function Trim_Left_Zero (S: String) return String; + -- remove any 0 at the left of a string + -- example :00010 => 10; 000 => 0; 0.10 => .10 + +end Backlit.Utils; diff --git a/src/backlit.ads b/src/backlit.ads index a4b18ee..de3635e 100644 --- a/src/backlit.ads +++ b/src/backlit.ads @@ -23,6 +23,6 @@ package Backlit is pragma Pure; - Error : exception; + Error, Query_Error : exception; end Backlit; -- 2.11.4.GIT