├── version_information ├── testsuite ├── e3-test.yaml ├── tests │ ├── sql1 │ │ ├── test.yaml │ │ ├── test.gpr │ │ ├── gnatcoll-sql-unit_tests.ads │ │ ├── test.adb │ │ └── database.adb │ ├── subsec │ │ ├── test.yaml │ │ ├── subsec.gpr │ │ └── test.adb │ └── db2ada │ │ ├── enums │ │ ├── db.sql │ │ ├── test.yaml │ │ └── test.adb │ │ └── chinook │ │ ├── chinook.gpr │ │ ├── test.sh │ │ └── test.yaml ├── support │ ├── test.gpr │ ├── test_assert.ads │ ├── test_remote.ads │ └── test_assert.adb ├── README.md ├── drivers │ ├── basic.py │ └── db2ada.py └── run-tests ├── pgxs ├── source │ ├── pgxs.sym │ ├── pgxs-pools-defaults.ads │ ├── pgxs-generic_bytea.ads │ ├── pgxs-pools.adb │ ├── pgxs-abi.ads │ ├── pgxs-varlen.ads │ ├── pgxs-generic_bytea.adb │ ├── pgxs.ads │ ├── pgxs-varlen.adb │ ├── pgxs-pools.ads │ ├── pgxs-types.ads │ ├── pgxs-logs.ads │ ├── pgxs-composites.adb │ ├── pgxs-return_sets.ads │ └── pgxs-composites.ads ├── .gitignore ├── example │ ├── schema.sql │ ├── module.sql.in │ ├── module.gpr │ ├── sample.ads │ └── sample.adb ├── testsuite │ ├── test_pgxs.expected │ ├── README.md │ ├── test_pgxs.sql │ ├── module.gpr │ └── module.sql.in ├── Makefile └── README.md ├── docs ├── note.png ├── tip.png ├── favicon.ico ├── important.png ├── adacore-logo-white.png └── index.rst ├── gnat_debug.adc ├── .gitreview ├── sqlite ├── amalgamation │ └── README ├── README.md ├── gnatcoll-sql-sqlite-builder.ads ├── gnatcoll_sqlite.gpr └── gnatcoll_sqlite_conf.gpr ├── examples └── library │ ├── generate.sh │ ├── README │ ├── default.gpr │ ├── fixture.txt │ ├── dbschema.txt │ └── generated │ ├── database.adb │ └── database_names.ads ├── .gitattributes ├── .flake8 ├── .gitignore ├── .pre-commit-config.yaml ├── CONTRIBUTING.md ├── gnatcoll_db2ada ├── README.md ├── gnatcoll-db2ada-main.ads ├── gnatcoll_db2ada.gpr ├── gnatcoll_postgres2ada.gpr ├── gnatcoll_sqlite2ada.gpr ├── gnatcoll_all2ada.gpr ├── gnatcoll-db2ada.ads ├── gnatcoll_db2ada.adb ├── gnatcoll_sqlite2ada.adb ├── gnatcoll_postgres2ada.adb └── gnatcoll_all2ada.adb ├── gnatinspect ├── README.md └── gnatinspect.gpr ├── postgres ├── README.md ├── postgres_support.c ├── gnatcoll-sql-postgres-builder.ads ├── gnatcoll_postgres.gpr └── gnatcoll_postgres_conf.gpr ├── gen_gps_help.py ├── README.md ├── xref ├── README.md ├── gnatcoll_xref.gpr └── gnatcoll_xref_conf.gpr ├── sql ├── gnatcoll-sql_fields.adb ├── gnatcoll_sql.gpr ├── gnatcoll_sql_conf.gpr ├── gnatcoll-sql-exec-tasking.ads └── gnatcoll-sql-orm.adb ├── COPYING.RUNTIME └── gnatcoll_db_shared.gpr /version_information: -------------------------------------------------------------------------------- 1 | 0.0 2 | -------------------------------------------------------------------------------- /testsuite/e3-test.yaml: -------------------------------------------------------------------------------- 1 | main: run-tests 2 | default_args: [] 3 | -------------------------------------------------------------------------------- /testsuite/tests/sql1/test.yaml: -------------------------------------------------------------------------------- 1 | description: Test 1 for GNATCOLL.SQL 2 | -------------------------------------------------------------------------------- /pgxs/source/pgxs.sym: -------------------------------------------------------------------------------- 1 | PGXSSYMS { 2 | global: 3 | Pg_magic_func; 4 | }; 5 | -------------------------------------------------------------------------------- /docs/note.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AdaCore/gnatcoll-db/HEAD/docs/note.png -------------------------------------------------------------------------------- /docs/tip.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AdaCore/gnatcoll-db/HEAD/docs/tip.png -------------------------------------------------------------------------------- /testsuite/tests/subsec/test.yaml: -------------------------------------------------------------------------------- 1 | description: Test for subseconds in timestamp 2 | -------------------------------------------------------------------------------- /docs/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AdaCore/gnatcoll-db/HEAD/docs/favicon.ico -------------------------------------------------------------------------------- /gnat_debug.adc: -------------------------------------------------------------------------------- 1 | pragma Initialize_Scalars; 2 | -- pragma Restrictions (No_Streams); 3 | -------------------------------------------------------------------------------- /docs/important.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AdaCore/gnatcoll-db/HEAD/docs/important.png -------------------------------------------------------------------------------- /pgxs/.gitignore: -------------------------------------------------------------------------------- 1 | .objs 2 | .libs 3 | example/module.sql 4 | testsuite/module.sql 5 | test_pgxs.output 6 | -------------------------------------------------------------------------------- /docs/adacore-logo-white.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AdaCore/gnatcoll-db/HEAD/docs/adacore-logo-white.png -------------------------------------------------------------------------------- /.gitreview: -------------------------------------------------------------------------------- 1 | [gerrit] 2 | host = git.adacore.com 3 | port = 29418 4 | project = gnatcoll-db 5 | defaultbranch = master 6 | -------------------------------------------------------------------------------- /sqlite/amalgamation/README: -------------------------------------------------------------------------------- 1 | This is SQLite amalgamation-3210000 downloaded from 2 | http://www.sqlite.org/download.html 3 | -------------------------------------------------------------------------------- /examples/library/generate.sh: -------------------------------------------------------------------------------- 1 | cd generated 2 | 3 | # Generate the Ada API 4 | gnatcoll_db2ada -api=Database -orm=ORM -dbmodel=../dbschema.txt 5 | -------------------------------------------------------------------------------- /testsuite/tests/db2ada/enums/db.sql: -------------------------------------------------------------------------------- 1 | CREATE TABLE colors (name text, value int); 2 | INSERT INTO colors (name, value) VALUES ('red', 1), ('green', 2), ('dark gray', 3); 3 | .quit 4 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | docs/conf.py no-precommit-check 2 | sqlite/amalgamation/* no-precommit-check 3 | testsuite/** no-precommit-check 4 | -------------------------------------------------------------------------------- /examples/library/README: -------------------------------------------------------------------------------- 1 | This is the library example declared in the GNATCOLL.SQL documentation. 2 | 3 | To build example execute: 4 | 5 | gprbuild -p 6 | 7 | To run example execute: 8 | 9 | obj/library 10 | -------------------------------------------------------------------------------- /testsuite/tests/db2ada/chinook/chinook.gpr: -------------------------------------------------------------------------------- 1 | with "gnatcoll_core"; 2 | with "gnatcoll_sqlite"; 3 | 4 | project Chinook is 5 | for Main use ("test.adb"); 6 | for Source_Dirs use (".", "../../../support"); 7 | for Object_Dir use "obj"; 8 | end Chinook; 9 | -------------------------------------------------------------------------------- /testsuite/tests/db2ada/enums/test.yaml: -------------------------------------------------------------------------------- 1 | description: Do not quote original names in enum image function 2 | sqlite_db: "db.sql" 3 | db2ada: ["-enum", "colors,value,name,Color,Integer", 4 | "-enum-image", "-api-enums", "colorspkg"] 5 | driver: db2ada 6 | -------------------------------------------------------------------------------- /testsuite/tests/db2ada/enums/test.adb: -------------------------------------------------------------------------------- 1 | with Colorspkg; use Colorspkg; 2 | with Test_Assert; 3 | function Test return Integer is 4 | package A renames Test_Assert; 5 | begin 6 | A.Assert (Image_Color_Id (Color_Dark_Gray) = "dark gray"); 7 | return A.Report; 8 | end Test; 9 | -------------------------------------------------------------------------------- /testsuite/tests/subsec/subsec.gpr: -------------------------------------------------------------------------------- 1 | with "gnatcoll_core"; 2 | -- with "gnatcoll_postgres"; 3 | with "gnatcoll_sqlite"; 4 | 5 | project Subsec is 6 | for Main use ("test.adb"); 7 | for Source_Dirs use (".", "../../support"); 8 | for Object_Dir use "obj"; 9 | end Subsec; 10 | -------------------------------------------------------------------------------- /.flake8: -------------------------------------------------------------------------------- 1 | [flake8] 2 | exclude = .git,__pycache__ 3 | filename = *.py 4 | # See 5 | # https://github.com/psf/black/blob/main/docs/guides/using_black_with_other_tools.md#flake8 6 | # to understand the max-line-length and ignore settings. 7 | max-line-length = 80 8 | ignore = E203, E501, W503, B907 9 | select = ANN,B,B9,BLK,C,E,F,T4,W 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | makefile.setup 2 | 3 | gnat/ 4 | 5 | docs/_build 6 | 7 | *.cgpr 8 | b__* 9 | *.bexch 10 | *.a 11 | *.d 12 | gnatinspect.db 13 | obj/ 14 | lib/ 15 | *.stdout 16 | *.stderr 17 | *.ali 18 | *.gli 19 | *.exe 20 | *.gcda 21 | *.gcno 22 | *.gcov 23 | *.bexch 24 | *.o 25 | *.deps 26 | *.pyc 27 | /gnat_src 28 | 29 | examples/library/obj 30 | -------------------------------------------------------------------------------- /pgxs/example/schema.sql: -------------------------------------------------------------------------------- 1 | 2 | CREATE TABLE emp 3 | (name CHARACTER VARYING NOT NULL UNIQUE, 4 | salary INTEGER); 5 | 6 | INSERT INTO emp VALUES ('Bill', 900); 7 | INSERT INTO emp VALUES ('Bob', 90); 8 | INSERT INTO emp VALUES ('Sam', 9); 9 | INSERT INTO emp VALUES ('Null', null); 10 | 11 | CREATE TYPE apgxs_composite_type AS (x integer, y integer); 12 | -------------------------------------------------------------------------------- /testsuite/tests/db2ada/chinook/test.sh: -------------------------------------------------------------------------------- 1 | # It is not part of the test, it is script to debug/develop test 2 | rm db.db database*.ad? 3 | set -e 4 | sqlite3 -cmd ".read chinook.sql" db.db 5 | gnatcoll_sqlite2ada -dbname db.db 6 | gprbuild -p 7 | obj/test 8 | 9 | gnatcoll_sqlite2ada -dbname db.db -text > schema.txt 10 | gnatcoll_sqlite2ada -dbmodel schema.txt -orm orm 11 | -------------------------------------------------------------------------------- /.pre-commit-config.yaml: -------------------------------------------------------------------------------- 1 | repos: 2 | - repo: https://github.com/psf/black 3 | rev: 23.1.0 4 | hooks: 5 | - id: black 6 | - repo: https://github.com/pycqa/flake8 7 | rev: 6.0.0 8 | hooks: 9 | - id: flake8 10 | additional_dependencies: 11 | - flake8-bugbear 12 | - flake8-builtins 13 | - flake8-comprehensions 14 | - flake8-docstrings 15 | - flake8-rst-docstrings 16 | - pygments 17 | -------------------------------------------------------------------------------- /pgxs/example/module.sql.in: -------------------------------------------------------------------------------- 1 | 2 | CREATE OR REPLACE FUNCTION to_bytea(integer, integer) RETURNS bytea 3 | AS '@MODULEDIR@/libadamodule', 'to_bytea' 4 | LANGUAGE C STRICT; 5 | 6 | CREATE OR REPLACE FUNCTION get_x(bytea) RETURNS integer 7 | AS '@MODULEDIR@/libadamodule', 'get_x' 8 | LANGUAGE C STRICT; 9 | 10 | CREATE OR REPLACE FUNCTION get_y(bytea) RETURNS integer 11 | AS '@MODULEDIR@/libadamodule', 'get_y' 12 | LANGUAGE C STRICT; 13 | -------------------------------------------------------------------------------- /docs/index.rst: -------------------------------------------------------------------------------- 1 | GNATcoll - Database packages 2 | ============================ 3 | 4 | .. toctree:: 5 | :numbered: 6 | :maxdepth: 3 7 | 8 | sql 9 | xref 10 | 11 | Indices and tables 12 | ================== 13 | 14 | * :ref:`genindex` 15 | 16 | This document may be copied, in whole or in part, in any form or by any 17 | means, as is or with alterations, provided that (1) alterations are clearly 18 | marked as alterations and (2) this copyright notice is included 19 | unmodified in any copy. 20 | -------------------------------------------------------------------------------- /testsuite/support/test.gpr: -------------------------------------------------------------------------------- 1 | -- Default project use for tests 2 | -- 3 | -- The scenario variable TEST_SOURCES is automatically set by the 4 | -- driver to point to the test sources. 5 | with "gnatcoll_core"; 6 | 7 | project Test is 8 | Test_Sources := External("TEST_SOURCES"); 9 | Support_Sources := External("SUPPORT_SOURCES"); 10 | for Source_Dirs use (".", Support_Sources, Test_Sources); 11 | for Main use ("test.adb"); 12 | for Languages use ("Ada"); 13 | for Object_Dir use "obj"; 14 | end Test; 15 | -------------------------------------------------------------------------------- /pgxs/testsuite/test_pgxs.expected: -------------------------------------------------------------------------------- 1 | 0 2 | 3 | 1 4 | 5 | 2 6 | 7 | f 8 | 9 | t 10 | 11 | f 12 | 13 | t 14 | 15 | 2 16 | 17 | 3 18 | 19 | 4 20 | 21 | 5 22 | 23 | Bill | t 24 | Null | f 25 | Sam | f 26 | 27 | \x0200000005000000 28 | 29 | 3 30 | 31 | 8 32 | 33 | (5,10) 34 | 35 | 1 36 | 2 37 | 3 38 | 39 | ("(1,2)",3) 40 | 41 | -------------------------------------------------------------------------------- /pgxs/testsuite/README.md: -------------------------------------------------------------------------------- 1 | How to test the binding 2 | ----------------------- 3 | 4 | 1. Build an example 5 | 6 | 2. Create database as ordinary user 7 | 8 | createdb test 9 | 10 | 3. Create database schema as ordinary user 11 | 12 | psql test -f example/schema.sql 13 | 14 | 4. Create functions declarations as PostgreSQL superuser 15 | 16 | psql test -f example/module.sql 17 | 18 | 5. Run the test script 19 | 20 | psql test -f testsuite/test_pgxs.sql 21 | 22 | 6. Compare the output with the expected result 23 | -------------------------------------------------------------------------------- /examples/library/default.gpr: -------------------------------------------------------------------------------- 1 | with "gnatcoll_core"; 2 | with "gnatcoll_sqlite"; -- or "gnatcoll_postgres" 3 | 4 | project Default is 5 | for Source_Dirs use ("generated", -- generated files 6 | "src"); -- example files 7 | for Object_Dir use "obj"; 8 | for Main use ("library.adb"); 9 | 10 | package Compiler is 11 | for Switches ("Ada") use ("-g"); 12 | end Compiler; 13 | 14 | package Binder is 15 | for Switches ("Ada") use ("-E"); -- Get backtrace for exceptions 16 | end Binder; 17 | 18 | end Default; 19 | -------------------------------------------------------------------------------- /testsuite/tests/db2ada/chinook/test.yaml: -------------------------------------------------------------------------------- 1 | description: Chinook database test https://github.com/lerocha/chinook-database 2 | sqlite_db: "chinook.sql" 3 | driver: db2ada 4 | #****************************************************************************** 5 | # Chinook Database - Version 1.4 6 | # Script: Chinook_Sqlite.sql 7 | # Description: Creates and populates the Chinook database. 8 | # DB Server: Sqlite 9 | # Author: Luis Rocha 10 | # License: http://www.codeplex.com/ChinookDatabase/license 11 | #****************************************************************************** 12 | -------------------------------------------------------------------------------- /testsuite/tests/sql1/test.gpr: -------------------------------------------------------------------------------- 1 | with "gnatcoll_core"; 2 | with "gnatcoll_sql"; 3 | with "gnatcoll_postgres"; 4 | with "gnatcoll_sqlite"; 5 | 6 | project Test is 7 | for Main use ("test.adb"); 8 | for Source_Dirs use (".", "../../support"); 9 | for Object_Dir use "obj"; 10 | 11 | package Compiler is 12 | for Switches ("Ada") use ("-g", "-gnateE"); 13 | for Switches ("s-memory.adb") use ("-gnatg") & Compiler'Switches ("Ada"); 14 | end Compiler; 15 | 16 | package Binder is 17 | for Switches ("Ada") use ("-E"); 18 | end Binder; 19 | 20 | end Test; 21 | -------------------------------------------------------------------------------- /testsuite/README.md: -------------------------------------------------------------------------------- 1 | Running GNATcoll Testsuite 2 | ========================== 3 | 4 | `The testsuite is currently under construction !` 5 | 6 | To run it you need to have Python installed along with the package 7 | e3-testsuite. 8 | 9 | To install e3-testsuite: 10 | 11 | ```sh 12 | pip install git+https://github.com/AdaCore/e3-testsuite.git 13 | ``` 14 | 15 | Then do 16 | 17 | ```sh 18 | ./run-tests 19 | ``` 20 | 21 | In order to have coverage information with gcov, just add `--gcov`. In that 22 | case a summary of the coverage information is displayed at the end of the 23 | testsuite. Full coverage information can be found in `gcov/results` 24 | subdirectory. 25 | -------------------------------------------------------------------------------- /pgxs/testsuite/test_pgxs.sql: -------------------------------------------------------------------------------- 1 | 2 | SELECT apgxs_num_args(); 3 | SELECT apgxs_num_args(100500); 4 | SELECT apgxs_num_args(100500, 'x'); 5 | SELECT apgxs_arg_is_null(100); 6 | SELECT apgxs_arg_is_null(null); 7 | SELECT apgxs_inverse_bool(true); 8 | SELECT apgxs_inverse_bool(false); 9 | SELECT apgxs_add_one_smallint(CAST (1 as smallint)); 10 | SELECT apgxs_add_one_integer(CAST (2 as integer)); 11 | SELECT apgxs_add_one_float4(CAST (3 as float4)); 12 | SELECT apgxs_add_one_float8(CAST (4 as float8)); 13 | 14 | SELECT name, apgxs_overpaid(emp, 10) FROM emp WHERE name = 'Bill' OR name = 'Sam' Or name = 'Null' ORDER BY name; 15 | 16 | SELECT to_bytea(2, 5); 17 | SELECT get_x(to_bytea(3, 7)); 18 | SELECT get_y(to_bytea(4, 8)); 19 | 20 | SELECT apgxs_composite(5, 10); 21 | SELECT apgxs_set_simple(3); 22 | 23 | SELECT pos_from_bin(E'\\x00 00 80 3F 00 00 00 40 03 00 00 00'); 24 | -------------------------------------------------------------------------------- /examples/library/fixture.txt: -------------------------------------------------------------------------------- 1 | # for Emacs: -*- mode: org; mode: flyspell; fill-column: 79 -*- 2 | 3 | | TABLE | customers | | 4 | | id | first | last | 5 | |-------+-----------+--------| 6 | | 1 | John | Smith | 7 | | 2 | Alain | Dupont | 8 | 9 | | TABLE | books | | | | 10 | | title | author | pages | published | borrowed_by | 11 | |------------+---------+-------+------------+-------------| 12 | | Art of War | Sun Tzu | 90 | 01-01-2000 | 1 | 13 | | Ada RM | WRG | 250 | 01-07-2005 | | 14 | 15 | | TABLE | dvds | | | 16 | | title | author | region | borrowed_by(&last) | 17 | |--------------+----------+--------+--------------------| 18 | | The Birds | Hitchcok | 1 | &Smith | 19 | | The Dictator | Chaplin | 3 | &Dupont | 20 | -------------------------------------------------------------------------------- /pgxs/Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: setup 3 | gprbuild -p -P example/module.gpr -XPG_CONFIG_INCLUDEDIR_SERVER=`pg_config --includedir-server` 4 | gprbuild -p -P testsuite/module.gpr -XPG_CONFIG_INCLUDEDIR_SERVER=`pg_config --includedir-server` 5 | 6 | setup: 7 | sed "s/@MODULEDIR@/`pwd | sed 's/\\//\\\\\\//g'`\/.libs/" example/module.sql.in > example/module.sql 8 | sed "s/@MODULEDIR@/`pwd | sed 's/\\//\\\\\\//g'`\/.libs/" testsuite/module.sql.in > testsuite/module.sql 9 | 10 | clean: 11 | rm -rf .objs .libs 12 | rm -f example/module.sql testsuite/module.sql 13 | rm -f test_pgxs.output 14 | 15 | initdb_ordinary: 16 | dropdb test || true 17 | createdb test 18 | psql test -f testsuite/schema.sql 19 | 20 | initdb_super: 21 | psql test -f example/module.sql 22 | psql test -f testsuite/module.sql 23 | 24 | check: 25 | psql -q -t test -f testsuite/test_pgxs.sql > test_pgxs.output 26 | diff -u testsuite/test_pgxs.expected test_pgxs.output 27 | rm test_pgxs.output 28 | -------------------------------------------------------------------------------- /pgxs/testsuite/module.gpr: -------------------------------------------------------------------------------- 1 | 2 | library project Module is 3 | 4 | IncludeDir_Server := 5 | external ("PG_CONFIG_INCLUDEDIR_SERVER", "/usr/include/pgsql/server"); 6 | -- A Path to server extensions header files reported by 7 | -- 8 | -- $ pg_config --includedir-server 9 | 10 | for Languages use ("C", "Ada"); 11 | for Object_Dir use "../.objs/test"; 12 | for Source_Dirs use (".", "../source"); 13 | 14 | for Library_Name use "adatestmodule"; 15 | for Library_Kind use "relocatable"; 16 | for Library_Dir use "../.libs"; 17 | for Library_Options use ("-Wl,--version-script=../../source/pgxs.sym"); 18 | for Library_Interface use 19 | ("Test_PGXS", 20 | "PGXS", 21 | "PGXS.ABI", 22 | "PGXS.Call_Info", 23 | "PGXS.Datums", 24 | "PGXS.Generic_Bytea", 25 | "PGXS.Types", 26 | "PGXS.Varlen"); 27 | 28 | package Compiler is 29 | for Switches ("Ada") use ("-g", "-fPIC"); 30 | for Switches ("C") use ("-g", "-fPIC", "-I" & IncludeDir_Server); 31 | end Compiler; 32 | 33 | end Module; 34 | -------------------------------------------------------------------------------- /pgxs/example/module.gpr: -------------------------------------------------------------------------------- 1 | 2 | library project Module is 3 | 4 | IncludeDir_Server := 5 | external ("PG_CONFIG_INCLUDEDIR_SERVER", "/usr/include/pgsql/server"); 6 | -- A Path to server extensions header files reported by 7 | -- 8 | -- $ pg_config --includedir-server 9 | 10 | for Languages use ("C", "Ada"); 11 | for Object_Dir use "../.objs/module"; 12 | for Source_Dirs use (".", "../source", "../testsuite"); 13 | 14 | for Library_Name use "adamodule"; 15 | for Library_Kind use "relocatable"; 16 | for Library_Dir use "../.libs"; 17 | for Library_Options use ("-Wl,--version-script=../../source/pgxs.sym"); 18 | for Library_Interface use 19 | ("Sample", 20 | "PGXS", 21 | "PGXS.ABI", 22 | "PGXS.Call_Info", 23 | "PGXS.Datums", 24 | "PGXS.Generic_Bytea", 25 | "PGXS.Types", 26 | "PGXS.Varlen"); 27 | 28 | package Compiler is 29 | for Switches ("Ada") use ("-g", "-fPIC"); 30 | for Switches ("C") use ("-g", "-fPIC", "-I" & IncludeDir_Server); 31 | end Compiler; 32 | 33 | end Module; 34 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | Contributing to GNATcoll 2 | ======================== 3 | 4 | Thank you for taking the time to contribute! 5 | 6 | If this is your first contribution, we invite you to read our [list of 7 | guidelines](https://github.com/AdaCore/contributing-howto), common to all 8 | AdaCore repositories. 9 | 10 | Below are specific guidelines to contribute to GNATcoll. 11 | 12 | Coding style 13 | ------------ 14 | 15 | Please follow [GNAT's coding style](https://gcc.gnu.org/onlinedocs/gnat-style/) 16 | for Ada code, and [PEP8](https://www.python.org/dev/peps/pep-0008/) for Python 17 | code. 18 | 19 | Commits 20 | ------- 21 | 22 | Organize your work into separated, atomic commits. A commit should 23 | ideally contain the single smallest unit of change possible without breaking 24 | anything. A change should include any tests that were added or modified for it. 25 | 26 | Testing 27 | ------- 28 | 29 | Every change you add to the code should be tested. If this is a bug fix, add 30 | regression test(s). If it's a change of functionality, add functional test(s). 31 | The available tests should provide 100% coverage of the lines added or modified 32 | by the change; if this is not achievable, provide justification why some lines 33 | can't be covered (such as defensive code, etc). 34 | 35 | Please refer to [GNATcoll testsuite documentation](testsuite/README.md) for 36 | technical details. 37 | -------------------------------------------------------------------------------- /examples/library/dbschema.txt: -------------------------------------------------------------------------------- 1 | # for Emacs: -*- mode: org; mode: flyspell; fill-column: 79 -*- 2 | 3 | | TABLE | customers | customer | | The customer for the library | 4 | | id | AUTOINCREMENT | PK | | Auto-generated id | 5 | | first | TEXT | NOT NULL | | Customer's first name | 6 | | last | TEXT | NOT NULL, INDEX | | Customer's last name | 7 | 8 | | ABSTRACT TABLE | media | media | | The contents of the library | 9 | | id | AUTOINCREMENT | PK | | Auto-generated id | 10 | | title | TEXT | | | The title of the media | 11 | | author | TEXT | | | The author | 12 | | published | DATE | | | Publication date | 13 | 14 | | TABLE (media) | books | book | | The books in the library | 15 | | pages | INTEGER | | 100 | | 16 | | borrowed_by | FK customers(borrowed_books) | NULL | | Who borrowed the media | 17 | 18 | | TABLE (media) | dvds | dvd | | The dvds in the library | 19 | | region | INTEGER | | 1 | | 20 | | borrowed_by | FK customers(borrowed_dvds) | NULL | | Who borrowed the media | 21 | -------------------------------------------------------------------------------- /gnatcoll_db2ada/README.md: -------------------------------------------------------------------------------- 1 | The GNAT Components Collection (GNATCOLL) - gnatcoll_db2ada 2 | =========================================================== 3 | 4 | ??? WORK IN PROGRESS 5 | 6 | The gnatcoll_db2ada tool. 7 | 8 | Dependencies 9 | ------------ 10 | 11 | This component requires the following external components, that should be 12 | available on your system: 13 | 14 | - gprbuild 15 | - gnatcoll-core 16 | 17 | Configuring the build process 18 | ----------------------------- 19 | 20 | The following variables can be used to configure the build process: 21 | 22 | General: 23 | 24 | prefix : location of the installation, the default is the running 25 | GNAT installation root. 26 | 27 | BUILD : control the build options : PROD (default) or DEBUG 28 | 29 | PROCESSORS : parallel compilation (default is 0, which uses all available 30 | cores) 31 | 32 | TARGET : for cross-compilation, auto-detected for native platforms 33 | 34 | SOURCE_DIR : for out-of-tree build 35 | 36 | INTEGRATED : treat prefix as compiler installation (yes/no) 37 | this is so that installed gnatcoll project can later be 38 | referenced as predefined project of this compiler; 39 | this adds a normalized target subdir to prefix 40 | default is "no" 41 | 42 | To use the default options: 43 | 44 | $ make setup 45 | 46 | Building 47 | -------- 48 | 49 | The component is built using a standalone GPR project file. 50 | 51 | It is also possible to use the provided Makefile: 52 | 53 | $ make 54 | 55 | Then, to install it: 56 | 57 | $ make install 58 | 59 | 60 | Bug reports 61 | ----------- 62 | 63 | Please send questions and bug reports to support@adacore.com following 64 | the same procedures used to submit reports with the GNAT toolset itself. 65 | -------------------------------------------------------------------------------- /gnatinspect/README.md: -------------------------------------------------------------------------------- 1 | The GNAT Components Collection (GNATCOLL) - gnatinspect 2 | ======================================================= 3 | 4 | The gnatinspect tool. 5 | 6 | Dependencies 7 | ------------ 8 | 9 | This component requires the following external components, that should be 10 | available on your system: 11 | 12 | - gprbuild 13 | - gnatcoll-core 14 | - gnatcoll-readline 15 | - gnatcoll-xref 16 | - gnatcoll-sqlite 17 | 18 | Configuring the build process 19 | ----------------------------- 20 | 21 | The following variables can be used to configure the build process: 22 | 23 | General: 24 | 25 | prefix : location of the installation, the default is the running 26 | GNAT installation root. 27 | 28 | BUILD : control the build options : PROD (default) or DEBUG 29 | 30 | PROCESSORS : parallel compilation (default is 0, which uses all available 31 | cores) 32 | 33 | TARGET : for cross-compilation, auto-detected for native platforms 34 | 35 | SOURCE_DIR : for out-of-tree build 36 | 37 | INTEGRATED : treat prefix as compiler installation (yes/no) 38 | this is so that installed gnatcoll project can later be 39 | referenced as predefined project of this compiler; 40 | this adds a normalized target subdir to prefix 41 | default is "no" 42 | 43 | To use the default options: 44 | 45 | $ make setup 46 | 47 | Building 48 | -------- 49 | 50 | The component is built using a standalone GPR project file. 51 | 52 | It is also possible to use the provided Makefile: 53 | 54 | $ make 55 | 56 | Then, to install it: 57 | 58 | $ make install 59 | 60 | 61 | Bug reports 62 | ----------- 63 | 64 | Please send questions and bug reports to support@adacore.com following 65 | the same procedures used to submit reports with the GNAT toolset itself. 66 | -------------------------------------------------------------------------------- /testsuite/tests/sql1/gnatcoll-sql-unit_tests.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- Database interface utilities -- 3 | -- -- 4 | -- Copyright (C) 2006-2018, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | package GNATCOLL.SQL.Unit_Tests is 25 | procedure Do_Tests; 26 | end GNATCOLL.SQL.Unit_Tests; 27 | -------------------------------------------------------------------------------- /pgxs/source/pgxs-pools-defaults.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- PostgreSQL server extension modules binding -- 3 | -- -- 4 | -- Copyright (C) 2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | -- Default PostgreSQL memory pool 24 | 25 | package PGXS.Pools.Defaults is 26 | 27 | Default_Pool : Memory_Context_Pool; 28 | 29 | end PGXS.Pools.Defaults; 30 | -------------------------------------------------------------------------------- /postgres/README.md: -------------------------------------------------------------------------------- 1 | The GNAT Components Collection (GNATCOLL) - Postgres 2 | ==================================================== 3 | 4 | This component extends the GNATCOLL.SQL hierarchy for the PostgreSQL DBMS. 5 | 6 | Dependencies 7 | ------------ 8 | 9 | This component requires the following external components, that should be 10 | available on your system: 11 | 12 | - gprbuild 13 | - gnatcoll-core 14 | - postgres 15 | 16 | Configuring the build process 17 | ----------------------------- 18 | 19 | The following variables can be used to configure the build process: 20 | 21 | General: 22 | 23 | prefix : location of the installation, the default is the running 24 | GNAT installation root. 25 | 26 | BUILD : control the build options : PROD (default) or DEBUG 27 | 28 | PROCESSORS : parallel compilation (default is 0, which uses all available 29 | cores) 30 | 31 | TARGET : for cross-compilation, auto-detected for native platforms 32 | 33 | SOURCE_DIR : for out-of-tree build 34 | 35 | INTEGRATED : treat prefix as compiler installation (yes/no) 36 | this is so that installed gnatcoll project can later be 37 | referenced as predefined project of this compiler; 38 | this adds a normalized target subdir to prefix 39 | default is "no" 40 | 41 | Component-specific: 42 | 43 | GNATCOLL_HASPQPREPARE : Whether PQPREPARE is available (yes/no) 44 | 45 | To use the default options: 46 | 47 | $ make setup 48 | 49 | Building 50 | -------- 51 | 52 | The component is built using a standalone GPR project file. 53 | 54 | However, to build all versions of the library (static, relocatable and 55 | static-pic) it is simpler to use the provided Makefile: 56 | 57 | $ make 58 | 59 | Then, to install it: 60 | 61 | $ make install 62 | 63 | 64 | Bug reports 65 | ----------- 66 | 67 | Please send questions and bug reports to support@adacore.com following 68 | the same procedures used to submit reports with the GNAT toolset itself. 69 | -------------------------------------------------------------------------------- /gen_gps_help.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | import os 4 | import os.path 5 | import re 6 | 7 | pkg_re = re.compile(r"^(private)?\s*package\s*(\S+)") 8 | 9 | 10 | def recursive_ls(dir): 11 | """Return the list of ads files in dir and its subdirs""" 12 | result = set() 13 | for f in os.listdir(dir): 14 | if f.endswith(".ads") and f.startswith("gnatcoll-"): 15 | private = False 16 | pkg = "" 17 | for line in open(os.path.join(dir, f)).readlines(): 18 | m = pkg_re.search(line) 19 | if m: 20 | private = m.group(1) 21 | pkg = m.group(2) 22 | break 23 | 24 | if not private: 25 | result.add((pkg, os.path.splitext(f)[0])) 26 | 27 | elif os.path.isdir(os.path.join(dir, f)): 28 | result = result.union(recursive_ls(os.path.join(dir, f))) 29 | 30 | return result 31 | 32 | 33 | list = recursive_ls("..") 34 | out = open("help_gnatcoll-db.py", "w") 35 | out.write( 36 | """XML = r''' 37 | 38 | """ 39 | ) 40 | 41 | for pkg, f in sorted(list): 42 | if "__" in f: 43 | # An internal package with a specific naming scheme 44 | continue 45 | 46 | menu = pkg.replace(".", "/").replace("_", "__") 47 | 48 | # Do we have a submenu ? 49 | in_front = False 50 | for _, b in list: 51 | if b.startswith(f + "-"): 52 | item = menu[menu.rfind("/") + 1 :] 53 | menu = menu + "/<" + item + ">" 54 | break 55 | 56 | out.write( 57 | """ 58 | Editor.edit "%(file)s.ads" 59 | %(package)s 60 | /Help/%(menu)s 61 | GNAT Components Collection 62 | 63 | 64 | """ 65 | % {"file": f, "menu": menu, "package": pkg} 66 | ) 67 | 68 | out.write( 69 | """''' 70 | import GPS 71 | GPS.parse_xml(XML) 72 | """ 73 | ) 74 | out.close() 75 | -------------------------------------------------------------------------------- /sqlite/README.md: -------------------------------------------------------------------------------- 1 | The GNAT Components Collection (GNATCOLL) - Sqlite 2 | ================================================== 3 | 4 | This component extends the GNATCOLL.SQL hierarchy for the sqlite3 DBMS. 5 | 6 | Dependencies 7 | ------------ 8 | 9 | This component requires the following external components, that should be 10 | available on your system: 11 | 12 | - gprbuild 13 | - gnatcoll-core 14 | - sqlite3 if you are using external library 15 | 16 | Configuring the build process 17 | ----------------------------- 18 | 19 | The following variables can be used to configure the build process: 20 | 21 | General: 22 | 23 | prefix : location of the installation, the default is the running 24 | GNAT installation root. 25 | 26 | BUILD : control the build options : PROD (default) or DEBUG 27 | 28 | PROCESSORS : parallel compilation (default is 0, which uses all available 29 | cores) 30 | 31 | TARGET : for cross-compilation, auto-detected for native platforms 32 | 33 | SOURCE_DIR : for out-of-tree build 34 | 35 | INTEGRATED : treat prefix as compiler installation (yes/no) 36 | this is so that installed gnatcoll project can later be 37 | referenced as predefined project of this compiler; 38 | this adds a normalized target subdir to prefix 39 | default is "no" 40 | 41 | Component-specific: 42 | 43 | GNATCOLL_SQLITE : Sqlite3 implementation to use (embedded/external) 44 | 45 | To use the default options: 46 | 47 | $ make setup 48 | 49 | Building 50 | -------- 51 | 52 | The component is built using a standalone GPR project file. 53 | 54 | However, to build all versions of the library (static, relocatable and 55 | static-pic) it is simpler to use the provided Makefile: 56 | 57 | $ make 58 | 59 | Then, to install it: 60 | 61 | $ make install 62 | 63 | 64 | Bug reports 65 | ----------- 66 | 67 | Please send questions and bug reports to support@adacore.com following 68 | the same procedures used to submit reports with the GNAT toolset itself. 69 | -------------------------------------------------------------------------------- /postgres/postgres_support.c: -------------------------------------------------------------------------------- 1 | /*---------------------------------------------------------------------------- 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2009-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ----------------------------------------------------------------------------*/ 23 | 24 | #ifdef HAS_PQPREPARE 25 | 26 | extern void* PQprepare(void); // Only the routine name matters here. 27 | // Parameters and return value are defined in the Ada part. 28 | void* gnatcoll_pqprepare = &PQprepare; 29 | 30 | #else 31 | 32 | void* gnatcoll_pqprepare = (void*)0; 33 | 34 | #endif 35 | -------------------------------------------------------------------------------- /gnatcoll_db2ada/gnatcoll-db2ada-main.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2005-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | procedure GNATCOLL.Db2Ada.Main 25 | (Default_DB_Type : String; 26 | Description : Db2Ada_Description); 27 | -- Gnatcoll_db2ada main 28 | -- 29 | -- Default_DB_Type is the default backend database name (-dbtype option 30 | -- default). Description is a function that return a Database_Description 31 | -- instance (See GNATCOLL.Db2Ada). 32 | -------------------------------------------------------------------------------- /testsuite/tests/sql1/test.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- T E S T -- 3 | -- -- 4 | -- Copyright (C) 2008-2018, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with GNATCOLL.SQL.Unit_Tests; 25 | with GNATCOLL.SQL; use GNATCOLL.SQL; 26 | with Test_Assert; 27 | 28 | function Test return Integer is 29 | T : T_Money := T_Money'First; 30 | begin 31 | -- Check visibility on the operators for T_Money 32 | if T = T_Money'First then 33 | null; 34 | end if; 35 | 36 | Unit_Tests.Do_Tests; 37 | 38 | return Test_Assert.Report; 39 | end Test; 40 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | The GNAT Components Collection (GNATcoll) - Database packages 2 | ============================================================= 3 | 4 | This is the DB module of the GNAT Components Collection. Please refer to 5 | individual components for more details. 6 | 7 | 8 | Dependencies 9 | ------------ 10 | 11 | This module depends on the following external components, that should be 12 | available on your system: 13 | 14 | * GPRbuild 15 | * gnatcoll-core 16 | * As well as relevant third-party libraries required by components. 17 | 18 | 19 | Configuring the build process 20 | ----------------------------- 21 | 22 | The following variables can be used to configure the build process: 23 | 24 | ### General: 25 | 26 | * `prefix`: location of the installation, the default is the running GNAT 27 | installation root. 28 | 29 | * `BUILD`: control the build options: `PROD` (default) or `DEBUG` 30 | 31 | * `PROCESSORS`: parallel compilation (default is 0, which uses all available 32 | cores) 33 | 34 | * `TARGET`: for cross-compilation, auto-detected for native platforms 35 | 36 | * `SOURCE_DIR`: for out-of-tree build 37 | 38 | * `INTEGRATED`: treat prefix as compiler installation (yes/no) this is so that 39 | installed GNATcoll project can later be referenced as predefined project of 40 | this compiler; this adds a normalized target subdir to prefix default is "no" 41 | 42 | ### Module-specific: 43 | 44 | Please refer to individual components. To use the default options: 45 | 46 | ```sh 47 | $ make setup 48 | ``` 49 | 50 | 51 | Building 52 | -------- 53 | 54 | The components of GNATcoll Database are built using standalone GPR project 55 | files, to build each of them is as simple as: 56 | 57 | ```sh 58 | $ gprbuild gnatcoll-.gpr 59 | ``` 60 | 61 | However, to build all versions of the library (static, relocatable and 62 | static-pic) it is simpler to use the provided Makefiles: 63 | 64 | ```sh 65 | $ make -C 66 | ``` 67 | 68 | Then, to install it: 69 | 70 | ```sh 71 | $ make -C install 72 | ``` 73 | 74 | 75 | Bug reports 76 | ----------- 77 | 78 | Please send questions and bug reports to support@adacore.com following 79 | the same procedures used to submit reports with the GNAT toolset itself. 80 | -------------------------------------------------------------------------------- /examples/library/generated/database.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2021, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | package body Database is 25 | pragma Style_Checks (Off); 26 | 27 | function FK (Self : T_Books'Class; Foreign : T_Customers'Class) return SQL_Criteria is 28 | begin 29 | return Self.Borrowed_By = Foreign.Id; 30 | end FK; 31 | 32 | function FK (Self : T_Dvds'Class; Foreign : T_Customers'Class) return SQL_Criteria is 33 | begin 34 | return Self.Borrowed_By = Foreign.Id; 35 | end FK; 36 | end Database; 37 | -------------------------------------------------------------------------------- /testsuite/drivers/basic.py: -------------------------------------------------------------------------------- 1 | from e3.fs import cp 2 | from e3.testsuite.driver import TestDriver 3 | from e3.testsuite.process import check_call 4 | from e3.testsuite.result import TestStatus 5 | from drivers import gprbuild 6 | import os 7 | 8 | 9 | class BasicTestDriver(TestDriver): 10 | """Default GNATcoll testsuite driver. 11 | 12 | In order to declare a test: 13 | 14 | 1- Create a directory with a test.yaml inside 15 | 2- Add test sources in that directory 16 | 3- Add a main called test.adb that use support/test_assert.ads package. 17 | 4- Do not put test.gpr there, it breaks the test, if you need a project 18 | file for testing, name it something else. 19 | 5- If you need additional files for you test, list them in test.yaml: 20 | data: 21 | - "your_file1" 22 | - "your_file2" 23 | """ 24 | 25 | def add_test(self, dag): 26 | """Declare test workflow. 27 | 28 | The workflow is the following:: 29 | 30 | build --> check status 31 | 32 | :param dag: tree of test fragment to amend 33 | :type dag: e3.collection.dag.DAG 34 | """ 35 | self.add_fragment(dag, "build") 36 | self.add_fragment(dag, "check_run", after=["build"]) 37 | 38 | if "test_exe" not in self.test_env: 39 | self.test_env["test_exe"] = "obj/test" 40 | 41 | def build(self, previous_values): 42 | """Build fragment.""" 43 | return gprbuild(self, gcov=self.env.gcov, components=self.env.components) 44 | 45 | def check_run(self, previous_values): 46 | """Check status fragment.""" 47 | if not previous_values["build"]: 48 | return 49 | 50 | for data in self.test_env.get("data", []): 51 | cp( 52 | os.path.join(self.test_env["test_dir"], data), 53 | self.test_env["working_dir"], 54 | recursive=True, 55 | ) 56 | 57 | process = check_call( 58 | self, 59 | [os.path.join(self.test_env["working_dir"], self.test_env["test_exe"])], 60 | ) 61 | if "<=== TEST PASSED ===>" not in process.out: 62 | self.result.set_status(TestStatus.FAIL) 63 | else: 64 | self.result.set_status(TestStatus.PASS) 65 | self.push_result() 66 | -------------------------------------------------------------------------------- /pgxs/testsuite/module.sql.in: -------------------------------------------------------------------------------- 1 | 2 | CREATE TYPE Coord AS 3 | (X float4, 4 | Y float4); 5 | 6 | CREATE TYPE Pos AS 7 | (C Coord, 8 | H int4); 9 | 10 | CREATE OR REPLACE FUNCTION apgxs_num_args() RETURNS integer 11 | AS '@MODULEDIR@/libadatestmodule', 'apgxs_num_args' 12 | LANGUAGE C STRICT; 13 | 14 | CREATE OR REPLACE FUNCTION apgxs_num_args(integer) RETURNS integer 15 | AS '@MODULEDIR@/libadatestmodule', 'apgxs_num_args' 16 | LANGUAGE C STRICT; 17 | 18 | CREATE OR REPLACE FUNCTION apgxs_num_args(integer, bytea) RETURNS integer 19 | AS '@MODULEDIR@/libadatestmodule', 'apgxs_num_args' 20 | LANGUAGE C STRICT; 21 | 22 | CREATE OR REPLACE FUNCTION apgxs_arg_is_null(integer) RETURNS bool 23 | AS '@MODULEDIR@/libadatestmodule', 'apgxs_arg_is_null' 24 | LANGUAGE C; 25 | 26 | CREATE OR REPLACE FUNCTION apgxs_inverse_bool(bool) RETURNS bool 27 | AS '@MODULEDIR@/libadatestmodule', 'apgxs_inverse_bool' 28 | LANGUAGE C STRICT; 29 | 30 | CREATE OR REPLACE FUNCTION apgxs_add_one_smallint(smallint) RETURNS smallint 31 | AS '@MODULEDIR@/libadatestmodule', 'apgxs_add_one_int16' 32 | LANGUAGE C STRICT; 33 | 34 | CREATE OR REPLACE FUNCTION apgxs_add_one_integer(integer) RETURNS integer 35 | AS '@MODULEDIR@/libadatestmodule', 'apgxs_add_one_int32' 36 | LANGUAGE C STRICT; 37 | 38 | CREATE OR REPLACE FUNCTION apgxs_add_one_float4(float4) RETURNS float4 39 | AS '@MODULEDIR@/libadatestmodule', 'apgxs_add_one_float4' 40 | LANGUAGE C STRICT; 41 | 42 | CREATE OR REPLACE FUNCTION apgxs_add_one_float8(float8) RETURNS float8 43 | AS '@MODULEDIR@/libadatestmodule', 'apgxs_add_one_float8' 44 | LANGUAGE C STRICT; 45 | 46 | CREATE OR REPLACE FUNCTION apgxs_overpaid(emp, integer) RETURNS boolean 47 | AS '@MODULEDIR@/libadatestmodule', 'apgxs_overpaid' 48 | LANGUAGE C STRICT; 49 | 50 | CREATE OR REPLACE FUNCTION apgxs_composite(integer, integer) RETURNS apgxs_composite_type 51 | AS '@MODULEDIR@/libadatestmodule', 'apgxs_composite' 52 | LANGUAGE C STRICT; 53 | 54 | CREATE OR REPLACE FUNCTION apgxs_set_simple(integer) RETURNS SETOF integer 55 | AS '@MODULEDIR@/libadatestmodule', 'apgxs_set_simple' 56 | LANGUAGE C STRICT; 57 | 58 | CREATE OR REPLACE FUNCTION pos_from_bin(bytea) RETURNS pos 59 | AS '@MODULEDIR@/libadatestmodule', 'pos_from_bin' 60 | LANGUAGE C STRICT; 61 | -------------------------------------------------------------------------------- /postgres/gnatcoll-sql-postgres-builder.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2005-2017, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | -- Implementation of gnatcoll-sql-exec_private for Postgres. 25 | -- This isn't in GNATCOLL.SQL.Postgres so that GNATCOLL can have the same API 26 | -- no matter whether postgresql is installed on the machine or not 27 | 28 | limited with GNATCOLL.SQL.Postgres.Gnade; 29 | 30 | private package GNATCOLL.SQL.Postgres.Builder is 31 | 32 | function Build_Connection 33 | (Descr : access Postgres_Description'Class) return Database_Connection; 34 | -- See doc in GNATCOLL.SQL.Postgres 35 | 36 | function To_Native 37 | (Connection : Database_Connection) return access Gnade.Database'Class; 38 | 39 | end GNATCOLL.SQL.Postgres.Builder; 40 | -------------------------------------------------------------------------------- /pgxs/source/pgxs-generic_bytea.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- PostgreSQL server extension modules binding -- 3 | -- -- 4 | -- Copyright (C) 2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | -- Wrapper around BYTEA to represent its value as Ada record 24 | 25 | with PGXS.Types; 26 | 27 | generic 28 | type Data is private; 29 | 30 | package PGXS.Generic_Bytea is 31 | 32 | function Get_Arg 33 | (Args : Function_Call_Info; Index : PGXS.Types.Int_32) return Data; 34 | -- Returns value of the function's argument as object of user defined type. 35 | -- Caller is responsible to check 'null' value of the parameter first. 36 | 37 | function Return_Value 38 | (Args : Function_Call_Info; Item : Data) return PGXS.Datum; 39 | -- Construct bytea value from the given object of the user defined type 40 | -- and return it as Datum. 41 | 42 | end PGXS.Generic_Bytea; 43 | -------------------------------------------------------------------------------- /testsuite/tests/subsec/test.adb: -------------------------------------------------------------------------------- 1 | with Ada.Calendar; use Ada.Calendar; 2 | with Ada.Text_IO; use Ada.Text_IO; 3 | 4 | with GNATCOLL.SQL.Exec; use GNATCOLL.SQL.Exec; 5 | -- with GNATCOLL.SQL.Postgres; use GNATCOLL.SQL; 6 | with GNATCOLL.SQL.Sqlite; use GNATCOLL.SQL; 7 | with GNATCOLL.Utils; 8 | 9 | with GNAT.Calendar.Time_IO; 10 | 11 | with Test_Assert; use Test_Assert; 12 | 13 | function Test return Integer is 14 | -- DB_Descr : Database_Description := Postgres.Setup ("test"); 15 | DB_Descr : Database_Description := Sqlite.Setup ("test.db"); 16 | DBC : Database_Connection := DB_Descr.Build_Connection; 17 | RS : Forward_Cursor; 18 | Old : constant Time := 19 | Time_Of 20 | (Year_Number'First, Month_Number'First, Day_Number'First); 21 | Now : constant Time := Clock; 22 | Stmt : Prepared_Statement'Class := 23 | Prepare 24 | ("insert into Keep_Timestamp values ($1)", 25 | Name => "add_timestamp", 26 | On_Server => True); 27 | 28 | Dts : array (1 .. 24) of Time; 29 | 30 | begin 31 | Execute (DBC, "create table Keep_Timestamp (DT Timestamp)"); 32 | if not DBC.Success then 33 | Put_Line (DBC.Error); 34 | end if; 35 | DBC.Commit; 36 | 37 | Execute (DBC, "delete from Keep_Timestamp"); 38 | if not DBC.Success then 39 | Put_Line (DBC.Error); 40 | end if; 41 | 42 | for J in Dts'First .. Dts'Length / 2 - 1 loop 43 | Dts (J) := Old + 987654.321_098_765 * J; 44 | end loop; 45 | 46 | for J in Dts'Length / 2 + 1 .. Dts'Last loop 47 | Dts (J) := Now + 1234_567.890_123_456 * J; 48 | end loop; 49 | 50 | Dts (Dts'Length / 2) := Time_Of (2000, 9, 8, (7.0 * 60 + 34.0) * 60 + 56.0); 51 | 52 | for J in reverse Dts'Range loop 53 | Execute (DBC, Stmt, (1 => +Dts (J))); 54 | 55 | if not DBC.Success then 56 | Put_Line (DBC.Error); 57 | end if; 58 | end loop; 59 | 60 | DBC.Commit; 61 | 62 | Fetch (RS, DBC, "select * from Keep_Timestamp order by 1"); 63 | 64 | for J in Dts'Range loop 65 | Assert 66 | (Dts (J) = Time_Value (RS, 0), 67 | "Check date " & Value (RS, 0) & ' ' & 68 | GNAT.Calendar.Time_IO.Image 69 | (Dts (J), "%Y-%m-%d %H:%M:%S.%o") 70 | & ' ' & Duration'Image (Dts (J) - Time_Value (RS, 0))); 71 | 72 | Next (RS); 73 | end loop; 74 | 75 | Assert (not Has_Row (RS), "Done."); 76 | 77 | return Report; 78 | end Test; 79 | -------------------------------------------------------------------------------- /xref/README.md: -------------------------------------------------------------------------------- 1 | The GNAT Components Collection (GNATCOLL) - Postgres 2 | ==================================================== 3 | 4 | This component provides support for parsing the .ali and .gli files that 5 | are generated by GNAT and gcc. In particular, those files contain 6 | information that can be used to do cross-references for entities (going 7 | from references to their declaration for instance). 8 | 9 | A typical example would be: 10 | 11 | declare 12 | Session : Session_Type; 13 | begin 14 | GNATCOLL.SQL.Sessions.Setup 15 | (Descr => GNATCOLL.SQL.Sqlite.Setup (":memory:")); 16 | Session := Get_New_Session; 17 | 18 | ... parse the project through GNATCOLL.Projects 19 | 20 | Create_Database (Session.DB); 21 | Parse_All_LI_Files (Session, ...); 22 | end; 23 | 24 | Dependencies 25 | ------------ 26 | 27 | This component requires the following external components, that should be 28 | available on your system: 29 | 30 | - gprbuild 31 | - gnatcoll-core 32 | - gnatcoll-iconv 33 | - gnatcoll-sqlite 34 | 35 | Configuring the build process 36 | ----------------------------- 37 | 38 | The following variables can be used to configure the build process: 39 | 40 | General: 41 | 42 | prefix : location of the installation, the default is the running 43 | GNAT installation root. 44 | 45 | BUILD : control the build options : PROD (default) or DEBUG 46 | 47 | PROCESSORS : parallel compilation (default is 0, which uses all available 48 | cores) 49 | 50 | TARGET : for cross-compilation, auto-detected for native platforms 51 | 52 | SOURCE_DIR : for out-of-tree build 53 | 54 | INTEGRATED : treat prefix as compiler installation (yes/no) 55 | this is so that installed gnatcoll project can later be 56 | referenced as predefined project of this compiler; 57 | this adds a normalized target subdir to prefix 58 | default is "no" 59 | 60 | To use the default options: 61 | 62 | $ make setup 63 | 64 | Building 65 | -------- 66 | 67 | The component is built using a standalone GPR project file. 68 | 69 | However, to build all versions of the library (static, relocatable and 70 | static-pic) it is simpler to use the provided Makefile: 71 | 72 | $ make 73 | 74 | Then, to install it: 75 | 76 | $ make install 77 | 78 | 79 | Bug reports 80 | ----------- 81 | 82 | Please send questions and bug reports to support@adacore.com following 83 | the same procedures used to submit reports with the GNAT toolset itself. 84 | -------------------------------------------------------------------------------- /gnatcoll_db2ada/gnatcoll_db2ada.gpr: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2015-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with "../gnatcoll_db_shared.gpr"; 25 | with "gnatcoll_core"; 26 | with "gnatcoll_sql"; 27 | 28 | standard project GNATCOLL_DB2Ada is 29 | 30 | for Languages use ("Ada"); 31 | 32 | for Main use (project'Name); 33 | for Object_Dir use "obj"; 34 | for Source_Dirs use ("."); 35 | 36 | package Compiler renames Gnatcoll_Db_Shared.Compiler; 37 | 38 | package Binder renames Gnatcoll_Db_Shared.Binder; 39 | 40 | package Builder renames Gnatcoll_Db_Shared.Builder; 41 | 42 | package Ide renames Gnatcoll_Db_Shared.Ide; 43 | 44 | package Install is 45 | for Artifacts ("share/gnatcoll") use ("dborm.py"); 46 | end Install; 47 | 48 | package Linker renames Gnatcoll_Db_Shared.Linker; 49 | 50 | end GNATCOLL_DB2Ada; 51 | -------------------------------------------------------------------------------- /gnatcoll_db2ada/gnatcoll_postgres2ada.gpr: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2015-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with "../gnatcoll_db_shared.gpr"; 25 | with "gnatcoll_core"; 26 | with "gnatcoll_sql"; 27 | with "gnatcoll_postgres"; 28 | 29 | standard project gnatcoll_Postgres2ada is 30 | 31 | for Languages use ("Ada"); 32 | 33 | for Main use (project'Name); 34 | for Object_Dir use "obj"; 35 | 36 | package Compiler renames Gnatcoll_Db_Shared.Compiler; 37 | 38 | package Binder renames Gnatcoll_Db_Shared.Binder; 39 | 40 | package Builder renames Gnatcoll_Db_Shared.Builder; 41 | 42 | package Ide renames Gnatcoll_Db_Shared.Ide; 43 | 44 | package Install is 45 | for Artifacts ("share/gnatcoll") use ("dborm.py"); 46 | end Install; 47 | 48 | package Linker renames Gnatcoll_Db_Shared.Linker; 49 | 50 | end gnatcoll_Postgres2ada; 51 | -------------------------------------------------------------------------------- /pgxs/source/pgxs-pools.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- PostgreSQL server extension modules binding -- 3 | -- -- 4 | -- Copyright (C) 2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | package body PGXS.Pools is 25 | 26 | -------------- 27 | -- Allocate -- 28 | -------------- 29 | 30 | overriding procedure Allocate 31 | (Pool : in out Memory_Context_Pool; 32 | Storage_Address : out System.Address; 33 | Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; 34 | Alignment : System.Storage_Elements.Storage_Count) 35 | is 36 | pragma Unreferenced (Alignment); 37 | 38 | function palloc (Size : PGXS.Types.Int_32) return System.Address 39 | with Import, Convention => C, Link_Name => "__ada_palloc"; 40 | 41 | begin 42 | Storage_Address := palloc (PGXS.Types.Int_32 (Size_In_Storage_Elements)); 43 | end Allocate; 44 | 45 | end PGXS.Pools; 46 | -------------------------------------------------------------------------------- /pgxs/source/pgxs-abi.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- PostgreSQL server extension modules binding -- 3 | -- -- 4 | -- Copyright (C) 2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | -- Calling conventions version declarations subprogram 24 | 25 | package PGXS.ABI is 26 | 27 | pragma Preelaborate; 28 | 29 | type Function_Info_Record is limited private; 30 | 31 | function Ada_Function_Info_1 32 | return not null access PGXS.ABI.Function_Info_Record 33 | with Import, Convention => C, Link_Name => "pg_finfo__ada_function"; 34 | -- Returns version infomation for the calling conventions version 1. 35 | -- For calling conventions version 1 each user defined function should 36 | -- have additional exported function which should call this function. 37 | -- See documentation for more information. 38 | 39 | private 40 | 41 | type Function_Info_Record is limited null record 42 | with Convention => C; 43 | 44 | end PGXS.ABI; 45 | -------------------------------------------------------------------------------- /gnatcoll_db2ada/gnatcoll_sqlite2ada.gpr: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2015-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with "../gnatcoll_db_shared.gpr"; 25 | with "gnatcoll_core"; 26 | with "gnatcoll_sql"; 27 | with "gnatcoll_sqlite"; 28 | 29 | standard project gnatcoll_sqlite2ada is 30 | 31 | for Languages use ("Ada"); 32 | 33 | for Main use (project'Name); 34 | for Object_Dir use "obj"; 35 | for Source_Dirs use ("."); 36 | 37 | package Compiler renames Gnatcoll_Db_Shared.Compiler; 38 | 39 | package Binder renames Gnatcoll_Db_Shared.Binder; 40 | 41 | package Builder renames Gnatcoll_Db_Shared.Builder; 42 | 43 | package Ide renames Gnatcoll_Db_Shared.Ide; 44 | 45 | package Install is 46 | for Artifacts ("share/gnatcoll") use ("dborm.py"); 47 | end Install; 48 | 49 | package Linker renames Gnatcoll_Db_Shared.Linker; 50 | 51 | end gnatcoll_sqlite2ada; 52 | -------------------------------------------------------------------------------- /gnatcoll_db2ada/gnatcoll_all2ada.gpr: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with "../gnatcoll_db_shared.gpr"; 25 | with "gnatcoll_core"; 26 | with "gnatcoll_sql"; 27 | with "gnatcoll_sqlite"; 28 | with "gnatcoll_postgres"; 29 | 30 | standard project gnatcoll_all2ada is 31 | 32 | for Languages use ("Ada"); 33 | 34 | for Main use (project'Name); 35 | for Object_Dir use "obj"; 36 | for Source_Dirs use ("."); 37 | 38 | package Compiler renames Gnatcoll_Db_Shared.Compiler; 39 | 40 | package Binder renames Gnatcoll_Db_Shared.Binder; 41 | 42 | package Builder renames Gnatcoll_Db_Shared.Builder; 43 | 44 | package Ide renames Gnatcoll_Db_Shared.Ide; 45 | 46 | package Install is 47 | for Artifacts ("share/gnatcoll") use ("dborm.py"); 48 | end Install; 49 | 50 | package Linker renames Gnatcoll_Db_Shared.Linker; 51 | 52 | end gnatcoll_all2ada; 53 | -------------------------------------------------------------------------------- /pgxs/source/pgxs-varlen.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- PostgreSQL server extension modules binding -- 3 | -- -- 4 | -- Copyright (C) 2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | -- Base subprograms to manipulate variable length data 24 | 25 | with System.Storage_Elements; 26 | 27 | package PGXS.Varlen is 28 | 29 | type Varlen_A is private; 30 | 31 | function Allocate 32 | (Size : System.Storage_Elements.Storage_Count) return Varlen_A; 33 | -- Allocates new object of given size 34 | 35 | function Size 36 | (Item : Varlen_A) return System.Storage_Elements.Storage_Count; 37 | -- Returns size of the object 38 | 39 | function Data (Item : Varlen_A) return System.Address 40 | with Import, Convention => C, Link_Name => "__ada_VARDATA_ANY"; 41 | -- Returns pointer of the first storage element of the data 42 | 43 | private 44 | 45 | type Varlen_Record is null record 46 | with Convention => C; 47 | 48 | type Varlen_A is access all Varlen_Record; 49 | 50 | end PGXS.Varlen; 51 | -------------------------------------------------------------------------------- /gnatcoll_db2ada/gnatcoll-db2ada.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2005-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with GNATCOLL.SQL.Exec; use GNATCOLL.SQL.Exec; 25 | 26 | package GNATCOLL.DB2Ada is 27 | 28 | type Db2Ada_Description is access function 29 | (DB_Type : String; 30 | Database : String; 31 | User : String; 32 | Host : String; 33 | Password : String; 34 | Port : Integer) 35 | return Database_Description; 36 | -- Given access parameter return a Database_Description. 37 | -- 38 | -- DB_Type is the database backend name. Function should return null if the 39 | -- given backend is not supported. 40 | -- 41 | -- Db2Ada_Description received the following connection parameters: 42 | -- * Database: the database name 43 | -- * User: user name 44 | -- * Host: host name 45 | -- * Password: password to access the database 46 | -- * Port: port number 47 | 48 | end GNATCOLL.DB2Ada; 49 | -------------------------------------------------------------------------------- /sql/gnatcoll-sql_fields.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2016-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with Ada.Strings.Fixed; use Ada.Strings.Fixed; 25 | 26 | package body GNATCOLL.SQL_Fields is 27 | 28 | ----------------- 29 | -- Json_To_SQL -- 30 | ----------------- 31 | 32 | function Json_To_SQL 33 | (Self : Formatter'Class; Value : String; Quote : Boolean) return String is 34 | begin 35 | if Trim (Value, Ada.Strings.Both) = "" then 36 | return "null"; 37 | -- Json null, not to be confused with SQL NULL. 38 | else 39 | return String_Image (Self, Value, Quote); 40 | end if; 41 | end Json_To_SQL; 42 | 43 | ----------------- 44 | -- XML_To_SQL -- 45 | ----------------- 46 | 47 | function XML_To_SQL 48 | (Self : Formatter'Class; Value : String; Quote : Boolean) return String 49 | is 50 | pragma Unreferenced (Self, Quote); 51 | begin 52 | if Trim (Value, Ada.Strings.Both) = "" then 53 | return ""; 54 | -- XML null, not to be confused with SQL NULL. 55 | else 56 | return Value; 57 | end if; 58 | end XML_To_SQL; 59 | 60 | end GNATCOLL.SQL_Fields; 61 | -------------------------------------------------------------------------------- /gnatcoll_db2ada/gnatcoll_db2ada.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2005-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with GNATCOLL.DB2Ada.Main; 25 | with GNATCOLL.SQL.Exec; use GNATCOLL.SQL.Exec; 26 | 27 | procedure GNATCOLL_DB2Ada is 28 | 29 | function No_Backend_Description 30 | (DB_Type : String; 31 | Database : String; 32 | User : String; 33 | Host : String; 34 | Password : String; 35 | Port : Integer) 36 | return Database_Description; 37 | 38 | function No_Backend_Description 39 | (DB_Type : String; 40 | Database : String; 41 | User : String; 42 | Host : String; 43 | Password : String; 44 | Port : Integer) 45 | return Database_Description 46 | is 47 | pragma Unreferenced (DB_Type); 48 | pragma Unreferenced (Database); 49 | pragma Unreferenced (User); 50 | pragma Unreferenced (Host); 51 | pragma Unreferenced (Password); 52 | pragma Unreferenced (Port); 53 | begin 54 | return null; 55 | end No_Backend_Description; 56 | 57 | begin 58 | GNATCOLL.DB2Ada.Main 59 | ("", 60 | No_Backend_Description'Unrestricted_Access); 61 | end GNATCOLL_DB2Ada; 62 | -------------------------------------------------------------------------------- /pgxs/source/pgxs-generic_bytea.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- PostgreSQL server extension modules binding -- 3 | -- -- 4 | -- Copyright (C) 2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with PGXS.Call_Info; 25 | with PGXS.Datums; 26 | 27 | package body PGXS.Generic_Bytea is 28 | 29 | ------------- 30 | -- Get_Arg -- 31 | ------------- 32 | 33 | function Get_Arg 34 | (Args : Function_Call_Info; Index : PGXS.Types.Int_32) return Data 35 | is 36 | Aux : constant PGXS.Types.Byte_A := 37 | PGXS.Call_Info.Get_Arg (Args, Index); 38 | Result : Data 39 | with Import, Address => PGXS.Types.Data (Aux); 40 | 41 | begin 42 | return Result; 43 | end Get_Arg; 44 | 45 | ------------------ 46 | -- Return_Value -- 47 | ------------------ 48 | 49 | function Return_Value 50 | (Args : Function_Call_Info; Item : Data) return PGXS.Datum 51 | is 52 | pragma Unreferenced (Args); 53 | 54 | Result : PGXS.Types.Byte_A := 55 | PGXS.Types.Allocate (Data'Max_Size_In_Storage_Elements); 56 | Storage : Data 57 | with Import, Address => PGXS.Types.Data (Result); 58 | 59 | begin 60 | Storage := Item; 61 | 62 | return PGXS.Datums.To_Datum (Result); 63 | end Return_Value; 64 | 65 | end PGXS.Generic_Bytea; 66 | -------------------------------------------------------------------------------- /sqlite/gnatcoll-sql-sqlite-builder.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2009-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | -- Implementation of gnatcoll-sql-exec_private for sqlite. 25 | -- This isn't in GNATCOLL.SQL.Sqlite so that GNATCOLL can have the same API 26 | -- no matter whether sqlite is installed on the machine or not 27 | 28 | private package GNATCOLL.SQL.Sqlite.Builder is 29 | 30 | function Build_Connection 31 | (Descr : access Sqlite_Description'Class) return Database_Connection; 32 | -- See doc in GNATCOLL.SQL.Sqlite 33 | 34 | procedure Setup; 35 | -- Perform additional setup 36 | 37 | function Backup 38 | (DB1 : access Database_Connection_Record'Class; 39 | DB2 : String; 40 | From_DB1_To_DB2 : Boolean := True) return Boolean; 41 | -- Backup the database From to a new database with the given file name 42 | -- (or ":memory:") 43 | -- Returns False in case of error 44 | 45 | function Backup 46 | (From : access Database_Connection_Record'Class; 47 | To : access Database_Connection_Record'Class) return Boolean; 48 | -- Copy all the contents from From to TO. 49 | -- Returns False in case of error 50 | 51 | end GNATCOLL.SQL.Sqlite.Builder; 52 | -------------------------------------------------------------------------------- /sql/gnatcoll_sql.gpr: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2015-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with "gnatcoll_sql_conf.gpr"; 25 | with "gnatcoll_core"; 26 | 27 | library project GnatColl_SQL is 28 | 29 | Version := External ("GNATCOLL_SQL_VERSION", 30 | GnatColl_Sql_Conf.Gnatcoll_Version); 31 | 32 | for Library_Kind use GnatColl_Sql_Conf.Library_Type; 33 | for Source_Dirs use ("."); 34 | for Object_Dir 35 | use "obj/" & Project'Library_Kind; 36 | for Library_Dir 37 | use "lib/" & Project'Library_Kind; 38 | for Library_Name use project'Name; 39 | for Languages use ("Ada"); 40 | 41 | case GnatColl_Sql_Conf.Library_Type is 42 | when "relocatable" => 43 | for Leading_Library_Options use GnatColl_Sql_Conf.Ldflags; 44 | for Library_Version use 45 | "lib" & project'Library_Name & Gnatcoll_core.So_Ext & "." & Version; 46 | when "static" | "static-pic" => 47 | null; 48 | end case; 49 | 50 | package Compiler renames GnatColl_Sql_Conf.Compiler; 51 | 52 | package Binder renames GnatColl_Sql_Conf.Binder; 53 | 54 | package Builder renames GnatColl_Sql_Conf.Builder; 55 | 56 | package Ide renames GnatColl_Sql_Conf.Ide; 57 | 58 | end GnatColl_SQL; 59 | -------------------------------------------------------------------------------- /pgxs/source/pgxs.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- PostgreSQL server extension modules binding -- 3 | -- -- 4 | -- Copyright (C) 2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | -- Type declarations for data types of PostgreSQL server extension modules 24 | -- API not directly related to SQL data types. 25 | 26 | private with Interfaces.C.Extensions; 27 | private with System; 28 | 29 | package PGXS is 30 | 31 | pragma Preelaborate; 32 | 33 | type Function_Call_Info is limited private; 34 | -- Function call information: arguments and return value. 35 | 36 | type Datum is private; 37 | -- Generic container of the value for some SQL data type. 38 | 39 | type Heap_Tuple_Header is private; 40 | -- Container of the composite object 41 | 42 | type Tuple_Desc is private; 43 | -- Tuple descriptor 44 | 45 | private 46 | 47 | type Function_Call_Info is limited null record with Convention => C; 48 | 49 | type Datum is new Interfaces.C.Extensions.void_ptr; 50 | 51 | type Heap_Tuple_Header is new Interfaces.C.Extensions.void_ptr; 52 | 53 | type Heap_Tuple is new Interfaces.C.Extensions.void_ptr; 54 | 55 | type Tuple_Desc is new Interfaces.C.Extensions.void_ptr; 56 | 57 | type Func_Call_Context is new Interfaces.C.Extensions.void_ptr; 58 | 59 | type Memory_Context is new Interfaces.C.Extensions.void_ptr; 60 | 61 | end PGXS; 62 | -------------------------------------------------------------------------------- /pgxs/source/pgxs-varlen.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- PostgreSQL server extension modules binding -- 3 | -- -- 4 | -- Copyright (C) 2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with PGXS.Types; 25 | 26 | package body PGXS.Varlen is 27 | 28 | -------------- 29 | -- Allocate -- 30 | -------------- 31 | 32 | function Allocate 33 | (Size : System.Storage_Elements.Storage_Count) return Varlen_A 34 | is 35 | function palloc_varlena (Size : PGXS.Types.Int_32) return Varlen_A 36 | with Import, Convention => C, Link_Name => "__ada_palloc_varlena"; 37 | 38 | procedure Set_Size (Item : Varlen_A; Size : PGXS.Types.Int_32) 39 | with Import, Convention => C, Link_Name => "__ada_SET_VARSIZE"; 40 | 41 | begin 42 | return Result : Varlen_A := palloc_varlena (PGXS.Types.Int_32 (Size)) do 43 | Set_Size (Result, PGXS.Types.Int_32 (Size)); 44 | end return; 45 | end Allocate; 46 | 47 | ---------- 48 | -- Size -- 49 | ---------- 50 | 51 | function Size 52 | (Item : Varlen_A) return System.Storage_Elements.Storage_Count 53 | is 54 | function Imported (Item : Varlen_A) return PGXS.Types.Int_32 55 | with Import, Convention => C, Link_Name => "__ada_VARSIZE_ANY_EXHDR"; 56 | 57 | begin 58 | return System.Storage_Elements.Storage_Count (Imported (Item)); 59 | end Size; 60 | 61 | end PGXS.Varlen; 62 | -------------------------------------------------------------------------------- /xref/gnatcoll_xref.gpr: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2015-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with "gnatcoll_xref_conf.gpr"; 25 | with "gnatcoll_core"; 26 | with "gnatcoll_projects"; 27 | with "gnatcoll_iconv"; 28 | with "gnatcoll_sql"; 29 | with "gnatcoll_sqlite"; 30 | 31 | library project GnatColl_Xref is 32 | 33 | Version := External ("GNATCOLL_XREF_VERSION", 34 | GnatColl_Xref_Conf.Gnatcoll_Version); 35 | 36 | for Library_Kind use GnatColl_Xref_Conf.Library_Type; 37 | for Source_Dirs use (".", "generated"); 38 | for Object_Dir 39 | use "obj/" & Project'Library_Kind; 40 | for Library_Dir 41 | use "lib/" & Project'Library_Kind; 42 | for Library_Name use project'Name; 43 | for Languages use ("Ada"); 44 | 45 | case GnatColl_Xref_Conf.Library_Type is 46 | when "relocatable" => 47 | for Leading_Library_Options use GnatColl_Xref_Conf.Ldflags; 48 | for Library_Version use 49 | "lib" & project'Library_Name & Gnatcoll_Core.So_Ext & "." & Version; 50 | when "static" | "static-pic" => 51 | null; 52 | end case; 53 | 54 | package Compiler renames GnatColl_Xref_Conf.Compiler; 55 | 56 | package Binder renames GnatColl_Xref_Conf.Binder; 57 | 58 | package Builder renames GnatColl_Xref_Conf.Builder; 59 | 60 | package Ide renames GnatColl_Xref_Conf.Ide; 61 | 62 | end GnatColl_Xref; 63 | -------------------------------------------------------------------------------- /pgxs/example/sample.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- PostgreSQL server extension modules binding -- 3 | -- -- 4 | -- Copyright (C) 2020-2021, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with PGXS; 25 | with PGXS.ABI; 26 | with PGXS.Generic_Bytea; 27 | 28 | package Sample is 29 | 30 | type Information is record 31 | X : Integer; 32 | Y : Integer; 33 | end record; 34 | 35 | package Information_Bytea is new PGXS.Generic_Bytea (Information); 36 | 37 | function To_Bytea (Args : in out PGXS.Function_Call_Info) return PGXS.Datum 38 | with Export, Convention => C, Link_Name => "to_bytea"; 39 | 40 | function To_Bytea_Info 41 | return not null access PGXS.ABI.Function_Info_Record 42 | is (PGXS.ABI.Ada_Function_Info_1) 43 | with Export, Convention => C, Link_Name => "pg_finfo_to_bytea"; 44 | 45 | function Get_X (Args : in out PGXS.Function_Call_Info) return PGXS.Datum 46 | with Export, Convention => C, Link_Name => "get_x"; 47 | 48 | function Get_X_Info 49 | return not null access PGXS.ABI.Function_Info_Record 50 | is (PGXS.ABI.Ada_Function_Info_1) 51 | with Export, Convention => C, Link_Name => "pg_finfo_get_x"; 52 | 53 | function Get_Y (Args : in out PGXS.Function_Call_Info) return PGXS.Datum 54 | with Export, Convention => C, Link_Name => "get_y"; 55 | 56 | function Get_Y_Info 57 | return not null access PGXS.ABI.Function_Info_Record 58 | is (PGXS.ABI.Ada_Function_Info_1) 59 | with Export, Convention => C, Link_Name => "pg_finfo_get_y"; 60 | 61 | end Sample; 62 | -------------------------------------------------------------------------------- /gnatinspect/gnatinspect.gpr: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2015-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with "../gnatcoll_db_shared.gpr"; 25 | with "gnatcoll_core"; 26 | with "gnatcoll_xref"; 27 | with "gnatcoll_sql"; 28 | with "gnatcoll_sqlite"; 29 | 30 | standard project Gnatinspect is 31 | 32 | Build : Gnatcoll_Db_Shared.Build_Type := 33 | External ("GNATINSPECT_BUILD", Gnatcoll_Db_Shared.Build); 34 | 35 | for Languages use ("Ada"); 36 | 37 | for Main use (project'Name); 38 | for Object_Dir use "obj"; 39 | 40 | package Compiler is 41 | -- Use Build, which may differ from Gnatcoll_Db_Shared.Build. 42 | case Build is 43 | when "DEBUG" => 44 | for Switches ("Ada") use 45 | Gnatcoll_Db_Shared.Adaflags_Debug & Gnatcoll_Db_Shared.Adaflags; 46 | when "PROD" => 47 | for Switches ("Ada") use 48 | Gnatcoll_Db_Shared.Adaflags_Prod & Gnatcoll_Db_Shared.Adaflags; 49 | end case; 50 | end Compiler; 51 | 52 | package Binder is 53 | for Switches ("Ada") use ("-E"); 54 | end Binder; 55 | 56 | package Builder is 57 | case Build is 58 | when "DEBUG" => 59 | for Global_Configuration_Pragmas use "../gnat_debug.adc"; 60 | when "PROD" => 61 | null; 62 | end case; 63 | end Builder; 64 | 65 | package Ide renames Gnatcoll_Db_Shared.Ide; 66 | 67 | package Linker renames Gnatcoll_Db_Shared.Linker; 68 | 69 | end Gnatinspect; 70 | -------------------------------------------------------------------------------- /pgxs/example/sample.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- PostgreSQL server extension modules binding -- 3 | -- -- 4 | -- Copyright (C) 2020-2021, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with PGXS.Call_Info; 25 | with PGXS.Types; 26 | 27 | package body Sample is 28 | 29 | ----------- 30 | -- Get_X -- 31 | ----------- 32 | 33 | function Get_X (Args : in out PGXS.Function_Call_Info) return PGXS.Datum is 34 | V : constant Information := Information_Bytea.Get_Arg (Args, 0); 35 | 36 | begin 37 | return PGXS.Call_Info.Return_Value (Args, PGXS.Types.Int_32 (V.X)); 38 | end Get_X; 39 | 40 | ----------- 41 | -- Get_Y -- 42 | ----------- 43 | 44 | function Get_Y (Args : in out PGXS.Function_Call_Info) return PGXS.Datum is 45 | V : constant Information := Information_Bytea.Get_Arg (Args, 0); 46 | 47 | begin 48 | return PGXS.Call_Info.Return_Value (Args, PGXS.Types.Int_32 (V.Y)); 49 | end Get_Y; 50 | 51 | -------------- 52 | -- To_Bytea -- 53 | -------------- 54 | 55 | function To_Bytea 56 | (Args : in out PGXS.Function_Call_Info) return PGXS.Datum 57 | is 58 | X : constant PGXS.Types.Int_32 := PGXS.Call_Info.Get_Arg (Args, 0); 59 | Y : constant PGXS.Types.Int_32 := PGXS.Call_Info.Get_Arg (Args, 1); 60 | 61 | begin 62 | return 63 | Information_Bytea.Return_Value 64 | (Args, 65 | (X => Integer (X), 66 | Y => Integer (Y))); 67 | 68 | exception 69 | when others => 70 | return PGXS.Call_Info.Return_Null (Args); 71 | end To_Bytea; 72 | 73 | end Sample; 74 | -------------------------------------------------------------------------------- /pgxs/source/pgxs-pools.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- PostgreSQL server extension modules binding -- 3 | -- -- 4 | -- Copyright (C) 2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | -- Memory pool on top of PostgreSQL memory allocator. 24 | -- 25 | -- Allocated memory is not need to be freed manually, all allocated chunks 26 | -- freed when memory context is freed. 27 | 28 | with System.Storage_Elements; 29 | with System.Storage_Pools; 30 | 31 | private with PGXS.Types; 32 | 33 | package PGXS.Pools is 34 | 35 | type Memory_Context_Pool is 36 | new System.Storage_Pools.Root_Storage_Pool with private; 37 | 38 | private 39 | 40 | type Memory_Context_Pool is 41 | new System.Storage_Pools.Root_Storage_Pool with null record; 42 | 43 | overriding procedure Allocate 44 | (Pool : in out Memory_Context_Pool; 45 | Storage_Address : out System.Address; 46 | Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; 47 | Alignment : System.Storage_Elements.Storage_Count); 48 | 49 | overriding procedure Deallocate 50 | (Pool : in out Memory_Context_Pool; 51 | Storage_Address : System.Address; 52 | Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; 53 | Alignment : System.Storage_Elements.Storage_Count) 54 | is null; 55 | 56 | overriding function Storage_Size 57 | (Pool : Memory_Context_Pool) 58 | return System.Storage_Elements.Storage_Count is 59 | (System.Storage_Elements.Storage_Count (PGXS.Types.Int_32'Last)); 60 | 61 | end PGXS.Pools; 62 | -------------------------------------------------------------------------------- /gnatcoll_db2ada/gnatcoll_sqlite2ada.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2005-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with GNATCOLL.DB2Ada.Main; 25 | with GNATCOLL.SQL.Exec; use GNATCOLL.SQL.Exec; 26 | with GNATCOLL.SQL.Sqlite; 27 | 28 | procedure GNATCOLL_Sqlite2Ada is 29 | 30 | function Sqlite_Description (DB_Type : String; 31 | Database : String; 32 | User : String; 33 | Host : String; 34 | Password : String; 35 | Port : Integer) 36 | return Database_Description; 37 | function Sqlite_Description (DB_Type : String; 38 | Database : String; 39 | User : String; 40 | Host : String; 41 | Password : String; 42 | Port : Integer) 43 | return Database_Description 44 | is 45 | pragma Unreferenced (User); 46 | pragma Unreferenced (Host); 47 | pragma Unreferenced (Password); 48 | pragma Unreferenced (Port); 49 | begin 50 | if DB_Type /= "sqlite" then 51 | return null; 52 | end if; 53 | return GNATCOLL.SQL.Sqlite.Setup 54 | (Database => Database, 55 | Cache_Support => False); 56 | end Sqlite_Description; 57 | 58 | begin 59 | GNATCOLL.DB2Ada.Main ( 60 | "sqlite", 61 | Sqlite_Description'Unrestricted_Access); 62 | end GNATCOLL_Sqlite2Ada; 63 | -------------------------------------------------------------------------------- /gnatcoll_db2ada/gnatcoll_postgres2ada.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2005-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with GNATCOLL.DB2Ada.Main; 25 | with GNATCOLL.SQL.Exec; use GNATCOLL.SQL.Exec; 26 | with GNATCOLL.SQL.Postgres; 27 | 28 | procedure GNATCOLL_Postgres2Ada is 29 | 30 | function Postgres_Description (DB_Type : String; 31 | Database : String; 32 | User : String; 33 | Host : String; 34 | Password : String; 35 | Port : Integer) 36 | return Database_Description; 37 | function Postgres_Description (DB_Type : String; 38 | Database : String; 39 | User : String; 40 | Host : String; 41 | Password : String; 42 | Port : Integer) 43 | return Database_Description 44 | is 45 | begin 46 | if DB_Type /= "postgresql" then 47 | return null; 48 | end if; 49 | return GNATCOLL.SQL.Postgres.Setup 50 | (Database => Database, 51 | User => User, 52 | Host => Host, 53 | Password => Password, 54 | Port => Port, 55 | Cache_Support => False); 56 | end Postgres_Description; 57 | 58 | begin 59 | GNATCOLL.DB2ADA.Main ( 60 | "postgresql", 61 | Postgres_Description'Unrestricted_Access); 62 | end GNATCOLL_Postgres2Ada; 63 | -------------------------------------------------------------------------------- /pgxs/source/pgxs-types.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- PostgreSQL server extension modules binding -- 3 | -- -- 4 | -- Copyright (C) 2020-2021, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | -- Mapping of SQL types to C and Ada 24 | -- 25 | -- oid Oid postgres.h Oid 26 | -- boolean bool postgres.h Bool 27 | -- smallint (int2) int16 postgres.h Int_16 28 | -- integer (int4) int32 postgres.h Int_32 29 | -- real (float4) float4* postgres.h Float_4 30 | -- double precision (float8) float8* postgres.h Float_8 31 | -- bytea bytea* postgres.h Byte_A 32 | -- character BpChar* postgres.h Bp_Char 33 | -- text text* postgres.h Text 34 | -- varchar VarChar* postgres.h Var_Char 35 | 36 | with Interfaces.C; 37 | 38 | with PGXS.Varlen; 39 | 40 | package PGXS.Types is 41 | 42 | type Oid is private; 43 | 44 | subtype Bool is Interfaces.C.C_bool; 45 | 46 | subtype Int_16 is Interfaces.Integer_16; 47 | 48 | subtype UInt_16 is Interfaces.Unsigned_16; 49 | 50 | subtype Int_32 is Interfaces.Integer_32; 51 | 52 | subtype UInt_32 is Interfaces.Unsigned_32; 53 | 54 | subtype Int_64 is Interfaces.Integer_64; 55 | 56 | subtype UInt_64 is Interfaces.Unsigned_64; 57 | 58 | subtype Float_4 is Interfaces.IEEE_Float_32; 59 | 60 | subtype Float_8 is Interfaces.IEEE_Float_64; 61 | 62 | type Byte_A is new PGXS.Varlen.Varlen_A; 63 | 64 | type Bp_Char is new PGXS.Varlen.Varlen_A; 65 | 66 | type Text is new PGXS.Varlen.Varlen_A; 67 | 68 | type Var_Char is new PGXS.Varlen.Varlen_A; 69 | 70 | private 71 | 72 | type Oid is new Interfaces.C.unsigned; 73 | 74 | end PGXS.Types; 75 | -------------------------------------------------------------------------------- /pgxs/README.md: -------------------------------------------------------------------------------- 1 | PostgreSQL Server Extensions Modules in Ada 2 | ------------------------------------------- 3 | 4 | This directory contains the binding to develop extension modules for PostgreSQL 5 | server. They are loaded by the database backend and provide functions that are 6 | called from SQL queries. 7 | 8 | Installation 9 | ============ 10 | 11 | To use this binding, the user should copy all code in the source directory 12 | inside source code of his own project. 13 | 14 | Binding structure 15 | ================= 16 | 17 | Package | Description 18 | --------------------|------------------------- 19 | PGXS | declaration of internal types 20 | PGXS.ABI | the function to declare the version of calling convention of extension functions 21 | PGXS.Call_Info | subprograms to get values of arguments and set the return value 22 | PGXS.Composites | subprograms to manipulate by composite types 23 | PGXS.Datums | subprograms to get value of Datum and create Datum from value 24 | PGXS.Generic_Bytea | generic package to manipulate with BYTEA values as Ada record 25 | PGXS.Logs | error reporting and logging 26 | PGXS.Pools | memory management 27 | PGXS.Pools.Defaults | default memory pool 28 | PGXS.Return_Sets | subprograms and utilities to return sets 29 | PGXS.Types | declarations of types used as representation of SQL types 30 | PGXS.Varlen | subprograms to manipulate by varlena objects 31 | 32 | Declaring exported functions 33 | ============================ 34 | 35 | Each exported extension function should have following declaration: 36 | 37 | function My_Function 38 | (Args : in out PGXS.Function_Call_Info) return PGXS.Datum 39 | with Export, Convention => C, Link_Name => "my_function"; 40 | 41 | It should have a companion function to declare calling conventions: 42 | 43 | function My_Function_Info 44 | return not null access PGXS.ABI.Function_Info_Record 45 | is (PGXS.ABI.Ada_Function_Info_1) 46 | with Export, Convention => C, Link_Name => "pg_finfo_my_function"; 47 | 48 | Note that calling convention declaration function should have its link name 49 | constructed as "pg_finfo_" prefix and link name of the user function. 50 | 51 | Building the module 52 | =================== 53 | 54 | The module should be built as a standalone shared library. Here is an example 55 | project file with only the important attributes and packages, others may need 56 | to be provided. 57 | 58 | library project My_Module is 59 | 60 | PostgreSQL_IncludeDir_Server := "/usr/include/pgsql/server"; 61 | -- A Path to server extensions header files reported by 62 | -- 63 | -- $ pg_config --includedir-server 64 | 65 | for Languages use ("C", "Ada"); 66 | for Object_Dir use "obj"; 67 | for Source_Dirs use ("source/pgxs", "source/my_module"); 68 | 69 | for Library_Name use "my_module"; 70 | for Library_Kind use "relocatable"; 71 | for Library_Dir use "lib"; 72 | for Library_Options use ("-Wl,--version-script=source/pgxs.sym"); 73 | -- Linker script to be used when linking extension module 74 | for Library_Interface use ("My_Module", "PGXS", ...); 75 | 76 | package Compiler is 77 | for Switches ("Ada") use ("-fPIC"); 78 | for Switches ("C") use 79 | ("-fPIC", "-I" & PostgreSQL_IncludeDir_Server); 80 | end Compiler; 81 | 82 | end My_Module; 83 | -------------------------------------------------------------------------------- /pgxs/source/pgxs-logs.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- PostgreSQL server extension modules binding -- 3 | -- -- 4 | -- Copyright (C) 2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | -- Access to PostgreSQL error reporting/logging features 24 | 25 | with Interfaces.C; 26 | 27 | private with PGXS.Types; 28 | 29 | package PGXS.Logs is 30 | 31 | type Error_Level is private; 32 | 33 | Debug_5 : constant Error_Level; 34 | Debug_4 : constant Error_Level; 35 | Debug_3 : constant Error_Level; 36 | Debug_2 : constant Error_Level; 37 | Debug_1 : constant Error_Level; 38 | Log : constant Error_Level; 39 | Log_Server_Only : constant Error_Level; 40 | Info : constant Error_Level; 41 | Notice : constant Error_Level; 42 | Warning : constant Error_Level; 43 | Error : constant Error_Level; 44 | 45 | procedure Report 46 | (Level : Error_Level; 47 | Message : Interfaces.C.char_array) 48 | with Import, Convention => C, Link_Name => "__ada_PG_ereport"; 49 | -- Reports message of given level. Message must be C-style 'nul' terminated 50 | -- string. 51 | 52 | private 53 | 54 | type Error_Level is new PGXS.Types.Int_32; 55 | 56 | Debug_5 : constant Error_Level := 10; 57 | Debug_4 : constant Error_Level := 11; 58 | Debug_3 : constant Error_Level := 12; 59 | Debug_2 : constant Error_Level := 13; 60 | Debug_1 : constant Error_Level := 14; 61 | Log : constant Error_Level := 15; 62 | Log_Server_Only : constant Error_Level := 16; 63 | Info : constant Error_Level := 17; 64 | Notice : constant Error_Level := 18; 65 | Warning : constant Error_Level := 19; 66 | Error : constant Error_Level := 20; 67 | 68 | end PGXS.Logs; 69 | -------------------------------------------------------------------------------- /gnatcoll_db2ada/gnatcoll_all2ada.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2018-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with Ada.Command_Line; use Ada.Command_Line; 25 | with Ada.Strings.Fixed; use Ada.Strings; 26 | 27 | with GNATCOLL.DB2Ada.Main; 28 | with GNATCOLL.SQL.Exec; use GNATCOLL.SQL.Exec; 29 | with GNATCOLL.SQL.Postgres; 30 | with GNATCOLL.SQL.Sqlite; 31 | 32 | procedure GNATCOLL_All2Ada is 33 | 34 | function Create_Description 35 | (DB_Type : String; 36 | Database : String; 37 | User : String; 38 | Host : String; 39 | Password : String; 40 | Port : Integer) return Database_Description; 41 | 42 | function Create_Description 43 | (DB_Type : String; 44 | Database : String; 45 | User : String; 46 | Host : String; 47 | Password : String; 48 | Port : Integer) return Database_Description is 49 | begin 50 | if DB_Type = "postgresql" then 51 | return GNATCOLL.SQL.Postgres.Setup 52 | (Database => Database, 53 | User => User, 54 | Host => Host, 55 | Password => Password, 56 | Port => Port, 57 | Cache_Support => False); 58 | 59 | elsif DB_Type = "sqlite" then 60 | return GNATCOLL.SQL.Sqlite.Setup 61 | (Database => Database, 62 | Cache_Support => False); 63 | 64 | else 65 | return null; 66 | end if; 67 | end Create_Description; 68 | 69 | begin 70 | GNATCOLL.DB2Ada.Main 71 | (Default_DB_Type => (if Fixed.Index (Command_Name, "sqlite") > 0 72 | then "sqlite" 73 | else "postgresql"), 74 | Description => Create_Description'Unrestricted_Access); 75 | end GNATCOLL_All2Ada; 76 | -------------------------------------------------------------------------------- /COPYING.RUNTIME: -------------------------------------------------------------------------------- 1 | GCC RUNTIME LIBRARY EXCEPTION 2 | 3 | Version 3.1, 31 March 2009 4 | 5 | Copyright (c) 2009 Free Software Foundation, Inc. 6 | 7 | Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. 8 | 9 | This GCC Runtime Library Exception ("Exception") is an additional permission under section 7 of the GNU General Public License, 10 | version 3 ("GPLv3"). It applies to a given file (the "Runtime Library") that bears a notice placed by the copyright holder of 11 | the file stating that the file is governed by GPLv3 along with this Exception. 12 | 13 | When you use GCC to compile a program, GCC may combine portions of certain GCC header files and runtime libraries with the 14 | compiled program. The purpose of this Exception is to allow compilation of non-GPL (including proprietary) programs to 15 | use, in this way, the header files and runtime libraries covered by this Exception. 16 | 17 | 0. Definitions. 18 | 19 | A file is an "Independent Module" if it either requires the Runtime Library for execution after a Compilation 20 | Process, or makes use of an interface provided by the Runtime Library, but is not otherwise based on the Runtime Library. 21 | 22 | "GCC" means a version of the GNU Compiler Collection, with or without modifications, governed by version 3 23 | (or a specified later version) of the GNU General Public License (GPL) with the option of using any subsequent 24 | versions published by the FSF. 25 | 26 | "GPL-compatible Software" is software whose conditions of propagation, modification and use would permit combination 27 | with GCC in accord with the license of GCC. 28 | 29 | "Target Code" refers to output from any compiler for a real or virtual target processor architecture, in executable 30 | form or suitable for input to an assembler, loader, linker and/or execution phase. Notwithstanding that, Target Code 31 | does not include data in any format that is used as a compiler intermediate representation, or used for producing a 32 | compiler intermediate representation. 33 | 34 | The "Compilation Process" transforms code entirely represented in non-intermediate languages designed for human-written 35 | code, and/or in Java Virtual Machine byte code, into Target Code. Thus, for example, use of source code generators and 36 | preprocessors need not be considered part of the Compilation Process, since the Compilation Process can be understood as 37 | starting with the output of the generators or preprocessors. 38 | 39 | A Compilation Process is "Eligible" if it is done using GCC, alone or with other GPL-compatible software, or if it is 40 | done without using any work based on GCC. For example, using non-GPL-compatible Software to optimize any GCC 41 | intermediate representations would not qualify as an Eligible Compilation Process. 42 | 43 | 1. Grant of Additional Permission. 44 | 45 | You have permission to propagate a work of Target Code formed by combining the Runtime Library with Independent Modules, 46 | even if such propagation would otherwise violate the terms of GPLv3, provided that all Target Code was generated by 47 | Eligible Compilation Processes. You may then convey such a combination under terms of your choice, consistent with the 48 | licensing of the Independent Modules. 49 | 50 | 2. No Weakening of GCC Copyleft. 51 | 52 | The availability of this Exception does not imply any general presumption that third-party software is unaffected by 53 | the copyleft requirements of the license of GCC. 54 | -------------------------------------------------------------------------------- /examples/library/generated/database_names.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2021, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with GNATCOLL.SQL; use GNATCOLL.SQL; 25 | package Database_Names is 26 | pragma Style_Checks (Off); 27 | TC_Books : aliased constant String := "books"; 28 | Ta_Books : constant Cst_String_Access := TC_Books'Access; 29 | TC_Customers : aliased constant String := "customers"; 30 | Ta_Customers : constant Cst_String_Access := TC_Customers'Access; 31 | TC_Dvds : aliased constant String := "dvds"; 32 | Ta_Dvds : constant Cst_String_Access := TC_Dvds'Access; 33 | TC_Media : aliased constant String := "media"; 34 | Ta_Media : constant Cst_String_Access := TC_Media'Access; 35 | 36 | NC_Author : aliased constant String := "author"; 37 | N_Author : constant Cst_String_Access := NC_author'Access; 38 | NC_Borrowed_By : aliased constant String := "borrowed_by"; 39 | N_Borrowed_By : constant Cst_String_Access := NC_borrowed_by'Access; 40 | NC_First : aliased constant String := """first"""; 41 | N_First : constant Cst_String_Access := NC_first'Access; 42 | NC_Id : aliased constant String := "id"; 43 | N_Id : constant Cst_String_Access := NC_id'Access; 44 | NC_Last : aliased constant String := """last"""; 45 | N_Last : constant Cst_String_Access := NC_last'Access; 46 | NC_Pages : aliased constant String := "pages"; 47 | N_Pages : constant Cst_String_Access := NC_pages'Access; 48 | NC_Published : aliased constant String := "published"; 49 | N_Published : constant Cst_String_Access := NC_published'Access; 50 | NC_Region : aliased constant String := "region"; 51 | N_Region : constant Cst_String_Access := NC_region'Access; 52 | NC_Title : aliased constant String := "title"; 53 | N_Title : constant Cst_String_Access := NC_title'Access; 54 | end Database_Names; 55 | -------------------------------------------------------------------------------- /testsuite/support/test_assert.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2018, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | -- Helper package to implement tests that comply with the expectations 25 | -- of the default test driver. 26 | 27 | with GNAT.Source_Info; 28 | with GNATCOLL.VFS; 29 | 30 | package Test_Assert is 31 | 32 | package SI renames GNAT.Source_Info; 33 | package VFS renames GNATCOLL.VFS; 34 | 35 | Final_Status : Natural := 0; 36 | 37 | procedure Assert 38 | (Success : Boolean; 39 | Msg : String := ""; 40 | Location : String := SI.Source_Location); 41 | -- If Success is True then test case is considered PASSED, otherwise 42 | -- the test status is FAILED and Final_Status set to 1. 43 | 44 | procedure Assert 45 | (Left, Right : String; 46 | Msg : String := ""; 47 | Location : String := SI.Source_Location); 48 | -- If Left = Right then test case is considered PASSED, otherwise 49 | -- the test status is FAILED and Final_Status set to 1. 50 | 51 | procedure Assert 52 | (Left, Right : Integer; 53 | Msg : String := ""; 54 | Location : String := SI.Source_Location); 55 | 56 | procedure Assert 57 | (Left, Right : VFS.Virtual_File; 58 | Msg : String := ""; 59 | Location : String := SI.Source_Location); 60 | -- If Left = Right then test case is considered PASSED, otherwise 61 | -- the test status is FAILED and Final_Status set to 1. 62 | 63 | function Report return Natural; 64 | -- Report should be called the following way at the end of a test 65 | -- program main function: 66 | -- 67 | -- return Report; 68 | -- 69 | -- Testsuite driver will consider a test to PASS if all the 70 | -- following conditions are met: 71 | -- 72 | -- * test program exit with status 0 73 | -- * all assert calls did succeed 74 | -- * test program display the message "<=== TEST PASSED ===>" 75 | end Test_Assert; 76 | -------------------------------------------------------------------------------- /postgres/gnatcoll_postgres.gpr: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2015-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with "gnatcoll_postgres_conf.gpr"; 25 | with "gnatcoll_core"; 26 | with "gnatcoll_sql"; 27 | 28 | library project GnatColl_Postgres is 29 | 30 | Version := External ("GNATCOLL_POSTGRES_VERSION", 31 | GnatColl_Postgres_Conf.Gnatcoll_Version); 32 | 33 | for Library_Kind use GnatColl_Postgres_Conf.Library_Type; 34 | for Source_Dirs use ("."); 35 | for Object_Dir use "obj/" & Project'Library_Kind; 36 | for Library_Dir use "lib/" & Project'Library_Kind; 37 | for Library_Name use project'Name; 38 | 39 | case GnatColl_Postgres_Conf.Library_Type is 40 | when "relocatable" => 41 | for Library_Options use ("-lpq"); 42 | for Library_Interface use 43 | ("gnatcoll.sql.postgres", "gnatcoll.sql.ranges"); 44 | for Leading_Library_Options use GnatColl_Postgres_Conf.Ldflags; 45 | for Library_Version use 46 | "lib" & project'Library_Name & Gnatcoll_core.So_Ext & "." & Version; 47 | when "static" | "static-pic" => 48 | null; 49 | end case; 50 | 51 | for Languages use ("Ada", "C"); 52 | 53 | type Yes_No is ("yes", "no"); 54 | Has_PQP : Yes_No := External ("GNATCOLL_HASPQPREPARE", "yes"); 55 | 56 | package Compiler extends GnatColl_Postgres_Conf.Compiler is 57 | case Has_PQP is 58 | when "yes" => 59 | for Switches ("C") use 60 | GnatColl_Postgres_Conf.Cflags_Mode & "-DHAS_PQPREPARE" 61 | & GnatColl_Postgres_Conf.Cflags & GnatColl_Postgres_Conf.Cppflags; 62 | when "no" => 63 | null; 64 | end case; 65 | end Compiler; 66 | 67 | package Binder renames GnatColl_Postgres_Conf.Binder; 68 | 69 | package Builder renames GnatColl_Postgres_Conf.Builder; 70 | 71 | package Ide renames GnatColl_Postgres_Conf.Ide; 72 | 73 | package Linker is 74 | for Linker_Options use ("-lpq"); 75 | end Linker; 76 | 77 | end GnatColl_Postgres; 78 | -------------------------------------------------------------------------------- /pgxs/source/pgxs-composites.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- PostgreSQL server extension modules binding -- 3 | -- -- 4 | -- Copyright (C) 2020-2021, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with PGXS.Types; 25 | 26 | package body PGXS.Composites is 27 | 28 | -------------- 29 | -- Allocate -- 30 | -------------- 31 | 32 | function Allocate 33 | (Descriptor : PGXS.Tuple_Desc; 34 | Size : Attribute_Count) return Attributes is 35 | begin 36 | return 37 | new Attributes_Arrays' 38 | (Size => Size, Descriptor => Descriptor, others => <>); 39 | end Allocate; 40 | 41 | ------------------ 42 | -- Return_Value -- 43 | ------------------ 44 | 45 | function Return_Value 46 | (Args : Function_Call_Info; Item : Attributes) return PGXS.Datum 47 | is 48 | 49 | function Heap_From_Tuple 50 | (Tupdesc : PGXS.Tuple_Desc; 51 | Values : not null access constant PGXS.Datum; 52 | Isnull : not null access constant PGXS.Types.Bool) 53 | return PGXS.Heap_Tuple 54 | with Import, Convention => C, Link_Name => "heap_form_tuple"; 55 | 56 | function To_Datum (Item : PGXS.Heap_Tuple) return PGXS.Datum 57 | with Import, 58 | Convention => C, 59 | Link_Name => "__ada_PG_HeapTupleGetDatum"; 60 | 61 | begin 62 | return 63 | To_Datum 64 | (Heap_From_Tuple 65 | (Item.Descriptor, 66 | Item.Datums (Item.Datums'First)'Access, 67 | Item.Nulls (Item.Nulls'First)'Access)); 68 | end Return_Value; 69 | 70 | -------------- 71 | -- Set_Null -- 72 | -------------- 73 | 74 | procedure Set_Null 75 | (Self : in out Attributes; 76 | Index : Attribute_Number) is 77 | begin 78 | Self.Nulls (Index) := Interfaces.C.True; 79 | end Set_Null; 80 | 81 | --------------- 82 | -- Set_Value -- 83 | --------------- 84 | 85 | procedure Set_Value 86 | (Self : in out Attributes; 87 | Index : Attribute_Number; 88 | To : PGXS.Datum) is 89 | begin 90 | Self.Nulls (Index) := Interfaces.C.False; 91 | Self.Datums (Index) := To; 92 | end Set_Value; 93 | 94 | end PGXS.Composites; 95 | -------------------------------------------------------------------------------- /testsuite/tests/sql1/database.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- Database interface utilities -- 3 | -- -- 4 | -- Copyright (C) 2017-2018, AdaCore -- 5 | ------------------------------------------------------------------------------ 6 | 7 | package body Database is 8 | pragma Style_Checks (Off); 9 | 10 | function FK (Self : T_Action_Item'Class; Foreign : T_Sales_Entity'Class) return SQL_Criteria is 11 | begin 12 | return Self.Se_Nb = Foreign.Se_Nb; 13 | end FK; 14 | 15 | function FK (Self : T_Action_Item'Class; Foreign : T_Staff'Class) return SQL_Criteria is 16 | begin 17 | return Self.Who_Done = Foreign.Id; 18 | end FK; 19 | 20 | function FK (Self : T_Contract'Class; Foreign : T_Sales_Entity'Class) return SQL_Criteria is 21 | begin 22 | return Self.Se_Nb = Foreign.Se_Nb; 23 | end FK; 24 | 25 | function FK (Self : T_Mailing_List'Class; Foreign : T_Tn_Status'Class) return SQL_Criteria is 26 | begin 27 | return Self.Default_Status = Foreign.Id; 28 | end FK; 29 | 30 | function FK (Self : T_Mailing_List_Recipients'Class; Foreign : T_Staff_Email'Class) return SQL_Criteria is 31 | begin 32 | return Self.Email = Foreign.Id; 33 | end FK; 34 | 35 | function FK (Self : T_Mailing_List_Recipients'Class; Foreign : T_Mailing_List'Class) return SQL_Criteria is 36 | begin 37 | return Self.List = Foreign.Id; 38 | end FK; 39 | 40 | function FK (Self : T_Mailing_List_Recipients'Class; Foreign : T_Mailing_List_Subscription_Type'Class) return SQL_Criteria is 41 | begin 42 | return Self.Subscription_Type = Foreign.Id; 43 | end FK; 44 | 45 | function FK (Self : T_Sales_Entity'Class; Foreign : T_Region'Class) return SQL_Criteria is 46 | begin 47 | return Self.Region = Foreign.Id; 48 | end FK; 49 | 50 | function FK (Self : T_Sales_Entity'Class; Foreign : T_Staff'Class) return SQL_Criteria is 51 | begin 52 | return Self.Sales_Rep = Foreign.Id; 53 | end FK; 54 | 55 | function FK (Self : T_Staff'Class; Foreign : T_Staff_Email'Class) return SQL_Criteria is 56 | begin 57 | return Self.Preferred_Email = Foreign.Id; 58 | end FK; 59 | 60 | function FK (Self : T_Staff'Class; Foreign : T_Region'Class) return SQL_Criteria is 61 | begin 62 | return Self.Region = Foreign.Id; 63 | end FK; 64 | 65 | function FK (Self : T_Staff_Email'Class; Foreign : T_Staff'Class) return SQL_Criteria is 66 | begin 67 | return Self.Staff = Foreign.Id; 68 | end FK; 69 | 70 | function FK (Self : T_Subscription'Class; Foreign : T_Contract'Class) return SQL_Criteria is 71 | begin 72 | return Self.Subscription_Nb = Foreign.Contract_Nb; 73 | end FK; 74 | 75 | function FK (Self : T_Wavefront'Class; Foreign : T_Staff'Class) return SQL_Criteria is 76 | begin 77 | return Self.Delivered_By = Foreign.Id; 78 | end FK; 79 | 80 | function FK (Self : T_Wavefront'Class; Foreign : T_Sales_Entity'Class) return SQL_Criteria is 81 | begin 82 | return Self.Se_Nb = Foreign.Se_Nb; 83 | end FK; 84 | 85 | function FK (Self : T_Wavefront'Class; Foreign : T_Wavefront_Status'Class) return SQL_Criteria is 86 | begin 87 | return Self.Status = Foreign.Id; 88 | end FK; 89 | 90 | function FK (Self : T_Wavefront_Tn'Class; Foreign : T_Tracking_Number'Class) return SQL_Criteria is 91 | begin 92 | return Self.Tn = Foreign.Tn; 93 | end FK; 94 | 95 | function FK (Self : T_Wavefront_Tn'Class; Foreign : T_Wavefront'Class) return SQL_Criteria is 96 | begin 97 | return Self.Wave = Foreign.Id; 98 | end FK; 99 | end Database; 100 | -------------------------------------------------------------------------------- /testsuite/support/test_remote.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2018, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | -- The package provides remote support using only local resources. This 25 | -- allows to test remote functionalities without the need for a remote host. 26 | 27 | with GNAT.Expect; 28 | with GNAT.Strings; 29 | with GNATCOLL.Remote; 30 | with GNATCOLL.VFS_Types; 31 | with GNATCOLL.Remote.DB; 32 | 33 | package Test_Remote is 34 | 35 | package GR renames GNATCOLL.Remote; 36 | package GRDB renames GNATCOLL.Remote.DB; 37 | package GVT renames GNATCOLL.VFS_Types; 38 | 39 | -- Declare local transport protocol (basically spawn /bin/bash) 40 | type Local_Transport is new GR.Server_Record with null record; 41 | 42 | function Nickname (Server : Local_Transport) return String; 43 | function Shell_FS (Server : Local_Transport) return GVT.FS_Type; 44 | 45 | procedure Execute_Remotely 46 | (Server : access Local_Transport; 47 | Args : GNAT.Strings.String_List; 48 | Status : out Boolean; 49 | Execution_Directory : GVT.FS_String := ""); 50 | 51 | procedure Execute_Remotely 52 | (Server : access Local_Transport; 53 | Args : GNAT.Strings.String_List; 54 | Result : out GNAT.Strings.String_Access; 55 | Status : out Boolean; 56 | Execution_Directory : GVT.FS_String := ""); 57 | 58 | procedure Spawn_Remotely 59 | (Server : access Local_Transport; 60 | Descriptor : out GNAT.Expect.Process_Descriptor_Access; 61 | Args : GNAT.Strings.String_List); 62 | 63 | -- Declare local remote database which holds only one host nickname 64 | -- called local_test 65 | type Local_DB is new GRDB.Remote_Db_Interface with null record; 66 | 67 | function Is_Configured 68 | (Config : Local_DB; 69 | Nickname : String) 70 | return Boolean; 71 | 72 | function Get_Server 73 | (Config : Local_DB; 74 | Nickname : String) 75 | return GR.Server_Access; 76 | 77 | function Nb_Mount_Points 78 | (Config : Local_DB; 79 | Nickname : String) 80 | return Natural; 81 | 82 | function Get_Mount_Point_Local_Root 83 | (Config : Local_DB; 84 | Nickname : String; 85 | Index : Natural) 86 | return GVT.FS_String; 87 | 88 | function Get_Mount_Point_Host_Root 89 | (Config : Local_DB; 90 | Nickname : String; 91 | Index : Natural) return GVT.FS_String; 92 | 93 | end Test_Remote; 94 | -------------------------------------------------------------------------------- /testsuite/drivers/db2ada.py: -------------------------------------------------------------------------------- 1 | from e3.fs import cp 2 | from e3.testsuite.driver import TestDriver 3 | from e3.testsuite.process import check_call 4 | from e3.testsuite.result import TestStatus 5 | from e3.fs import mkdir 6 | from drivers import gprbuild 7 | import os 8 | 9 | 10 | class DB2AdaTestDriver(TestDriver): 11 | """Driver with db2ada integration 12 | 13 | In order to declare a test: 14 | 15 | 1- Create a directory with a test.yaml inside. driver should be set to 16 | "db2ada" 17 | 2- Add test sources in that directory 18 | 3- Add a main called test.adb that use support/test_assert.ads package. 19 | 4- In test.yaml, under the "db2ada" add the list of parameter for 20 | gnatcoll_db2ada 21 | 22 | Example of test.yaml: 23 | 24 | description: SQL test 1 25 | sqlite_db: db.sql 26 | db2ada: 27 | - "-api=DB" 28 | - "-dbmodel=descr.txt" 29 | driver: db2ada 30 | 31 | if sqlite_db is set then a sql file is loaded into a sqlite database and 32 | then gnatcoll_sqlite2ada is used instead of gnatcoll_db2ada with the 33 | resulting database (no need to specify -dbname in the db2ada arguments) 34 | """ 35 | 36 | def add_test(self, dag): 37 | """Declare test workflow. 38 | 39 | The workflow is the following:: 40 | 41 | db2ada --> build --> check status 42 | 43 | :param dag: tree of test fragment to amend 44 | :type dag: e3.collection.dag.DAG 45 | """ 46 | self.add_fragment(dag, "db2ada") 47 | self.add_fragment(dag, "build", after=["db2ada"]) 48 | self.add_fragment(dag, "check_run", after=["build"]) 49 | 50 | if "test_exe" not in self.test_env: 51 | self.test_env["test_exe"] = "obj/test" 52 | 53 | def db2ada(self, previous_values): 54 | """Run db2ada.""" 55 | mkdir(self.test_env["working_dir"]) 56 | db2ada_args = [] 57 | db2ada = "gnatcoll_db2ada" 58 | 59 | # If necessary initialize an sqlite database 60 | if "sqlite_db" in self.test_env: 61 | check_call( 62 | self, 63 | [ 64 | "sqlite3", 65 | "db.db", 66 | "-cmd", 67 | ".read %s" 68 | % os.path.join( 69 | self.test_env["test_dir"], self.test_env["sqlite_db"] 70 | ), 71 | ], 72 | input="|", 73 | ) 74 | db2ada = "gnatcoll_sqlite2ada" 75 | db2ada_args.append( 76 | "-dbname=%s" % os.path.join(self.test_env["working_dir"], "db.db") 77 | ) 78 | 79 | # Compute db2ada arguments 80 | for value in self.test_env.get("db2ada", []): 81 | if value.startswith("-dbmodel="): 82 | dbmodel = value.split("=", 1)[1] 83 | dbmodel = os.path.join(self.test_env["test_dir"], dbmodel) 84 | db2ada_args.append("-dbmodel=%s" % dbmodel) 85 | else: 86 | db2ada_args.append(value) 87 | 88 | check_call(self, [db2ada] + db2ada_args) 89 | 90 | def build(self, previous_values): 91 | """Build fragment.""" 92 | return gprbuild(self, gcov=self.env.gcov, components=self.env.components) 93 | 94 | def check_run(self, previous_values): 95 | """Check status fragment.""" 96 | if not previous_values["build"]: 97 | return 98 | 99 | for data in self.test_env.get("data", []): 100 | cp( 101 | os.path.join(self.test_env["test_dir"], data), 102 | self.test_env["working_dir"], 103 | recursive=True, 104 | ) 105 | 106 | process = check_call( 107 | self, 108 | [os.path.join(self.test_env["working_dir"], self.test_env["test_exe"])], 109 | ) 110 | if "<=== TEST PASSED ===>" not in process.out: 111 | self.result.set_status(TestStatus.FAIL) 112 | else: 113 | self.result.set_status(TestStatus.PASS) 114 | self.push_result() 115 | -------------------------------------------------------------------------------- /sqlite/gnatcoll_sqlite.gpr: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2015-2022, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with "gnatcoll_sqlite_conf.gpr"; 25 | with "gnatcoll_core"; 26 | with "gnatcoll_sql"; 27 | 28 | library project GnatColl_Sqlite is 29 | 30 | Version := External ("GNATCOLL_SQLITE_VERSION", 31 | GnatColl_Sqlite_Conf.Gnatcoll_Version); 32 | OS := External ("OS", "unix"); 33 | 34 | for Library_Kind use GnatColl_Sqlite_Conf.Library_Type; 35 | for Object_Dir use "obj/" & Project'Library_Kind; 36 | for Library_Dir use "lib/" & Project'Library_Kind; 37 | for Library_Name use project'Name; 38 | 39 | Thread_Lib := (); 40 | case OS is 41 | when "Windows_NT" => 42 | null; 43 | when others => 44 | Thread_Lib := ("-lpthread"); 45 | end case; 46 | 47 | type Sqlite_Dep_Kind is ("embedded", "external"); 48 | Sqlite_Dep : Sqlite_Dep_Kind := External ("GNATCOLL_SQLITE", "embedded"); 49 | 50 | Sqlite_Lib := (); 51 | case Sqlite_Dep is 52 | when "embedded" => 53 | for Source_Dirs use (".", "amalgamation"); 54 | for Languages use ("Ada", "C"); 55 | when "external" => 56 | for Source_Dirs use ("."); 57 | for Languages use ("Ada"); 58 | Sqlite_Lib := ("-lsqlite3"); 59 | end case; 60 | 61 | case GnatColl_Sqlite_Conf.Library_Type is 62 | when "relocatable" => 63 | for Library_Interface use ("gnatcoll.sql.sqlite"); 64 | for Leading_Library_Options use GnatColl_Sqlite_Conf.Ldflags; 65 | for Library_Options use Sqlite_Lib & Thread_Lib; 66 | for Library_Version use 67 | "lib" & project'Library_Name & Gnatcoll_core.So_Ext & "." & Version; 68 | when "static" | "static-pic" => 69 | null; 70 | end case; 71 | 72 | package Compiler extends GnatColl_Sqlite_Conf.Compiler is 73 | -- C switches are only used when Sqlite_Dep is "embedded". 74 | for Switches ("C") 75 | use GnatColl_Sqlite_Conf.Cflags_Mode 76 | & ("-DSQLITE_OMIT_LOAD_EXTENSION", 77 | "-D__EXTENSIONS__", 78 | "-O3") 79 | & GnatColl_Sqlite_Conf.Cflags 80 | & GnatColl_Sqlite_Conf.Cppflags; 81 | end Compiler; 82 | 83 | package Binder renames GnatColl_Sqlite_Conf.Binder; 84 | 85 | package Builder renames GnatColl_Sqlite_Conf.Builder; 86 | 87 | package Ide renames GnatColl_Sqlite_Conf.Ide; 88 | 89 | package Linker is 90 | for Linker_Options use Sqlite_Lib & Thread_Lib; 91 | end Linker; 92 | 93 | end GnatColl_Sqlite; 94 | -------------------------------------------------------------------------------- /gnatcoll_db_shared.gpr: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2022-2022, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | abstract project Gnatcoll_Db_Shared is 25 | 26 | for Source_Files use (); 27 | 28 | type Build_Type is ("DEBUG", "PROD"); 29 | Build : Build_Type := External ("BUILD", "PROD"); 30 | Gnatcoll_Build_Mode : Build_Type := External ("GNATCOLL_BUILD_MODE", Build); 31 | 32 | type Library_Type_Type is ("relocatable", "static", "static-pic"); 33 | Library_Type : Library_Type_Type := External ("LIBRARY_TYPE", "static"); 34 | 35 | Gnatcoll_Version := External ("GNATCOLL_VERSION", "0.0"); 36 | 37 | -- User settings should come after defaults and take precedence. 38 | Adaflags := External_As_List ("ADAFLAGS", " "); 39 | Cflags := External_As_List ("CFLAGS", " "); 40 | Cppflags := External_As_List ("CPPFLAGS", " "); 41 | 42 | Adaflags_Debug := ("-g", "-O0", "-gnata", "-gnatVa", "-gnatQ", "-gnaty", 43 | "-gnateE", "-gnatwaCJe", "-fstack-check"); 44 | Cflags_Debug := ("-g", "-Wunreachable-code"); 45 | 46 | -- Do not use -gnatwe for production mode 47 | Adaflags_Prod := ("-O2", "-gnatn", "-gnatwaCJ"); 48 | Cflags_Prod := ("-O2", "-Wunreachable-code"); 49 | 50 | Adaflags_Mode := (); 51 | Cflags_Mode := (); 52 | case Gnatcoll_Build_Mode is 53 | when "DEBUG" => 54 | Adaflags_Mode := Adaflags_Debug; 55 | Cflags_Mode := Cflags_Debug; 56 | when "PROD" => 57 | Adaflags_Mode := Adaflags_Prod; 58 | Cflags_Mode := Cflags_Prod; 59 | end case; 60 | 61 | package Compiler is 62 | for Switches ("Ada") use Adaflags_Mode & Adaflags; 63 | for Switches ("C") use Cflags_Mode & Cflags & Cppflags; 64 | end Compiler; 65 | 66 | package Binder is 67 | case Gnatcoll_Build_Mode is 68 | when "DEBUG" => 69 | for Switches ("Ada") use ("-E"); 70 | when "PROD" => 71 | null; 72 | end case; 73 | end Binder; 74 | 75 | package Builder is 76 | case Gnatcoll_Build_Mode is 77 | when "DEBUG" => 78 | for Global_Configuration_Pragmas use "gnat_debug.adc"; 79 | when "PROD" => 80 | null; 81 | end case; 82 | end Builder; 83 | 84 | package Ide is 85 | for VCS_Kind use "Git"; 86 | end Ide; 87 | 88 | -- Some options for the dynamic linker need to come before the 89 | -- objects they affect (for example --as-needed). 90 | Ldflags := External_As_List ("LDFLAGS", " "); 91 | 92 | -- This template is intended for standard projects. 93 | -- Relocatable libraries should use Leading_Library_Options. 94 | package Linker is 95 | for Leading_Switches ("Ada") use Ldflags; 96 | end Linker; 97 | 98 | end Gnatcoll_Db_Shared; 99 | -------------------------------------------------------------------------------- /sql/gnatcoll_sql_conf.gpr: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2022-2022, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | abstract project GnatColl_Sql_Conf is 25 | 26 | for Source_Files use (); 27 | 28 | type Build_Type is ("DEBUG", "PROD"); 29 | Build : Build_Type := External ("BUILD", "PROD"); 30 | Gnatcoll_Build_Mode : Build_Type := External ("GNATCOLL_BUILD_MODE", Build); 31 | 32 | type Library_Type_Type is ("relocatable", "static", "static-pic"); 33 | Library_Type : Library_Type_Type := External ("LIBRARY_TYPE", "static"); 34 | 35 | Gnatcoll_Version := External ("GNATCOLL_VERSION", "0.0"); 36 | 37 | -- User settings should come after defaults and take precedence. 38 | Adaflags := External_As_List ("ADAFLAGS", " "); 39 | Cflags := External_As_List ("CFLAGS", " "); 40 | Cppflags := External_As_List ("CPPFLAGS", " "); 41 | 42 | Adaflags_Debug := ("-g", "-O0", "-gnata", "-gnatVa", "-gnatQ", "-gnaty", 43 | "-gnateE", "-gnatwaCJe", "-fstack-check"); 44 | Cflags_Debug := ("-g", "-Wunreachable-code"); 45 | 46 | -- Do not use -gnatwe for production mode 47 | Adaflags_Prod := ("-O2", "-gnatn", "-gnatwaCJ"); 48 | Cflags_Prod := ("-O2", "-Wunreachable-code"); 49 | 50 | Adaflags_Mode := (); 51 | Cflags_Mode := (); 52 | case Gnatcoll_Build_Mode is 53 | when "DEBUG" => 54 | Adaflags_Mode := Adaflags_Debug; 55 | Cflags_Mode := Cflags_Debug; 56 | when "PROD" => 57 | Adaflags_Mode := Adaflags_Prod; 58 | Cflags_Mode := Cflags_Prod; 59 | end case; 60 | 61 | package Compiler is 62 | for Switches ("Ada") use Adaflags_Mode & Adaflags; 63 | for Switches ("C") use Cflags_Mode & Cflags & Cppflags; 64 | end Compiler; 65 | 66 | package Binder is 67 | case Gnatcoll_Build_Mode is 68 | when "DEBUG" => 69 | for Switches ("Ada") use ("-E"); 70 | when "PROD" => 71 | null; 72 | end case; 73 | end Binder; 74 | 75 | package Builder is 76 | case Gnatcoll_Build_Mode is 77 | when "DEBUG" => 78 | for Global_Configuration_Pragmas use "gnat_debug.adc"; 79 | when "PROD" => 80 | null; 81 | end case; 82 | end Builder; 83 | 84 | package Ide is 85 | for VCS_Kind use "Git"; 86 | end Ide; 87 | 88 | -- Some options for the dynamic linker need to come before the 89 | -- objects they affect (for example --as-needed). 90 | Ldflags := External_As_List ("LDFLAGS", " "); 91 | 92 | -- This template is intended for standard projects. 93 | -- Relocatable libraries should use Leading_Library_Options. 94 | package Linker is 95 | for Leading_Switches ("Ada") use Ldflags; 96 | end Linker; 97 | 98 | end GnatColl_Sql_Conf; 99 | -------------------------------------------------------------------------------- /xref/gnatcoll_xref_conf.gpr: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2022-2022, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | abstract project Gnatcoll_Xref_Conf is 25 | 26 | for Source_Files use (); 27 | 28 | type Build_Type is ("DEBUG", "PROD"); 29 | Build : Build_Type := External ("BUILD", "PROD"); 30 | Gnatcoll_Build_Mode : Build_Type := External ("GNATCOLL_BUILD_MODE", Build); 31 | 32 | type Library_Type_Type is ("relocatable", "static", "static-pic"); 33 | Library_Type : Library_Type_Type := External ("LIBRARY_TYPE", "static"); 34 | 35 | Gnatcoll_Version := External ("GNATCOLL_VERSION", "0.0"); 36 | 37 | -- User settings should come after defaults and take precedence. 38 | Adaflags := External_As_List ("ADAFLAGS", " "); 39 | Cflags := External_As_List ("CFLAGS", " "); 40 | Cppflags := External_As_List ("CPPFLAGS", " "); 41 | 42 | Adaflags_Debug := ("-g", "-O0", "-gnata", "-gnatVa", "-gnatQ", "-gnaty", 43 | "-gnateE", "-gnatwaCJe", "-fstack-check"); 44 | Cflags_Debug := ("-g", "-Wunreachable-code"); 45 | 46 | -- Do not use -gnatwe for production mode 47 | Adaflags_Prod := ("-O2", "-gnatn", "-gnatwaCJ"); 48 | Cflags_Prod := ("-O2", "-Wunreachable-code"); 49 | 50 | Adaflags_Mode := (); 51 | Cflags_Mode := (); 52 | case Gnatcoll_Build_Mode is 53 | when "DEBUG" => 54 | Adaflags_Mode := Adaflags_Debug; 55 | Cflags_Mode := Cflags_Debug; 56 | when "PROD" => 57 | Adaflags_Mode := Adaflags_Prod; 58 | Cflags_Mode := Cflags_Prod; 59 | end case; 60 | 61 | package Compiler is 62 | for Switches ("Ada") use Adaflags_Mode & Adaflags; 63 | for Switches ("C") use Cflags_Mode & Cflags & Cppflags; 64 | end Compiler; 65 | 66 | package Binder is 67 | case Gnatcoll_Build_Mode is 68 | when "DEBUG" => 69 | for Switches ("Ada") use ("-E"); 70 | when "PROD" => 71 | null; 72 | end case; 73 | end Binder; 74 | 75 | package Builder is 76 | case Gnatcoll_Build_Mode is 77 | when "DEBUG" => 78 | for Global_Configuration_Pragmas use "gnat_debug.adc"; 79 | when "PROD" => 80 | null; 81 | end case; 82 | end Builder; 83 | 84 | package Ide is 85 | for VCS_Kind use "Git"; 86 | end Ide; 87 | 88 | -- Some options for the dynamic linker need to come before the 89 | -- objects they affect (for example --as-needed). 90 | Ldflags := External_As_List ("LDFLAGS", " "); 91 | 92 | -- This template is intended for standard projects. 93 | -- Relocatable libraries should use Leading_Library_Options. 94 | package Linker is 95 | for Leading_Switches ("Ada") use Ldflags; 96 | end Linker; 97 | 98 | end GnatColl_Xref_Conf; 99 | -------------------------------------------------------------------------------- /sqlite/gnatcoll_sqlite_conf.gpr: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2022-2022, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | abstract project GnatColl_Sqlite_Conf is 25 | 26 | for Source_Files use (); 27 | 28 | type Build_Type is ("DEBUG", "PROD"); 29 | Build : Build_Type := External ("BUILD", "PROD"); 30 | Gnatcoll_Build_Mode : Build_Type := External ("GNATCOLL_BUILD_MODE", Build); 31 | 32 | type Library_Type_Type is ("relocatable", "static", "static-pic"); 33 | Library_Type : Library_Type_Type := External ("LIBRARY_TYPE", "static"); 34 | 35 | Gnatcoll_Version := External ("GNATCOLL_VERSION", "0.0"); 36 | 37 | -- User settings should come after defaults and take precedence. 38 | Adaflags := External_As_List ("ADAFLAGS", " "); 39 | Cflags := External_As_List ("CFLAGS", " "); 40 | Cppflags := External_As_List ("CPPFLAGS", " "); 41 | 42 | Adaflags_Debug := ("-g", "-O0", "-gnata", "-gnatVa", "-gnatQ", "-gnaty", 43 | "-gnateE", "-gnatwaCJe", "-fstack-check"); 44 | Cflags_Debug := ("-g", "-Wunreachable-code"); 45 | 46 | -- Do not use -gnatwe for production mode 47 | Adaflags_Prod := ("-O2", "-gnatn", "-gnatwaCJ"); 48 | Cflags_Prod := ("-O2", "-Wunreachable-code"); 49 | 50 | Adaflags_Mode := (); 51 | Cflags_Mode := (); 52 | case Gnatcoll_Build_Mode is 53 | when "DEBUG" => 54 | Adaflags_Mode := Adaflags_Debug; 55 | Cflags_Mode := Cflags_Debug; 56 | when "PROD" => 57 | Adaflags_Mode := Adaflags_Prod; 58 | Cflags_Mode := Cflags_Prod; 59 | end case; 60 | 61 | package Compiler is 62 | for Switches ("Ada") use Adaflags_Mode & Adaflags; 63 | for Switches ("C") use Cflags_Mode & Cflags & Cppflags; 64 | end Compiler; 65 | 66 | package Binder is 67 | case Gnatcoll_Build_Mode is 68 | when "DEBUG" => 69 | for Switches ("Ada") use ("-E"); 70 | when "PROD" => 71 | null; 72 | end case; 73 | end Binder; 74 | 75 | package Builder is 76 | case Gnatcoll_Build_Mode is 77 | when "DEBUG" => 78 | for Global_Configuration_Pragmas use "gnat_debug.adc"; 79 | when "PROD" => 80 | null; 81 | end case; 82 | end Builder; 83 | 84 | package Ide is 85 | for VCS_Kind use "Git"; 86 | end Ide; 87 | 88 | -- Some options for the dynamic linker need to come before the 89 | -- objects they affect (for example --as-needed). 90 | Ldflags := External_As_List ("LDFLAGS", " "); 91 | 92 | -- This template is intended for standard projects. 93 | -- Relocatable libraries should use Leading_Library_Options. 94 | package Linker is 95 | for Leading_Switches ("Ada") use Ldflags; 96 | end Linker; 97 | 98 | end GnatColl_Sqlite_Conf; 99 | -------------------------------------------------------------------------------- /postgres/gnatcoll_postgres_conf.gpr: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2022-2022, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | abstract project GnatColl_Postgres_Conf is 25 | 26 | for Source_Files use (); 27 | 28 | type Build_Type is ("DEBUG", "PROD"); 29 | Build : Build_Type := External ("BUILD", "PROD"); 30 | Gnatcoll_Build_Mode : Build_Type := External ("GNATCOLL_BUILD_MODE", Build); 31 | 32 | type Library_Type_Type is ("relocatable", "static", "static-pic"); 33 | Library_Type : Library_Type_Type := External ("LIBRARY_TYPE", "static"); 34 | 35 | Gnatcoll_Version := External ("GNATCOLL_VERSION", "0.0"); 36 | 37 | -- User settings should come after defaults and take precedence. 38 | Adaflags := External_As_List ("ADAFLAGS", " "); 39 | Cflags := External_As_List ("CFLAGS", " "); 40 | Cppflags := External_As_List ("CPPFLAGS", " "); 41 | 42 | Adaflags_Debug := ("-g", "-O0", "-gnata", "-gnatVa", "-gnatQ", "-gnaty", 43 | "-gnateE", "-gnatwaCJe", "-fstack-check"); 44 | Cflags_Debug := ("-g", "-Wunreachable-code"); 45 | 46 | -- Do not use -gnatwe for production mode 47 | Adaflags_Prod := ("-O2", "-gnatn", "-gnatwaCJ"); 48 | Cflags_Prod := ("-O2", "-Wunreachable-code"); 49 | 50 | Adaflags_Mode := (); 51 | Cflags_Mode := (); 52 | case Gnatcoll_Build_Mode is 53 | when "DEBUG" => 54 | Adaflags_Mode := Adaflags_Debug; 55 | Cflags_Mode := Cflags_Debug; 56 | when "PROD" => 57 | Adaflags_Mode := Adaflags_Prod; 58 | Cflags_Mode := Cflags_Prod; 59 | end case; 60 | 61 | package Compiler is 62 | for Switches ("Ada") use Adaflags_Mode & Adaflags; 63 | for Switches ("C") use Cflags_Mode & Cflags & Cppflags; 64 | end Compiler; 65 | 66 | package Binder is 67 | case Gnatcoll_Build_Mode is 68 | when "DEBUG" => 69 | for Switches ("Ada") use ("-E"); 70 | when "PROD" => 71 | null; 72 | end case; 73 | end Binder; 74 | 75 | package Builder is 76 | case Gnatcoll_Build_Mode is 77 | when "DEBUG" => 78 | for Global_Configuration_Pragmas use "gnat_debug.adc"; 79 | when "PROD" => 80 | null; 81 | end case; 82 | end Builder; 83 | 84 | package Ide is 85 | for VCS_Kind use "Git"; 86 | end Ide; 87 | 88 | -- Some options for the dynamic linker need to come before the 89 | -- objects they affect (for example --as-needed). 90 | Ldflags := External_As_List ("LDFLAGS", " "); 91 | 92 | -- This template is intended for standard projects. 93 | -- Relocatable libraries should use Leading_Library_Options. 94 | package Linker is 95 | for Leading_Switches ("Ada") use Ldflags; 96 | end Linker; 97 | 98 | end GnatColl_Postgres_Conf; 99 | -------------------------------------------------------------------------------- /testsuite/support/test_assert.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2018, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | with Ada.Text_IO; 25 | 26 | package body Test_Assert is 27 | package IO renames Ada.Text_IO; 28 | 29 | ------------ 30 | -- Assert -- 31 | ------------ 32 | 33 | procedure Assert 34 | (Success : Boolean; 35 | Msg : String := ""; 36 | Location : String := SI.Source_Location) 37 | is 38 | begin 39 | IO.Put (Location & ": "); 40 | if Success then 41 | IO.Put ("PASSED:"); 42 | else 43 | IO.Put ("FAILED:"); 44 | Final_Status := 1; 45 | end if; 46 | if Msg'Length > 0 then 47 | IO.Put (" "); 48 | IO.Put (Msg); 49 | end if; 50 | IO.New_Line; 51 | end Assert; 52 | 53 | ------------ 54 | -- Assert -- 55 | ------------ 56 | 57 | procedure Assert 58 | (Left, Right : String; 59 | Msg : String := ""; 60 | Location : String := SI.Source_Location) 61 | is 62 | Success : constant Boolean := Left = Right; 63 | begin 64 | Assert (Success, Msg, Location); 65 | if not Success then 66 | if Right'Length > 0 then 67 | IO.Put_Line ("expected: " & Right); 68 | else 69 | IO.Put_Line ("expected empty string"); 70 | end if; 71 | 72 | if Left'Length > 0 then 73 | IO.Put_Line ("got: " & Left); 74 | else 75 | IO.Put_Line ("got empty string"); 76 | end if; 77 | end if; 78 | end Assert; 79 | 80 | ------------ 81 | -- Assert -- 82 | ------------ 83 | 84 | procedure Assert 85 | (Left, Right : Integer; 86 | Msg : String := ""; 87 | Location : String := SI.Source_Location) is 88 | begin 89 | Assert (Left'Img, Right'Img, Msg, Location); 90 | end Assert; 91 | 92 | ------------ 93 | -- Assert -- 94 | ------------ 95 | 96 | procedure Assert 97 | (Left, Right : VFS.Virtual_File; 98 | Msg : String := ""; 99 | Location : String := SI.Source_Location) 100 | is 101 | use type VFS.Virtual_File; 102 | Success : constant Boolean := Left = Right; 103 | begin 104 | Assert (Success, Msg, Location); 105 | if not Success then 106 | IO.Put_Line ("expected: " & VFS.Display_Full_Name (Right)); 107 | IO.Put_Line ("got: " & VFS.Display_Full_Name (Left)); 108 | end if; 109 | end Assert; 110 | 111 | ------------ 112 | -- Report -- 113 | ------------ 114 | 115 | function Report return Natural is 116 | begin 117 | if Final_Status = 0 then 118 | IO.Put_Line ("<=== TEST PASSED ===>"); 119 | else 120 | IO.PUT_Line ("<=== TEST FAILED ===>"); 121 | end if; 122 | return Final_Status; 123 | end Report; 124 | 125 | end Test_Assert; 126 | -------------------------------------------------------------------------------- /pgxs/source/pgxs-return_sets.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- PostgreSQL server extension modules binding -- 3 | -- -- 4 | -- Copyright (C) 2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | -- Support to return sets (multiple rows) 24 | 25 | with PGXS.Types; 26 | 27 | package PGXS.Return_Sets is 28 | 29 | function Return_Next_Value 30 | (Args : PGXS.Function_Call_Info; 31 | Context : PGXS.Func_Call_Context; 32 | Value : PGXS.Datum) return PGXS.Datum 33 | with Import, Convention => C, Link_Name => "__ada_SRF_RETURN_NEXT"; 34 | -- Return given value and continue processing 35 | 36 | function Return_Next_Null 37 | (Args : PGXS.Function_Call_Info; 38 | Context : PGXS.Func_Call_Context) return PGXS.Datum 39 | with Import, Convention => C, Link_Name => "__ada_SRF_RETURN_NEXT_NULL"; 40 | -- Return null value and continue processing 41 | 42 | function Return_Done 43 | (Args : PGXS.Function_Call_Info; 44 | Context : PGXS.Func_Call_Context) return PGXS.Datum 45 | with Import, Convention => C, Link_Name => "__ada_SRF_RETURN_DONE"; 46 | -- Return without any value and end processing 47 | 48 | function Get_Call_Counter 49 | (Context : PGXS.Func_Call_Context) return PGXS.Types.UInt_64 50 | with Import, 51 | Convention => C, 52 | Link_Name => "__ada_PG_FuncCallContext_call_cntr"; 53 | -- Call counter of the function in current context 54 | 55 | function Get_Tuple_Descriptor 56 | (Context : PGXS.Func_Call_Context) return PGXS.Tuple_Desc 57 | with Import, 58 | Convention => C, 59 | Link_Name => "__ada_PG_FuncCallContext_get_tuple_desc"; 60 | 61 | procedure Set_Tuple_Descriptor 62 | (Context : PGXS.Func_Call_Context; 63 | To : PGXS.Tuple_Desc) 64 | with Import, 65 | Convention => C, 66 | Link_Name => "__ada_PG_FuncCallContext_set_tuple_desc"; 67 | 68 | generic 69 | type User_Data (<>) is limited private; 70 | type User_Data_Access is access all User_Data; 71 | 72 | with procedure First_Initialize 73 | (Args : PGXS.Function_Call_Info; 74 | Context : PGXS.Func_Call_Context; 75 | Data : out User_Data_Access); 76 | -- Do first time initialization. User data must be allocated with 77 | -- memory pool defined in PGXS.Pools. 78 | 79 | with procedure Step_Initialize 80 | (Args : PGXS.Function_Call_Info; 81 | Context : PGXS.Func_Call_Context; 82 | Data : User_Data_Access) is null; 83 | -- Do each step initialization. 84 | 85 | with function Step 86 | (Args : PGXS.Function_Call_Info; 87 | Context : PGXS.Func_Call_Context; 88 | Data : User_Data_Access) return PGXS.Datum; 89 | -- Return result of current iteration. Implementation should use 90 | -- Return_Nex_Value or Return_Next_Null function to construct next 91 | -- return value or Return_Done to end processing. 92 | 93 | function Generic_Set_Return_Function 94 | (Args : in out PGXS.Function_Call_Info) return PGXS.Datum 95 | with Convention => C; 96 | 97 | end PGXS.Return_Sets; 98 | -------------------------------------------------------------------------------- /testsuite/run-tests: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | from drivers import ( 3 | make_gnatcoll_for_gcov, 4 | TESTSUITE_ROOT_DIR, 5 | COMPONENTS, 6 | COMPONENT_PROPERTIES, 7 | get_components_closure, 8 | ) 9 | from drivers.basic import BasicTestDriver 10 | from drivers.db2ada import DB2AdaTestDriver 11 | from e3.testsuite import Testsuite 12 | from e3.fs import mkdir, find 13 | from e3.os.process import Run 14 | import re 15 | import os 16 | import logging 17 | 18 | 19 | class MyTestsuite(Testsuite): 20 | CROSS_SUPPORT = True 21 | TEST_SUBDIR = "tests" 22 | DRIVERS = {"db2ada": DB2AdaTestDriver, "default": BasicTestDriver} 23 | 24 | def add_options(self): 25 | self.main.argument_parser.add_argument( 26 | "--gcov", 27 | help="compute testsuite coverage of gnatcoll", 28 | default=False, 29 | action="store_true", 30 | ) 31 | self.main.argument_parser.add_argument( 32 | "--components", 33 | help="list of component to test in %s (default: %s)" 34 | % (",".join(COMPONENT_PROPERTIES.keys()), ",".join(COMPONENTS)), 35 | default=",".join(COMPONENTS), 36 | ) 37 | 38 | def tear_up(self): 39 | logging.info("running testsuite for components: %s" % self.main.args.components) 40 | self.env.gcov = self.main.args.gcov 41 | self.env.components = get_components_closure( 42 | self.main.args.components.split(",") 43 | ) 44 | self.env.enable_cleanup = self.main.args.enable_cleanup 45 | if self.main.args.gcov: 46 | work_dir = os.path.join(TESTSUITE_ROOT_DIR, "gcov") 47 | gpr_dir, src_dir, obj_dir = make_gnatcoll_for_gcov( 48 | work_dir, self.env.components 49 | ) 50 | self.env.gnatcoll_gpr_dir = gpr_dir 51 | self.env.gnatcoll_src_dir = src_dir 52 | self.env.gnatcoll_obj_dir = obj_dir 53 | 54 | def tear_down(self): 55 | if self.main.args.gcov: 56 | wd = TESTSUITE_ROOT_DIR 57 | 58 | # We need to call gcov on gcda present both in gnatcoll itself and 59 | # tests (for generics coverage). 60 | gcda_files = find(os.path.join(self.env.gnatcoll_obj_dir), "*.gcda") + find( 61 | os.path.join(self.env.working_dir), "*.gcda" 62 | ) 63 | mkdir(os.path.join(wd, "gcov", "results")) 64 | gcr = os.path.join(wd, "gcov", "results") 65 | Run(["gcov"] + gcda_files, cwd=os.path.join(wd, "gcov", "results")) 66 | total_sources = 0 67 | total_covered = 0 68 | 69 | for source_file in find(self.env.gnatcoll_src_dir, "*.ad[sb]"): 70 | base_file = os.path.basename(source_file) 71 | if not os.path.isfile(os.path.join(gcr, base_file + ".gcov")): 72 | total = 1 73 | covered = 0 74 | with open(source_file) as fd: 75 | total = len( 76 | [ 77 | line 78 | for line in fd 79 | if line.strip() and not re.match(r" *--", line) 80 | ] 81 | ) 82 | else: 83 | with open(os.path.join(gcr, base_file + ".gcov")) as fd: 84 | total = 0 85 | covered = 0 86 | for line in fd: 87 | if re.match(r" *-:", line): 88 | pass 89 | elif re.match(r" *[#=]{5}:", line): 90 | total += 1 91 | else: 92 | total += 1 93 | covered += 1 94 | total_sources += total 95 | total_covered += covered 96 | 97 | logging.info( 98 | "%6.2f %% %8d/%-8d %s", 99 | float(covered) * 100.0 / float(total), 100 | covered, 101 | total, 102 | os.path.basename(source_file), 103 | ) 104 | 105 | logging.info( 106 | "%6.2f %% %8d/%-8d %s", 107 | float(total_covered) * 100.0 / float(total_sources), 108 | total_covered, 109 | total_sources, 110 | "TOTAL", 111 | ) 112 | super(MyTestsuite, self).tear_down() 113 | 114 | @property 115 | def default_driver(self): 116 | return "default" 117 | 118 | 119 | if __name__ == "__main__": 120 | suite = MyTestsuite(os.path.dirname(__file__)) 121 | suite.testsuite_main() 122 | for k, v in suite.test_status_counters.iteritems(): 123 | print("%-24s: %d" % (k, v)) 124 | -------------------------------------------------------------------------------- /sql/gnatcoll-sql-exec-tasking.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2005-2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | -- This package provides additional subprograms to interact with a database 25 | -- in a tasking context. 26 | 27 | package GNATCOLL.SQL.Exec.Tasking is 28 | 29 | function Get_Task_Connection 30 | (Description : Database_Description; 31 | Username : String := "") 32 | return Database_Connection; 33 | -- Return the database connection specific to the current task. A new one 34 | -- is created if none existed yet, and the connection to the database is 35 | -- done automatically. 36 | -- If the thread is not connected yet, a new connection is created through 37 | -- Factory. 38 | -- The newly created connection and Username are then passed to 39 | -- Reset_Connection (see below). 40 | 41 | ---------------------------------------------------------------------------- 42 | -- The database independent cursor implementation. Could be used either -- 43 | -- to provide Direct_Cursor for databases where it is not supported or -- 44 | -- to provide data which could be shared between different tasks. -- 45 | ---------------------------------------------------------------------------- 46 | 47 | function Task_Safe_Instance 48 | (Source : Forward_Cursor'Class; 49 | Index_By : Field_Index'Base := No_Field_Index) return Direct_Cursor; 50 | -- Creates and returns cursor which could be used to clone the copies for 51 | -- different tasks. This routine creates Source cursor data copy into 52 | -- internal structures of the resulting cursor. If the Source cursor 53 | -- already created using this routine, copy is not created but returned the 54 | -- Source cursor. 55 | -- Index_By could be supplied to index the result set by some field for 56 | -- the fast record lookup by the field value. Could be commonly used to 57 | -- lookup the record by the one field primary key. 58 | 59 | function Task_Safe_Instance 60 | (Source : Abstract_Cursor_Access; 61 | Index_By : Field_Index'Base := No_Field_Index) 62 | return Abstract_Cursor_Access; 63 | -- Need to support databases, where direct cursors is not supported. 64 | -- Returns the same pointer if the Source is already the task safe 65 | -- direct cursor. 66 | 67 | function Task_Safe_Clone (Source : Direct_Cursor) return Direct_Cursor; 68 | -- Clone the cursor copy to use in the current task and reset the copy to 69 | -- the first position, 70 | -- Source must be the result of a call to Task_Safe_Instance. 71 | -- The clone have to be made in the task where it will be used. 72 | -- Each task would use the same data, but own cursor pointer to the current 73 | -- record. If the Task_Safe_Clone called from the same task where the 74 | -- Task_Safe_Instance called, the routine returns the same Source cursor 75 | -- reset to the first position to avoid odd copy. 76 | 77 | procedure Find (Self : Abstract_Cursor_Access; Value : String); 78 | -- Search the record with specified field value over the internal cursor 79 | -- index by field defined on Prepare routine call in Index_By parameter. 80 | -- Set cursor position to the found row. If rows is not indexed, the 81 | -- Constraint_Error will be raised. 82 | 83 | end GNATCOLL.SQL.Exec.Tasking; 84 | -------------------------------------------------------------------------------- /pgxs/source/pgxs-composites.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- PostgreSQL server extension modules binding -- 3 | -- -- 4 | -- Copyright (C) 2020-2021, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | -- Subprograms to obtain and to construct values of composite types. 24 | 25 | with Interfaces.C; 26 | 27 | private with PGXS.Pools.Defaults; 28 | with PGXS.Types; 29 | 30 | package PGXS.Composites is 31 | 32 | type Attribute_Count is 33 | new PGXS.Types.Int_16 range 0 .. PGXS.Types.Int_16'Last; 34 | 35 | subtype Attribute_Number is Attribute_Count range 1 .. Attribute_Count'Last; 36 | 37 | type Attributes is private; 38 | 39 | function Allocate 40 | (Descriptor : PGXS.Tuple_Desc; 41 | Size : Attribute_Count) return Attributes; 42 | -- Allocate memory to store given number of values. 43 | 44 | procedure Set_Value 45 | (Self : in out Attributes; 46 | Index : Attribute_Number; 47 | To : PGXS.Datum); 48 | -- Set value of the attribute at givent index to given value. 49 | 50 | procedure Set_Null 51 | (Self : in out Attributes; 52 | Index : Attribute_Number); 53 | -- Set value of the attribute at given index to null. 54 | 55 | function Return_Value 56 | (Args : Function_Call_Info; Item : Attributes) return PGXS.Datum; 57 | -- Creates internal representation of the given set of attributes and 58 | -- converts them to be returned from the user defined function. 59 | 60 | function Get_Attribute_By_Name 61 | (Item : PGXS.Heap_Tuple_Header; 62 | Name : Interfaces.C.char_array; 63 | Is_Null : out PGXS.Types.Bool) return PGXS.Datum 64 | with Import, Convention => C, Link_Name => "GetAttributeByName"; 65 | -- Return value of the attribute by name. Note, C-style nul terminated 66 | -- string should be used as Name. 67 | 68 | function Get_Attribute_By_Number 69 | (Item : PGXS.Heap_Tuple_Header; 70 | Number : Attribute_Number; 71 | Is_Null : out PGXS.Types.Bool) return PGXS.Datum 72 | with Import, Convention => C, Link_Name => "GetAttributeByNum"; 73 | -- Return value of the attribute by number. Attribute numbers start at 1. 74 | 75 | function Bless_Tuple_Desc (Item : PGXS.Tuple_Desc) return PGXS.Tuple_Desc 76 | with Import, Convention => C, Link_Name => "BlessTupleDesc"; 77 | -- Complete tuple descriptor by initially missing information to return 78 | -- values from the user defined extension function. 79 | 80 | function Relation_Name_Get_Tuple_Desc 81 | (Relname : Interfaces.C.char_array) return PGXS.Tuple_Desc 82 | with Import, Convention => C, Link_Name => "RelationNameGetTupleDesc"; 83 | -- Given a (possibly qualified) relation name, build a TupleDesc. 84 | -- Note, C-style nul terminated string should be used as Relname. 85 | 86 | private 87 | 88 | type Datum_Array is array (Attribute_Number range <>) of aliased PGXS.Datum; 89 | 90 | type Bool_Array is 91 | array (Attribute_Number range <>) of aliased PGXS.Types.Bool; 92 | 93 | type Attributes_Arrays (Size : Attribute_Count) is record 94 | Descriptor : PGXS.Tuple_Desc; 95 | Datums : Datum_Array (1 .. Size); 96 | Nulls : Bool_Array (1 .. Size) := (others => Interfaces.C.True); 97 | end record; 98 | 99 | type Attributes is access all Attributes_Arrays 100 | with Storage_Pool => PGXS.Pools.Defaults.Default_Pool; 101 | 102 | end PGXS.Composites; 103 | -------------------------------------------------------------------------------- /sql/gnatcoll-sql-orm.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- G N A T C O L L -- 3 | -- -- 4 | -- Copyright (C) 2020, AdaCore -- 5 | -- -- 6 | -- This library is free software; you can redistribute it and/or modify it -- 7 | -- under terms of the GNU General Public License as published by the Free -- 8 | -- Software Foundation; either version 3, or (at your option) any later -- 9 | -- version. This library is distributed in the hope that it will be useful, -- 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11 | -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12 | -- -- 13 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 14 | -- additional permissions described in the GCC Runtime Library Exception, -- 15 | -- version 3.1, as published by the Free Software Foundation. -- 16 | -- -- 17 | -- You should have received a copy of the GNU General Public License and -- 18 | -- a copy of the GCC Runtime Library Exception along with this program; -- 19 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20 | -- . -- 21 | -- -- 22 | ------------------------------------------------------------------------------ 23 | 24 | package body GNATCOLL.SQL.Orm is 25 | 26 | -------------- 27 | -- Order_By -- 28 | -------------- 29 | 30 | procedure Order_By (Self : in out Manager'Class; By : SQL_Field_List) is 31 | begin 32 | Self.Order_By := By; 33 | end Order_By; 34 | 35 | -------------- 36 | -- Order_By -- 37 | -------------- 38 | 39 | procedure Order_By (Self : in out Manager'Class; By : SQL_Field'Class) is 40 | begin 41 | Self.Order_By := +By; 42 | end Order_By; 43 | 44 | ----------- 45 | -- Limit -- 46 | ----------- 47 | 48 | procedure Limit 49 | (Self : in out Manager'Class; Count : Natural; From : Natural := 0) 50 | is 51 | begin 52 | Self.Limit_Count := Count; 53 | Self.Offset := From; 54 | end Limit; 55 | 56 | -------------- 57 | -- Distinct -- 58 | -------------- 59 | 60 | procedure Distinct (Self : in out Manager'Class) is 61 | begin 62 | Self.Distinct := True; 63 | end Distinct; 64 | 65 | -------------------- 66 | -- Select_Related -- 67 | -------------------- 68 | 69 | procedure Select_Related 70 | (Self : in out Manager'Class; 71 | Depth : Natural; 72 | Follow_Left_Join : Boolean := False) 73 | is 74 | begin 75 | Self.Select_Related := Depth; 76 | Self.Follow_LJ := Follow_Left_Join; 77 | end Select_Related; 78 | 79 | -------------------- 80 | -- Select_Related -- 81 | -------------------- 82 | 83 | function Select_Related (Self : Manager'Class) return Natural is 84 | begin 85 | return Self.Select_Related; 86 | end Select_Related; 87 | 88 | ------------ 89 | -- Filter -- 90 | ------------ 91 | 92 | procedure Filter (Self : in out Manager'Class; Condition : SQL_Criteria) is 93 | begin 94 | Self.Where := Self.Where and Condition; 95 | end Filter; 96 | 97 | ----------- 98 | -- Query -- 99 | ----------- 100 | 101 | procedure Query (Self : Manager'Class; 102 | Query : out SQL_Query; 103 | Fields : SQL_Field_List; 104 | From : SQL_Table_List; 105 | Criteria : SQL_Criteria := No_Criteria) is 106 | begin 107 | Query := SQL_Select 108 | (Fields => Fields, 109 | From => From, 110 | Where => Self.Where and Criteria, 111 | Order_By => Self.Order_By, 112 | Limit => Self.Limit_Count, 113 | Offset => Self.Offset, 114 | Distinct => Self.Distinct); 115 | Auto_Complete (Query); 116 | end Query; 117 | 118 | ---------- 119 | -- Copy -- 120 | ---------- 121 | 122 | procedure Copy (Self : Manager'Class; Into : in out Manager'Class) is 123 | begin 124 | Into.Where := Self.Where; 125 | Into.Order_By := Self.Order_By; 126 | Into.Limit_Count := Self.Limit_Count; 127 | Into.Offset := Self.Offset; 128 | Into.Distinct := Self.Distinct; 129 | Into.Select_Related := Self.Select_Related; 130 | Into.Follow_LJ := Self.Follow_LJ; 131 | end Copy; 132 | 133 | --------------- 134 | -- Follow_LJ -- 135 | --------------- 136 | 137 | function Follow_LJ (Self : Manager'Class) return Boolean is 138 | begin 139 | return Self.Follow_LJ; 140 | end Follow_LJ; 141 | 142 | end GNATCOLL.SQL.Orm; 143 | --------------------------------------------------------------------------------