------------------------------------------------------------------------------
-- G N A T C O L L --
-- --
-- Copyright (C) 2005-2020, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Containers.Indefinite_Doubly_Linked_Lists;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Command_Line; use GNAT.Command_Line;
with GNAT.Expect; use GNAT.Expect;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Regexp; use GNAT.Regexp;
with GNAT.Strings;
with GNATCOLL.Arg_Lists; use GNATCOLL.Arg_Lists;
with GNATCOLL.SQL.Inspect; use GNATCOLL.SQL.Inspect;
with GNATCOLL.Strings; use GNATCOLL.Strings;
with GNATCOLL.Traces; use GNATCOLL.Traces;
with GNATCOLL.Utils; use GNATCOLL.Utils;
with GNATCOLL.VFS; use GNATCOLL.VFS;
procedure GNATCOLL.Db2Ada.Main
(Default_DB_Type : String;
Description : Db2Ada_Description)
is
Me : constant Trace_Handle := Create ("DB2ADA");
Generated : GNAT.Strings.String_Access := new String'("Database");
Generated_Orm : GNAT.Strings.String_Access := new String'("ORM_Queries");
Load_File : Virtual_File := GNATCOLL.VFS.No_File; -- File to load
Output_Dir : Virtual_File := Get_Current_Dir;
DB_Model : GNAT.OS_Lib.String_Access := null;
Orm_Tables : GNAT.OS_Lib.String_Access := null;
type Output_Kind is
(Output_Ada_Specs,
Output_Ada_Enums,
Output_Ada_Enums_Image,
Output_Text,
Output_Orm,
Output_Dot,
Output_Load,
Output_Adacreate,
Output_Createdb);
Output : array (Output_Kind) of Boolean := (others => False);
-- The type of output for this utility
Need_Schema_For_Output : constant array (Output_Kind) of Boolean :=
(Output_Ada_Enums => False, Output_Ada_Enums_Image => False,
others => True);
-- Whether the various outputs require a database schema.
Schema : DB_Schema;
DB_IO : DB_Schema_IO;
File_IO : File_Schema_IO;
package String_Lists is new Ada.Containers.Indefinite_Doubly_Linked_Lists
(String);
use String_Lists;
type Dumped_Enums is record
Base_Type : XString;
Type_Name : XString;
Prefix : XString;
Names : String_Lists.List;
Values : String_Lists.List;
end record;
-- Describes a table to be dumped. All values from this table will have an
-- Ada constant with the same value generated for them. This applies for
-- tables that correspond to enumeration types and contain special values
-- that are useful for the logic of the code.
-- Generated code looks like:
-- subtype is ;
-- For each value in the table, the following is dumped:
-- _ : constant := value;
package Enumeration_Lists is new Ada.Containers.Doubly_Linked_Lists
(Dumped_Enums);
use Enumeration_Lists;
Enumerations : Enumeration_Lists.List;
procedure Add_Enumeration
(DB : access Database_Connection_Record'Class;
Table, Id, Name, Prefix, Base_Type : String);
-- Register a table that should be dumped
type Dumped_Vars is record
Name : XString;
Value : XString;
Comment : XString;
end record;
function Ada_Quote (Str : String) return String;
-- If Str contains quotes, duplicate them so that Str can be inserted in
-- generated code
package Variables_List is new Ada.Containers.Doubly_Linked_Lists
(Dumped_Vars);
use Variables_List;
Variables : Variables_List.List;
procedure Add_Variable
(DB : access Database_Connection_Record'Class;
Name, Table, Field, Where, Comment : String);
-- Register a new variable to be dumped
procedure Print_Help;
-- Print the help and exit the application
procedure Main;
-- Get the list of parameters to use to connect to the postgres database
procedure Dump_Tables
(Connection : access Database_Connection_Record'Class;
Enums : String_Lists.List;
Vars : String_Lists.List);
-- Dump the contents of some tables into Trans. We unfortunately need some
-- hard-coded strings for some tables, and it is better to create Ada
-- constants for those rather than hard-code them every where. At least
-- when they are renamed we will be forced to change the Ada code.
procedure Generate
(Generated : String; Include_Database_Create : Boolean);
procedure Generate
(Generated : String; Include_Database_Create : Boolean) is separate;
-- Generate the actual output. This can be implemented either through
-- Ada.Text_IO or using the templates parser
-- If Include_Database_Create is true, an additional subprogram is
-- generated to regenerate the database and load initial data without
-- requiring external files.
procedure Generate_Orm;
-- Generate the ORM API via a python script
procedure Generate_Dot;
-- Generate a dot graph for the database schema
procedure Spawn_Dborm (Command : String; Extra_Args : Argument_List);
-- Spawn "python dborm.py COMMAND dbschema.txt EXTRA_ARGS".
-- Do not free Extra_Args, it is already freed in the context of this
-- procedure
---------------
-- Ada_Quote --
---------------
function Ada_Quote (Str : String) return String is
begin
if Str (Str'First) = '"' then
return '"' & Str & '"';
else
return Str;
end if;
end Ada_Quote;
-----------------
-- Spawn_Dborm --
-----------------
procedure Spawn_Dborm (Command : String; Extra_Args : Argument_List) is
DbOrm1 : constant String := -- official setup
Executable_Location & "share/gnatcoll/dborm.py";
DbOrm2 : constant String := -- development setup
Executable_Location & "../dborm.py";
Status : aliased Integer;
Args : Argument_List (1 .. 3 + Extra_Args'Length);
begin
if DB_Model = null then
Put_Line ("FAILED: -orm currently requires a textual description of");
Put_Line (" the schema, and does not read it from a live database"
& " (use -dbmodel=FILE)");
return;
end if;
if Is_Regular_File (DbOrm1) then
Args (1) := new String'(DbOrm1);
elsif Is_Regular_File (DbOrm2) then
Args (1) := new String'(DbOrm2);
else
Put_Line ("FAILED: could not find " & DbOrm1);
return;
end if;
Args (2) := new String'(Command);
Args (3) := new String'(DB_Model.all);
Args (4 .. Args'Length) := Extra_Args;
declare
Output : constant String := Get_Command_Output
(Command => "python",
Arguments => Args,
Input => "",
Status => Status'Access,
Err_To_Out => True);
begin
if Output /= "" then
Put_Line (Output);
end if;
if Status /= 0 then
Put_Line ("FAILED to execute command: "
& Argument_List_To_String (Args));
end if;
exception
when Invalid_Process =>
Put_Line ("FAILED to spawn python");
end;
Free (Args);
end Spawn_Dborm;
------------------
-- Generate_Dot --
------------------
procedure Generate_Dot is
Args : Argument_List (1 .. 200);
A : Integer := Args'First;
begin
loop
declare
Cluster : constant String := GNAT.Command_Line.Get_Argument;
begin
exit when Cluster = "";
Args (A) := new String'(Cluster);
A := A + 1;
end;
end loop;
Spawn_Dborm ("-graph", Args (Args'First .. A - 1));
end Generate_Dot;
------------------
-- Generate_Orm --
------------------
procedure Generate_Orm is
Args : Argument_List (1 .. 4);
begin
Args (1) := new String'(Generated_Orm.all);
Args (2) := new String'(Generated.all);
Args (3) := new String'(Output_Dir.Display_Full_Name);
if Orm_Tables /= null then
Args (4) := new String'(Orm_Tables.all);
else
Args (4) := new String'("");
end if;
Spawn_Dborm ("-ada", Args);
end Generate_Orm;
----------------
-- Print_Help --
----------------
procedure Print_Help is
begin
Put_Line ("==== Specifying the database");
Put_Line ("-dbmodel : textual description of the database schema");
Put_Line (" Not compatible with -enum and -var");
Put_Line ("-dbhost : host on which the database runs");
Put_Line ("-dbname : name of the database");
Put_Line ("-dbuser : user name to log in the database");
Put_Line ("-dbpasswd : password for the database");
Put_Line ("-dbport : port for the database");
Put_Line ("-dbtype : database backend to use"
& " (default is " & Default_DB_Type & ")");
Put_Line ("-dbfilter REGEXP: regular expression filtering tables used");
Put_Line (" for -text and -api output generation from database.");
Put_Line (" The default is to use all tables.");
New_Line;
Put_Line ("==== Specifying output");
Put_Line ("The default output is a set of Ada files that represent the");
Put_Line ("database schema.");
Put_Line ("-enum table,id,name,prefix,base");
Put_Line (" Name of a table to dump. Used for for enumeration-like");
Put_Line (" tables, which might contain special values. This will");
Put_Line (" generate Ada code like");
Put_Line (" subtype _id is ;");
Put_Line (" _... : constant _id := ...;");
Put_Line ("-enum-image");
Put_Line (" Generate image function for integer enums");
Put_Line ("-var name,table,field,criteria,comment");
Put_Line (" Similar to -enum, but dumps one specific value");
Put_Line (" from a table, selected with criteria.");
Put_Line ("-text: generate a textual description of the database,");
Put_Line (" instead of usual output. Disables -api.");
Put_Line ("-omit-schema: Schema name have to be omitted in text output");
Put_Line ("-createdb: Creates the database given by -dbname");
Put_Line ("-adacreate: Generates an Ada function to create the schema");
Put_Line (" and load the initial data (embedded files from -dbmodel");
Put_Line (" and -load, if specified). This requires -api");
Put_Line ("-api PKG: generate an Ada package describing the schema");
Put_Line (" This is the default output, with PKG='database'");
Put_Line
("-api-enums PKG: generates an Ada package that extracts values");
Put_Line
(" from a database (see -enum and -var). Similar to -api, but");
Put_Line (" does not dump the tables schema");
Put_Line ("-orm PKG: generate a high-level Ada package to manipulate");
Put_Line (" Ada objects rather than SQL queries. This package");
Put_Line (" depends on the one generated by -api.");
Put_Line ("-ormtables LIST: a comma-separated list of tables for which");
Put_Line (" an ORM binding should be generated. The default is");
Put_Line (" to bind all tables");
Put_Line ("-dot: generate in the current directory a file schema.dot");
Put_Line (" representing the database schema. If possible, this is");
Put_Line (" converted to Postscript via the graphviz utility 'dot'");
Put_Line ("-load FILE: load the file contents into the database.");
Put_Line (" You should also use -dbmodel to specify the schema.");
Put_Line ("-output DIR: directory in which created files should go");
Put_Line (" Applies to -api, -orm and -api-enums");
GNAT.OS_Lib.OS_Exit (0);
end Print_Help;
----------
-- Main --
----------
procedure Main is
DB_Name : GNAT.OS_Lib.String_Access := new String'("");
DB_Host : GNAT.OS_Lib.String_Access := new String'("");
DB_User : GNAT.OS_Lib.String_Access := new String'("");
DB_Passwd : GNAT.OS_Lib.String_Access := new String'("");
DB_Port : Integer := -1;
DB_Type : GNAT.OS_Lib.String_Access := new String'(Default_DB_Type);
DB_Filter : Regexp := Compile (".*");
Enums, Vars : String_Lists.List;
-- The internal index corresponding to each table. This is used to
-- create the adjacency matrix, that indicates whether there is a known
-- relationship between two tables.
Descr : Database_Description;
Connection : Database_Connection;
Need_Schema : Boolean;
begin
loop
case Getopt ("dbhost= h -help dbname= dbuser= dbpasswd= enum= var="
& " dbtype= dbmodel= dot text orm= createdb api="
& " adacreate dbport= enum-image dbfilter= omit-schema="
& " ormtables= api-enums= load= output=")
is
when 'h' | '-' =>
Print_Help;
when 'a' =>
if Full_Switch = "api" then
if Parameter /= "" then
Free (Generated);
Generated := new String'(Parameter);
end if;
Output (Output_Ada_Specs) := True;
Output (Output_Ada_Enums) := True;
elsif Full_Switch = "api-enums" then
if Parameter /= "" then
Free (Generated);
Generated := new String'(Parameter);
end if;
Output (Output_Ada_Enums) := True;
elsif Full_Switch = "adacreate" then
Output (Output_Adacreate) := True;
end if;
when 'd' =>
if Full_Switch = "dot" then
Output (Output_Dot) := True;
elsif Full_Switch = "dbhost" then
Free (DB_Host);
DB_Host := new String'(Parameter);
elsif Full_Switch = "dbname" then
Free (DB_Name);
DB_Name := new String'(Parameter);
elsif Full_Switch = "dbuser" then
Free (DB_User);
DB_User := new String'(Parameter);
elsif Full_Switch = "dbpasswd" then
Free (DB_Passwd);
DB_Passwd := new String'(Parameter);
elsif Full_Switch = "dbtype" then
Free (DB_Type);
DB_Type := new String'(Parameter);
elsif Full_Switch = "dbport" then
begin
DB_Port := Integer'Value (Parameter);
exception
when Constraint_Error =>
DB_Port := -1;
end;
elsif Full_Switch = "dbmodel" then
Free (DB_Model);
DB_Model := new String'(Parameter);
elsif Full_Switch = "dbfilter" then
DB_Filter := GNAT.Regexp.Compile (Parameter);
end if;
when 'c' =>
Output (Output_Createdb) := True;
when 'e' =>
if Full_Switch = "enum-image" then
Output (Output_Ada_Enums_Image) := True;
else
Append (Enums, Parameter);
end if;
when 'v' =>
Append (Vars, Parameter);
when 't' =>
Output (Output_Text) := True;
when 'l' =>
Output (Output_Load) := True;
Load_File := Create (+Parameter);
when 'o' =>
if Full_Switch = "ormtables" then
Free (Orm_Tables);
Orm_Tables := new String'(Parameter);
elsif Full_Switch = "orm" then
if Parameter /= "" then
Free (Generated_Orm);
Generated_Orm := new String'(Parameter);
end if;
Output (Output_Orm) := True;
elsif Full_Switch = "output" then
Output_Dir := Create (+Parameter);
elsif Full_Switch = "omit-schema" then
File_IO.Omit_Schema.Include (Parameter);
end if;
when others =>
exit;
end case;
end loop;
if Output = (Output_Kind => False) then
Output := (Output_Ada_Specs => True,
Output_Ada_Enums => True,
others => False);
end if;
Need_Schema := False;
for J in Need_Schema_For_Output'Range loop
if Output (J) and then Need_Schema_For_Output (J) then
Need_Schema := True;
exit;
end if;
end loop;
if DB_Name.all /= "" then
-- If the user specified the name of a database, we connect to it.
-- This might be to read the schema, or to create the database
Descr := Description (
DB_Type => DB_Type.all,
Database => DB_Name.all,
User => DB_User.all,
Host => DB_Host.all,
Password => DB_Passwd.all,
Port => DB_Port);
if Descr = null then
Ada.Text_IO.Put_Line ("Database not supported: " & DB_Type.all);
Set_Exit_Status (Failure);
return;
end if;
Connection := Descr.Build_Connection;
DB_IO.DB := Connection;
DB_IO.Filter := DB_Filter;
-- If we should read the model from the database
if DB_Model = null then
if Need_Schema then
Schema := DB_IO.Read_Schema;
end if;
end if;
end if;
if DB_Model /= null then
File_IO.File := GNATCOLL.VFS.Create (+DB_Model.all);
if Need_Schema then
Schema := File_IO.Read_Schema;
end if;
end if;
-- Output will always be to stdout
File_IO.File := No_File;
Free (DB_Name);
Free (DB_Host);
Free (DB_User);
Free (DB_Passwd);
Free (DB_Type);
if Need_Schema and then Schema = No_Schema then
Put_Line ("Could not parse the database schema, exiting...");
Set_Exit_Status (Failure);
return;
end if;
-- The order below is significant, in case multiple switches are
-- specified on the command line
if Output (Output_Createdb) then
DB_IO.Write_Schema (Schema);
end if;
if Output (Output_Load) then
Load_Data
(DB => DB_IO.DB,
File => Load_File,
Schema => Schema);
DB_IO.DB.Commit;
end if;
if Output (Output_Ada_Specs)
or else Output (Output_Ada_Enums)
or else Output (Output_Adacreate)
then
Dump_Tables (Connection, Enums, Vars);
Generate (Generated.all,
Include_Database_Create => Output (Output_Adacreate));
end if;
if Output (Output_Text) then
File_IO.Write_Schema (Schema);
end if;
if Output (Output_Orm) then
Generate_Orm;
end if;
if Output (Output_Dot) then
Generate_Dot;
end if;
Free (DB_Model);
Free (Generated);
Free (Generated_Orm);
exception
when GNAT.Command_Line.Invalid_Switch
| GNAT.Command_Line.Invalid_Parameter =>
Put_Line ("gnatcoll_db2ada: unrecognized option '-"
& Full_Switch & "'");
Put_Line ("Try `gnatcoll_db2ada --help` for more information.");
Set_Exit_Status (Failure);
end Main;
---------------------
-- Add_Enumeration --
---------------------
procedure Add_Enumeration
(DB : access Database_Connection_Record'Class;
Table, Id, Name, Prefix, Base_Type : String)
is
Enum : Dumped_Enums;
R : GNATCOLL.SQL.Exec.Forward_Cursor;
begin
Enum.Prefix := To_XString (Prefix);
if Base_Type = "" then
Enum.Base_Type := To_XString ("Integer");
else
Enum.Base_Type := To_XString (Base_Type);
end if;
Enum.Type_Name := To_XString (Prefix & "_Id");
if Name /= "" then
R.Fetch
(DB,
"SELECT """ & Id & """, """ & Name & """ FROM """ & Table
& """ ORDER BY lower(""" & Name & """)");
while Has_Row (R) loop
Append (Enum.Values, Value (R, 0));
Append (Enum.Names, Value (R, 1));
Next (R);
end loop;
end if;
Append (Enumerations, Enum);
end Add_Enumeration;
------------------
-- Add_Variable --
------------------
procedure Add_Variable
(DB : access Database_Connection_Record'Class;
Name, Table, Field, Where, Comment : String)
is
R : GNATCOLL.SQL.Exec.Forward_Cursor;
Var : Dumped_Vars;
begin
if Where /= "" then
R.Fetch (DB, "SELECT " & Field
& " FROM """ & Table & """ WHERE " & Where);
else
R.Fetch (DB, "SELECT " & Field & " FROM """ & Table & '"');
end if;
Var.Name := To_XString (Name);
Var.Value := To_XString (Value (R, 0));
Var.Comment := To_XString (Comment);
Append (Variables, Var);
end Add_Variable;
-----------------
-- Dump_Tables --
-----------------
procedure Dump_Tables
(Connection : access Database_Connection_Record'Class;
Enums : String_Lists.List;
Vars : String_Lists.List)
is
C : String_Lists.Cursor;
Comma1, Comma2, Comma3, Comma4 : Integer;
begin
C := First (Enums);
while Has_Element (C) loop
declare
Str : constant String := Element (C);
begin
Comma1 := Index (Str, ",");
Comma2 := Index (Str (Comma1 + 1 .. Str'Last), ",");
Comma3 := Index (Str (Comma2 + 1 .. Str'Last), ",");
Comma4 := Index (Str (Comma3 + 1 .. Str'Last), ",");
if Comma4 < Str'First
or Comma3 < Str'First
or Comma2 < Str'First
then
Ada.Text_IO.Put_Line ("Missing arguments for -enum " & Str);
return;
end if;
Add_Enumeration
(Connection,
Table => Str (Str'First .. Comma1 - 1),
Id => Str (Comma1 + 1 .. Comma2 - 1),
Name => Str (Comma2 + 1 .. Comma3 - 1),
Prefix => Str (Comma3 + 1 .. Comma4 - 1),
Base_Type => Str (Comma4 + 1 .. Str'Last));
end;
Next (C);
end loop;
C := First (Vars);
while Has_Element (C) loop
declare
Str : constant String := Element (C);
begin
Comma1 := Index (Str, ",");
Comma2 := Index (Str (Comma1 + 1 .. Str'Last), ",");
Comma3 := Index (Str (Comma2 + 1 .. Str'Last), ",");
Comma4 := Index (Str (Comma3 + 1 .. Str'Last), ",");
if Comma4 < Str'First then
Ada.Text_IO.Put_Line ("Missing arguments for -var " & Str);
return;
end if;
Add_Variable
(Connection,
Name => Str (Str'First .. Comma1 - 1),
Table => Str (Comma1 + 1 .. Comma2 - 1),
Field => Str (Comma2 + 1 .. Comma3 - 1),
Where => Str (Comma3 + 1 .. Comma4 - 1),
Comment => Str (Comma4 + 1 .. Str'Last));
end;
Next (C);
end loop;
end Dump_Tables;
begin
GNATCOLL.Traces.Parse_Config_File;
Main;
GNATCOLL.Traces.Finalize;
exception
when E : Invalid_Type =>
Ada.Text_IO.Put_Line
(Ada.Text_IO.Standard_Error, Exception_Message (E));
Set_Exit_Status (Failure);
when E : others =>
Trace (Me, E);
Ada.Text_IO.Put_Line
(Ada.Text_IO.Standard_Error,
"A database error occurred, please try again...");
Ada.Text_IO.Put_Line
(Ada.Text_IO.Standard_Error, Exception_Information (E));
Set_Exit_Status (Failure);
end GNATCOLL.DB2Ada.Main;