From: Samuel Tardieu <sam@ada.eu.org>
Subject: Re: Ada bindings for MySQL? [long]
Date: 1998/09/25
Date: 1998-09-25T00:00:00+00:00 [thread overview]
Message-ID: <8790j89otw.fsf@zaphod.enst.fr> (raw)
In-Reply-To: 360B81F7.657E0B5C@dial.pipex.com
>>>>> "Jeff" == Jeff Foster <acp59@dial.pipex.com> writes:
Jeff> Does anyone know if there are any Ada bindings for MySQL? In
Jeff> particular, for the GNU Ada 95 compiler.
I happened to write one (a quick and dirty hack) because I needed it
to access an existing database. I make no guarantee at all that it
still works (I'm just extracting a copy from my repository) and I do
not intend to maintain it. However, please report me any error so that
I can fix my local copy just in case it works well enough to be
reused and maybe released.
In fact, I since switched to PostGreSQL (http://www.postgresql.org/)
which proved to be a much more superior database with a clearer
licence (more in the "free software" spirit), and have written a
binding for this one, and intend to release it some time in the
future.
I haven't put a licence explicitely in each file, but you can consider
that this version is put in the public domain, you can do everything
with it, even declare that you are the author and sell it some
zillions :)
Extract what's included after my signature and run it through
gnatchop. Included is a test_mysql program that you can adapt.
For those who don't want to see long messages here, too bad if you
came up to this point, [long] was inserted in the subject :) But I
think it may benefit to many people, so I post it here.
Sam
--
Samuel Tardieu -- sam@ada.eu.org
--
-- $ProjectHeader: Mysql 0.20 Fri, 25 Sep 1998 17:41:02 +0200 sam $
--
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Interfaces.C.Strings; use Interfaces.C, Interfaces.C.Strings;
package body Mysql.Base is
use Thin;
-----------------------
-- Local Subprograms --
-----------------------
function TCPON (S : String) return chars_ptr;
-- If the string is not empty, return its C equivalent. Otherwise,
-- return Null_Ptr.
function Current_Field_Length (Conn : access Mysql_Connection)
return Natural;
-- Length of current field
procedure FCPINN (C : in out chars_ptr);
-- Free it if it is not Null_Ptr
procedure Raise_Mysql_Exception (Conn : access Mysql_Connection);
pragma No_Return (Raise_Mysql_Exception);
-- Raise an exception with the right error string
procedure Raise_Mysql_Exception (Message : in String := "");
pragma No_Return (Raise_Mysql_Exception);
-- Raise an exception with the corresponding message
function Error_String (Mysql : Mysql_Access) return String;
-- Return the error string corresponding to the last error
procedure Free is
new Ada.Unchecked_Deallocation (Thin.Mysql, Mysql_Access);
-----------------
-- Advance_Row --
-----------------
procedure Advance_Row (Conn : access Mysql_Connection) is
begin
Conn.Current_Row := Conn.Current_Row + 1;
Conn.Current_Field := -1;
if Conn.Current_Row >= Conn.Num_Rows then
raise Constraint_Error;
end if;
Conn.Row := Mysql_Fetch_Row (Conn.Result);
Conn.Lengths := Mysql_Fetch_Lengths (Conn.Result);
end Advance_Row;
-------------------
-- Affected_Rows --
-------------------
function Affected_Rows (Conn : access Mysql_Connection) return Natural is
begin
return Natural (Conn.Connection.Affected_Rows);
end Affected_Rows;
-------------
-- Connect --
-------------
procedure Connect (Conn : access Mysql_Connection;
Host : in String := "";
User : in String := "";
Password : in String := "")
is
C_Host : chars_ptr := TCPON (Host);
C_User : chars_ptr := TCPON (User);
C_Password : chars_ptr := TCPON (Password);
Success : Boolean;
begin
Success :=
Mysql_Connect (Conn.Connection, C_Host, C_User, C_Password) /= null;
FCPINN (C_Host);
FCPINN (C_User);
FCPINN (C_Password);
if not Success then
Raise_Mysql_Exception (Conn);
end if;
Conn.Connected := True;
end Connect;
---------------------
-- Create_Database --
---------------------
procedure Create_Database (Conn : access Mysql_Connection;
Base : in String)
is
C_Base : chars_ptr := New_String (Base);
Success : Boolean;
begin
Success := Mysql_Create_Db (Conn.Connection, C_Base) = 0;
Free (C_Base);
if not Success then
Raise_Mysql_Exception (Conn);
end if;
end Create_Database;
--------------------------
-- Current_Field_Length --
--------------------------
function Current_Field_Length (Conn : access Mysql_Connection)
return Natural
is
begin
return Natural (Conn.Lengths (Conn.Current_Field));
end Current_Field_Length;
------------------------
-- Current_Field_Type --
------------------------
function Current_Field_Type (Conn : access Mysql_Connection)
return Thin.Mysql_Field
is
begin
return Conn.Result.Fields (Conn.Current_Field);
end Current_Field_Type;
-------------------
-- Drop_Database --
-------------------
procedure Drop_Database (Conn : access Mysql_Connection;
Base : in String)
is
C_Base : chars_ptr := New_String (Base);
Success : Boolean;
begin
Success := Mysql_Drop_Db (Conn.Connection, C_Base) = 0;
Free (C_Base);
if not Success then
Raise_Mysql_Exception (Conn);
end if;
end Drop_Database;
------------------
-- Error_String --
------------------
function Error_String (Mysql : Mysql_Access) return String is
begin
return To_Ada (Mysql.Net_Field.Last_Error);
end Error_String;
--------------
-- Finalize --
--------------
procedure Finalize (O : in out Mysql_Connection) is
begin
Free_Result (O'Access);
if O.Connected then
Mysql_Close (O.Connection);
O.Connected := False;
end if;
Free (O.Connection);
end Finalize;
------------
-- FCPINN --
------------
procedure FCPINN (C : in out chars_ptr) is
begin
if C /= Null_Ptr then
Free (C);
end if;
end FCPINN;
-----------------
-- Field_Count --
-----------------
function Field_Count (Conn : access Mysql_Connection) return Natural is
begin
return Conn.Num_Fields;
end Field_Count;
-----------------
-- Free_Result --
-----------------
procedure Free_Result (Conn : access Mysql_Connection) is
begin
if Conn.Result /= null then
Mysql_Free_Result (Conn.Result);
Conn.Result := null;
end if;
end Free_Result;
---------------------
-- Get_Client_Info --
---------------------
function Get_Client_Info return String is
begin
return Value (Mysql_Get_Client_Info);
end Get_Client_Info;
-------------------
-- Get_Host_Info --
-------------------
function Get_Host_Info (Conn : access Mysql_Connection) return String is
begin
return Value (Mysql_Get_Host_Info (Conn.Connection));
end Get_Host_Info;
--------------------
-- Get_Proto_Info --
--------------------
function Get_Proto_Info (Conn : access Mysql_Connection) return Natural is
begin
return Natural (Mysql_Get_Proto_Info (Conn.Connection));
end Get_Proto_Info;
---------------------
-- Get_Server_Info --
---------------------
function Get_Server_Info (Conn : access Mysql_Connection) return String is
begin
return Value (Mysql_Get_Server_Info (Conn.Connection));
end Get_Server_Info;
----------------
-- Initialize --
----------------
procedure Initialize (O : in out Mysql_Connection) is
begin
O.Connection := new Thin.Mysql;
end Initialize;
---------------
-- Insert_Id --
---------------
function Insert_Id (Conn : access Mysql_Connection) return Natural is
begin
return Natural (Conn.Connection.Insert_Id);
end Insert_Id;
----------------
-- Next_Field --
----------------
function Next_Field (Conn : access Mysql_Connection)
return Char_Subarray_Access
is
begin
if Conn.Current_Row = -1 then
raise Constraint_Error;
end if;
Conn.Current_Field := Conn.Current_Field + 1;
if Conn.Current_Field >= Conn.Num_Fields then
raise Constraint_Error;
end if;
return Conn.Row (Conn.Current_Field);
end Next_Field;
--------------------------
-- Next_Field_As_String --
--------------------------
function Next_Field_As_String (Conn : access Mysql_Connection)
return String
is
Current_Field : constant Char_Subarray_Access := Next_Field (Conn);
Field_Length : constant Natural :=
Current_Field_Length (Conn);
Result : String (1 .. Field_Length);
begin
for I in Result'Range loop
Result (I) := Character'Val (char'Pos (Current_Field (size_t (I))));
end loop;
return Result;
end Next_Field_As_String;
-----------
-- Query --
-----------
procedure Query
(Conn : access Mysql_Connection;
Query : in String;
Result_On_Server : in Boolean := False)
is
begin
if Conn.Result /= null then
Free_Result (Conn);
end if;
Conn.Num_Rows := 0;
Conn.Current_Row := -1;
if
Mysql_Real_Query (Conn.Connection, Query'Address, Query'Length) /= 0
then
Raise_Mysql_Exception (Conn);
end if;
if Result_On_Server then
Conn.Result := Mysql_Use_Result (Conn.Connection);
else
Conn.Result := Mysql_Store_Result (Conn.Connection);
end if;
if Conn.Result = null then
Conn.Num_Rows := 0;
Conn.Num_Fields := 0;
else
Conn.Num_Rows := Natural (Conn.Result.Row_Count);
Conn.Num_Fields := Natural (Conn.Result.Field_Count);
end if;
end Query;
-----------
-- Query --
-----------
function Query
(Conn : access Mysql_Connection;
Query : String;
Result_On_Server : Boolean := False)
return Natural
is
begin
Base.Query (Conn, Query, Result_On_Server);
return Row_Count (Conn);
end Query;
---------------------------
-- Raise_Mysql_Exception --
---------------------------
procedure Raise_Mysql_Exception (Message : in String := "") is
begin
Raise_Exception (Mysql_Error'Identity, Message);
end Raise_Mysql_Exception;
---------------------------
-- Raise_Mysql_Exception --
---------------------------
procedure Raise_Mysql_Exception (Conn : access Mysql_Connection) is
begin
Raise_Mysql_Exception (Error_String (Conn.Connection));
end Raise_Mysql_Exception;
---------------
-- Row_Count --
---------------
function Row_Count (Conn : access Mysql_Connection) return Natural is
begin
return Conn.Num_Rows;
end Row_Count;
---------------------
-- Select_Database --
---------------------
procedure Select_Database (Conn : access Mysql_Connection;
Database : in String)
is
C_Database : chars_ptr := New_String (Database);
Ok : Boolean;
begin
Ok := Mysql_Select_Db (Conn.Connection, C_Database) = 0;
Free (C_Database);
if not Ok then
Raise_Mysql_Exception (Conn);
end if;
end Select_Database;
--------------
-- Shutdown --
--------------
procedure Shutdown (Conn : access Mysql_Connection) is
begin
if Mysql_Shutdown (Conn.Connection) /= 0 then
Raise_Mysql_Exception (Conn);
end if;
end Shutdown;
-----------
-- TCPON --
-----------
function TCPON (S : String) return chars_ptr is
begin
if S = "" then
return Null_Ptr;
else
return New_String (S);
end if;
end TCPON;
end Mysql.Base;
--
-- $ProjectHeader: Mysql 0.20 Fri, 25 Sep 1998 17:41:02 +0200 sam $
--
with Ada.Finalization;
with Mysql.Thin;
package Mysql.Base is
type Mysql_Connection is
new Ada.Finalization.Limited_Controlled with private;
-- A mySQL connection with the database
Mysql_Error : exception;
procedure Connect (Conn : access Mysql_Connection;
Host : in String := "";
User : in String := "";
Password : in String := "");
-- Connect onto a database. If host is not specified, then localhost
-- is assumed. An exception is raised when it is not possible to connect
-- to the database.
function Get_Client_Info return String;
-- Return client information
function Get_Server_Info (Conn : access Mysql_Connection) return String;
-- Return server information
function Get_Host_Info (Conn : access Mysql_Connection) return String;
-- Return host information
function Get_Proto_Info (Conn : access Mysql_Connection) return Natural;
-- Return protocol information
procedure Select_Database (Conn : access Mysql_Connection;
Database : in String);
-- Select the current database
procedure Query
(Conn : access Mysql_Connection;
Query : in String;
Result_On_Server : in Boolean := False);
-- Perform a query
function Query
(Conn : access Mysql_Connection;
Query : String;
Result_On_Server : Boolean := False)
return Natural;
-- Perform a query and return the number of rows returned by the server.
-- If Result_On_Server is True, then the results will not be downloaded.
function Row_Count (Conn : access Mysql_Connection) return Natural;
pragma Inline (Row_Count);
-- Return the number of rows returned by the latest query
function Field_Count (Conn : access Mysql_Connection) return Natural;
pragma Inline (Field_Count);
-- Return the number of fields returned by the latest query
function Insert_Id (Conn : access Mysql_Connection) return Natural;
-- In case of auto-increment variable, return the latest one that has
-- been automatically inserted by the last command.
procedure Free_Result (Conn : access Mysql_Connection);
-- Free the result once it is of no more use
function Affected_Rows (Conn : access Mysql_Connection) return Natural;
-- Return the number of rows affected by the last UPDATE, DELETE or INSERT
-- command. If the whole table has been erased, then it returns 0 due to
-- MySQL optimizations.
procedure Advance_Row (Conn : access Mysql_Connection);
-- Advance by one row in the result set. Raise Constraint_Error if there
-- are no more rows.
function Next_Field (Conn : access Mysql_Connection)
return Thin.Char_Subarray_Access;
-- Return the next field. Raise Constraint_Error if there are no more
-- fields in the row.
function Next_Field_As_String (Conn : access Mysql_Connection)
return String;
-- Return a string representing the next field
function Current_Field_Type (Conn : access Mysql_Connection)
return Thin.Mysql_Field;
-- Return the type of the current field
procedure Create_Database (Conn : access Mysql_Connection;
Base : in String);
-- Create a new database
procedure Drop_Database (Conn : access Mysql_Connection;
Base : in String);
-- Remove a database
procedure Shutdown (Conn : access Mysql_Connection);
-- Shutdown the MySQL server
private
type Mysql_Connection is new Ada.Finalization.Limited_Controlled with record
Connection : Thin.Mysql_Access;
Connected : Boolean := False;
Result : Thin.Mysql_Res_Access;
Num_Rows : Natural;
Num_Fields : Natural;
Row : Thin.Mysql_Row;
Current_Row : Integer;
Current_Field : Integer;
Lengths : Thin.Unsigned_Array_Access;
end record;
procedure Initialize (O : in out Mysql_Connection);
procedure Finalize (O : in out Mysql_Connection);
pragma Inline (Affected_Rows);
pragma Inline (Free_Result);
pragma Inline (Get_Client_Info);
pragma Inline (Get_Host_Info);
pragma Inline (Get_Proto_Info);
pragma Inline (Get_Server_Info);
pragma Inline (Insert_Id);
end Mysql.Base;
--
-- $ProjectHeader: Mysql 0.20 Fri, 25 Sep 1998 17:41:02 +0200 sam $
--
package body Mysql.Insert is
use Mysql.Base;
------------
-- Insert --
------------
procedure Insert (Conn : access Mysql_Connection;
Table : in String;
S : in Struct;
Fields : in String := "")
is
begin
if Fields = "" then
Query (Conn, "INSERT INTO " & Table & " VALUES (" &
Write (S) & ")");
else
Query (Conn, "INSERT INTO " & Table & "(" & Fields & ") VALUES (" &
Write (S) & ")");
end if;
end Insert;
end Mysql.Insert;
--
-- $ProjectHeader: Mysql 0.20 Fri, 25 Sep 1998 17:41:02 +0200 sam $
--
with Mysql.Base;
generic
type Struct is private;
with function Write (S : Struct) return String;
-- Write must return a comma separated string of values
package Mysql.Insert is
procedure Insert (Conn : access Base.Mysql_Connection;
Table : in String;
S : in Struct;
Fields : in String := "");
-- Insert a struct into a table. If no value is given for Fields, then
-- all the fields will be used.
end Mysql.Insert;
--
-- $ProjectHeader: Mysql 0.20 Fri, 25 Sep 1998 17:41:02 +0200 sam $
--
with Ada.Exceptions; use Ada.Exceptions;
with Mysql.Types; use Mysql.Types;
package body Mysql.Shortcuts is
use Mysql.Base;
-----------------
-- Short_Query --
-----------------
function Short_Query (Db : access Base.Mysql_Connection;
Query : String)
return String
is
begin
if Base.Query (Db, Query) /= 1 then
Raise_Exception (Constraint_Error'Identity,
"Not exactly one row returned for Short_Query");
end if;
if Field_Count (Db) /= 1 then
Raise_Exception (Constraint_Error'Identity,
"Not exactly one column returned for Short_Query");
end if;
Advance_Row (Db);
return Fetch_Field (Db);
end Short_Query;
-----------------
-- Short_Query --
-----------------
function Short_Query (Db : access Base.Mysql_Connection;
Query : String)
return Integer
is
begin
return Integer'Value (Short_Query (Db, Query));
end Short_Query;
-----------------
-- Short_Query --
-----------------
function Short_Query (Db : access Base.Mysql_Connection;
Query : String)
return Float
is
begin
return Float'Value (Short_Query (Db, Query));
end Short_Query;
end Mysql.Shortcuts;
--
-- $ProjectHeader: Mysql 0.20 Fri, 25 Sep 1998 17:41:02 +0200 sam $
--
with Mysql.Base;
package Mysql.Shortcuts is
function Short_Query (Db : access Base.Mysql_Connection;
Query : String)
return String;
-- Execute a query for which the result will only be one string. If this
-- is not the case, Constraint_Error will be raised.
function Short_Query (Db : access Base.Mysql_Connection;
Query : String)
return Integer;
-- Similar function for integer types
function Short_Query (Db : access Base.Mysql_Connection;
Query : String)
return Float;
-- Similar function for floating point types
end Mysql.Shortcuts;
--
-- $ProjectHeader: Mysql 0.20 Fri, 25 Sep 1998 17:41:02 +0200 sam $
--
package body Mysql.Struct is
use Mysql.Base;
--------------
-- Read_All --
--------------
function Read_All (Conn : access Mysql_Connection) return Struct_Array is
Rows : constant Natural := Row_Count (Conn);
Result : Struct_Array (1 .. Rows);
begin
for I in Result'Range loop
Advance_Row (Conn);
Result (I) := Read (Conn);
end loop;
return Result;
end Read_All;
--------------
-- Read_All --
--------------
function Read_All
(Conn : access Mysql_Connection;
Query : String)
return Struct_Array is
begin
Base.Query (Conn, Query);
return Read_All (Conn);
end Read_All;
end Mysql.Struct;
--
-- $ProjectHeader: Mysql 0.20 Fri, 25 Sep 1998 17:41:02 +0200 sam $
--
with Mysql.Base;
generic
type Struct is private;
type Struct_Array is array (Positive range <>) of Struct;
with function Read (Conn : access Base.Mysql_Connection) return Struct;
-- Read will return a struct using Mysql.Types functions
package Mysql.Struct is
function Read_All (Conn : access Base.Mysql_Connection)
return Struct_Array;
-- Read all the results from the previous query
function Read_All (Conn : access Base.Mysql_Connection;
Query : String)
return Struct_Array;
-- Perform the query and read the results
end Mysql.Struct;
--
-- $ProjectHeader: Mysql 0.20 Fri, 25 Sep 1998 17:41:02 +0200 sam $
--
with Interfaces.C.Strings; use Interfaces.C, Interfaces.C.Strings;
with System;
package Mysql.Thin is
pragma Preelaborate;
type Used_Mem;
type Used_Mem_Access is access Used_Mem;
pragma Convention (C, Used_Mem_Access);
type Used_Mem is record
Next : Used_Mem_Access;
Left : unsigned;
Size : unsigned;
end record;
pragma Convention (C, Used_Mem);
type Error_Handler_Type is access procedure;
pragma Convention (C, Error_Handler_Type);
type Mem_Root is record
Free : Used_Mem;
Used : Used_Mem;
Min_Malloc : unsigned;
Block_Size : unsigned;
Error_Handler : Error_Handler_Type;
end record;
pragma Convention (C, Mem_Root);
Mysql_Errmsg_Size : constant := 200;
type My_Bool is new char;
type Socket is new int;
type Net is record
Fd : Socket;
Fcntl : int;
Buff : chars_ptr;
Buff_End : chars_ptr;
Write_Pos : chars_ptr;
Last_Error : char_array (1 .. Mysql_Errmsg_Size);
Last_Errno : unsigned;
Max_Packet : unsigned;
Timeout : unsigned;
Pkt_Nr : unsigned;
Error : My_Bool;
Return_Errno : My_Bool;
end record;
pragma Convention (C, Net);
type Field_Types is (Field_Type_Decimal, Field_Type_Tiny,
Field_Type_Short, Field_Type_Long,
Field_Type_Float, Field_Type_Double,
Field_Type_Null, Field_Type_Timestamp,
Field_Type_Longlong, Field_Type_Int24,
Field_Type_Date, Field_Type_Time,
Field_Type_Datetime,
Field_Type_Enum,
Field_Type_Set,
Field_Type_Tiny_Blob,
Field_Type_Medium_Blob,
Field_Type_Long_Blob,
Field_Type_Blob,
Field_Type_Var_String,
Field_Type_String);
for Field_Types use (Field_Type_Decimal => 0,
Field_Type_Tiny => 1,
Field_Type_Short => 2,
Field_Type_Long => 3,
Field_Type_Float => 4,
Field_Type_Double => 5,
Field_Type_Null => 6,
Field_Type_Timestamp => 7,
Field_Type_Longlong => 8,
Field_Type_Int24 => 9,
Field_Type_Date => 10,
Field_Type_Time => 11,
Field_Type_Datetime => 12,
Field_Type_Enum => 247,
Field_Type_Set => 248,
Field_Type_Tiny_Blob => 249,
Field_Type_Medium_Blob => 250,
Field_Type_Long_Blob => 251,
Field_Type_Blob => 252,
Field_Type_Var_String => 253,
Field_Type_String => 254);
for Field_Types'Size use int'Size;
pragma Convention (C, Field_Types);
type Mysql_Field is record
Name : chars_ptr;
Table : chars_ptr;
Def : chars_ptr;
Typ : Field_Types;
Length : unsigned;
Max_Length : unsigned;
Flags : unsigned;
Decimals : unsigned;
end record;
pragma Convention (C, Mysql_Field);
type Mysql_Field_Access is access Mysql_Field;
pragma Convention (C, Mysql_Field_Access);
type Mysql_Field_Array is array (0 .. 65536) of Mysql_Field;
pragma Convention (C, Mysql_Field_Array);
type Mysql_Field_Array_Access is access Mysql_Field_Array;
pragma Convention (C, Mysql_Field_Array_Access);
subtype Char_Subarray is char_array (1 .. 65535);
type Char_Subarray_Access is access Char_Subarray;
pragma Convention (C, Char_Subarray_Access);
type Byte_Access_Array is array (0 .. 65535) of Char_Subarray_Access;
pragma Convention (C, Byte_Access_Array);
type Mysql_Row is access Byte_Access_Array;
pragma Convention (C, Mysql_Row);
type Mysql_Field_Offset is new unsigned;
type Mysql_Rows;
type Mysql_Rows_Access is access Mysql_Rows;
pragma Convention (C, Mysql_Rows_Access);
type Mysql_Rows is record
Next : Mysql_Rows_Access;
Data : Mysql_Row;
end record;
pragma Convention (C, Mysql_Rows);
type Mysql_Row_Offset is access Mysql_Rows;
pragma Convention (C, Mysql_Row_Offset);
type Mysql_Data is record
Rows : unsigned;
Fields : unsigned;
Data : Mysql_Rows;
Alloc : Mem_Root;
end record;
pragma Convention (C, Mysql_Data);
type Mysql_Data_Access is access Mysql_Data;
pragma Convention (C, Mysql_Data_Access);
type Mysql_Status is (Mysql_Status_Ready, Mysql_Status_Get_Result,
Mysql_Status_Use_Result);
for Mysql_Status'Size use int'Size;
pragma Convention (C, Mysql_Status);
type Mysql is record
Net_Field : Net;
Host : chars_ptr;
User : chars_ptr;
Passwd : chars_ptr;
Unix_Socket : chars_ptr;
Server_Version : chars_ptr;
Host_Info : chars_ptr;
Info : chars_ptr;
Db : chars_ptr;
Port : unsigned;
Client_Flag : unsigned;
Server_Capabilities : unsigned;
Protocol_Version : unsigned;
Field_Count : unsigned;
Thread_Id : unsigned_long;
Affected_Rows : unsigned_long;
Insert_Id : unsigned_long;
Extra_Info : unsigned_long;
Status : Mysql_Status;
Fields : Mysql_Field_Array_Access;
Field_Alloc : Mem_Root;
Free_Me : My_Bool;
Reconnect : My_Bool;
end record;
pragma Convention (C, Mysql);
type Mysql_Access is access Mysql;
pragma Convention (C, Mysql_Access);
type Unsigned_Array is array (0 .. 65535) of unsigned;
pragma Convention (C, Unsigned_Array);
type Unsigned_Array_Access is access Unsigned_Array;
pragma Convention (C, Unsigned_Array_Access);
type Mysql_Res is record
Row_Count : unsigned_long;
Field_Count : unsigned;
Current_Field : unsigned;
Fields : Mysql_Field_Array_Access;
Data : Mysql_Data_Access;
Data_Cursor : Mysql_Rows_Access;
Field_Alloc : Mem_Root;
Row : Mysql_Row;
Current_Row : Mysql_Row;
Lengths : Unsigned_Array_Access;
Handle : Mysql_Access;
Eof : My_Bool;
end record;
pragma Convention (C, Mysql_Res);
type Mysql_Res_Access is access Mysql_Res;
pragma Convention (C, Mysql_Res_Access);
function Mysql_Connect (Mysql : Mysql_Access;
Host : chars_ptr;
User : chars_ptr;
Passwd : chars_ptr)
return Mysql_Access;
pragma Import (C, Mysql_Connect, "mysql_connect");
function Mysql_Real_Connect (Mysql : Mysql_Access;
Host : chars_ptr;
User : chars_ptr;
Passwd : chars_ptr;
Port : unsigned;
Unix_Socket : chars_ptr;
Clientflag : unsigned)
return Mysql_Access;
pragma Import (C, Mysql_Real_Connect, "mysql_real_connect");
procedure Mysql_Close (Sock : in Mysql_Access);
pragma Import (C, Mysql_Close, "mysql_close");
function Mysql_Select_Db (Mysql : Mysql_Access;
Db : chars_ptr)
return int;
pragma Import (C, Mysql_Select_Db, "mysql_select_db");
function Mysql_Query (Mysql : Mysql_Access;
Q : chars_ptr)
return int;
pragma Import (C, Mysql_Query, "mysql_query");
function Mysql_Real_Query (Mysql : Mysql_Access;
Q : System.Address;
Length : unsigned)
return int;
pragma Import (C, Mysql_Real_Query, "mysql_real_query");
function Mysql_Create_Db (Mysql : Mysql_Access;
Db : chars_ptr)
return int;
pragma Import (C, Mysql_Create_Db, "mysql_create_db");
function Mysql_Drop_Db (Mysql : Mysql_Access;
Db : chars_ptr)
return int;
pragma Import (C, Mysql_Drop_Db, "mysql_drop_db");
function Mysql_Shutdown (Mysql : Mysql_Access) return int;
pragma Import (C, Mysql_Shutdown, "mysql_shutdown");
function Mysql_Dump_Debug_Info (Mysql : Mysql_Access) return int;
pragma Import (C, Mysql_Dump_Debug_Info, "mysql_dump_debug_info");
function Mysql_Refresh (Mysql : Mysql_Access;
Refresh_Options : unsigned)
return int;
pragma Import (C, Mysql_Refresh, "mysql_refresh");
function Mysql_Kill (Mysql : Mysql_Access;
Pid : unsigned_long)
return int;
pragma Import (C, Mysql_Kill, "mysql_kill");
function Mysql_Stat (Mysql : Mysql_Access) return chars_ptr;
pragma Import (C, Mysql_Stat, "mysql_stat");
function Mysql_Get_Server_Info (Mysql : Mysql_Access) return chars_ptr;
pragma Import (C, Mysql_Get_Server_Info, "mysql_get_server_info");
function Mysql_Get_Client_Info return chars_ptr;
pragma Import (C, Mysql_Get_Client_Info, "mysql_get_client_info");
function Mysql_Get_Host_Info (Mysql : Mysql_Access) return chars_ptr;
pragma Import (C, Mysql_Get_Host_Info, "mysql_get_host_info");
function Mysql_Get_Proto_Info (Mysql : Mysql_Access) return unsigned;
pragma Import (C, Mysql_Get_Proto_Info, "mysql_get_proto_info");
function Mysql_List_Dbs (Mysql : Mysql_Access;
Wild : chars_ptr)
return Mysql_Res_Access;
pragma Import (C, Mysql_List_Dbs, "mysql_list_dbs");
function Mysql_List_Tables (Mysql : Mysql_Access;
Wild : chars_ptr)
return Mysql_Res_Access;
pragma Import (C, Mysql_List_Tables, "mysql_list_tables");
function Mysql_List_Fields (Mysql : Mysql_Access;
Table : chars_ptr;
Wild : chars_ptr)
return Mysql_Res_Access;
pragma Import (C, Mysql_List_Fields, "mysql_list_fields");
function Mysql_List_Processes (Mysql : Mysql_Access)
return Mysql_Res_Access;
pragma Import (C, Mysql_List_Processes, "mysql_list_processes");
function Mysql_Store_Result (Mysql : Mysql_Access) return Mysql_Res_Access;
pragma Import (C, Mysql_Store_Result, "mysql_store_result");
function Mysql_Use_Result (Mysql : Mysql_Access) return Mysql_Res_Access;
pragma Import (C, Mysql_Use_Result, "mysql_use_result");
procedure Mysql_Free_Result (Result : in Mysql_Res_Access);
pragma Import (C, Mysql_Free_Result, "mysql_free_result");
procedure Mysql_Data_Seek (Mysql : in Mysql_Res_Access;
Offset : in unsigned);
pragma Import (C, Mysql_Data_Seek, "mysql_data_seek");
function Mysql_Row_Seek (Mysql : Mysql_Res_Access;
Offset : unsigned)
return Mysql_Row_Offset;
pragma Import (C, Mysql_Row_Seek, "mysql_row_seek");
function Mysql_Field_Seek (Mysql : Mysql_Res_Access;
Offset : Mysql_Field_Offset)
return Mysql_Field_Offset;
pragma Import (C, Mysql_Field_Seek, "mysql_field_seek");
function Mysql_Fetch_Row (Mysql : Mysql_Res_Access) return Mysql_Row;
pragma Import (C, Mysql_Fetch_Row, "mysql_fetch_row");
function Mysql_Fetch_Lengths (Mysql : Mysql_Res_Access)
return Unsigned_Array_Access;
pragma Import (C, Mysql_Fetch_Lengths, "mysql_fetch_lengths");
function Mysql_Fetch_Field (Handle : Mysql_Res_Access)
return Mysql_Field_Access;
pragma Import (C, Mysql_Fetch_Field, "mysql_fetch_field");
function Mysql_Escape_String (To : System.Address;
From : System.Address;
Length : unsigned)
return unsigned;
pragma Import (C, Mysql_Escape_String, "mysql_escape_string");
procedure Mysql_Debug (Debug : in chars_ptr);
pragma Import (C, Mysql_Debug, "mysql_debug");
pragma Linker_Options ("-lmysqlclient");
pragma Linker_Options ("-lpthread");
pragma Linker_Options ("-lm");
end Mysql.Thin;
--
-- $ProjectHeader: Mysql 0.20 Fri, 25 Sep 1998 17:41:02 +0200 sam $
--
with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
with Ada.Strings.Fixed; use Ada.Strings, Ada.Strings.Fixed;
with Ada.Unchecked_Conversion;
with Interfaces.C; use Interfaces.C;
package body Mysql.Types is
use Ada.Calendar, Ada.Streams, Mysql.Base, Mysql.Thin;
function Field_Type (Conn : access Base.Mysql_Connection)
return Field_Types;
pragma Inline (Field_Type);
-- Return the type of the current field
function Escape_Duration (D : Duration) return String;
-- Return a duration without quotes
function To_Duration (S : String) return Duration;
-- Read a string of form [-]HH:MM:SS and get a duration from it
function To_Time (S : String) return Time;
-- Read a string of form YYYY-MM-DD[[ -]HH:MM:SS] and get a time from it
------------
-- Escape --
------------
function Escape (S : String) return String is
Result : String (1 .. S'Length * 2 + 2);
Last : Natural := 1;
begin
Result (1) := Quotation;
for I in S'Range loop
case S (I) is
when Ada.Characters.Latin_1.NUL =>
Last := Last + 2;
Result (Last - 1 .. Last) := "\0";
when LF =>
Last := Last + 2;
Result (Last - 1 .. Last) := "\n";
when HT =>
Last := Last + 2;
Result (Last - 1 .. Last) := "\t";
when CR =>
Last := Last + 2;
Result (Last - 1 .. Last) := "\r";
when BS =>
Last := Last + 2;
Result (Last - 1 .. Last) := "\b";
when Apostrophe | Quotation | Reverse_Solidus =>
Last := Last + 2;
Result (Last - 1) := '\';
Result (Last) := S (I);
when others =>
Last := Last + 1;
Result (Last) := S (I);
end case;
end loop;
Last := Last + 1;
Result (Last) := Quotation;
return Result (1 .. Last);
end Escape;
------------
-- Escape --
------------
function Escape (S : access String) return String is
begin
return Escape (S.all);
end Escape;
------------
-- Escape --
------------
function Escape (I : Integer) return String is
begin
return Trim (Integer'Image (I), Side => Left);
end Escape;
------------
-- Escape --
------------
function Escape (T : Time) return String is
T_Year : Year_Number;
T_Month : Month_Number;
T_Day : Day_Number;
Seconds : Day_Duration;
function To_Duration is
new Ada.Unchecked_Conversion (Time, Duration);
begin
Split (Date => T, Year => T_Year, Month => T_Month, Day => T_Day,
Seconds => Seconds);
return """" & Escape (T_Year) & "-" & Escape (T_Month) & "-" &
Escape (T_Day) & " " & Escape_Duration (Seconds) & """";
end Escape;
------------
-- Escape --
------------
function Escape (F : Float) return String is
begin
return Trim (Float'Image (F), Side => Left);
end Escape;
------------
-- Escape --
------------
function Escape (S : Stream_Element_Array) return String is
Result : String (1 .. S'Length);
Index : Positive := 1;
begin
for I in S'Range loop
Result (Index) := Character'Val (Stream_Element'Pos (S (I)));
Index := Index + 1;
end loop;
return Result;
end Escape;
------------
-- Escape --
------------
function Escape (D : Duration) return String is
begin
return """" & Escape_Duration (D) & """";
end Escape;
---------------------
-- Escape_Duration --
---------------------
function Escape_Duration (D : Duration) return String is
H : constant Integer := Integer (abs D) / 3600;
M : constant Natural := (Integer (abs D) - H * 3600) / 60;
S : constant Natural := (Integer (abs D) - H * 3600 - M * 60);
begin
if D < 0.0 then
return "-" & Escape (H) & ":" & Escape (M) & ":" & Escape (S);
else
return Escape (H) & ":" & Escape (M) & ":" & Escape (S);
end if;
end Escape_Duration;
-----------------
-- Fetch_Field --
-----------------
function Fetch_Field (Conn : access Base.Mysql_Connection)
return Integer
is
Str : constant String := Next_Field_As_String (Conn);
begin
pragma Assert
(Field_Type (Conn) = Field_Type_Tiny or else
Field_Type (Conn) = Field_Type_Short or else
Field_Type (Conn) = Field_Type_Long);
return Integer'Value (Str);
end Fetch_Field;
-----------------
-- Fetch_Field --
-----------------
function Fetch_Field (Conn : access Base.Mysql_Connection)
return String
is
Str : constant String := Next_Field_As_String (Conn);
begin
pragma Assert
(Field_Type (Conn) = Field_Type_String or else
Field_Type (Conn) = Field_Type_Var_String);
return Str;
end Fetch_Field;
-----------------
-- Fetch_Field --
-----------------
function Fetch_Field (Conn : access Base.Mysql_Connection)
return Stream_Element_Array
is
Str : constant String := Next_Field_As_String (Conn);
Result : Stream_Element_Array (1 .. Str'Length);
Index : Stream_Element_Offset := 1;
begin
pragma Assert
(Field_Type (Conn) = Field_Type_Tiny_Blob or else
Field_Type (Conn) = Field_Type_Medium_Blob or else
Field_Type (Conn) = Field_Type_Long_Blob or else
Field_Type (Conn) = Field_Type_Blob or else
Field_Type (Conn) = Field_Type_String or else
Field_Type (Conn) = Field_Type_Var_String);
for I in Str'Range loop
Result (Index) := Stream_Element'Val (Character'Pos (Str (I)));
Index := Index + 1;
end loop;
return Result;
end Fetch_Field;
-----------------
-- Fetch_Field --
-----------------
function Fetch_Field (Conn : access Base.Mysql_Connection)
return String_Access
is
begin
return new String'(Fetch_Field (Conn));
end Fetch_Field;
-----------------
-- Fetch_Field --
-----------------
function Fetch_Field (Conn : access Base.Mysql_Connection)
return Time
is
Str : constant String := Next_Field_As_String (Conn);
Typ : constant Field_Types := Field_Type (Conn);
begin
-- ??? Wrong
if Typ = Field_Type_Timestamp then
declare
function To_Time is
new Ada.Unchecked_Conversion (Duration, Time);
begin
return To_Time (Duration (Integer'Value (Str)));
end;
else
return To_Time (Str);
end if;
end Fetch_Field;
-----------------
-- Fetch_Field --
-----------------
function Fetch_Field (Conn : access Base.Mysql_Connection)
return Duration
is
Str : constant String := Next_Field_As_String (Conn);
Typ : constant Field_Types := Field_Type (Conn);
begin
if Typ = Field_Type_Timestamp then
return Duration (Integer'Value (Str));
end if;
pragma Assert (Typ = Field_Type_Time);
return To_Duration (Str);
end Fetch_Field;
-----------------
-- Fetch_Field --
-----------------
function Fetch_Field (Conn : access Base.Mysql_Connection)
return Float
is
Str : constant String := Next_Field_As_String (Conn);
begin
pragma Assert
(Field_Type (Conn) = Field_Type_Float or else
Field_Type (Conn) = Field_Type_Double);
return Float'Value (Str);
end Fetch_Field;
----------------
-- Field_Type --
----------------
function Field_Type (Conn : access Base.Mysql_Connection)
return Field_Types
is
begin
return Current_Field_Type (Conn) .Typ;
end Field_Type;
-----------------
-- To_Duration --
-----------------
function To_Duration (S : String) return Duration is
H : constant Integer := Integer'Value (S (S'First .. S'Last - 6));
M : constant Natural := Natural'Value (S (S'Last - 4 .. S'Last - 3));
E : constant Natural := Natural'Value (S (S'Last - 1 .. S'Last));
begin
if H < 0 then
return Duration (H * 3600 - M * 60 - E);
else
return Duration (H * 3600 + M * 60 + E);
end if;
end To_Duration;
-------------
-- To_Time --
-------------
function To_Time (S : String) return Time is
Year : constant Year_Number :=
Year_Number'Value (S (S'First .. S'First + 3));
Month : constant Month_Number :=
Month_Number'Value (S (S'First + 5 .. S'First + 6));
Day : constant Day_Number :=
Day_Number'Value (S (S'First + 8 .. S'First + 9));
Result : constant Time := Time_Of (Year, Month, Day);
begin
if S'Length < 11 then
return Result;
else
return Result + To_Duration (S (S'First + 11 .. S'Last));
end if;
end To_Time;
end Mysql.Types;
--
-- $ProjectHeader: Mysql 0.20 Fri, 25 Sep 1998 17:41:02 +0200 sam $
--
with Ada.Calendar;
with Ada.Streams;
with Ada.Unchecked_Deallocation;
with Mysql.Base;
with Mysql.Thin;
package Mysql.Types is
function Fetch_Field (Conn : access Base.Mysql_Connection)
return Integer;
-- Fetch an integral field
function Fetch_Field (Conn : access Base.Mysql_Connection)
return String;
-- Return a string field
function Fetch_Field (Conn : access Base.Mysql_Connection)
return Ada.Calendar.Time;
-- Return a date-like field
function Fetch_Field (Conn : access Base.Mysql_Connection)
return Float;
-- Return a floating point field
function Fetch_Field (Conn : access Base.Mysql_Connection)
return Duration;
-- Return a duration
type String_Access is access String;
procedure Free is
new Ada.Unchecked_Deallocation (String, String_Access);
function Fetch_Field (Conn : access Base.Mysql_Connection)
return String_Access;
-- Return a pointer on string that will have to be freed later by the
-- user using the Free procedure provided above.
function Fetch_Field (Conn : access Base.Mysql_Connection)
return Ada.Streams.Stream_Element_Array;
-- Return an opaque structure corresponding to the field
function Escape (S : String) return String;
-- Escape a string according to mySQL specification (i.e. the string is
-- guaranteed not to contain any null character, is surrounded by "",
-- and has all the special characters escaped).
function Escape (S : access String) return String;
-- Similar function for access-to-string types
function Escape (I : Integer) return String;
-- Similar function for integer types
function Escape (T : Ada.Calendar.Time) return String;
-- Similar function for time types
function Escape (D : Duration) return String;
-- Similar function for duration
function Escape (F : Float) return String;
-- Similar function for floating point types
function Escape (S : Ada.Streams.Stream_Element_Array) return String;
-- Similar function for opaque streams
end Mysql.Types;
--
-- $ProjectHeader: Mysql 0.20 Fri, 25 Sep 1998 17:41:02 +0200 sam $
--
package Mysql is
pragma Pure;
end Mysql;
--
-- $ProjectHeader: Mysql 0.20 Fri, 25 Sep 1998 17:41:02 +0200 sam $
--
with Ada.Calendar; use Ada.Calendar;
with Ada.Text_IO; use Ada.Text_IO;
with Mysql.Base; use Mysql.Base;
with Mysql.Insert;
with Mysql.Thin; use Mysql.Thin;
with Mysql.Types; use Mysql.Types;
with Mysql.Struct;
procedure Test_Mysql is
Db : aliased Mysql_Connection;
Ada_Db_Name : constant String := "ada_mysql_test";
type Integer_Array is array (Positive range <>) of Integer;
package Mysql_Integer is new Mysql.Struct
(Struct => Integer,
Struct_Array => Integer_Array,
Read => Fetch_Field);
use Mysql_Integer;
type Struct is record
Name : String (1 .. 10);
Surn : String (1 .. 10);
Value : Integer;
D : Time;
T : Time;
end record;
function Write (S : Struct) return String;
package Mysql_Insert is new Mysql.Insert
(Struct => Struct,
Write => Write);
-----------
-- Write --
-----------
function Write (S : Struct) return String is
begin
return Escape (S.Name) & "," & Escape (S.Surn) & "," &
Escape (S.Value) & "," & Escape (S.D) & "," &
Escape (S.T);
end Write;
begin
Put_Line ("Escaped string: " & Escape ("ABC""D'E'G["00"]`H"));
Put_Line ("Escape date: " & Escape (Clock));
Put_Line (Get_Client_Info);
Connect (Db'Access);
Put_Line (Get_Server_Info (Db'Access));
Put_Line (Get_Host_Info (Db'Access));
Put_Line (Natural'Image (Get_Proto_Info (Db'Access)));
begin
Drop_Database (Db'Access, Ada_Db_Name);
Put_Line ("Removing old database");
exception
when Mysql_Error =>
Put_Line ("Database not existing yet");
end;
Create_Database (Db'Access, Ada_Db_Name);
Select_Database (Db'Access, Ada_Db_Name);
Query (Db'Access,
"CREATE TABLE adatest (name char(10), surn char(10), " &
"value int, d date, t time)");
Mysql_Insert.Insert (Db'Access, "adatest",
(Name => "Samuel ",
Surn => "sam ",
Value => 132,
D | T => Clock));
for I in 1 .. Query (Db'Access,
"select * from adatest")
loop
Put_Line ("--- Row" & Positive'Image (I));
Advance_Row (Db'Access);
for J in 1 .. Field_Count (Db'Access) loop
Put_Line (" " & Next_Field_As_String (Db'Access));
end loop;
end loop;
declare
Result : constant Integer_Array :=
Read_All (Db'Access, "select value from adatest");
begin
Put_Line ("### Number of answers:" & Natural'Image (Result'Length));
for I in Result'Range loop
Put_Line (" " & Integer'Image (Result (I)));
end loop;
end;
Put_Line ("Removing test database");
Drop_Database (Db'Access, Ada_Db_Name);
end Test_Mysql;
next prev parent reply other threads:[~1998-09-25 0:00 UTC|newest]
Thread overview: 4+ messages / expand[flat|nested] mbox.gz Atom feed top
1998-09-25 0:00 Ada bindings for MySQL? Jeff Foster
1998-09-25 0:00 ` Samuel Tardieu [this message]
1998-09-28 0:00 ` Jerry van Dijk
1998-09-29 0:00 ` Jeff Foster
replies disabled
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox