pax_global_header00006660000000000000000000000064117210251060014505gustar00rootroot0000000000000052 comment=cd9bf227db643db6da70236b9dc8be604af18756 apq-postgresql-3.2.0/000077500000000000000000000000001172102510600144715ustar00rootroot00000000000000apq-postgresql-3.2.0/COPYING000066400000000000000000000020411172102510600155210ustar00rootroot00000000000000This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. As a special exception, if other files instantiate generics from this unit, or you link this unit with other files to produce an executable, this unit does not by itself cause the resulting executable to be covered by the GNU General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Public License. apq-postgresql-3.2.0/GPL000066400000000000000000000431311172102510600150400ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. apq-postgresql-3.2.0/INSTALL000066400000000000000000000002771172102510600155300ustar00rootroot00000000000000This is a simple installation instructions file. The installation is the all-known basic ./configure && make all install Please read the configure file for more information on options ' apq-postgresql-3.2.0/Makefile000066400000000000000000000005721172102510600161350ustar00rootroot00000000000000# Makefile for the KOW Generic Library Framework # # @author Marcelo Coraça de Freitas # # # Please, read Makefile.include for more information all: ./scripts/build.sh install: ./scripts/install.sh uninstall: ./scripts/uninstall.sh clean: ./scripts/clean.sh rm -f src/apq-postgresql.ads distclean: @-${MAKE} clean @-${MAKE} -C samples clean apq-postgresql-3.2.0/PG_COPYRIGHT000066400000000000000000000022561172102510600163570ustar00rootroot00000000000000PostgreSQL Database Management System (formerly known as Postgres, then as Postgres95) Portions Copyright (c) 1996-2001, The PostgreSQL Global Development Group Portions Copyright (c) 1994, The Regents of the University of California Permission to use, copy, modify, and distribute this software and its documentation for any purpose, without fee, and without a written agreement is hereby granted, provided that the above copyright notice and this paragraph and the following two paragraphs appear in all copies. IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, INCLUDING LOST PROFITS, ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATIONS TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. apq-postgresql-3.2.0/TODO.txt000066400000000000000000000003471172102510600160030ustar00rootroot0000000000000022jul2010 19h00 GMT-3 Daniel Norte de Moraes I'll document , with examples, the new options and a guide to use apq-postgresl with ssl, included the use of more que one certificates/servers/keys in a same program !! Enjoy!! :-) apq-postgresql-3.2.0/configure000077500000000000000000000056471172102510600164140ustar00rootroot00000000000000#!/usr/bin/env bash # Main configuration file for KOW framework projects # # @author Marcelo C. de Freitas source scripts/buildutil.sh ################### # Default Options # ################### enable_debug="false"; enable_static="true"; enable_relocatable="true"; include_files=src/* work_path="$PWD/work" prefix=$(dirname `which gnatls`) prefix=$(dirname $prefix) version=$(cat version) processors=2 GPRBUILD="gprbuild" if [[ $OS -eq "" ]] then OS="GNU/Linux" fi ########################### # Command Line Parameters # ########################### # Setup build environment for i in $@ do option=`echo $i | cut -d= -f1` value=`echo $i | cut -d= -f2` case $option in --prefix ) prefix="$value";; --enable-debug ) enable_debug="true";; --disable-static ) enable_static="false";; --disable-relocatable ) enable_relocatable="false";; --os ) OS="$value";; --work-path ) work_path="$value";; --gprbuild ) GPRBUILD="$value";; --gprbuild-params ) gprbuild_params="$value";; --processors ) processors=$value;; esac done ######################### # Initial configuration # ######################### check_in_path gprbuild check_in_path gnatprep init_configuration init_gnatprep ########################### # Run local configuration # ########################### if [[ -x configure.local ]] then source configure.local fi ####################### # Include Files Setup # ####################### echo "Copying source files" source_destination="$work_path/src/$project" mkdir -p $source_destination for i in $include_files do cpu "$i" $source_destination done ############# # GPR Files # ############# echo "Copying standard project files" gpr_destination="$work_path/lib/gnat" mkdir -p "$gpr_destination" for i in gnat/*.gpr do if [[ -f $i ]] then cpu $i $gpr_destination fi done echo "Preparing def file.." set_gnatprep version $version set_gnatprep prefix "$prefix" set_gnatprep project "$project" for i in gnat/*.gpr.in do if [[ -f $i ]] then fname=$(basename "$i" .in) destination="$gpr_destination/$fname" gnatprep "$i" "$destination" gnatprep.def fi done ####################################### # Store the usual configuration flags # ####################################### set_configuration prefix "$prefix" set_configuration enable_debug $enable_debug set_configuration enable_static $enable_static set_configuration enable_relocatable $enable_relocatable set_configuration OS "$OS" set_configuration include_files "$include_files" set_configuration version "$version" set_configuration work_path "$work_path" set_configuration GPRBUILD "$GPRBUILD" set_configuration gprbuild_params "$gprbuild_params" set_configuration processors $processors set_configuration project "$project" echo echo "################################################" echo "# This is the build environment you did setup: #" echo "################################################" cat_configuration apq-postgresql-3.2.0/configure.local000077500000000000000000000033551172102510600174770ustar00rootroot00000000000000#!/usr/bin/env bash # # Local configuration file for APQ.PostgreSQL ################ # Project Name # ################ project="apq-postgresql" ################### # Standard Checks # ################### check_project apq check_in_path sed check_in_path grep ######################################## # PostgreSQL Compiler and Linker Flags # ######################################## if [[ "$OS" = "Windows_NT" ]] then if [[ "${POSTGRESQL_PATH}" = "" ]] then echo "Please set the POSTGRESQL_PATH environment variable pointing to your MySQL installment"; exit -1; fi POSTGRESQL_CFLAGS=-I "${POSTGRESQL_PATH}\include" -I./ -D_WINDOWS -D__LCC__ POSTGRESQL_LIBS="-L${POSTGRESQL_PATH}\lib -lpq" POSTGRESQL_INCLUDE_PATH="${POSTGRESQL_PATH}\include" else check_in_path pg_config POSTGRESQL_CFLAGS=`pg_config --cflags` POSTGRESQL_LIBDIR=`pg_config --libdir` POSTGRESQL_LIBS="-L${POSTGRESQL_LIBDIR} -lpq" POSTGRESQL_INCLUDE_PATH=`pg_config --includedir` fi ################################# # apq-postgresql.ads Generation # ################################# get_linker_options(){ for i in $POSTGRESQL_LIBS do echo " pragma Linker_Options( \"$i\" );"; done; } if [[ -f src/apq-postgresql.ads ]] then echo "apq-postgresql.ads exists"; else echo "Generating src/apq-postgresql.ads"; cp "src-in/apq-postgresql.ads.in" "src/apq-postgresql.ads"; linker_options=`get_linker_options` echo "$linker_options" replace_in_file src/apq-postgresql.ads "%POSTGRESQL_LIBS%" "$linker_options" fi mkdir -p gnat GPR="gnat/apq-postgresql.gpr.in"; cp "src-in/apq-postgresql.gpr.in" $GPR list=`sedfy_gpr_list "$POSTGRESQL_CFLAGS"` replace_in_file "$GPR" "%POSTGRESQL_CFLAGS%" "$list" set_configuration APQPOSTGRESQL_EXTERNALLY_BUILT "false" apq-postgresql-3.2.0/gnat/000077500000000000000000000000001172102510600154225ustar00rootroot00000000000000apq-postgresql-3.2.0/gnat/apq-postgresql.gpr.in000066400000000000000000000035141172102510600215260ustar00rootroot00000000000000-- Build file for KOW_Lib. -- -- author Marcelo Coraça de Freitas -- -- Repository information: -- $Date$ -- $Revision$ -- $Author$ with "apq"; project APQ.PostgreSQL is ----------------------- -- Type declarations -- ----------------------- type True_False is ( "true", "false" ); type Supported_OS is ("Windows_NT", "GNU/Linux", "Darwin" ); -------------------- -- Main Variables -- -------------------- version := $version; OS : Supported_OS := external( "OS", "GNU/Linux" ); Debug : True_False := external( "DEBUG", "false" ); ---------------- -- Parameters -- ---------------- for Library_Name use $project; for Languages use ( "Ada", "C" ); for Source_Dirs use ( "../../src/" & Project'Library_Name & "/" ); for Library_kind use external( "LIBRARY_KIND", "static" ); case Debug is when "true" => for Library_Dir use "../" & Project'Library_Name & "-debug/" & Project'Library_Kind; when "false" => for Library_Dir use "../" & Project'Library_name & "/" & Project'Library_Kind; end case; for Object_Dir use Project'Library_Dir & "/objects/"; for Library_Version use "lib" & Project'Library_Name & ".so." & Version; for Externally_Built use External( "APQPOSTGRESQL_EXTERNALLY_BUILT", "true" ); ---------------------- -- Compiler Package -- ---------------------- package Compiler is for Default_Switches ( "Ada" ) use ( "-O2", "-gnat05", "-fPIC" ); for Default_Switches ( "C" ) use ( "-O2","-pipe","-fno-strict-aliasing","-Wall","-Wmissing-prototypes","-Wpointer-arith","-Winline","-Wdeclaration-after-statement","-Wendif-labels","-fno-strict-aliasing","-fwrapv" , "-O2", "-fPIC" ); case Debug is when "true" => for Default_Switches ("ada") use Compiler'Default_Switches("Ada") & ( "-g" ); when "false" => end case; end Compiler; end APQ.PostgreSQL; apq-postgresql-3.2.0/gnat/apq-postgresql.gpr.in-e000066400000000000000000000032541172102510600217510ustar00rootroot00000000000000-- Build file for KOW_Lib. -- -- author Marcelo Coraça de Freitas -- -- Repository information: -- $Date$ -- $Revision$ -- $Author$ with "apq"; project APQ.PostgreSQL is ----------------------- -- Type declarations -- ----------------------- type True_False is ( "true", "false" ); type Supported_OS is ("Windows_NT", "GNU/Linux", "Darwin" ); -------------------- -- Main Variables -- -------------------- version := $version; OS : Supported_OS := external( "OS", "GNU/Linux" ); Debug : True_False := external( "DEBUG", "false" ); ---------------- -- Parameters -- ---------------- for Library_Name use $project; for Languages use ( "Ada", "C" ); for Source_Dirs use ( "../../src/" & Project'Library_Name & "/" ); for Library_kind use external( "LIBRARY_KIND", "static" ); case Debug is when "true" => for Library_Dir use "../" & Project'Library_Name & "-debug/" & Project'Library_Kind; when "false" => for Library_Dir use "../" & Project'Library_name & "/" & Project'Library_Kind; end case; for Object_Dir use Project'Library_Dir & "/objects/"; for Library_Version use "lib" & Project'Library_Name & ".so." & Version; for Externally_Built use External( "APQPOSTGRESQL_EXTERNALLY_BUILT", "true" ); ---------------------- -- Compiler Package -- ---------------------- package Compiler is for Default_Switches ( "Ada" ) use ( "-O2", "-gnat05", "-fPIC" ); for Default_Switches ( "C" ) use ( %POSTGRESQL_CFLAGS%, "-O2", "-fPIC" ); case Debug is when "true" => for Default_Switches ("ada") use Compiler'Default_Switches("Ada") & ( "-g" ); when "false" => end case; end Compiler; end APQ.PostgreSQL; apq-postgresql-3.2.0/samples/000077500000000000000000000000001172102510600161355ustar00rootroot00000000000000apq-postgresql-3.2.0/samples/COPYING000066400000000000000000000020411172102510600171650ustar00rootroot00000000000000This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. As a special exception, if other files instantiate generics from this unit, or you link this unit with other files to produce an executable, this unit does not by itself cause the resulting executable to be covered by the GNU General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Public License. apq-postgresql-3.2.0/samples/GPL000066400000000000000000000431311172102510600165040ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. apq-postgresql-3.2.0/samples/Makefile000066400000000000000000000005331172102510600175760ustar00rootroot00000000000000# Makefile for the KOW Generic Library Framework # # @author Marcelo Coraça de Freitas # # # Please, read Makefile.include for more information all: ./scripts/build.sh install: ./scripts/install.sh uninstall: ./scripts/uninstall.sh clean: ./scripts/clean.sh distclean: @-${MAKE} clean @-${MAKE} -C samples clean apq-postgresql-3.2.0/samples/configure000077500000000000000000000056471172102510600200600ustar00rootroot00000000000000#!/usr/bin/env bash # Main configuration file for KOW framework projects # # @author Marcelo C. de Freitas source scripts/buildutil.sh ################### # Default Options # ################### enable_debug="false"; enable_static="true"; enable_relocatable="true"; include_files=src/* work_path="$PWD/work" prefix=$(dirname `which gnatls`) prefix=$(dirname $prefix) version=$(cat version) processors=2 GPRBUILD="gprbuild" if [[ $OS -eq "" ]] then OS="GNU/Linux" fi ########################### # Command Line Parameters # ########################### # Setup build environment for i in $@ do option=`echo $i | cut -d= -f1` value=`echo $i | cut -d= -f2` case $option in --prefix ) prefix="$value";; --enable-debug ) enable_debug="true";; --disable-static ) enable_static="false";; --disable-relocatable ) enable_relocatable="false";; --os ) OS="$value";; --work-path ) work_path="$value";; --gprbuild ) GPRBUILD="$value";; --gprbuild-params ) gprbuild_params="$value";; --processors ) processors=$value;; esac done ######################### # Initial configuration # ######################### check_in_path gprbuild check_in_path gnatprep init_configuration init_gnatprep ########################### # Run local configuration # ########################### if [[ -x configure.local ]] then source configure.local fi ####################### # Include Files Setup # ####################### echo "Copying source files" source_destination="$work_path/src/$project" mkdir -p $source_destination for i in $include_files do cpu "$i" $source_destination done ############# # GPR Files # ############# echo "Copying standard project files" gpr_destination="$work_path/lib/gnat" mkdir -p "$gpr_destination" for i in gnat/*.gpr do if [[ -f $i ]] then cpu $i $gpr_destination fi done echo "Preparing def file.." set_gnatprep version $version set_gnatprep prefix "$prefix" set_gnatprep project "$project" for i in gnat/*.gpr.in do if [[ -f $i ]] then fname=$(basename "$i" .in) destination="$gpr_destination/$fname" gnatprep "$i" "$destination" gnatprep.def fi done ####################################### # Store the usual configuration flags # ####################################### set_configuration prefix "$prefix" set_configuration enable_debug $enable_debug set_configuration enable_static $enable_static set_configuration enable_relocatable $enable_relocatable set_configuration OS "$OS" set_configuration include_files "$include_files" set_configuration version "$version" set_configuration work_path "$work_path" set_configuration GPRBUILD "$GPRBUILD" set_configuration gprbuild_params "$gprbuild_params" set_configuration processors $processors set_configuration project "$project" echo echo "################################################" echo "# This is the build environment you did setup: #" echo "################################################" cat_configuration apq-postgresql-3.2.0/samples/configure.local000077500000000000000000000004541172102510600211400ustar00rootroot00000000000000#!/usr/bin/env bash # # Local configuration file for APQ.PostgreSQL ################ # Project Name # ################ project="apq-postgresql-examples" ################### # Standard Checks # ################### check_project apq check_project apq-postgresql check_project apq-samples apq-postgresql-3.2.0/samples/gnat/000077500000000000000000000000001172102510600170665ustar00rootroot00000000000000apq-postgresql-3.2.0/samples/gnat/apq-postgresql-examples.gpr.in000066400000000000000000000025341172102510600250070ustar00rootroot00000000000000-- Build file for KOW_Lib. -- -- author Marcelo Coraça de Freitas -- -- Repository information: -- $Date$ -- $Revision$ -- $Author$ with "apq"; with "apq-postgresql"; with "apq-samples"; project APQ.PostgreSQL.Examples is ----------------------- -- Type declarations -- ----------------------- type True_False is ( "true", "false" ); type Supported_OS is ("Windows_NT", "GNU/Linux", "Darwin" ); -------------------- -- Main Variables -- -------------------- version := $version; OS : Supported_OS := external( "OS", "GNU/Linux" ); Debug : True_False := external( "DEBUG", "false" ); ---------------- -- Parameters -- ---------------- for Languages use ( "Ada" ); for Main use ( "add_user", "list_users" ); for Source_Dirs use ( "../../src/" & $project ); for Library_kind use external( "LIBRARY_KIND", "static" ); case Debug is when "true" => for Exec_Dir use "../../bin/debug/"; when "false" => for Exec_Dir use "../../bin/"; end case; ---------------------- -- Compiler Package -- ---------------------- package Compiler is for Default_Switches ( "Ada" ) use ( "-O2", "-gnat05", "-fPIC" ); case Debug is when "true" => for Default_Switches ("ada") use Compiler'Default_Switches("Ada") & ( "-g" ); when "false" => end case; end Compiler; end APQ.PostgreSQL.Examples; apq-postgresql-3.2.0/samples/scripts/000077500000000000000000000000001172102510600176245ustar00rootroot00000000000000apq-postgresql-3.2.0/samples/scripts/build.sh000077500000000000000000000011711172102510600212620ustar00rootroot00000000000000#!/usr/bin/env bash # # Builder for the KOW Framework project # # All it actually does is to call gprbuild several times ################## # Initialization # ################## source scripts/buildutil.sh load_configuration echo $KOWLIB_EXTERNALLY_BUILT if [[ "$enable_debug" = "true" ]] then echo "############################"; echo "# Building Debug Libraries #"; echo "############################"; export DEBUG="true"; build_libraries; fi echo "##############################"; echo "# Building Regular Libraries #"; echo "##############################"; export DEBUG="false"; build_libraries; gen_filelist; apq-postgresql-3.2.0/samples/scripts/buildutil.sh000077500000000000000000000132701172102510600221630ustar00rootroot00000000000000#!/usr/bin/env bash # # Auxiliary functions for the KOW Framework main build system # # @author Marcelo C. de Freitas ###################### # Environment Checks # ###################### # Check if a given command is in path; # usage: # check_in_path COMMAND_NAME check_in_path(){ echo -n "Looking for $1 ... " hash $1 2>&- || { echo "[false]"; echo >&2 "I need $1 in path but I can't find it... aborting"; exit 1; } && echo "[ok]" } # Check if a project file is available # usage: # check_project projectname check_project(){ proj=$1; echo -n "Looking for project $proj ... " ${GPRBUILD} -ws -P$proj 2>&- || { echo "[false]"; echo "${GPRBUILD} can't find $proj in ADA_PROJECT_PATH"; exit -1;} && echo "[ok]"; } # Copy updating a regular file or directory # usage: # cpu origin destination cpu(){ origin="$1" fname=$(basename "$1") destination="$2/$fname" if [[ -f "$origin" ]] then if [[ "$origin" -nt "$destination" ]] then cp "$origin" "$destination" else echo "Skipping \"$origin\"" >> configure.log fi else echo "Can't copy (not a regular file): \"$origin\"" >&2 exit 1; fi } ############################ # Configuration Management # ############################ # reset the configuration file init_configuration(){ echo -n "" > .configuration } # Set a configuration key/value: # usage: # setconfiguration key value set_configuration() { echo export $1=\"$2\" >> .configuration } # Printout the configuration file # usage: # cat_configuration cat_configuration(){ cat .configuration } # load the configuration file: # usage: # load_configuration load_configuration(){ if [[ -f .configuration ]] then source .configuration else echo "Please run configure first" >&2; exit 1; fi } ################### # Data Processing # ################### # iterate for printing a list of declarations, used internally by print_enum_declaration and print_for_declaration # usage: # iterate_enum_list "the list of values" echo_function_name # # The list of values should respect the format: # number name # number name # number name # number name # # and eatch line is trimmed before calling the given function iterate_enum_list(){ local is_first=1; echo "$1" | while read a do if [[ "$a" = "" ]] then echo -n #skip empty lines else if [[ $is_first -eq 1 ]] then is_first=0; else echo ','; fi; echo -n " "; $2 $a fi done echo; } _enum_declaration(){ echo -n $2; } # For each entry print as expected for the enum declaration type echo_enum_declaration(){ iterate_enum_list "$1" _enum_declaration } _for_declaration(){ echo -n "$2 => $1"; } echo_for_declaration(){ iterate_enum_list "$1" _for_declaration } # Will set a enum value using the same list as the one used in iterate_enum_list # in the given file (edit the given file). # usage: # set_enum_values FILE LIST_OF_VALUES PREFIX # # This will replace: # %${PREFIX}_DECLARATION% with the result of echo_enum_declaration # %${PREFIX}_FOR% with the result of echo_for_declaration # set_enum_values(){ local outfile="$1" local values="$2" local prefix="$3" declaration_values=`echo_enum_declaration "$values"` for_values=`echo_for_declaration "$values"` replace_in_file "$outfile" "%${prefix}_DECLARATION%" "$declaration_values" replace_in_file "$outfile" "%${prefix}_FOR%" "$for_values" echo "[ok]" } # Simple str_replace in a file # usage # replace_in_file FILENAME FROM TO replace_in_file(){ filename="$1" from="$2" to=$(echo "$3" | sed -e 's/$/\\&/' | sed -e 's/\//\\&/g' ); sed -i -e "s/$from/$to /" "$filename" } ################################ # Gnatprep def file management # ################################ # see the documentation for configuration files; basically the same thing init_gnatprep() { echo -n "" > gnatprep.def } set_gnatprep(){ echo $1:=\"$2\" >> gnatprep.def } # transform a list of parameters in a format both sed and gprbuild will understand... # the output of this function is meant to be used by replace_in_file, which processes / and new lines sedfy_gpr_list(){ is_first=1 for option in $1 do if [[ $is_first -eq 1 ]] then is_first=0; else echo -n "," fi #option=`echo $i | sed 's/\//\\\&/g'` echo -n \\\"$option\\\" done } ############ # Building # ############ build_libraries(){ if [[ "$enable_static" = "true" ]] then build_library static fi if [[ "$enable_relocatable" = "true" ]] then build_library relocatable fi } build_library(){ kind=$1; echo "Building $kind library"; export LIBRARY_KIND=$kind $GPRBUILD -P$work_path/lib/gnat/$project.gpr -d -q -j$processors --create-missing-dirs $gprbuild_params } ############# # File list # ############# gen_filelist(){ list="$PWD/files.list" cd "$work_path" && find * > "$list" } cat_filelist(){ if [[ -f files.list ]] then cat files.list else echo "Please remember to build $project first" >&2; fi; } # iterate over the list of files... # usage: # iterate_filelist thecommandtobexecuted iterate_filelist(){ cat_filelist | while read a; do $1 "$a";done } # Reverse iterate in the sense of listing first files than directories.. reverse_iterate_filelist(){ cat_filelist | sort -nr | while read a; do $1 "$a";done } ########### # Install # ########### install_item(){ if [[ -d "$work_path"/"$1" ]] then install_directory "$1"; else install_file "$1"; fi } install_directory(){ install -d "$prefix/$1"; } install_file(){ install "$work_path/$1" "$prefix/$1" } ############# # Uninstall # ############# uninstall_item(){ if [[ -d "$work_path"/"$1" ]] then uninstall_directory "$1"; else uninstall_file "$1"; fi } uninstall_directory(){ rmdir "$prefix/$1" || echo skipping "$prefix/$1" } uninstall_file(){ rm "$prefix/$1" } apq-postgresql-3.2.0/samples/scripts/clean.sh000077500000000000000000000002571172102510600212510ustar00rootroot00000000000000#!/usr/bin/env bash source scripts/buildutil.sh load_configuration rm -rf "$work_path" rm -rf "$object_path" rm -f gnatprep.def rm -f .configuration rm -f configure.log apq-postgresql-3.2.0/samples/scripts/install.sh000077500000000000000000000004241172102510600216310ustar00rootroot00000000000000#!/usr/bin/env bash # Installer for KOW Framework applications # # @author Marcelo C. de Freitas # # All this script does is to recursivelly install everything from $work_path inside $prefix source scripts/buildutil.sh load_configuration iterate_filelist install_item apq-postgresql-3.2.0/samples/scripts/uninstall.sh000077500000000000000000000004551172102510600222000ustar00rootroot00000000000000#!/usr/bin/env bash # Installer for KOW Framework applications # # @author Marcelo C. de Freitas # # All this script does is to recursivelly install everything from $work_path inside $prefix source scripts/buildutil.sh load_configuration reverse_iterate_filelist uninstall_item rmdir $prefix apq-postgresql-3.2.0/samples/sql/000077500000000000000000000000001172102510600167345ustar00rootroot00000000000000apq-postgresql-3.2.0/samples/sql/create_table.sql000066400000000000000000000000731172102510600220670ustar00rootroot00000000000000 CREATE TABLE USERS ( name varchar(50), birth date ); apq-postgresql-3.2.0/samples/src/000077500000000000000000000000001172102510600167245ustar00rootroot00000000000000apq-postgresql-3.2.0/samples/src/add_user.adb000066400000000000000000000054231172102510600211660ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- APQ DATABASE BINDINGS -- -- -- -- A P Q -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Warren W. Gay VE3WWG -- -- Copyright (C) 2007-2009, Ada Works Project -- -- -- -- -- -- APQ is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. APQ is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with APQ; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ------------------------------------------------------------------------------ with Ada.Calendar; with APQ; use APQ; with APQ.PostgreSQL.Client; use APQ.PostgreSQL.Client; with APQ.Samples; use APQ.Samples; procedure add_user is C: Connection_Type; begin -- Set_Host_Name( C, "localhost" ); -- Set_User_Password( C, "postgres", "senhapg" ); Set_DB_Name( C, "apq_test" ); Connect( C ); Insert_Value( C, "John Doe", Ada.Calendar.Clock ); end add_user; apq-postgresql-3.2.0/samples/src/list_users.adb000066400000000000000000000054511172102510600215750ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- APQ DATABASE BINDINGS -- -- -- -- A P Q -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Warren W. Gay VE3WWG -- -- Copyright (C) 2007-2009, Ada Works Project -- -- -- -- -- -- APQ is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. APQ is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with APQ; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ------------------------------------------------------------------------------ with Ada.Calendar; with APQ; use APQ; with APQ.PostgreSQL.Client; use APQ.PostgreSQL.Client; with APQ.Samples; use APQ.Samples; procedure list_users is C: Connection_Type; begin -- Set_Host_Name( C, "localhost" ); -- Set_User_Password( C, "postgres", "senhapg" ); Set_DB_Name( C, "apq_test" ); Connect( C ); Query_Results( C ); end list_users; apq-postgresql-3.2.0/scripts/000077500000000000000000000000001172102510600161605ustar00rootroot00000000000000apq-postgresql-3.2.0/scripts/build.sh000077500000000000000000000011711172102510600176160ustar00rootroot00000000000000#!/usr/bin/env bash # # Builder for the KOW Framework project # # All it actually does is to call gprbuild several times ################## # Initialization # ################## source scripts/buildutil.sh load_configuration echo $KOWLIB_EXTERNALLY_BUILT if [[ "$enable_debug" = "true" ]] then echo "############################"; echo "# Building Debug Libraries #"; echo "############################"; export DEBUG="true"; build_libraries; fi echo "##############################"; echo "# Building Regular Libraries #"; echo "##############################"; export DEBUG="false"; build_libraries; gen_filelist; apq-postgresql-3.2.0/scripts/buildutil.sh000077500000000000000000000132701172102510600205170ustar00rootroot00000000000000#!/usr/bin/env bash # # Auxiliary functions for the KOW Framework main build system # # @author Marcelo C. de Freitas ###################### # Environment Checks # ###################### # Check if a given command is in path; # usage: # check_in_path COMMAND_NAME check_in_path(){ echo -n "Looking for $1 ... " hash $1 2>&- || { echo "[false]"; echo >&2 "I need $1 in path but I can't find it... aborting"; exit 1; } && echo "[ok]" } # Check if a project file is available # usage: # check_project projectname check_project(){ proj=$1; echo -n "Looking for project $proj ... " ${GPRBUILD} -ws -P$proj 2>&- || { echo "[false]"; echo "${GPRBUILD} can't find $proj in ADA_PROJECT_PATH"; exit -1;} && echo "[ok]"; } # Copy updating a regular file or directory # usage: # cpu origin destination cpu(){ origin="$1" fname=$(basename "$1") destination="$2/$fname" if [[ -f "$origin" ]] then if [[ "$origin" -nt "$destination" ]] then cp "$origin" "$destination" else echo "Skipping \"$origin\"" >> configure.log fi else echo "Can't copy (not a regular file): \"$origin\"" >&2 exit 1; fi } ############################ # Configuration Management # ############################ # reset the configuration file init_configuration(){ echo -n "" > .configuration } # Set a configuration key/value: # usage: # setconfiguration key value set_configuration() { echo export $1=\"$2\" >> .configuration } # Printout the configuration file # usage: # cat_configuration cat_configuration(){ cat .configuration } # load the configuration file: # usage: # load_configuration load_configuration(){ if [[ -f .configuration ]] then source .configuration else echo "Please run configure first" >&2; exit 1; fi } ################### # Data Processing # ################### # iterate for printing a list of declarations, used internally by print_enum_declaration and print_for_declaration # usage: # iterate_enum_list "the list of values" echo_function_name # # The list of values should respect the format: # number name # number name # number name # number name # # and eatch line is trimmed before calling the given function iterate_enum_list(){ local is_first=1; echo "$1" | while read a do if [[ "$a" = "" ]] then echo -n #skip empty lines else if [[ $is_first -eq 1 ]] then is_first=0; else echo ','; fi; echo -n " "; $2 $a fi done echo; } _enum_declaration(){ echo -n $2; } # For each entry print as expected for the enum declaration type echo_enum_declaration(){ iterate_enum_list "$1" _enum_declaration } _for_declaration(){ echo -n "$2 => $1"; } echo_for_declaration(){ iterate_enum_list "$1" _for_declaration } # Will set a enum value using the same list as the one used in iterate_enum_list # in the given file (edit the given file). # usage: # set_enum_values FILE LIST_OF_VALUES PREFIX # # This will replace: # %${PREFIX}_DECLARATION% with the result of echo_enum_declaration # %${PREFIX}_FOR% with the result of echo_for_declaration # set_enum_values(){ local outfile="$1" local values="$2" local prefix="$3" declaration_values=`echo_enum_declaration "$values"` for_values=`echo_for_declaration "$values"` replace_in_file "$outfile" "%${prefix}_DECLARATION%" "$declaration_values" replace_in_file "$outfile" "%${prefix}_FOR%" "$for_values" echo "[ok]" } # Simple str_replace in a file # usage # replace_in_file FILENAME FROM TO replace_in_file(){ filename="$1" from="$2" to=$(echo "$3" | sed -e 's/$/\\&/' | sed -e 's/\//\\&/g' ); sed -i -e "s/$from/$to /" "$filename" } ################################ # Gnatprep def file management # ################################ # see the documentation for configuration files; basically the same thing init_gnatprep() { echo -n "" > gnatprep.def } set_gnatprep(){ echo $1:=\"$2\" >> gnatprep.def } # transform a list of parameters in a format both sed and gprbuild will understand... # the output of this function is meant to be used by replace_in_file, which processes / and new lines sedfy_gpr_list(){ is_first=1 for option in $1 do if [[ $is_first -eq 1 ]] then is_first=0; else echo -n "," fi #option=`echo $i | sed 's/\//\\\&/g'` echo -n \\\"$option\\\" done } ############ # Building # ############ build_libraries(){ if [[ "$enable_static" = "true" ]] then build_library static fi if [[ "$enable_relocatable" = "true" ]] then build_library relocatable fi } build_library(){ kind=$1; echo "Building $kind library"; export LIBRARY_KIND=$kind $GPRBUILD -P$work_path/lib/gnat/$project.gpr -d -q -j$processors --create-missing-dirs $gprbuild_params } ############# # File list # ############# gen_filelist(){ list="$PWD/files.list" cd "$work_path" && find * > "$list" } cat_filelist(){ if [[ -f files.list ]] then cat files.list else echo "Please remember to build $project first" >&2; fi; } # iterate over the list of files... # usage: # iterate_filelist thecommandtobexecuted iterate_filelist(){ cat_filelist | while read a; do $1 "$a";done } # Reverse iterate in the sense of listing first files than directories.. reverse_iterate_filelist(){ cat_filelist | sort -nr | while read a; do $1 "$a";done } ########### # Install # ########### install_item(){ if [[ -d "$work_path"/"$1" ]] then install_directory "$1"; else install_file "$1"; fi } install_directory(){ install -d "$prefix/$1"; } install_file(){ install "$work_path/$1" "$prefix/$1" } ############# # Uninstall # ############# uninstall_item(){ if [[ -d "$work_path"/"$1" ]] then uninstall_directory "$1"; else uninstall_file "$1"; fi } uninstall_directory(){ rmdir "$prefix/$1" || echo skipping "$prefix/$1" } uninstall_file(){ rm "$prefix/$1" } apq-postgresql-3.2.0/scripts/clean.sh000077500000000000000000000003001172102510600175720ustar00rootroot00000000000000#!/usr/bin/env bash source scripts/buildutil.sh load_configuration rm -rf "$work_path" rm -rf "$object_path" rm -f gnatprep.def rm -f .configuration rm -f configure.log rm -f files.list apq-postgresql-3.2.0/scripts/install.sh000077500000000000000000000004241172102510600201650ustar00rootroot00000000000000#!/usr/bin/env bash # Installer for KOW Framework applications # # @author Marcelo C. de Freitas # # All this script does is to recursivelly install everything from $work_path inside $prefix source scripts/buildutil.sh load_configuration iterate_filelist install_item apq-postgresql-3.2.0/scripts/uninstall.sh000077500000000000000000000004551172102510600205340ustar00rootroot00000000000000#!/usr/bin/env bash # Installer for KOW Framework applications # # @author Marcelo C. de Freitas # # All this script does is to recursivelly install everything from $work_path inside $prefix source scripts/buildutil.sh load_configuration reverse_iterate_filelist uninstall_item rmdir $prefix apq-postgresql-3.2.0/src-in/000077500000000000000000000000001172102510600156645ustar00rootroot00000000000000apq-postgresql-3.2.0/src-in/apq-postgresql.ads.in000066400000000000000000000113061172102510600217450ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- APQ DATABASE BINDINGS -- -- -- -- A P Q -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Warren W. Gay VE3WWG -- -- Copyright (C) 2007-2009, Ada Works Project -- -- -- -- -- -- APQ is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. APQ is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with APQ; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ------------------------------------------------------------------------------ ------------------------------------------------------------------------------- -- This is the base package for the PostreSQL driver for APQ. -- ------------------------------------------------------------------------------- package APQ.PostgreSQL is %POSTGRESQL_LIBS% type Result_Type is ( Empty_Query, Command_OK, Tuples_OK, Copy_Out, Copy_In, Bad_Response, Nonfatal_Error, Fatal_Error ); for Result_Type use ( Empty_Query => 0, Command_OK => 1, Tuples_OK => 2, Copy_Out => 3, Copy_In => 4, Bad_Response => 5, Nonfatal_Error => 6, Fatal_Error => 7 ); subtype PG_Smallint is APQ_Smallint; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Integer is APQ_Integer; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Bigint is APQ_Bigint; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Real is APQ_Real; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Double is APQ_Double; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Serial is APQ_Serial; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Bigserial is APQ_Bigserial; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Oid is APQ.Row_ID_Type; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Boolean is Boolean; -- For compatibility only (use APQ_Boolean or Boolean instead) subtype PG_Date is APQ_Date; -- For compatibility only (use APQ_Date instead) subtype PG_Time is APQ_Time; -- For compatibility only (use APQ_Time instead) subtype PG_Timestamp is APQ_Timestamp; -- For compatibility only (use APQ_Timestamp instead) --subtype PG_Timezone is APQ_Timezone; -- For compatibility only (use APQ_Timestamp instead) subtype PG_Bitstring is APQ_Bitstring; -- For compatibility only (use APQ_Timestamp instead) type Mode_Type is ( Write, Read, Read_Write ); for Mode_Type use ( Write => 16#00020000#, -- Write access Read => 16#00040000#, -- Read access Read_Write => 16#00060000# -- Read/Write access ); for Mode_Type'Size use 32; private type PQOid_Type is mod 2 ** 32; -- Currently PostgreSQL uses unsigned int for Oid Null_Row_ID : constant Row_ID_Type := 0; -- Value representing no OID end APQ.PostgreSQL; apq-postgresql-3.2.0/src-in/apq-postgresql.gpr.in000066400000000000000000000032541172102510600217710ustar00rootroot00000000000000-- Build file for KOW_Lib. -- -- author Marcelo Coraça de Freitas -- -- Repository information: -- $Date$ -- $Revision$ -- $Author$ with "apq"; project APQ.PostgreSQL is ----------------------- -- Type declarations -- ----------------------- type True_False is ( "true", "false" ); type Supported_OS is ("Windows_NT", "GNU/Linux", "Darwin" ); -------------------- -- Main Variables -- -------------------- version := $version; OS : Supported_OS := external( "OS", "GNU/Linux" ); Debug : True_False := external( "DEBUG", "false" ); ---------------- -- Parameters -- ---------------- for Library_Name use $project; for Languages use ( "Ada", "C" ); for Source_Dirs use ( "../../src/" & Project'Library_Name & "/" ); for Library_kind use external( "LIBRARY_KIND", "static" ); case Debug is when "true" => for Library_Dir use "../" & Project'Library_Name & "-debug/" & Project'Library_Kind; when "false" => for Library_Dir use "../" & Project'Library_name & "/" & Project'Library_Kind; end case; for Object_Dir use Project'Library_Dir & "/objects/"; for Library_Version use "lib" & Project'Library_Name & ".so." & Version; for Externally_Built use External( "APQPOSTGRESQL_EXTERNALLY_BUILT", "true" ); ---------------------- -- Compiler Package -- ---------------------- package Compiler is for Default_Switches ( "Ada" ) use ( "-O2", "-gnat05", "-fPIC" ); for Default_Switches ( "C" ) use ( %POSTGRESQL_CFLAGS%, "-O2", "-fPIC" ); case Debug is when "true" => for Default_Switches ("ada") use Compiler'Default_Switches("Ada") & ( "-g" ); when "false" => end case; end Compiler; end APQ.PostgreSQL; apq-postgresql-3.2.0/src/000077500000000000000000000000001172102510600152605ustar00rootroot00000000000000apq-postgresql-3.2.0/src/apq-postgresql-client.adb000066400000000000000000001435351172102510600222010ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- APQ DATABASE BINDINGS -- -- -- -- A P Q - POSTGRESQL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Warren W. Gay VE3WWG -- -- Copyright (C) 2007-2009, Ada Works Project -- -- -- -- -- -- APQ is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. APQ is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with APQ; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Calendar; with Ada.Unchecked_Deallocation; with Ada.Unchecked_Conversion; with Ada.Characters.Latin_1; with Ada.Characters.Handling; with Ada.Strings.Fixed; with Ada.IO_Exceptions; with System; with System.Address_To_Access_Conversions; with Interfaces.C.Strings; with GNAT.OS_Lib; use Interfaces.C; use Ada.Exceptions; package body APQ.PostgreSQL.Client is Seek_Set : constant Interfaces.C.int := 0; Seek_Cur : constant Interfaces.C.int := 1; Seek_End : constant Interfaces.C.int := 2; No_Date : Ada.Calendar.Time; type PQ_Status_Type is ( Connection_OK, Connection_Bad, Connection_Started, -- Waiting for connection to be made. Connection_Made, -- Connection OK; waiting to send. Connection_Awaiting_Response, -- Waiting for a response Connection_Auth_OK, -- Received authentication Connection_Setenv -- Negotiating environment. ); for PQ_Status_Type use ( 0, -- CONNECTION_OK 1, -- CONNECTION_BAD 2, -- CONNECTION_STARTED 3, -- CONNECTION_MADE 4, -- CONNECTION_AWAITING_RESPONSE 5, -- CONNECTION_AUTH_OK 6 -- CONNECTION_SETENV ); ------------------------------ -- DATABASE CONNECTION : ------------------------------ function Engine_Of(C : Connection_Type) return Database_Type is begin return Engine_PostgreSQL; end Engine_Of; function New_Query(C : Connection_Type) return Root_Query_Type'Class is Q : Query_Type; begin return Q; end New_Query; procedure Notify_on_Standard_Error(C : in out Connection_Type; Message : String) is use Ada.Text_IO; begin Put(Standard_Error,"*** NOTICE : "); Put_Line(Standard_Error,Message); end Notify_on_Standard_Error; procedure Set_Instance(C : in out Connection_Type; Instance : String) is begin Raise_Exception(Not_Supported'Identity, "PG01: PostgreSQL has no Instance ID. (Set_Instance)"); end Set_Instance; function Host_Name(C : Connection_Type) return String is begin if not Is_Connected(C) then return Host_Name(Root_Connection_Type(C)); else declare use Interfaces.C.Strings; function PQhost(PGconn : PG_Conn) return chars_ptr; pragma Import(C,PQhost,"PQhost"); The_Host : chars_ptr := PQhost(C.Connection); begin if The_Host = Null_Ptr then return "localhost"; end if; return Value_Of(The_Host); end; end if; end Host_Name; function Port(C : Connection_Type) return Integer is begin if not Is_Connected(C) then return Port(Root_Connection_Type(C)); else declare use Interfaces.C.Strings; function PQport(PGconn : PG_Conn) return chars_ptr; pragma Import(C,PQport,"PQport"); The_Port : String := Value_Of(PQport(C.Connection)); begin return Integer'Value(The_Port); exception when others => Raise_Exception(Invalid_Format'Identity, "PG02: Invalid port number or is a UNIX socket reference (Port)."); end; end if; return 0; end Port; function Port(C : Connection_Type) return String is begin if not Is_Connected(C) then return Port(Root_Connection_Type(C)); else declare use Interfaces.C.Strings; function PQport(PGconn : PG_Conn) return chars_ptr; pragma Import(C,PQport,"PQport"); begin return Value_Of(PQport(C.Connection)); end; end if; end Port; function DB_Name(C : Connection_Type) return String is begin if not Is_Connected(C) then return To_Case(DB_Name(Root_Connection_Type(C)),C.SQL_Case); else declare use Interfaces.C.Strings; function PQdb(PGconn : PG_Conn) return chars_ptr; pragma Import(C,PQdb,"PQdb"); begin return Value_Of(PQdb(C.Connection)); end; end if; end DB_Name; function User(C : Connection_Type) return String is begin if not Is_Connected(C) then return User(Root_Connection_Type(C)); else declare use Interfaces.C.Strings; function PQuser(PGconn : PG_Conn) return chars_ptr; pragma Import(C,PQuser,"PQuser"); begin return Value_Of(PQuser(C.Connection)); end; end if; end User; function Password(C : Connection_Type) return String is begin if not Is_Connected(C) then return Password(Root_Connection_Type(C)); else declare use Interfaces.C.Strings; function PQpass(PGconn : PG_Conn) return chars_ptr; pragma Import(C,PQpass,"PQpass"); begin return Value_Of(PQpass(C.Connection)); end; end if; end Password; procedure Set_DB_Name(C : in out Connection_Type; DB_Name : String) is procedure Use_Database(C : in out Connection_Type; DB_Name : String) is Q : Query_Type; begin begin Prepare(Q,To_Case("USE " & DB_Name,C.SQL_Case)); Execute(Q,C); exception when SQL_Error => Raise_Exception(APQ.Use_Error'Identity, "PG03: Unable to select database " & DB_Name & ". (Use_Database)"); end; end Use_Database; begin if not Is_Connected(C) then -- Modify context to connect to this database when we connect Set_DB_Name(Root_Connection_Type(C),DB_Name); else -- Use this database now Use_Database(C,DB_Name); -- Update context info if no exception thrown above Set_DB_Name(Root_Connection_Type(C),DB_Name); end if; end Set_DB_Name; procedure Set_Options(C : in out Connection_Type; Options : String) is begin Replace_String(C.Options,Set_Options.Options); end Set_Options; function Options(C : Connection_Type) return String is begin if not Is_Connected(C) then if C.Options /= null then return C.Options.all; end if; else declare use Interfaces.C.Strings; function PQoptions(PGconn : PG_Conn) return chars_ptr; pragma Import(C,PQoptions,"PQoptions"); begin return Value_Of(PQoptions(C.Connection)); end; end if; return ""; end Options; procedure Set_Notify_Proc(C : in out Connection_Type; Notify_Proc : Notify_Proc_Type) is begin C.Notify_Proc := Set_Notify_Proc.Notify_Proc; end Set_Notify_Proc; function Notify_Proc(C : Connection_Type) return Notify_Proc_Type is begin return C.Notify_Proc; end Notify_Proc; -------------------------------------------------- -- Connection_Notify is called by notices.c as -- a callback from the libpq interface. -------------------------------------------------- procedure Connection_Notify(C_Addr : System.Address; Msg_Ptr : Interfaces.C.Strings.chars_ptr); pragma Export(C,Connection_Notify,"Connection_Notify"); procedure Connection_Notify(C_Addr : System.Address; Msg_Ptr : Interfaces.C.Strings.chars_ptr) is use Interfaces.C.Strings; package Addr is new System.Address_To_Access_Conversions(Connection_Type); function Strip_Prefix(S : String) return String is use Ada.Strings.Fixed, Ada.Strings; begin if S(S'First..S'First+6) = "NOTICE:" then return Trim(S(S'First+7..S'Last),Left); end if; return S; end Strip_Prefix; Abrt_Notice : constant String := "current transaction is aborted, queries ignored until end of transaction block"; Conn : Addr.Object_Pointer := Addr.To_Pointer(C_Addr); Msg : String := Strip_Prefix(Strip_NL(To_Ada_String(Msg_Ptr))); begin if Conn.Notice /= null then Free(Conn.Notice); -- Free last notice end if; -- Store new notice Conn.Notice := new String(1..Msg'Length); Conn.Notice.all := Msg; if Conn.Notice.all = Abrt_Notice then Conn.Abort_State := True; end if; if Conn.Notify_Proc /= Null then Conn.Notify_Proc(Conn.all,Conn.Notice.all); end if; end Connection_Notify; function PQ_Status(C : Connection_Type) return PQ_Status_Type is function PQstatus(C : PG_Conn) return PQ_Status_Type; pragma Import(C,PQstatus,"PQstatus"); begin if C.Connection = Null_Connection then return Connection_Bad; else return PQstatus(C.Connection); end if; end PQ_Status; procedure Connect(C : in out Connection_Type; Check_Connection : Boolean := True) is procedure Notice_Install(Conn : PG_Conn; ada_obj_ptr : System.Address); pragma import(C,Notice_Install,"notice_install"); function PQsetdbLogin(pghost, pgport, pgoptions, pgtty, dbname, login, pwd : System.Address) return PG_Conn; pragma import(C,PQsetdbLogin,"PQsetdbLogin"); use Interfaces.C.Strings; C_Host : char_array_access; A_Host : System.Address := System.Null_Address; C_Options : char_array_access; A_Options : System.Address := System.Null_Address; C_Tty : char_array_access; A_Tty : System.Address := System.Null_Address; C_Dbname : char_array_access; A_Dbname : System.Address := System.Null_Address; C_Login : char_array_access; A_Login : System.Address := System.Null_Address; C_Pwd : char_array_access; A_Pwd : System.Address := System.Null_Address; begin if Check_Connection and then Is_Connected(C) then Raise_Exception(Already_Connected'Identity, "PG07: Already connected (Connect)."); end if; C_String(C.Host_Name,C_Host,A_Host); C_String(C.Options,C_Options,A_Options); C_String(null,C_Tty,A_Tty); C_String(C.DB_Name,C_Dbname,A_Dbname); C_String(C.User_Name,C_Login,A_Login); C_String(C.User_Password,C_Pwd,A_Pwd); if C.Port_Format = IP_Port then declare C_Port : char_array := To_C(Port_Integer'Image(C.Port_Number)); A_Port : System.Address := C_Port'Address; begin -- Use application specified port # C.Connection := PQsetdbLogin(A_Host,A_Port,A_Options,A_Tty,A_Dbname,A_Login,A_Pwd); end; elsif C.Port_Format = UNIX_Port then declare C_Port : char_array_access; A_Port : System.Address := System.Null_Address; begin C_String(C.Port_Name,C_Port,A_Port); C.Connection := PQsetdbLogin(A_Host,A_Port,A_Options,A_Tty,A_Dbname,A_Login,A_Pwd); end; else raise Program_Error; end if; if C_Host /= null then Free(C_Host); end if; if C_Options /= null then Free(C_Options); end if; if C_Tty /= null then Free(C_Tty); end if; if C_Dbname /= null then Free(C_Dbname); end if; if C_Login /= null then Free(C_Login); end if; if C_Pwd /= null then Free(C_Pwd); end if; Free_Ptr(C.Error_Message); if PQ_Status(C) /= Connection_OK then declare procedure PQfinish(C : PG_Conn); pragma Import(C,PQfinish,"PQfinish"); Msg : String := Strip_NL(Error_Message(C)); begin PQfinish(C.Connection); C.Connection := Null_Connection; C.Error_Message := new String(1..Msg'Length); C.Error_Message.all := Msg; Raise_Exception(Not_Connected'Identity, "PG08: Failed to connect to database server (Connect)."); end; end if; Notice_Install(C.Connection,C'Address); -- Install Connection_Notify handler ------------------------------ -- SET PGDATESTYLE TO ISO; -- -- This is necessary for all of the -- APQ date handling routines to -- function correctly. This implies -- that all APQ applications programs -- should use the ISO date format. ------------------------------ declare SQL : Query_Type; begin Prepare(SQL,"SET DATESTYLE TO ISO"); Execute(SQL,C); exception when Ex : others => Disconnect(C); Reraise_Occurrence(Ex); end; end Connect; procedure Connect(C : in out Connection_Type; Same_As : Root_Connection_Type'Class) is type Info_Func is access function(C : Connection_Type) return String; procedure Clone(S : in out String_Ptr; Get_Info : Info_Func) is Info : String := Get_Info(Connection_Type(Same_As)); begin if Info'Length > 0 then S := new String(1..Info'Length); S.all := Info; else null; pragma assert(S = null); end if; end Clone; begin Reset(C); Clone(C.Host_Name,Host_Name'Access); C.Port_Format := Same_As.Port_Format; if C.Port_Format = IP_Port then C.Port_Number := Port(Same_As); -- IP_Port else Clone(C.Port_Name,Port'Access); -- UNIX_Port end if; Clone(C.DB_Name,DB_Name'Access); Clone(C.User_Name,User'Access); Clone(C.User_Password,Password'Access); Clone(C.Options,Options'Access); C.Rollback_Finalize := Same_As.Rollback_Finalize; C.Notify_Proc := Connection_Type(Same_As).Notify_Proc; Connect(C); -- Connect to database before worrying about trace facilities -- TRACE FILE & TRACE SETTINGS ARE NOT CLONED end Connect; procedure Disconnect(C : in out Connection_Type) is procedure Notice_Uninstall(C : PG_Conn); pragma Import(C,notice_uninstall,"notice_uninstall"); procedure PQfinish(C : PG_Conn); pragma Import(C,PQfinish,"PQfinish"); begin if not Is_Connected(C) then Raise_Exception(Not_Connected'Identity, "PG09: Not connected. (Disconnect)"); end if; Notice_Uninstall(C.Connection); -- Disconnect callback notices PQfinish(C.Connection); -- Now release the connection C.Connection := Null_Connection; C.Abort_State := False; -- Clear abort state C.Notify_Proc := null; -- De-register the notify procedure if C.Trace_Mode = Trace_APQ or else C.Trace_Mode = Trace_Full then Ada.Text_IO.Put_Line(C.Trace_Ada,"-- DISCONNECT"); end if; Reset(C); end Disconnect; function Is_Connected(C : Connection_Type) return Boolean is begin return PQ_Status(C) = Connection_OK; end Is_Connected; procedure Internal_Reset(C : in out Connection_Type; In_Finalize : Boolean := False) is begin Free_Ptr(C.Error_Message); if C.Connection /= Null_Connection then declare Q : Query_Type; begin Clear_Abort_State(C); if C.Rollback_Finalize or In_Abort_State(C) then if C.Trace_On and then C.Trace_Filename /= null and then In_Finalize = True then Ada.Text_IO.Put_Line(C.Trace_Ada,"-- ROLLBACK ON FINALIZE"); end if; Rollback_Work(Q,C); else if C.Trace_On and then C.Trace_Filename /= null and then In_Finalize = True then Ada.Text_IO.Put_Line(C.Trace_Ada,"-- COMMIT ON FINALIZE"); end if; Commit_Work(Q,C); end if; exception when others => null; -- Ignore if the Rollback/commit fails end; Clear_Abort_State(C); Disconnect(C); if C.Trace_Filename /= null then Close_DB_Trace(C); end if; end if; if C.Connection = Null_Connection then Free_Ptr(C.Host_Name); Free_Ptr(C.Host_Address); Free_Ptr(C.DB_Name); Free_Ptr(C.User_Name); Free_Ptr(C.User_Password); Free_Ptr(C.Options); Free_Ptr(C.Error_Message); Free_Ptr(C.Notice); end if; end Internal_Reset; procedure Reset(C : in out Connection_Type) is begin Internal_Reset(C,In_Finalize => False); end Reset; function Error_Message(C : Connection_Type) return String is function PQerrorMessage(C : PG_Conn) return Interfaces.C.Strings.chars_ptr; pragma Import(C,PQerrorMessage,"PQerrorMessage"); begin if C.Connection = Null_Connection then if C.Error_Message /= null then return C.Error_Message.all; else return ""; end if; else return To_Ada_String(PQerrorMessage(C.Connection)); end if; end Error_Message; function Notice_Message(C : Connection_Type) return String is begin if C.Notice /= null then return C.Notice.all; end if; return ""; end Notice_Message; procedure Open_DB_Trace(C : in out Connection_Type; Filename : String; Mode : Trace_Mode_Type := Trace_APQ) is begin if C.Trace_Filename /= null then Raise_Exception(Tracing_State'Identity, "PG04: Already in a tracing state (Open_DB_Trace)."); end if; if not Is_Connected(C) then Raise_Exception(Not_Connected'Identity, "PG05: Not connected (Open_DB_Trace)."); end if; if Mode = Trace_None then pragma assert(C.Trace_Mode = Trace_None); return; -- No trace required end if; declare use CStr, System, Ada.Text_IO, Ada.Text_IO.C_Streams; procedure PQtrace(PGconn : PG_Conn; debug_port : CStr.FILEs); pragma Import(C,PQtrace,"PQtrace"); C_Filename : char_array := To_C(Filename); File_Mode : char_array := To_C("a"); begin C.Trace_File := fopen(C_Filename'Address,File_Mode'Address); if C.Trace_File = Null_Stream then Raise_Exception(Ada.IO_Exceptions.Name_Error'Identity, "PG06: Unable to open trace file " & Filename & " (Open_DB_Trace)."); end if; Open(C.Trace_Ada,Append_File,C.Trace_File,Form => "shared=yes"); Ada.Text_IO.Put_Line(C.Trace_Ada,"-- Start of Trace, Mode = " & Trace_Mode_Type'Image(Mode)); if Mode = Trace_DB or Mode = Trace_Full then PQtrace(C.Connection,C.Trace_File); end if; end; C.Trace_Filename := new String(1..Filename'Length); C.Trace_Filename.all := Filename; C.Trace_Mode := Mode; C.Trace_On := True; -- Enabled by default until Set_Trace disables this end Open_DB_Trace; procedure Close_DB_Trace(C : in out Connection_Type) is begin if C.Trace_Mode = Trace_None then return; -- No tracing in progress end if; pragma assert(C.Trace_Filename /= null); declare use CStr; procedure PQuntrace(PGconn : PG_Conn); pragma Import(C,PQuntrace,"PQuntrace"); begin if C.Trace_Mode = Trace_DB or C.Trace_Mode = Trace_Full then PQuntrace(C.Connection); end if; Free(C.Trace_Filename); Ada.Text_IO.Put_Line(C.Trace_Ada,"-- End of Trace."); Ada.Text_IO.Close(C.Trace_Ada); -- This closes C.Trace_File too C.Trace_Mode := Trace_None; C.Trace_On := True; -- Restore default end; end Close_DB_Trace; procedure Set_Trace(C : in out Connection_Type; Trace_On : Boolean := True) is procedure PQtrace(PGconn : PG_Conn; debug_port : CStr.FILEs); procedure PQuntrace(PGconn : PG_Conn); pragma Import(C,PQtrace,"PQtrace"); pragma Import(C,PQuntrace,"PQuntrace"); Orig_Trace : Boolean := C.Trace_On; begin C.Trace_On := Set_Trace.Trace_On; if Orig_Trace = C.Trace_On then return; -- No change end if; if C.Trace_On then if C.Trace_Mode = Trace_DB or C.Trace_Mode = Trace_Full then PQtrace(C.Connection,C.Trace_File); -- Enable libpq tracing end if; else if C.Trace_Mode = Trace_DB or C.Trace_Mode = Trace_Full then PQuntrace(C.Connection); -- Disable libpq tracing end if; end if; end Set_Trace; function Is_Trace(C : Connection_Type) return Boolean is begin return C.Trace_On; end Is_Trace; function In_Abort_State(C : Connection_Type) return Boolean is begin if C.Connection = Null_Connection then return False; end if; return C.Abort_State; end In_Abort_State; ------------------------------ -- SQL QUERY API : ------------------------------ procedure Free(R : in out PQ_Result) is procedure PQclear(R : PQ_Result); pragma Import(C,PQclear,"PQclear"); begin if R /= Null_Result then PQclear(R); R := Null_Result; end if; end Free; procedure Clear(Q : in out Query_Type) is begin Free(Q.Result); Clear(Root_Query_Type(Q)); end Clear; procedure Append_Quoted(Q : in out Query_Type; Connection : Root_Connection_Type'Class; SQL : String; After : String := "") is function PQescapeString(to, from : System.Address; length : size_t) return size_t; pragma Import(C,PQescapeString,"PQescapeString"); C_Length : size_t := SQL'Length * 2 + 1; C_From : char_array := To_C(SQL); C_To : char_array(0..C_Length-1); R_Length : size_t := PQescapeString(C_To'Address,C_From'Address,C_Length); begin Append(Q,"'" & To_Ada(C_To) & "'",After); Q.Caseless(Q.Count) := False; -- Preserve case for this one end Append_Quoted; procedure Execute(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class) is function PQexec(C : PG_Conn; Q : System.Address) return PQ_Result; pragma Import(C,PQexec,"PQexec"); R : Result_Type; begin Query.SQL_Case := Connection.SQL_Case; if not Is_Connected(Connection) then Raise_Exception(Not_Connected'Identity, "PG14: The Connection_Type object supplied is not connected (Execute)."); end if; if In_Abort_State(Connection) then Raise_Exception(Abort_State'Identity, "PG15: The PostgreSQL connection is in the Abort state (Execute)."); end if; if Query.Result /= Null_Result then Free(Query.Result); end if; declare A_Query : String := To_String(Query); C_Query : char_array := To_C(A_Query); begin if Connection.Trace_On then if Connection.Trace_Mode = Trace_APQ or Connection.Trace_Mode = Trace_Full then Ada.Text_IO.Put_Line(Connection.Trace_Ada,"-- SQL QUERY:"); Ada.Text_IO.Put_Line(Connection.Trace_Ada,A_Query); Ada.Text_IO.Put_Line(Connection.Trace_Ada,";"); end if; end if; Query.Result := PQexec(Internal_Connection(Connection_Type(Connection)),C_Query'Address); if Connection.Trace_On then if Connection.Trace_Mode = Trace_APQ or Connection.Trace_Mode = Trace_Full then Ada.Text_IO.Put_Line(Connection.Trace_Ada,"-- Result: '" & Command_Status(Query) & "'"); Ada.Text_IO.New_Line(Connection.Trace_Ada); end if; end if; end; if Query.Result /= Null_Result then Query.Tuple_Index := First_Tuple_Index; R := Result(Query); if R /= Command_OK and R /= Tuples_OK then -- if Connection.Trace_On then -- Ada.Text_IO.Put_Line(Connection.Trace_Ada,"-- Error " & -- Result_Type'Image(Query.Error_Code) & " : " & Error_Message(Query)); -- end if; Raise_Exception(SQL_Error'Identity, "PG16: The query failed (Execute)."); end if; else -- if Connection.Trace_On then -- Ada.Text_IO.Put_Line(Connection.Trace_Ada,"-- Error " & -- Result_Type'Image(Query.Error_Code) & " : " & Error_Message(Query)); -- end if; Raise_Exception(SQL_Error'Identity, "PG17: The query failed (Execute)."); end if; end Execute; procedure Execute_Checked(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class; Msg : String := "") is use Ada.Text_IO; begin begin Execute(Query,Connection); exception when Ex : SQL_Error => if Msg'Length > 0 then Put(Standard_Error,"*** SQL ERROR: "); Put_Line(Standard_Error,Msg); else Put(Standard_Error,"*** SQL ERROR IN QUERY:"); New_Line(Standard_Error); Put(Standard_Error,To_String(Query)); if Col(Standard_Error) > 1 then New_Line(Standard_Error); end if; end if; Put(Standard_Error,"["); Put(Standard_Error,Result_Type'Image(Result(Query))); Put(Standard_Error,": "); Put(Standard_Error,Error_Message(Query)); Put_Line(Standard_Error,"]"); Reraise_Occurrence(Ex); when Ex : others => Reraise_Occurrence(Ex); end; end Execute_Checked; procedure Begin_Work(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class) is begin if In_Abort_State(Connection) then Raise_Exception(Abort_State'Identity, "PG36: PostgreSQL connection is in the abort state (Begin_Work)."); end if; Clear(Query); Prepare(Query,"BEGIN WORK"); Execute(Query,Connection); Clear(Query); end Begin_Work; procedure Commit_Work(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class) is begin if In_Abort_State(Connection) then Raise_Exception(Abort_State'Identity, "PG37: PostgreSQL connection is in the abort state (Commit_Work)."); end if; Clear(Query); Prepare(Query,"COMMIT WORK"); Execute(Query,Connection); Clear(Query); end Commit_Work; procedure Rollback_Work(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class) is begin Clear(Query); Prepare(Query,"ROLLBACK WORK"); Execute(Query,Connection); Clear_Abort_State(Connection); Clear(Query); end Rollback_Work; procedure Rewind(Q : in out Query_Type) is begin Q.Rewound := True; Q.Tuple_Index := First_Tuple_Index; end Rewind; procedure Fetch(Q : in out Query_Type) is begin if not Q.Rewound then Q.Tuple_Index := Q.Tuple_Index + 1; else Q.Rewound := False; end if; Fetch(Q,Q.Tuple_Index); end Fetch; procedure Fetch(Q : in out Query_Type; TX : Tuple_Index_Type) is NT : Tuple_Count_Type := Tuples(Q); -- May raise No_Result begin if NT < 1 then Raise_Exception(No_Tuple'Identity, "PG33: There is no row" & Tuple_Index_Type'Image(TX) & " (Fetch)."); end if; Q.Tuple_Index := TX; Q.Rewound := False; if TX > NT then Raise_Exception(No_Tuple'Identity, "PG34: There is no row" & Tuple_Index_Type'Image(TX) & " (Fetch)."); end if; end Fetch; function End_of_Query(Q : Query_Type) return Boolean is NT : Tuple_Count_Type := Tuples(Q); -- May raise No_Result begin if NT < 1 then return True; -- There are no tuples to return end if; if Q.Rewound then return False; -- There is at least 1 tuple to return yet end if; return Tuple_Count_Type(Q.Tuple_Index) >= NT; -- We've fetched them all end End_of_Query; function Tuple(Q : Query_Type) return Tuple_Index_Type is NT : Tuple_Count_Type := Tuples(Q); -- May raise No_Result begin if NT < 1 or else Q.Rewound then Raise_Exception(No_Tuple'Identity, "PG35: There are no tuples to return (Tuple)."); end if; return Q.Tuple_Index; end Tuple; function Tuples(Q : Query_Type) return Tuple_Count_Type is use Interfaces.C; function PQntuples(R : PQ_Result) return int; pragma Import(C,PQntuples,"PQntuples"); begin if Q.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG19: There are no query results (Tuples)."); end if; return Tuple_Count_Type(PQntuples(Q.Result)); end Tuples; function Columns(Q : Query_Type) return Natural is use Interfaces.C; function PQnfields(R : PQ_Result) return int; pragma Import(C,PQnfields,"PQnfields"); begin if Q.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG20: There are no query results (Columns)."); end if; return Natural(PQnfields(Q.Result)); end Columns; function Column_Name(Q : Query_Type; CX : Column_Index_Type) return String is use Interfaces.C.Strings; function PQfname(R : PQ_Result; CBX : int) return chars_ptr; pragma Import(C,PQfname,"PQfname"); CBX : int := int(CX) - 1; -- Make zero based begin if Q.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG21: There are no query results (Column_Name)."); end if; declare use Interfaces.C.Strings; CP : chars_ptr := PQfname(Q.Result,CBX); begin if CP = Null_Ptr then Raise_Exception(No_Column'Identity, "PG22: There is no column CX=" & Column_Index_Type'Image(CX) & "."); end if; return To_Case(Value_Of(CP),Q.SQL_Case); end; end Column_Name; function Column_Index(Q : Query_Type; Name : String) return Column_Index_Type is use Interfaces.C.Strings; function PQfnumber(R : PQ_Result; CBX : System.Address) return int; pragma Import(C,PQfnumber,"PQfnumber"); C_Name : char_array := To_C(Name); CBX : int := -1; begin if Q.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG23: There are no query results (Column_Index)."); end if; CBX := PQfnumber(Q.Result,C_Name'Address); if CBX < 0 then Raise_Exception(No_Column'Identity, "PG24: There is no column named '" & Name & " (Column_Index)."); end if; return Column_Index_Type(CBX+1); end Column_Index; function Is_Column(Q : Query_Type; CX : Column_Index_Type) return Boolean is begin if Q.Result = Null_Result then return False; end if; return Natural(CX) <= Columns(Q); end Is_Column; function Column_Type(Q : Query_Type; CX : Column_Index_Type) return Row_ID_Type is function PQftype(R : PQ_Result; Field_Index : int) return PQOid_Type; pragma Import(C,PQftype,"PQftype"); CBX : int := int(CX) - 1; begin if Q.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG25: There are no query results (Column_Type)."); end if; if not Is_Column(Q,CX) then Raise_Exception(No_Column'Identity, "PG26: There is no column CX=" & Column_Index_Type'Image(CX) & " (Column_Type)."); end if; return Row_ID_Type(PQftype(Q.Result,CBX)); end Column_Type; function Is_Null(Q : Query_Type; CX : Column_Index_Type) return Boolean is use Interfaces.C.Strings; function PQgetisnull(R : PQ_Result; tup_num, field_num : int) return int; pragma Import(C,PQgetisnull,"PQgetisnull"); C_TX : int := int(Q.Tuple_Index) - 1; -- Make zero based tuple # C_CX : int := int(CX) - 1; -- Field index begin if Q.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG31: There are no query results (Is_Null)."); end if; if not Is_Column(Q,CX) then Raise_Exception(No_Column'Identity, "PG32: There is now column" & Column_Index_Type'Image(CX) & " (Is_Null)."); end if; return PQgetisnull(Q.Result,C_TX,C_CX) /= 0; end Is_Null; function Value(Query : Query_Type; CX : Column_Index_Type) return String is use Interfaces.C.Strings; function PQgetvalue(R : PQ_Result; tup_num, field_num : int) return chars_ptr; pragma Import(C,PQgetvalue,"PQgetvalue"); function PQgetisnull(R : PQ_Result; tup_num, field_num : int) return int; pragma Import(C,PQgetisnull,"PQgetisnull"); C_TX : int := int(Query.Tuple_Index) - 1; -- Make zero based tuple # C_CX : int := int(CX) - 1; -- Field index begin if Query.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG27: There are no query results (Value)."); end if; if not Is_Column(Query,CX) then Raise_Exception(No_Column'Identity, "PG28: There is no column CX=" & Column_Index_Type'Image(CX) & " (Value)."); end if; declare use Ada.Strings, Ada.Strings.Fixed; C_Val : chars_ptr := PQgetvalue(Query.Result,C_TX,C_CX); begin if C_Val = Null_Ptr then Raise_Exception(No_Tuple'Identity, "PG29: There is no row" & Tuple_Index_Type'Image(Query.Tuple_Index) & " (Value)."); elsif PQgetisnull(Query.Result,C_TX,C_CX) /= 0 then Raise_Exception(Null_Value'Identity, "PG30: Value for column" & Column_Index_Type'Image(CX) & " is NULL (Value)."); else return Trim(Value_Of(C_Val),Right); end if; end; end Value; function Result(Query : Query_Type) return Natural is begin return Result_Type'Pos(Result(Query)); end Result; function Result(Query : Query_Type) return Result_Type is function PQresultStatus(R : PQ_Result) return Result_Type; pragma Import(C,PQresultStatus,"PQresultStatus"); begin if Query.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG13: There are no query results (function Result)."); end if; return PQresultStatus(Query.Result); end Result; function Command_Oid(Query : Query_Type) return Row_ID_Type is function PQoidValue(R : PQ_Result) return PQOid_Type; pragma Import(C,PQoidValue,"PQoidValue"); begin if Query.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG12: There are no query results (Command_Oid)."); end if; return Row_ID_Type(PQoidValue(Query.Result)); end Command_Oid; function Null_Oid(Query : Query_Type) return Row_ID_Type is begin return APQ.PostgreSQL.Null_Row_ID; end Null_Oid; function Command_Status(Query : Query_Type) return String is use Interfaces.C.Strings; function PQcmdStatus(R : PQ_Result) return chars_ptr; pragma Import(C,PQcmdStatus,"PQcmdStatus"); begin if Query.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG11: There are no query results (Command_Status)."); end if; declare use Interfaces.C.Strings; Msg_Ptr : chars_ptr := PQcmdStatus(Query.Result); begin if Msg_Ptr = Null_Ptr then return ""; else return Strip_NL(Value_Of(Msg_Ptr)); end if; end; end Command_Status; function Error_Message(Query : Query_Type) return String is use Interfaces.C.Strings; function PQresultErrorMessage(R : PQ_Result) return chars_ptr; pragma Import(C,PQresultErrorMessage,"PQresultErrorMessage"); begin if Query.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG10: There are no query results (Error_Message)."); end if; declare use Interfaces.C.Strings; Msg_Ptr : chars_ptr := PQresultErrorMessage(Query.Result); begin if Msg_Ptr = Null_Ptr then return ""; else return Strip_NL(Value_Of(Msg_Ptr)); end if; end; end Error_Message; function Is_Duplicate_Key(Query : Query_Type) return Boolean is Msg : String := Error_Message(Query); Dup : constant String := "ERROR: Cannot insert a duplicate key"; begin if Msg'Length < Dup'Length then return False; end if; return Msg(Msg'First..Msg'First+Dup'Length-1) = Dup; end Is_Duplicate_Key; function Engine_Of(Q : Query_Type) return Database_Type is begin return Engine_PostgreSQL; end Engine_Of; -------------------------------------------------- -- BLOB SUPPORT : -------------------------------------------------- function lo_creat(conn : PG_Conn; Mode : Mode_Type) return PQOid_Type; pragma Import(C,lo_creat,"lo_creat"); function lo_open(conn : PG_Conn; Oid : PQOid_Type; Mode : Mode_Type) return Blob_Fd; pragma Import(C,lo_open,"lo_open"); function lo_close(conn : PG_Conn; fd : Blob_Fd) return int; pragma Import(C,lo_close,"lo_close"); function lo_read(conn : PG_Conn; fd : Blob_Fd; buf : System.Address; len : size_t) return int; pragma Import(C,lo_read,"lo_read"); function lo_write(conn : PG_Conn; fd : Blob_Fd; buf : System.Address; len : size_t) return int; pragma Import(C,lo_write,"lo_write"); function lo_unlink(conn : PG_Conn; Oid : PQOid_Type) return int; pragma Import(C,lo_unlink,"lo_unlink"); function lo_lseek(conn : PG_Conn; fd : Blob_Fd; offset, whence : int) return int; pragma Import(C,lo_lseek,"lo_lseek"); procedure Free is new Ada.Unchecked_Deallocation(Blob_Object,Blob_Type); -- internal function Raw_Index(Blob : Blob_Type) return Str.Stream_Element_Offset is use Ada.Streams; Offset : int; begin loop -- In loop form in case EINTR processing should be required someday Offset := lo_lseek(Blob.Conn.Connection,Blob.Fd,0,Seek_Cur); exit when Offset >= 0; Raise_Exception(Blob_Error'Identity, "PG38: Server blob error occurred."); end loop; return Stream_Element_Offset(Offset + 1); end Raw_Index; procedure Raw_Set_Index(Blob : Blob_Object; To : Str.Stream_Element_Offset) is Offset : int := int(To) - 1; Z : int; begin loop -- In loop form in case EINTR processing should be required someday Z := lo_lseek(Blob.Conn.Connection,Blob.Fd,Offset,Seek_Set); exit when Z >= 0; Raise_Exception(Blob_Error'Identity, "PG39: Server blob error occurred."); end loop; end Raw_Set_Index; function Internal_Size(Blob : Blob_Type) return Str.Stream_Element_Offset is use Ada.Streams; Saved_Pos : Stream_Element_Offset := Raw_Index(Blob); End_Offset : int := lo_lseek(Blob.Conn.Connection,Blob.Fd,0,Seek_End); begin if End_Offset < 0 then Raise_Exception(Blob_Error'Identity, "PG40: Server blob error occurred."); end if; Raw_Set_Index(Blob.all,Saved_Pos); return Stream_Element_Offset(End_Offset); end Internal_Size; procedure Internal_Write( Stream: in out Blob_Object; Item: in Ada.Streams.Stream_Element_Array ) is use Ada.Streams; Total : size_t := 0; Len : size_t; IX : Stream_Element_Offset := Item'First; N : int; begin while IX < Item'Last loop Len := size_t(Item'Last - IX + 1); N := lo_write(Stream.Conn.Connection,Stream.Fd,Item(IX)'Address,Len); if N < 0 then Raise_Exception(Blob_Error'Identity, "PG43: Server blob write error occurred."); elsif N > 0 then IX := IX + Stream_Element_Offset(N); Stream.Phy_Offset := Stream.Phy_Offset + Stream_Element_Offset(N); if Stream.Phy_Offset - 1 > Stream.The_Size then Stream.The_Size := Stream.Phy_Offset - 1; end if; end if; if N = 0 then Raise_Exception(Ada.IO_Exceptions.End_Error'Identity, "PG44: End_Error raised while server was writing blob."); end if; end loop; end Internal_Write; procedure Internal_Read( Stream: in out Blob_Object; Item: out Ada.Streams.Stream_Element_Array; Last: out Ada.Streams.Stream_Element_Offset ) is use Ada.Streams; Len : size_t := size_t(Item'Length); N : int; begin loop -- In loop form in case EINTR processing should be required someday N := lo_read(Stream.Conn.Connection,Stream.Fd,Item(Item'First)'Address,Len); exit when N >= 0; Raise_Exception(Blob_Error'Identity, "PG41: Server blob error occurred while reading the blob."); end loop; if N = 0 then Raise_Exception(Ada.IO_Exceptions.End_Error'Identity, "PG42: Reached the end of blob while reading."); end if; Last := Item'First + Stream_Element_Offset(N) - 1; Stream.Phy_Offset := Stream.Phy_Offset + Stream_Element_Offset(N); end Internal_Read; procedure Internal_Blob_Open(Blob : in out Blob_Type; Mode : Mode_Type; Buf_Size : Natural := Buf_Size_Default) is use Ada.Streams; begin Blob.Mode := Internal_Blob_Open.Mode; Blob.Fd := lo_open(Blob.Conn.Connection,PQOid_Type(Blob.Oid),Blob.Mode); if Blob.Fd = -1 then Free(Blob); Raise_Exception(Blob_Error'Identity, "PG45: Unable to open blob on server (OID=" & Row_ID_Type'Image(Blob.Oid) & ")."); end if; if Buf_Size > 0 then Blob.Buffer := new Stream_Element_Array(1..Stream_Element_Offset(Buf_Size)); Blob.Buf_Empty := True; Blob.Buf_Dirty := False; Blob.Buf_Offset := 0; Blob.Log_Offset := 1; Blob.Phy_Offset := 1; Blob.The_Size := Stream_Element_Offset(Internal_Size(Blob)); else null; -- unbuffered blob operations will be used end if; end Internal_Blob_Open; procedure Internal_Set_Index(Blob : in out Blob_Object; To : Str.Stream_Element_Offset) is use Ada.Streams; begin if Blob.Phy_Offset /= Stream_Element_Offset(To) then Raw_Set_Index(Blob,To); Blob.Phy_Offset := Stream_Element_Offset(To); end if; end Internal_Set_Index; -- end internal function Blob_Create(DB : access Connection_Type; Buf_Size : Natural := Buf_Size_Default) return Blob_Type is Blob : Blob_Type; begin Blob := new Blob_Object(DB); Blob.Oid := Row_ID_Type(lo_creat(Blob.Conn.Connection,Read_Write)); if Blob.Oid = -1 then free(Blob); Raise_Exception(Blob_Error'Identity, "PG46: Unable to create blob on server."); end if; begin Internal_Blob_Open(Blob,Write,Buf_Size); exception when Ex : others => Blob_Unlink(DB.all,Blob.Oid); -- Release what will result in an unused blob! Reraise_Occurrence(Ex); -- HINT: Internal_Blob_Open() FAILS IF IT IS NOT IN A TRANSACTION! end; return Blob; end Blob_Create; function Blob_Open(DB : access Connection_Type; Oid : Row_ID_Type; Mode : Mode_Type; Buf_Size : Natural := Buf_Size_Default) return Blob_Type is Blob : Blob_Type; begin Blob := new Blob_Object(DB); Blob.Oid := Blob_Open.Oid; Internal_Blob_Open(Blob,Mode,Buf_Size); return Blob; end Blob_Open; procedure Blob_Flush(Blob : in out Blob_Object) is begin if Blob.Buffer /= null then if ( not Blob.Buf_Empty ) and Blob.Buf_Dirty then Internal_Set_Index(Blob,Blob.Buf_Offset); Internal_Write(Blob,Blob.Buffer(1..Blob.Buf_Size)); end if; Blob.Buf_Dirty := False; else null; -- Ignore flush calls in the unbuffered case end if; end Blob_Flush; procedure Blob_Flush(Blob : Blob_Type) is begin Blob_Flush(Blob.all); end Blob_Flush; procedure Internal_Blob_Close(Blob : in out Blob_Object) is Z : int; begin if Blob.Buffer /= null then if Blob.Buf_Dirty then Blob_Flush(Blob); end if; Free(Blob.Buffer); end if; Z := lo_close(Blob.Conn.Connection,Blob.Fd); if Z /= 0 then Raise_Exception(Blob_Error'Identity, "PG47: Server error when closing blob."); end if; Blob.Fd := -1; end Internal_Blob_Close; procedure Blob_Close(Blob : in out Blob_Type) is begin Internal_Blob_Close(Blob.all); Free(Blob); end Blob_Close; procedure Blob_Set_Index(Blob : Blob_Type; To : Blob_Offset) is use Ada.Streams; begin if Blob.Buffer /= null then Blob.Log_Offset := Stream_Element_Offset(To); else Internal_Set_Index(Blob.all,Stream_Element_Offset(To)); end if; end Blob_Set_Index; function Internal_Index(Blob : Blob_Type) return Str.Stream_Element_Offset is begin return Blob.Phy_Offset; end Internal_Index; function Blob_Index(Blob : Blob_Type) return Blob_Offset is begin if Blob.Buffer /= null then return Blob_Offset(Blob.Log_Offset); else return Blob_Offset(Internal_Index(Blob)); end if; end Blob_Index; function End_of_Blob(Blob : Blob_Type) return Boolean is use Ada.Streams; begin if Blob.Buffer /= null then return Blob.Log_Offset > Blob.The_Size; else return Blob_Index(Blob) > Blob_Size(Blob); end if; end End_of_Blob; function Blob_Oid(Blob : Blob_Type) return Row_ID_Type is begin return Blob.Oid; end Blob_Oid; function Blob_Size(Blob : Blob_Type) return Blob_Count is begin if Blob.Buffer /= null then return Blob_Count(Blob.The_Size); else return Blob_Count(Internal_Size(Blob)); end if; end Blob_Size; function Blob_Stream(Blob : Blob_Type) return Root_Stream_Access is begin if Blob = Null then Raise_Exception(Blob_Error'Identity, "PG49: No blob to create a stream from (Blob_Stream)."); end if; return Root_Stream_Access(Blob); end Blob_Stream; procedure Blob_Unlink(DB : Connection_Type; Oid : Row_ID_Type) is Z : int; begin Z := lo_unlink(DB.Connection,PQOid_Type(Oid)); if Z = -1 then Raise_Exception(Blob_Error'Identity, "PG50: Unable to unlink blob OID=" & Row_ID_Type'Image(Oid) & " (Blob_Unlink)."); end if; end Blob_Unlink; function lo_import(conn : PG_Conn; filename : System.Address) return int; pragma Import(C,lo_import,"lo_import"); function lo_export(conn : PG_Conn; Oid : PQOid_Type; filename : System.Address) return int; pragma Import(C,lo_export,"lo_export"); procedure Blob_Import(DB : Connection_Type; Pathname : String; Oid : out Row_ID_Type) is use Interfaces.C; P : char_array := To_C(Pathname); Z : int; begin Oid := Row_ID_Type'Last; Z := lo_import(DB.Connection,P'Address); if Z <= -1 then Raise_Exception(Blob_Error'Identity, "PG51: Unable to import blob from " & Pathname & " (Blob_Import)."); end if; Oid := Row_ID_Type(Z); end Blob_Import; procedure Blob_Export(DB : Connection_Type; Oid : Row_ID_Type; Pathname : String) is P : char_array := To_C(Pathname); Z : int; begin Z := lo_export(DB.Connection,PQOid_Type(Oid),P'Address); if Z <= -1 then Raise_Exception(Blob_Error'Identity, "PG52: Unable to export blob to " & Pathname & " (Blob_Export)."); end if; end Blob_Export; function Generic_Blob_Open(DB : access Connection_Type; Oid : Oid_Type; Mode : Mode_Type; Buf_Size : Natural := Buf_Size_Default) return Blob_Type is begin return Blob_Open(DB,Row_ID_Type(Oid),Mode,Buf_Size); end Generic_Blob_Open; function Generic_Blob_Oid(Blob : Blob_Type) return Oid_Type is begin return Oid_Type(Blob_Oid(Blob)); end Generic_Blob_Oid; procedure Generic_Blob_Unlink(DB : Connection_Type; Oid : Oid_Type) is begin Blob_Unlink(DB,Row_ID_Type(Oid)); end Generic_Blob_Unlink; procedure Generic_Blob_Import(DB : Connection_Type; Pathname : String; Oid : out Oid_Type) is Local_Oid : Row_ID_Type; begin Blob_Import(DB,Pathname,Local_Oid); Oid := Oid_Type(Local_Oid); end Generic_Blob_Import; procedure Generic_Blob_Export(DB : Connection_Type; Oid : Oid_Type; Pathname : String) is begin Blob_Export(DB,Row_ID_Type(Oid),Pathname); end Generic_Blob_Export; -- private --------------------- -- CONNECTION_TYPE -- --------------------- procedure Initialize(C : in out Connection_Type) is begin C.Port_Format := IP_Port; C.Port_Number := 5432; end Initialize; procedure Finalize(C : in out Connection_Type) is begin Internal_Reset(C,In_Finalize => True); end Finalize; function Internal_Connection(C : Connection_Type) return PG_Conn is begin return C.Connection; end Internal_Connection; function Query_Factory( C: in Connection_Type ) return Root_Query_Type'Class is q: Query_Type; begin return q; end query_factory; ---------------- -- QUERY_TYPE -- ---------------- procedure Adjust(Q : in out Query_Type) is begin Q.Result := Null_Result; Adjust(Root_Query_Type(Q)); end Adjust; procedure Finalize(Q : in out Query_Type) is begin Clear(Q); end Finalize; function SQL_Code(Query : Query_Type) return SQL_Code_Type is begin return 0; end SQL_Code; --------------- -- BLOB_TYPE -- --------------- procedure Finalize(Blob : in out Blob_Object) is begin if Blob.Fd /= -1 then Internal_Blob_Close(Blob); end if; end Finalize; procedure Read( Stream: in out Blob_Object; Item: out Ada.Streams.Stream_Element_Array; Last: out Ada.Streams.Stream_Element_Offset ) is use Ada.Streams; IX : Stream_Element_Offset := Item'First; BX : Stream_Element_Offset; begin if Stream.Buffer /= null then while IX <= Item'Last and Stream.Log_Offset <= Stream.The_Size loop if ( not Stream.Buf_Empty ) and then Stream.Buf_Dirty then -- if not empty and is dirty if Stream.Log_Offset < Stream.Buf_Offset -- if offset too low or else Stream.Log_Offset >= Stream.Buf_Offset + Stream.Buf_Size then -- or offset too high Blob_Flush(Stream); Stream.Buf_Empty := True; end if; end if; if Stream.Buf_Empty then -- If we have an empty buffer then.. if Stream.Log_Offset > Stream.The_Size + 1 then Raise_Exception(Ada.IO_Exceptions.End_Error'Identity, "PG47: End reached while reading blob."); end if; Stream.Buf_Offset := Stream.Log_Offset; -- Start with our convenient offset Stream.Buf_Size := Stream.Buffer.all'Length; -- Try to read entire buffer in if Stream.Buf_Offset + Stream.Buf_Size - 1 > Stream.The_Size then Stream.Buf_Size := Stream.The_Size + 1 - Stream.Buf_Offset; -- read somewhat less in end if; Internal_Set_Index(Stream,Stream.Buf_Offset); Internal_Read(Stream,Stream.Buffer(1..Stream.Buf_Size),Last); if Last /= Stream.Buf_Size then -- Check that all was read Raise_Exception(Blob_Error'Identity, "PG48: Error while reading from blob."); end if; Stream.Buf_Empty := False; -- Buffer is not empty pragma assert(Stream.Buf_Dirty = False); -- Should not be dirty at this point BX := Stream.Buffer.all'First; -- Start reading from buffer here else BX := Stream.Log_Offset - Stream.Buf_Offset + Stream.Buffer.all'First; end if; Item(IX) := Stream.Buffer.all(BX); -- Read item byte IX := IX + 1; -- Advance item index Stream.Log_Offset := Stream.Log_Offset + 1; -- Advance logical offset end loop; Last := IX - 1; else Internal_Read(Stream,Item,Last); end if; end Read; procedure Write( Stream: in out Blob_Object; Item: in Ada.Streams.Stream_Element_Array ) is use Ada.Streams; IX : Stream_Element_Offset := Item'First; BX : Stream_Element_Offset := -1; begin if Stream.Buffer /= null then while IX <= Item'Last loop if ( not Stream.Buf_Empty ) and then Stream.Buf_Dirty then -- Buffer is not empty and is dirty if Stream.Log_Offset < Stream.Buf_Offset -- if offset too low or else Stream.Log_Offset > Stream.Buf_Offset + Stream.Buf_Size -- or offset too high or else Stream.Buf_Size >= Stream.Buffer.all'Length then -- or buffer is full then.. Blob_Flush(Stream); -- Flush out dirty data Stream.Buf_Empty := True; -- Now mark buffer as empty else BX := Stream.Log_Offset - Stream.Buf_Offset + Stream.Buffer.all'First; end if; else BX := Stream.Log_Offset - Stream.Buf_Offset + Stream.Buffer.all'First; end if; if Stream.Buf_Empty then -- if buf was empty or was just made empty then.. Stream.Buf_Offset := Stream.Log_Offset; -- Set to our convenient offset Stream.Buf_Size := 0; -- No data in this buffer yet Stream.Buf_Dirty := False; -- Make sure it's not marked dirty yet BX := Stream.Buffer.all'First; -- Point to start of buffer end if; Stream.Buffer.all(BX) := Item(IX); -- Write the byte IX := IX + 1; -- Advance Item Index Stream.Log_Offset := Stream.Log_Offset + 1; -- Advance the logical blob offset Stream.Buf_Empty := False; -- Buffer is no longer empty Stream.Buf_Dirty := True; -- Buffer has been modified if BX > Stream.Buf_Size then -- Did the buffer contents grow? Stream.Buf_Size := Stream.Buf_Size + 1; -- Buffer size has grown end if; end loop; else Internal_Write(Stream,Item); end if; end Write; begin declare use Ada.Calendar; begin No_Date := Time_Of(Year_Number'First,Month_Number'First,Day_Number'First); end; end APQ.PostgreSQL.Client; -- End $Source: /cvsroot/apq/apq/apq-postgresql-client.adb,v $ apq-postgresql-3.2.0/src/apq-postgresql-client.ads000066400000000000000000000303401172102510600222070ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- APQ DATABASE BINDINGS -- -- -- -- A P Q - POSTGRESQL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Warren W. Gay VE3WWG -- -- Copyright (C) 2007-2009, Ada Works Project -- -- -- -- -- -- APQ is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. APQ is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with APQ; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ------------------------------------------------------------------------------ ------------------------------------------------------------------------------- -- This is the base package for the PostreSQL driver for APQ. -- ------------------------------------------------------------------------------- with System; with Interfaces; with Ada.Text_IO.C_Streams; with Ada.Finalization; with Ada.Streams.Stream_IO; with Ada.Calendar; with Ada.Strings.Bounded; with Ada.Strings.Unbounded; with Interfaces.C_Streams; package APQ.PostgreSQL.Client is package Str renames Ada.Streams; package CStr renames Interfaces.C_Streams; ------------------------------ -- CLIENT DATA TYPES ------------------------------ type Connection_Type is new APQ.Root_Connection_Type with private; type Notify_Proc_Type is access procedure(C : in out Connection_Type; Message : String); type Query_Type is new Root_Query_Type with private; type Blob_Type is private; type Root_Stream_Access is access all Str.Root_Stream_Type'Class; ------------------------------ -- DATABASE CONNECTION : ------------------------------ function Engine_Of(C : Connection_Type) return Database_Type; function New_Query(C : Connection_Type) return Root_Query_Type'Class; procedure Notify_on_Standard_Error(C : in out Connection_Type; Message : String); procedure Set_Instance(C : in out Connection_Type; Instance : String); function Host_Name(C : Connection_Type) return String; function Port(C : Connection_Type) return Integer; function Port(C : Connection_Type) return String; function DB_Name(C : Connection_Type) return String; function User(C : Connection_Type) return String; function Password(C : Connection_Type) return String; procedure Set_DB_Name(C : in out Connection_Type; DB_Name : String); procedure Set_Options(C : in out Connection_Type; Options : String); function Options(C : Connection_Type) return String; procedure Set_Notify_Proc(C : in out Connection_Type; Notify_Proc : Notify_Proc_Type); function Notify_Proc(C : Connection_Type) return Notify_Proc_Type; procedure Connect(C : in out Connection_Type; Check_Connection : Boolean := True); procedure Connect(C : in out Connection_Type; Same_As : Root_Connection_Type'Class); procedure Disconnect(C : in out Connection_Type); function Is_Connected(C : Connection_Type) return Boolean; procedure Reset(C : in out Connection_Type); function Error_Message(C : Connection_Type) return String; function Notice_Message(C : Connection_Type) return String; -- Open trace output file procedure Open_DB_Trace(C : in out Connection_Type; Filename : String; Mode : Trace_Mode_Type := Trace_APQ); procedure Close_DB_Trace(C : in out Connection_Type); -- Close trace output file procedure Set_Trace(C : in out Connection_Type; Trace_On : Boolean := True); -- Enable/Disable tracing function Is_Trace(C : Connection_Type) return Boolean; -- Test trace enabled/disabled function In_Abort_State(C : Connection_Type) return Boolean; No_Notify : constant Notify_Proc_Type := null; -- Null disables notification Standard_Error_Notify : constant Notify_Proc_Type; ------------------------------ -- SQL QUERY API : ------------------------------ procedure Clear(Q : in out Query_Type); procedure Append_Quoted(Q : in out Query_Type; Connection : Root_Connection_Type'Class; SQL : String; After : String := ""); procedure Execute(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class); procedure Execute_Checked(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class; Msg : String := ""); procedure Begin_Work(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class); procedure Commit_Work(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class); procedure Rollback_Work(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class); procedure Rewind(Q : in out Query_Type); procedure Fetch(Q : in out Query_Type); procedure Fetch(Q : in out Query_Type; TX : Tuple_Index_Type); function End_of_Query(Q : Query_Type) return Boolean; -- Avoid use (catch exception instead) function Tuple(Q : Query_Type) return Tuple_Index_Type; function Tuples(Q : Query_Type) return Tuple_Count_Type; function Columns(Q : Query_Type) return Natural; function Column_Name(Q : Query_Type; CX : Column_Index_Type) return String; function Column_Index(Q : Query_Type; Name : String) return Column_Index_Type; function Column_Type(Q : Query_Type; CX : Column_Index_Type) return Row_ID_Type; function Is_Null(Q : Query_Type; CX : Column_Index_Type) return Boolean; function Value(Query : Query_Type; CX : Column_Index_Type) return String; function Result(Query : Query_Type) return Natural; -- Returns Result_Type'Pos() function Result(Query : Query_Type) return Result_Type; function Command_Oid(Query : Query_Type) return Row_ID_Type; function Null_Oid(Query : Query_Type) return Row_ID_Type; function Command_Status(Query : Query_Type) return String; -- PostgreSQL only function Error_Message(Query : Query_Type) return String; function Is_Duplicate_Key(Query : Query_Type) return Boolean; function Engine_Of(Q : Query_Type) return Database_Type; ------------------------------ -- BLOB API : ------------------------------ Buf_Size_Default : constant Natural; type Blob_Count is new Ada.Streams.Stream_Element_Offset range 0..Ada.Streams.Stream_Element_Offset'Last; subtype Blob_Offset is Blob_Count range 1..Blob_Count'Last; function Blob_Create(DB : access Connection_Type; Buf_Size : Natural := Buf_Size_Default) return Blob_Type; function Blob_Open(DB : access Connection_Type; Oid : Row_ID_Type; Mode : Mode_Type; Buf_Size : Natural := Buf_Size_Default) return Blob_Type; procedure Blob_Flush(Blob : Blob_Type); procedure Blob_Close(Blob : in out Blob_Type); procedure Blob_Set_Index (Blob : Blob_Type; To : Blob_Offset); function Blob_Index(Blob : Blob_Type) return Blob_Offset; function End_of_Blob(Blob : Blob_Type) return Boolean; function Blob_Oid(Blob : Blob_Type) return Row_ID_Type; function Blob_Size(Blob : Blob_Type) return Blob_Count; function Blob_Stream(Blob : Blob_Type) return Root_Stream_Access; procedure Blob_Unlink(DB : Connection_Type; Oid : Row_ID_Type); procedure Blob_Import(DB : Connection_Type; Pathname : String; Oid : out Row_ID_Type); procedure Blob_Export(DB : Connection_Type; Oid : Row_ID_Type; Pathname : String); generic type Oid_Type is new Row_ID_Type; function Generic_Blob_Open(DB : access Connection_Type; Oid : Oid_Type; Mode : Mode_Type; Buf_Size : Natural := Buf_Size_Default) return Blob_Type; generic type Oid_Type is new Row_ID_Type; function Generic_Blob_Oid(Blob : Blob_Type) return Oid_Type; generic type Oid_Type is new Row_ID_Type; procedure Generic_Blob_Unlink(DB : Connection_Type; Oid : Oid_Type); generic type Oid_Type is new Row_ID_Type; procedure Generic_Blob_Import(DB : Connection_Type; Pathname : String; Oid : out Oid_Type); generic type Oid_Type is new Row_ID_Type; procedure Generic_Blob_Export(DB : Connection_Type; Oid : Oid_Type; Pathname : String); private type PG_Conn is new System.Address; Null_Connection : PG_Conn := PG_Conn(System.Null_Address); --------------------- -- CONNECTION_TYPE -- --------------------- type Connection_Type is new APQ.Root_Connection_Type with record Options : String_Ptr; -- Debug and trace options, if any Connection : PG_Conn := Null_Connection; Error_Message : String_Ptr; -- Error message after failed to connect (only) Notice : String_Ptr; -- Last notice message if any Notify_Proc : Notify_Proc_Type; -- Notify procedure or NULL end record; procedure Initialize(C : in out Connection_Type); procedure Finalize(C : in out Connection_Type); function Internal_Connection(C : Connection_Type) return PG_Conn; function Query_Factory( C: in Connection_Type ) return Root_Query_Type'Class; type PQ_Result is new System.Address; Null_Result : PQ_Result := PQ_Result(System.Null_Address); type Query_Type is new Root_Query_Type with record Result : PQ_Result := Null_Result; -- Result from a command end record; procedure Adjust(Q : in out Query_Type); procedure Finalize(Q : in out Query_Type); function SQL_Code(Query : Query_Type) return SQL_Code_Type; type Blob_Fd is range -2 ** 31 .. 2 ** 31 - 1; type Blob_Object(Conn : access Connection_Type) is new Ada.Streams.Root_Stream_Type with record Oid : Row_ID_Type := Row_ID_Type'First; -- Oid of this blob Mode : Mode_Type := Read; -- I/O mode of blob Fd : Blob_Fd := -1; -- Blob file descriptor Buffer : Stream_Element_Array_Ptr; -- The stream buffer, if any Buf_Empty : Boolean := True; -- True when buffer is empty Buf_Dirty : Boolean := False; -- True when the buffer needs writing out Buf_Size : Str.Stream_Element_Offset := 0; -- The logical size of the buffer Buf_Offset : Str.Stream_Element_Offset := 0; -- The physical offset of the buffer Log_Offset : Str.Stream_Element_Offset := 0; -- The current logical offset within the blob Phy_Offset : Str.Stream_Element_Offset := 0; -- Physical blob offset The_Size : Str.Stream_Element_Offset := 0; -- The blob's size in bytes end record; type Blob_Type is access all Blob_Object; procedure Finalize(Blob : in out Blob_Object); procedure Read( Stream: in out Blob_Object; Item: out Ada.Streams.Stream_Element_Array; Last: out Ada.Streams.Stream_Element_Offset ); procedure Write( Stream: in out Blob_Object; Item: in Ada.Streams.Stream_Element_Array ); Buf_Size_Default : constant Natural := 5 * 1024; Standard_Error_Notify : constant Notify_Proc_Type := Notify_on_Standard_Error'Access; pragma Inline(Is_Connected); pragma Inline(In_Abort_State); pragma Inline(Clear_Abort_State); pragma Inline(Raise_Exceptions); pragma Inline(Report_Errors); pragma Inline(Rewind); pragma Inline(End_Of_Query); pragma Inline(Blob_Oid); pragma Inline(End_Of_Blob); end APQ.PostgreSQL.Client; apq-postgresql-3.2.0/src/apq-postgresql-decimal.adb000066400000000000000000000410621172102510600223110ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- APQ DATABASE BINDINGS -- -- -- -- A P Q - POSTGRESQL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Warren W. Gay VE3WWG -- -- Copyright (C) 2007-2009, Ada Works Project -- -- -- -- -- -- APQ is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. APQ is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with APQ; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- ------------------------------------------------------------------------------ with Interfaces.C, Interfaces.C.Strings; use Interfaces.C, Interfaces.C.Strings; package body APQ.PostgreSQL.Decimal is type numeric_ex is ( C_No_Error, C_Numeric_Format, C_Numeric_Overflow, C_Undefined_Result, C_Divide_By_Zero ); for numeric_ex use ( 0, -- No_Error 1, -- Numeric_Format 2, -- Numeric_Overflow 3, -- Undefined_Result 4 -- Divide_By_Zero ); for numeric_ex'Size use 32; function numeric_global_rscale return Rscale_Type; pragma Import(C,numeric_global_rscale,"numeric_global_rscale"); procedure numeric_free(num : Numeric_Type); pragma Import(C,numeric_free,"numeric_free"); procedure free_cstring(ptr : chars_ptr); pragma Import(C,free_cstring,"numeric_free"); function numeric_isnan(num : Numeric_Type) return int; pragma Import(C,numeric_isnan,"numeric_isnan"); function numeric_in(str : System.Address; precision, scale : int; ex : System.Address) return Numeric_Type; pragma Import(C,numeric_in,"numeric_in"); function numeric_out(num : Numeric_Type) return chars_ptr; pragma Import(C,numeric_out,"numeric_out"); function numeric(num : Numeric_Type; precision, scale : int; ex : System.Address) return Numeric_Type; pragma Import(C,numeric,"numeric"); function numeric_uplus(num : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_uplus,"numeric_uplus"); function numeric_add(num1, num2 : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_add,"numeric_add"); function numeric_sub(num1, num2 : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_sub,"numeric_sub"); function numeric_mul(num1, num2 : Numeric_Type; global_rscale : System.Address) return Numeric_Type; pragma Import(C,numeric_mul,"numeric_mul"); function numeric_div(num1, num2 : Numeric_Type; global_rscale, ex : System.Address) return Numeric_Type; pragma Import(C,numeric_div,"numeric_div"); function numeric_abs(num : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_abs,"numeric_abs"); function numeric_uminus(num : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_uminus,"numeric_uminus"); function numeric_sign(num : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_sign,"numeric_sign"); function numeric_round(num : Numeric_Type; Scale : int) return Numeric_Type; pragma Import(C,numeric_round,"numeric_round"); function numeric_trunc(num : Numeric_Type; Scale : int) return Numeric_Type; pragma Import(C,numeric_trunc,"numeric_trunc"); function numeric_ceil(num : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_ceil,"numeric_ceil"); function numeric_floor(num : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_floor,"numeric_floor"); function numeric_eq(num1, num2 : Numeric_Type) return int; pragma Import(C,numeric_eq,"numeric_eq"); function numeric_ne(num1, num2 : Numeric_Type) return int; pragma Import(C,numeric_ne,"numeric_ne"); function numeric_gt(num1, num2 : Numeric_Type) return int; pragma Import(C,numeric_gt,"numeric_gt"); function numeric_ge(num1, num2 : Numeric_Type) return int; pragma Import(C,numeric_ge,"numeric_ge"); function numeric_lt(num1, num2 : Numeric_Type) return int; pragma Import(C,numeric_lt,"numeric_lt"); function numeric_le(num1, num2 : Numeric_Type) return int; pragma Import(C,numeric_le,"numeric_le"); function numeric_smaller(num1, num2 : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_smaller,"numeric_smaller"); function numeric_larger(num1, num2 : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_larger,"numeric_larger"); function numeric_sqrt(num : Numeric_Type; global_rscale, ex : System.Address) return Numeric_Type; pragma Import(C,numeric_sqrt,"numeric_sqrt"); function numeric_exp(num : Numeric_Type; global_rscale, ex : System.Address) return Numeric_Type; pragma Import(C,numeric_exp,"numeric_exp"); function numeric_ln(num : Numeric_Type; global_rscale, ex : System.Address) return Numeric_Type; pragma Import(C,numeric_ln,"numeric_ln"); function numeric_log(num, base : Numeric_Type; global_rscale, ex : System.Address) return Numeric_Type; pragma Import(C,numeric_log,"numeric_log"); function numeric_power(x, y : Numeric_Type; global_rscale, ex : System.Address) return Numeric_Type; pragma Import(C,numeric_power,"numeric_power"); procedure Free(Num : in out Numeric_Type) is begin if Num /= Null_Numeric then numeric_free(Num); Num := Null_Numeric; end if; end Free; procedure Raise_Exception(Ex : numeric_ex) is begin case Ex is when C_No_Error => return; when C_Numeric_Format => raise Decimal_Format; when C_Numeric_Overflow => raise Decimal_Overflow; when C_Undefined_Result => raise Undefined_Result; when C_Divide_By_Zero => raise Divide_By_Zero; end case; end Raise_Exception; -- private procedure Initialize(DT : in out Decimal_Type) is begin DT.Global_Rscale := numeric_global_rscale; end Initialize; procedure Finalize(DT : in out Decimal_Type) is begin Free(DT.Numeric); end Finalize; procedure Adjust(DT : in out Decimal_Type) is Num : Numeric_Type := DT.Numeric; begin if DT.Numeric = Null_Numeric or else Is_NaN(DT) then return; -- Nothing further to adjust end if; DT.Numeric := numeric_uplus(DT.Numeric); end Adjust; -- public function Is_Nan(DT : Decimal_Type) return Boolean is begin return DT.Numeric = Null_Numeric or else numeric_isnan(DT.Numeric) /= 0; end Is_Nan; procedure Convert(DT : in out Decimal_Type; S : String; Precision : Precision_Type := 0; Scale : Scale_Type := 2) is C_String : char_array := To_C(S); P : int := int(Precision); Sc : int := int(Scale); Ex : numeric_ex; begin if DT.Numeric /= Null_Numeric then Free(DT.Numeric); end if; DT.Numeric := numeric_in(C_String'Address,P,Sc,Ex'Address); if Ex /= C_No_Error then Raise_Exception(Ex); end if; end Convert; function To_String(DT : Decimal_Type) return String is begin if Is_Nan(DT) then raise Decimal_NaN; end if; declare C_Ptr : chars_ptr := numeric_out(DT.Numeric); begin if C_Ptr = Null_Ptr then return "NULL"; else declare S : String := To_Ada(Value(C_Ptr)); begin free_cstring(C_Ptr); return S; end; end if; end; end To_String; function Constrain(DT : Decimal_Type; Precision : Precision_Type; Scale : Scale_Type) return Decimal_Type is R : Decimal_Type; P : int := int(Precision); S : int := int(Scale); E : numeric_ex; begin if Is_Nan(DT) then raise Decimal_NaN; else if Precision /= 0 then R.Numeric := numeric(DT.Numeric,P,S,E'Address); -- Set precision and scale if E /= C_No_Error then Raise_Exception(E); end if; else R.Numeric := numeric_uplus(DT.Numeric); -- Just copy end if; end if; return R; end Constrain; function Abs_Value(DT : Decimal_Type) return Decimal_Type is begin if Is_NaN(DT) then raise Decimal_NaN; end if; declare R : Decimal_Type; begin R.Numeric := numeric_abs(DT.Numeric); return R; end; end Abs_Value; function Sign(DT : Decimal_Type) return Decimal_Type is begin if Is_NaN(DT) then raise Decimal_NaN; end if; declare R : Decimal_Type; begin R.Numeric := numeric_sign(DT.Numeric); return R; end; end Sign; function Ceil(DT : Decimal_Type) return Decimal_Type is begin if Is_NaN(DT) then raise Decimal_NaN; end if; declare R : Decimal_Type; begin R.Numeric := numeric_ceil(DT.Numeric); return R; end; end Ceil; function Floor(DT : Decimal_Type) return Decimal_Type is begin if Is_NaN(DT) then raise Decimal_NaN; end if; declare R : Decimal_Type; begin R.Numeric := numeric_floor(DT.Numeric); return R; end; end Floor; function Round(DT : Decimal_Type; Scale : Scale_Type) return Decimal_Type is begin if Is_NaN(DT) then raise Decimal_NaN; end if; declare R : Decimal_Type; begin R.Numeric := numeric_round(DT.Numeric,int(Scale)); return R; end; end Round; function Trunc(DT : Decimal_Type; Scale : Scale_Type) return Decimal_Type is begin if Is_NaN(DT) then raise Decimal_NaN; end if; declare R : Decimal_Type; begin R.Numeric := numeric_trunc(DT.Numeric,int(Scale)); return R; end; end Trunc; function Min_Value(Left, Right : Decimal_Type) return Decimal_Type is begin if Is_NaN(Left) or else Is_Nan(Right) then raise Decimal_NaN; end if; declare R : Decimal_Type; begin R.Numeric := numeric_smaller(Left.Numeric,Right.Numeric); return R; end; end Min_Value; function Max_Value(Left, Right : Decimal_Type) return Decimal_Type is begin if Is_NaN(Left) or else Is_Nan(Right) then raise Decimal_NaN; end if; declare R : Decimal_Type; begin R.Numeric := numeric_larger(Left.Numeric,Right.Numeric); return R; end; end Max_Value; function Sqrt(X : Decimal_Type) return Decimal_Type is begin if Is_NaN(X) then raise Decimal_NaN; end if; declare R : Decimal_Type; E : numeric_ex; begin R.Numeric := numeric_sqrt(X.Numeric,R.Global_Rscale'Address,E'Address); if E /= C_No_Error then Raise_Exception(E); end if; return R; end; end Sqrt; function Exp(X : Decimal_Type) return Decimal_Type is begin if Is_NaN(X) then raise Decimal_NaN; end if; declare R : Decimal_Type; E : numeric_ex; begin R.Numeric := numeric_exp(X.Numeric,R.Global_Rscale'Address,E'Address); if E /= C_No_Error then Raise_Exception(E); end if; return R; end; end Exp; function Ln(X : Decimal_Type) return Decimal_Type is begin if Is_NaN(X) then raise Decimal_NaN; end if; declare R : Decimal_Type; E : numeric_ex; begin R.Numeric := numeric_ln(X.Numeric,R.Global_Rscale'Address,E'Address); if E /= C_No_Error then Raise_Exception(E); end if; return R; end; end Ln; function Log10(X : Decimal_Type) return Decimal_Type is begin if Is_NaN(X) then raise Decimal_NaN; end if; declare R : Decimal_Type; E : numeric_ex; begin R.Numeric := numeric_log(Ten.Numeric,X.Numeric,R.Global_Rscale'Address,E'Address); if E /= C_No_Error then Raise_Exception(E); end if; return R; end; end Log10; function Log(X, Base : Decimal_Type) return Decimal_Type is begin if Is_NaN(X) or else Is_Nan(Base) then raise Decimal_NaN; end if; declare R : Decimal_Type; E : numeric_ex; begin R.Numeric := numeric_log(Base.Numeric,X.Numeric,R.Global_Rscale'Address,E'Address); if E /= C_No_Error then Raise_Exception(E); end if; return R; end; end Log; function Power(X, Y : Decimal_Type) return Decimal_Type is begin if Is_NaN(X) or else Is_Nan(Y) then raise Decimal_NaN; end if; declare R : Decimal_Type; E : numeric_ex; begin R.Numeric := numeric_power(X.Numeric,Y.Numeric,R.Global_Rscale'Address,E'Address); if E /= C_No_Error then Raise_Exception(E); end if; return R; end; end Power; function "+"(Left, Right : Decimal_Type) return Decimal_Type is R : Decimal_Type; begin R.Numeric := numeric_add(Left.Numeric,Right.Numeric); if Is_Nan(R) then raise Decimal_NaN; end if; return R; end "+"; function "-"(Left, Right : Decimal_Type) return Decimal_Type is R : Decimal_Type; begin R.Numeric := numeric_sub(Left.Numeric,Right.Numeric); if Is_Nan(R) then raise Decimal_NaN; end if; return R; end "-"; function "-"(DT : Decimal_Type) return Decimal_Type is R : Decimal_Type; begin if Is_NaN(DT) then raise Decimal_NaN; end if; R.Numeric := numeric_uminus(DT.Numeric); return R; end "-"; function "*"(Left, Right : Decimal_Type) return Decimal_Type is R : Decimal_Type; begin R.Numeric := numeric_mul(Left.Numeric,Right.Numeric,R.Global_Rscale'Address); if Is_Nan(R) then raise Decimal_NaN; end if; return R; end "*"; function "/"(Left, Right : Decimal_Type) return Decimal_Type is R : Decimal_Type; E : numeric_ex; begin R.Numeric := numeric_div(Left.Numeric,Right.Numeric,R.Global_Rscale'Address,E'Address); if E /= C_No_Error then Raise_Exception(E); end if; if Is_Nan(R) then raise Decimal_NaN; end if; return R; end "/"; function "="(Left, Right : Decimal_Type) return Boolean is begin if Is_NaN(Left) or else Is_Nan(Right) then raise Decimal_NaN; end if; return numeric_eq(Left.Numeric,Right.Numeric) /= 0; end "="; function ">"(Left, Right : Decimal_Type) return Boolean is begin if Is_NaN(Left) or else Is_Nan(Right) then raise Decimal_NaN; end if; return numeric_gt(Left.Numeric,Right.Numeric) /= 0; end ">"; function ">="(Left, Right : Decimal_Type) return Boolean is begin if Is_NaN(Left) or else Is_Nan(Right) then raise Decimal_NaN; end if; return numeric_ge(Left.Numeric,Right.Numeric) /= 0; end ">="; function "<"(Left, Right : Decimal_Type) return Boolean is begin if Is_NaN(Left) or else Is_Nan(Right) then raise Decimal_NaN; end if; return numeric_lt(Left.Numeric,Right.Numeric) /= 0; end "<"; function "<="(Left, Right : Decimal_Type) return Boolean is begin if Is_NaN(Left) or else Is_Nan(Right) then raise Decimal_NaN; end if; return numeric_le(Left.Numeric,Right.Numeric) /= 0; end "<="; Const_Nan : Decimal_Type; Const_Zero, Const_One, Const_Two, Const_Ten : Decimal_Type; -- Constants after elaboration function NaN return Decimal_Type is begin return Const_NaN; end Nan; function Zero return Decimal_Type is begin return Const_Zero; end Zero; function One return Decimal_Type is begin return Const_One; end One; function Two return Decimal_Type is begin return Const_Two; end Two; function Ten return Decimal_Type is begin return Const_Ten; end Ten; procedure Append(Query : in out PostgreSQL.Client.Query_Type; DT : Decimal_Type'Class; After : String := "") is use PostgreSQL.Client; begin Append(Query,To_String(DT),After); end Append; function Value(Query : PostgreSQL.Client.Query_Type; CX : Column_Index_Type) return Decimal_Type is use PostgreSQL.Client; begin if Is_Null(Query,CX) then return NaN; else declare S : String := Value(Query,CX); R : Decimal_Type; begin Convert(R,S); return R; end; end if; end Value; begin Convert(Const_Zero,"0"); Convert(Const_One,"1"); Convert(Const_Two,"2"); Convert(Const_Ten,"10"); end APQ.PostgreSQL.Decimal; -- End $Source: /cvsroot/apq/apq/apq-postgresql-decimal.adb,v $ apq-postgresql-3.2.0/src/apq-postgresql-decimal.ads000066400000000000000000000130141172102510600223260ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- APQ DATABASE BINDINGS -- -- -- -- A P Q - POSTGRESQL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Warren W. Gay VE3WWG -- -- Copyright (C) 2007-2009, Ada Works Project -- -- -- -- -- -- APQ is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. APQ is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with APQ; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- ------------------------------------------------------------------------------ with System; with Interfaces; with Ada.Finalization; with APQ.PostgreSQL.Client; package APQ.PostgreSQL.Decimal is Decimal_NaN : exception; Decimal_Format : exception; Decimal_Overflow : exception; Undefined_Result : exception; Divide_By_Zero : exception; type Decimal_Type is new Ada.Finalization.Controlled with private; type Precision_Type is range 0..32767; -- Implementation may not actually live up to these limits type Scale_Type is range 0..32767; -- Ditto. function Is_Nan(DT : Decimal_Type) return Boolean; procedure Convert(DT : in out Decimal_Type; S : String; Precision : Precision_Type := 0; Scale : Scale_Type := 2); function To_String(DT : Decimal_Type) return String; function Constrain(DT : Decimal_Type; Precision : Precision_Type; Scale : Scale_Type) return Decimal_Type; function Abs_Value(DT : Decimal_Type) return Decimal_Type; function Sign(DT : Decimal_Type) return Decimal_Type; function Ceil(DT : Decimal_Type) return Decimal_Type; function Floor(DT : Decimal_Type) return Decimal_Type; function Round(DT : Decimal_Type; Scale : Scale_Type) return Decimal_Type; function Trunc(DT : Decimal_Type; Scale : Scale_Type) return Decimal_Type; function Min_Value(Left, Right : Decimal_Type) return Decimal_Type; function Max_Value(Left, Right : Decimal_Type) return Decimal_Type; function Sqrt(X : Decimal_Type) return Decimal_Type; function Exp(X : Decimal_Type) return Decimal_Type; function Ln(X : Decimal_Type) return Decimal_Type; function Log10(X : Decimal_Type) return Decimal_Type; function Log(X, Base : Decimal_Type) return Decimal_Type; function Power(X, Y : Decimal_Type) return Decimal_Type; function "+"(Left, Right : Decimal_Type) return Decimal_Type; function "-"(Left, Right : Decimal_Type) return Decimal_Type; function "-"(DT : Decimal_Type) return Decimal_Type; function "*"(Left, Right : Decimal_Type) return Decimal_Type; function "/"(Left, Right : Decimal_Type) return Decimal_Type; function "="(Left, Right : Decimal_Type) return Boolean; function ">"(Left, Right : Decimal_Type) return Boolean; function ">="(Left, Right : Decimal_Type) return Boolean; function "<"(Left, Right : Decimal_Type) return Boolean; function "<="(Left, Right : Decimal_Type) return Boolean; function NaN return Decimal_Type; function Zero return Decimal_Type; function One return Decimal_Type; function Two return Decimal_Type; function Ten return Decimal_Type; procedure Append(Query : in out PostgreSQL.Client.Query_Type; DT : Decimal_Type'Class; After : String := ""); function Value(Query : PostgreSQL.Client.Query_Type; CX : Column_Index_Type) return Decimal_Type; private type Rscale_Type is range -2 ** 31 .. 2 ** 31 - 1; type Numeric_Type is new System.Address; Null_Numeric : constant Numeric_Type := Numeric_Type(System.Null_Address); type Decimal_Type is new Ada.Finalization.Controlled with record Global_Rscale : Rscale_Type; Precision : Precision_Type := 0; Scale : Scale_Type := 0; Numeric : Numeric_Type := Null_Numeric; end record; procedure Initialize(DT : in out Decimal_Type); procedure Finalize(DT : in out Decimal_Type); procedure Adjust(DT : in out Decimal_Type); end APQ.PostgreSQL.Decimal; -- End $Source: /cvsroot/apq/apq/apq-postgresql-decimal.ads,v $ apq-postgresql-3.2.0/src/apq-postgresql.ads-e000066400000000000000000000113061172102510600211560ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- APQ DATABASE BINDINGS -- -- -- -- A P Q -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Warren W. Gay VE3WWG -- -- Copyright (C) 2007-2009, Ada Works Project -- -- -- -- -- -- APQ is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. APQ is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with APQ; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ------------------------------------------------------------------------------ ------------------------------------------------------------------------------- -- This is the base package for the PostreSQL driver for APQ. -- ------------------------------------------------------------------------------- package APQ.PostgreSQL is %POSTGRESQL_LIBS% type Result_Type is ( Empty_Query, Command_OK, Tuples_OK, Copy_Out, Copy_In, Bad_Response, Nonfatal_Error, Fatal_Error ); for Result_Type use ( Empty_Query => 0, Command_OK => 1, Tuples_OK => 2, Copy_Out => 3, Copy_In => 4, Bad_Response => 5, Nonfatal_Error => 6, Fatal_Error => 7 ); subtype PG_Smallint is APQ_Smallint; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Integer is APQ_Integer; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Bigint is APQ_Bigint; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Real is APQ_Real; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Double is APQ_Double; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Serial is APQ_Serial; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Bigserial is APQ_Bigserial; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Oid is APQ.Row_ID_Type; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Boolean is Boolean; -- For compatibility only (use APQ_Boolean or Boolean instead) subtype PG_Date is APQ_Date; -- For compatibility only (use APQ_Date instead) subtype PG_Time is APQ_Time; -- For compatibility only (use APQ_Time instead) subtype PG_Timestamp is APQ_Timestamp; -- For compatibility only (use APQ_Timestamp instead) --subtype PG_Timezone is APQ_Timezone; -- For compatibility only (use APQ_Timestamp instead) subtype PG_Bitstring is APQ_Bitstring; -- For compatibility only (use APQ_Timestamp instead) type Mode_Type is ( Write, Read, Read_Write ); for Mode_Type use ( Write => 16#00020000#, -- Write access Read => 16#00040000#, -- Read access Read_Write => 16#00060000# -- Read/Write access ); for Mode_Type'Size use 32; private type PQOid_Type is mod 2 ** 32; -- Currently PostgreSQL uses unsigned int for Oid Null_Row_ID : constant Row_ID_Type := 0; -- Value representing no OID end APQ.PostgreSQL; apq-postgresql-3.2.0/src/decimal.h000066400000000000000000000120451172102510600170310ustar00rootroot00000000000000/****************************************************************************/ /* APQ DATABASE BINDINGS */ /* */ /* A P Q - POSTGRESQL */ /* */ /* S p e c */ /* */ /* Copyright (C) 2002-2007, Warren W. Gay VE3WWG */ /* Copyright (C) 2007-2009, Ada Works Project */ /* */ /* */ /* APQ is free software; you can redistribute it and/or modify it under */ /* terms of the GNU General Public License as published by the Free Soft- */ /* ware Foundation; either version 2, or (at your option) any later ver- */ /* sion. APQ is distributed in the hope that it will be useful, but WITH- */ /* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY */ /* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License */ /* for more details. You should have received a copy of the GNU General */ /* Public License distributed with APQ; see file COPYING. If not, write */ /* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, */ /* MA 02111-1307, USA. */ /* */ /* As a special exception, if other files instantiate generics from this */ /* unit, or you link this unit with other files to produce an executable, */ /* this unit does not by itself cause the resulting executable to be */ /* covered by the GNU General Public License. This exception does not */ /* however invalidate any other reasons why the executable file might be */ /* covered by the GNU Public License. */ /****************************************************************************/ #ifndef _DECIMAL_H_ #define _DECIMAL_H_ 1 #include "pgtypes.h" #include "numeric.h" enum Num_Exception { No_Error = 0, Numeric_Format, Numeric_Overflow, Undefined_Result, Divide_By_Zero }; typedef enum Num_Exception Decimal_Exception; extern int numeric_global_rscale(void); /* Initial value for global_rscale */ extern void numeric_free(Numeric num); /* Free storage used by Numeric */ extern int numeric_isnan(Numeric num); /* Test for NaN */ extern Numeric numeric_nan(void); /* Create a NaN */ extern Numeric numeric_in(const char *str,int precision,int scale,Decimal_Exception *ex); extern char * numeric_out(Numeric num); /* Numeric to String */ extern Numeric numeric(Numeric num, int precision, int scale, Decimal_Exception *ex); extern Numeric numeric_abs(Numeric num); /* Absolute value */ extern Numeric numeric_uminus(Numeric num); /* Unary minus */ extern Numeric numeric_uplus(Numeric num); /* Copy value */ extern Numeric numeric_sign(Numeric num); /* Determine sign */ extern Numeric numeric_round(Numeric num,int scale); /* Round */ extern Numeric numeric_trunc(Numeric num,int scale); /* Truncate */ extern Numeric numeric_ceil(Numeric num); /* Ceiling */ extern Numeric numeric_floor(Numeric num); /* Floor */ extern int numeric_cmp(Numeric num1, Numeric num2); /* Compare */ extern int numeric_eq(Numeric num1, Numeric num2); /* = */ extern int numeric_ne(Numeric num1, Numeric num2); /* != */ extern int numeric_gt(Numeric num1, Numeric num2); /* > */ extern int numeric_ge(Numeric num1, Numeric num2); /* >= */ extern int numeric_lt(Numeric num1, Numeric num2); /* < */ extern int numeric_le(Numeric num1, Numeric num2); /* <= */ extern Numeric numeric_add(Numeric num1, Numeric num2); /* + */ extern Numeric numeric_sub(Numeric num1, Numeric num2); /* - */ extern Numeric numeric_mul(Numeric num1, Numeric num2, int *global_rscale); /* * */ extern Numeric numeric_div(Numeric num1, Numeric num2, int *global_rscale, Decimal_Exception *ex); /* / */ extern Numeric numeric_mod(Numeric num1, Numeric num2, int *global_rscale, Decimal_Exception *ex); /* % */ extern Numeric numeric_smaller(Numeric num1, Numeric num2); /* min(a,b) */ extern Numeric numeric_larger(Numeric num1, Numeric num2); /* max(a,b) */ extern Numeric numeric_sqrt(Numeric num, int *global_rscale,Decimal_Exception *ex); /* Square root */ extern Numeric numeric_exp(Numeric num, int *global_rscale, Decimal_Exception *ex); /* Exponent */ extern Numeric numeric_ln(Numeric num, int *global_rscale, Decimal_Exception *ex); /* Ln */ extern Numeric numeric_log(Numeric num1, Numeric num2, int *global_rscale, Decimal_Exception *ex); /* Log */ extern Numeric numeric_power(Numeric num1, Numeric num2, int *global_rscale, Decimal_Exception *ex); /* Power */ #endif /* _DECIMAL_H_ */ /* End $Source: /cvsroot/apq/apq/decimal.h,v $ */ apq-postgresql-3.2.0/src/notices.c000066400000000000000000000055451172102510600171010ustar00rootroot00000000000000/****************************************************************************/ /* APQ DATABASE BINDINGS */ /* */ /* A P Q - POSTGRESQL */ /* */ /* B o d y */ /* */ /* Copyright (C) 2002-2007, Warren W. Gay VE3WWG */ /* Copyright (C) 2007-2009, Ada Works Project */ /* */ /* */ /* APQ is free software; you can redistribute it and/or modify it under */ /* terms of the GNU General Public License as published by the Free Soft- */ /* ware Foundation; either version 2, or (at your option) any later ver- */ /* sion. APQ is distributed in the hope that it will be useful, but WITH- */ /* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY */ /* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License */ /* for more details. You should have received a copy of the GNU General */ /* Public License distributed with APQ; see file COPYING. If not, write */ /* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, */ /* MA 02111-1307, USA. */ /* */ /* As a special exception, if other files instantiate generics from this */ /* unit, or you link this unit with other files to produce an executable, */ /* this unit does not by itself cause the resulting executable to be */ /* covered by the GNU General Public License. This exception does not */ /* however invalidate any other reasons why the executable file might be */ /* covered by the GNU Public License. */ /****************************************************************************/ #include #include /* * Connection_Notify is an Ada procedure using C calling convention : */ extern void Connection_Notify(void *arg,const char *message); /* * A do-nothing notices callback : */ static void notices_dud(void *arg,const char *message) { return; } /* * Install a new notices callback : */ void notice_install(PGconn *conn,void *ada_obj_ptr) { PQsetNoticeProcessor(conn,Connection_Notify,ada_obj_ptr); } /* * Disable callbacks to the Connection_Notify Ada procedure : */ void notice_uninstall(PGconn *conn) { PQsetNoticeProcessor(conn,notices_dud,NULL); } /* End $Source: /cvsroot/apq/apq/notices.c,v $ */ apq-postgresql-3.2.0/src/numeric.c000066400000000000000000002017621172102510600170760ustar00rootroot00000000000000/****************************************************************************/ /* APQ DATABASE BINDINGS */ /* */ /* A P Q - POSTGRESQL */ /* */ /* B o d y */ /* */ /* Copyright (C) 2002-2007, Warren W. Gay VE3WWG */ /* Copyright (C) 2007-2009, Ada Works Project */ /* */ /* */ /* APQ is free software; you can redistribute it and/or modify it under */ /* terms of the GNU General Public License as published by the Free Soft- */ /* ware Foundation; either version 2, or (at your option) any later ver- */ /* sion. APQ is distributed in the hope that it will be useful, but WITH- */ /* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY */ /* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License */ /* for more details. You should have received a copy of the GNU General */ /* Public License distributed with APQ; see file COPYING. If not, write */ /* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, */ /* MA 02111-1307, USA. */ /* */ /* As a special exception, if other files instantiate generics from this */ /* unit, or you link this unit with other files to produce an executable, */ /* this unit does not by itself cause the resulting executable to be */ /* covered by the GNU General Public License. This exception does not */ /* however invalidate any other reasons why the executable file might be */ /* covered by the GNU Public License. */ /****************************************************************************/ #include #include #include "decimal.h" /* ---------- * Uncomment the following to enable compilation of dump_numeric() * and dump_var() and to get a dump of any result produced by make_result(). * ---------- #define NUMERIC_DEBUG */ /* ---------- * Local definitions * ---------- */ #ifndef MIN #define MIN(a,b) (((a)<(b)) ? (a) : (b)) #endif #ifndef MAX #define MAX(a,b) (((a)>(b)) ? (a) : (b)) #endif #ifndef NAN #define NAN (0.0/0.0) #endif #define nan_var(v) free_var(v) /* ---------- * Local data types * * Note: the first digit of a NumericVar's value is assumed to be multiplied * by 10 ** weight. Another way to say it is that there are weight+1 digits * before the decimal point. It is possible to have weight < 0. * * The value represented by a NumericVar is determined by the sign, weight, * ndigits, and digits[] array. The rscale and dscale are carried along, * but they are just auxiliary information until rounding is done before * final storage or display. (Scales are the number of digits wanted * *after* the decimal point. Scales are always >= 0.) * * buf points at the physical start of the palloc'd digit buffer for the * NumericVar. digits points at the first digit in actual use (the one * with the specified weight). We normally leave an unused byte or two * (preset to zeroes) between buf and digits, so that there is room to store * a carry out of the top digit without special pushups. We just need to * decrement digits (and increment weight) to make room for the carry digit. * * If buf is NULL then the digit buffer isn't actually palloc'd and should * not be freed --- see the constants below for an example. * * NB: All the variable-level functions are written in a style that makes it * possible to give one and the same variable as argument and destination. * This is feasible because the digit buffer is separate from the variable. * ---------- */ typedef unsigned char NumericDigit; typedef struct NumericVar { int ndigits; /* number of digits in digits[] - can be * 0! */ int weight; /* weight of first digit */ int rscale; /* result scale */ int dscale; /* display scale */ int sign; /* NUMERIC_POS, NUMERIC_NEG, or * NUMERIC_NAN */ NumericDigit *buf; /* start of palloc'd space for digits[] */ NumericDigit *digits; /* decimal digits */ } NumericVar; /* ---------- * Some preinitialized variables we need often * ---------- */ static NumericDigit const_zero_data[1] = {0}; static NumericVar const_zero = {0, 0, 0, 0, NUMERIC_POS, NULL, const_zero_data}; static NumericDigit const_one_data[1] = {1}; static NumericVar const_one = {1, 0, 0, 0, NUMERIC_POS, NULL, const_one_data}; static NumericDigit const_two_data[1] = {2}; static NumericVar const_two = {1, 0, 0, 0, NUMERIC_POS, NULL, const_two_data}; static NumericVar const_nan = {0, 0, 0, 0, NUMERIC_NAN, NULL, NULL}; /* ---------- * Local functions * ---------- */ #ifdef NUMERIC_DEBUG static void dump_numeric(char *str, Numeric num); static void dump_var(char *str, NumericVar *var); #else #define dump_numeric(s,n) #define dump_var(s,v) #endif #define digitbuf_alloc(size) ((NumericDigit *) palloc(size)) #define digitbuf_free(buf) \ do { \ if ((buf) != NULL) \ pfree(buf); \ } while (0) #define init_var(v) memset(v,0,sizeof(NumericVar)) static void alloc_var(NumericVar *var, int ndigits); static void free_var(NumericVar *var); static void zero_var(NumericVar *var); static void set_var_from_str(const char *str, NumericVar *dest, Decimal_Exception *ex); static void set_var_from_num(Numeric value, NumericVar *dest); static void set_var_from_var(NumericVar *value, NumericVar *dest); static char *get_str_from_var(NumericVar *var, int dscale); static Numeric make_result(NumericVar *var); static void apply_typmod(NumericVar *var, int precision, int scale, Decimal_Exception *ex); static int cmp_numerics(Numeric num1, Numeric num2); static int cmp_var(NumericVar *var1, NumericVar *var2); static void add_var(NumericVar *var1, NumericVar *var2, NumericVar *result); static void sub_var(NumericVar *var1, NumericVar *var2, NumericVar *result); static void mul_var(NumericVar *var1, NumericVar *var2, NumericVar *result, int *global_rscale); static void div_var(NumericVar *var1, NumericVar *var2, NumericVar *result, int *global_rscale, Decimal_Exception *ex); static int select_div_scale(NumericVar *var1, NumericVar *var2, int *global_rscale); static void mod_var(NumericVar *var1, NumericVar *var2, NumericVar *result, int *global_rscale, Decimal_Exception *ex); static void ceil_var(NumericVar *var, NumericVar *result); static void floor_var(NumericVar *var, NumericVar *result); static void sqrt_var(NumericVar *arg, NumericVar *result, int *global_rscale, Decimal_Exception *ex); static void exp_var(NumericVar *arg, NumericVar *result, int *global_rscale, Decimal_Exception *ex); static void ln_var(NumericVar *arg, NumericVar *result, int *global_rscale, Decimal_Exception *ex); static void log_var(NumericVar *base, NumericVar *num, NumericVar *result, int *global_rscale, Decimal_Exception *ex); static void power_var(NumericVar *base, NumericVar *exp, NumericVar *result, int *global_rscale, Decimal_Exception *ex); static int cmp_abs(NumericVar *var1, NumericVar *var2); static void add_abs(NumericVar *var1, NumericVar *var2, NumericVar *result); static void sub_abs(NumericVar *var1, NumericVar *var2, NumericVar *result); /* * Provide an initialization value for global_rscale : */ int numeric_global_rscale(void) { return NUMERIC_MIN_RESULT_SCALE; } /* ---------------------------------------------------------------------- * * Input-, output- and rounding-functions * * ---------------------------------------------------------------------- * numeric_in() - * * Input function for numeric data type : * NOTES: * When precision is zero, the precision and scale arguments are * ignored. Otherwise the converted value is made to fit the * parameters supplied, else Numeric_Overflow exception. * ---------- */ Numeric numeric_in(const char *str, int precision, int scale, Decimal_Exception *ex) { NumericVar value; Numeric res; *ex = No_Error; /* * Check for NaN */ if (strcmp(str, "NaN") == 0) return make_result(&const_nan); /* * Use set_var_from_str() to parse the input string and return it in * the packed DB storage format */ init_var(&value); set_var_from_str(str, &value, ex); if ( *ex != No_Error ) { res = make_result(&const_nan); } else { if ( precision != 0 ) apply_typmod(&value, precision, scale, ex); res = make_result(&value); } free_var(&value); return res; } /* ---------- * numeric_out() - * * Output function for numeric data type * ---------- */ char * numeric_out(Numeric num) { NumericVar x; char *str; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return pstrdup("NaN"); /* * Get the number in the variable format. * * Even if we didn't need to change format, we'd still need to copy the * value to have a modifiable copy for rounding. set_var_from_num() * also guarantees there is extra digit space in case we produce a * carry out from rounding. */ init_var(&x); set_var_from_num(num, &x); str = get_str_from_var(&x, x.dscale); free_var(&x); return str; } /* * Return TRUE if the value is NaN : */ int numeric_isnan(Numeric num) { return NUMERIC_IS_NAN(num); } /* ---------- * numeric() - * * This is a special function called by the Postgres database system * before a value is stored in a tuples attribute. The precision and * scale of the attribute have to be applied on the value. * ---------- */ Numeric numeric(Numeric num, int precision, int scale, Decimal_Exception *ex) { Numeric new; int maxweight; NumericVar var; *ex = No_Error; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); maxweight = precision - scale; /* * If the number is in bounds and due to the present result scale no * rounding could be necessary, just make a copy of the input and * modify its scale fields. */ if (num->n_weight < maxweight && scale >= num->n_rscale) { new = (Numeric) palloc(num->varlen); memcpy(new, num, num->varlen); new->n_rscale = scale; new->n_sign_dscale = NUMERIC_SIGN(new) | ((uint16) scale & NUMERIC_DSCALE_MASK); return new; } /* * We really need to fiddle with things - unpack the number into a * variable and let apply_typmod() do it. */ init_var(&var); set_var_from_num(num, &var); apply_typmod(&var, precision, scale, ex); new = make_result(&var); free_var(&var); return new; } /* * Release the storage occupied by this Numeric : * (designed to be called by Ada95) */ void numeric_free(Numeric num) { free(num); } /* ---------------------------------------------------------------------- * * Sign manipulation, rounding and the like * * ---------------------------------------------------------------------- */ Numeric numeric_abs(Numeric num) { Numeric res; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); /* * Do it the easy way directly on the packed format */ res = (Numeric) palloc(num->varlen); memcpy(res, num, num->varlen); res->n_sign_dscale = NUMERIC_POS | NUMERIC_DSCALE(num); return res; } Numeric numeric_uminus(Numeric num) { Numeric res; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); /* * Do it the easy way directly on the packed format */ res = (Numeric) palloc(num->varlen); memcpy(res, num, num->varlen); /* * The packed format is known to be totally zero digit trimmed always. * So we can identify a ZERO by the fact that there are no digits at * all. Do nothing to a zero. */ if (num->varlen != NUMERIC_HDRSZ) { /* Else, flip the sign */ if (NUMERIC_SIGN(num) == NUMERIC_POS) res->n_sign_dscale = NUMERIC_NEG | NUMERIC_DSCALE(num); else res->n_sign_dscale = NUMERIC_POS | NUMERIC_DSCALE(num); } return res; } /* * This effectively just copies the value : */ Numeric numeric_uplus(Numeric num) { Numeric res; res = (Numeric) palloc(num->varlen); memcpy(res, num, num->varlen); return res; } /* * Return the sign of the value : */ Numeric numeric_sign(Numeric num) { Numeric res; NumericVar result; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); init_var(&result); /* * The packed format is known to be totally zero digit trimmed always. * So we can identify a ZERO by the fact that there are no digits at * all. */ if (num->varlen == NUMERIC_HDRSZ) set_var_from_var(&const_zero, &result); else { /* * And if there are some, we return a copy of ONE with the sign of * our argument */ set_var_from_var(&const_one, &result); result.sign = NUMERIC_SIGN(num); } res = make_result(&result); free_var(&result); return res; } /* ---------- * numeric_round() - * * Round a value to have 'scale' digits after the decimal point. * We allow negative 'scale', implying rounding before the decimal * point --- Oracle interprets rounding that way. * ---------- */ Numeric numeric_round(Numeric num,int scale) { Numeric res; NumericVar arg; int i; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); /* * Limit the scale value to avoid possible overflow in calculations * below. */ scale = MIN(NUMERIC_MAX_RESULT_SCALE, MAX(-NUMERIC_MAX_RESULT_SCALE, scale)); /* * Unpack the argument and round it at the proper digit position */ init_var(&arg); set_var_from_num(num, &arg); i = arg.weight + scale + 1; if (i < arg.ndigits) { /* * If i = 0, the value loses all digits, but could round up if its * first digit is more than 4. If i < 0 the result must be 0. */ if (i < 0) arg.ndigits = 0; else { int carry = (arg.digits[i] > 4) ? 1 : 0; arg.ndigits = i; while (carry) { carry += arg.digits[--i]; arg.digits[i] = carry % 10; carry /= 10; } if (i < 0) { Assert(i == -1); /* better not have added more than 1 digit */ Assert(arg.digits > arg.buf); arg.digits--; arg.ndigits++; arg.weight++; } } } /* * Set result's scale to something reasonable. */ scale = MIN(NUMERIC_MAX_DISPLAY_SCALE, MAX(0, scale)); arg.rscale = scale; arg.dscale = scale; /* * Return the rounded result */ res = make_result(&arg); free_var(&arg); return res; } /* ---------- * numeric_trunc() - * * Truncate a value to have 'scale' digits after the decimal point. * We allow negative 'scale', implying a truncation before the decimal * point --- Oracle interprets truncation that way. * ---------- */ Numeric numeric_trunc(Numeric num,int scale) { Numeric res; NumericVar arg; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); /* * Limit the scale value to avoid possible overflow in calculations * below. */ scale = MIN(NUMERIC_MAX_RESULT_SCALE, MAX(-NUMERIC_MAX_RESULT_SCALE, scale)); /* * Unpack the argument and truncate it at the proper digit position */ init_var(&arg); set_var_from_num(num, &arg); arg.ndigits = MIN(arg.ndigits, MAX(0, arg.weight + scale + 1)); /* * Set result's scale to something reasonable. */ scale = MIN(NUMERIC_MAX_DISPLAY_SCALE, MAX(0, scale)); arg.rscale = scale; arg.dscale = scale; /* * Return the truncated result */ res = make_result(&arg); free_var(&arg); return res; } /* ---------- * numeric_ceil() - * * Return the smallest integer greater than or equal to the argument * ---------- */ Numeric numeric_ceil(Numeric num) { Numeric res; NumericVar result; if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); init_var(&result); set_var_from_num(num, &result); ceil_var(&result, &result); result.dscale = 0; res = make_result(&result); free_var(&result); return res; } /* ---------- * numeric_floor() - * * Return the largest integer equal to or less than the argument * ---------- */ Numeric numeric_floor(Numeric num) { Numeric res; NumericVar result; if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); init_var(&result); set_var_from_num(num, &result); floor_var(&result, &result); result.dscale = 0; res = make_result(&result); free_var(&result); return res; } /* ---------------------------------------------------------------------- * * Comparison functions * * Note: btree indexes need these routines not to leak memory; therefore, * be careful to free working copies of toasted datums. Most places don't * need to be so careful. * ---------------------------------------------------------------------- */ int numeric_cmp(Numeric num1, Numeric num2) { Numeric orig1 = num1, orig2 = num2; int result; result = cmp_numerics(num1, num2); if ( num1 != orig1 ) free(num1); if ( num2 != orig2 ) free(num2); return result; } int numeric_eq(Numeric num1, Numeric num2) { return numeric_cmp(num1,num2) == 0; } int numeric_ne(Numeric num1, Numeric num2) { return numeric_cmp(num1,num2) != 0; } int numeric_gt(Numeric num1, Numeric num2) { return numeric_cmp(num1,num2) > 0; } int numeric_ge(Numeric num1, Numeric num2) { return numeric_cmp(num1,num2) >= 0; } int numeric_lt(Numeric num1, Numeric num2) { return numeric_cmp(num1,num2) < 0; } int numeric_le(Numeric num1, Numeric num2) { return numeric_cmp(num1,num2) <= 0; } static int cmp_numerics(Numeric num1, Numeric num2) { int result; /* * We consider all NANs to be equal and larger than any non-NAN. This * is somewhat arbitrary; the important thing is to have a consistent * sort order. */ if (NUMERIC_IS_NAN(num1)) { if (NUMERIC_IS_NAN(num2)) result = 0; /* NAN = NAN */ else result = 1; /* NAN > non-NAN */ } else if (NUMERIC_IS_NAN(num2)) { result = -1; /* non-NAN < NAN */ } else { NumericVar arg1; NumericVar arg2; init_var(&arg1); init_var(&arg2); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); result = cmp_var(&arg1, &arg2); free_var(&arg1); free_var(&arg2); } return result; } /* ---------------------------------------------------------------------- * * Arithmetic base functions * * ---------------------------------------------------------------------- * numeric_add() - * * Add two numerics * ---------- */ Numeric numeric_add(Numeric num1, Numeric num2) { NumericVar arg1; NumericVar arg2; NumericVar result; Numeric res; /* * Handle NaN */ if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); /* * Unpack the values, let add_var() compute the result and return it. * The internals of add_var() will automatically set the correct * result and display scales in the result. */ init_var(&arg1); init_var(&arg2); init_var(&result); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); add_var(&arg1, &arg2, &result); res = make_result(&result); free_var(&arg1); free_var(&arg2); free_var(&result); return res; } /* ---------- * numeric_sub() - * * Subtract one numeric from another * ---------- */ Numeric numeric_sub(Numeric num1, Numeric num2) { NumericVar arg1; NumericVar arg2; NumericVar result; Numeric res; /* * Handle NaN */ if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); /* * Unpack the two arguments, let sub_var() compute the result and * return it. */ init_var(&arg1); init_var(&arg2); init_var(&result); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); sub_var(&arg1, &arg2, &result); res = make_result(&result); free_var(&arg1); free_var(&arg2); free_var(&result); return res; } /* ---------- * numeric_mul() - * * Calculate the product of two numerics * ---------- */ Numeric numeric_mul(Numeric num1, Numeric num2, int *global_rscale) { NumericVar arg1; NumericVar arg2; NumericVar result; Numeric res; /* * Handle NaN */ if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); /* * Unpack the arguments, let mul_var() compute the result and return * it. Unlike add_var() and sub_var(), mul_var() will round the result * to the scale stored in global_rscale. In the case of numeric_mul(), * which is invoked for the * operator on numerics, we set it to the * exact representation for the product (rscale = sum(rscale of arg1, * rscale of arg2) and the same for the dscale). */ init_var(&arg1); init_var(&arg2); init_var(&result); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); *global_rscale = arg1.rscale + arg2.rscale; mul_var(&arg1, &arg2, &result, global_rscale); result.dscale = arg1.dscale + arg2.dscale; res = make_result(&result); free_var(&arg1); free_var(&arg2); free_var(&result); return res; } /* ---------- * numeric_div() - * * Divide one numeric into another * ---------- */ Numeric numeric_div(Numeric num1, Numeric num2, int *global_rscale, Decimal_Exception *ex) { NumericVar arg1; NumericVar arg2; NumericVar result; Numeric res; int res_dscale; *ex = No_Error; /* * Handle NaN */ if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); /* * Unpack the arguments */ init_var(&arg1); init_var(&arg2); init_var(&result); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); res_dscale = select_div_scale(&arg1, &arg2, global_rscale); /* * Do the divide, set the display scale and return the result */ div_var(&arg1, &arg2, &result, global_rscale, ex); if ( *ex != No_Error ) { res = make_result(&const_nan); } else { result.dscale = res_dscale; res = make_result(&result); } free_var(&arg1); free_var(&arg2); free_var(&result); return res; } /* ---------- * numeric_mod() - * * Calculate the modulo of two numerics * ---------- */ Numeric numeric_mod(Numeric num1, Numeric num2, int *global_rscale, Decimal_Exception *ex) { Numeric res; NumericVar arg1; NumericVar arg2; NumericVar result; *ex = No_Error; if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); init_var(&arg1); init_var(&arg2); init_var(&result); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); mod_var(&arg1, &arg2, &result, global_rscale, ex); res = make_result(&result); free_var(&result); free_var(&arg2); free_var(&arg1); return res; } /* ---------- * numeric_smaller() - * * Return the smaller of two numbers * ---------- */ Numeric numeric_smaller(Numeric num1, Numeric num2) { NumericVar arg1; NumericVar arg2; Numeric res; /* * Handle NaN */ if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); /* * Unpack the values, and decide which is the smaller one */ init_var(&arg1); init_var(&arg2); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); if (cmp_var(&arg1, &arg2) <= 0) res = make_result(&arg1); else res = make_result(&arg2); free_var(&arg1); free_var(&arg2); return res; } /* ---------- * numeric_larger() - * * Return the larger of two numbers * ---------- */ Numeric numeric_larger(Numeric num1, Numeric num2) { NumericVar arg1; NumericVar arg2; Numeric res; /* * Handle NaN */ if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); /* * Unpack the values, and decide which is the larger one */ init_var(&arg1); init_var(&arg2); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); if (cmp_var(&arg1, &arg2) >= 0) res = make_result(&arg1); else res = make_result(&arg2); free_var(&arg1); free_var(&arg2); return res; } /* ---------------------------------------------------------------------- * * Complex math functions * * ---------------------------------------------------------------------- * numeric_sqrt() - * * Compute the square root of a numeric. * ---------- */ Numeric numeric_sqrt(Numeric num, int *global_rscale, Decimal_Exception *ex) { Numeric res; NumericVar arg; NumericVar result; int res_dscale; *ex = No_Error; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); /* * Unpack the argument, determine the scales like for divide, let * sqrt_var() do the calculation and return the result. */ init_var(&arg); init_var(&result); set_var_from_num(num, &arg); res_dscale = MAX(arg.dscale, NUMERIC_MIN_DISPLAY_SCALE); res_dscale = MIN(res_dscale, NUMERIC_MAX_DISPLAY_SCALE); *global_rscale = MAX(arg.rscale, NUMERIC_MIN_RESULT_SCALE); *global_rscale = MAX(*global_rscale, res_dscale + 4); *global_rscale = MIN(*global_rscale, NUMERIC_MAX_RESULT_SCALE); sqrt_var(&arg, &result, global_rscale, ex); result.dscale = res_dscale; res = make_result(&result); free_var(&result); free_var(&arg); return res; } /* ---------- * numeric_exp() - * * Raise e to the power of x * ---------- */ Numeric numeric_exp(Numeric num, int *global_rscale, Decimal_Exception *ex) { Numeric res; NumericVar arg; NumericVar result; int res_dscale; *ex = No_Error; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); /* * Same procedure like for sqrt(). */ init_var(&arg); init_var(&result); set_var_from_num(num, &arg); res_dscale = MAX(arg.dscale, NUMERIC_MIN_DISPLAY_SCALE); res_dscale = MIN(res_dscale, NUMERIC_MAX_DISPLAY_SCALE); *global_rscale = MAX(arg.rscale, NUMERIC_MIN_RESULT_SCALE); *global_rscale = MAX(*global_rscale, res_dscale + 4); *global_rscale = MIN(*global_rscale, NUMERIC_MAX_RESULT_SCALE); exp_var(&arg, &result, global_rscale, ex); result.dscale = res_dscale; res = make_result(&result); free_var(&result); free_var(&arg); return res; } /* ---------- * numeric_ln() - * * Compute the natural logarithm of x * ---------- */ Numeric numeric_ln(Numeric num, int *global_rscale, Decimal_Exception *ex) { Numeric res; NumericVar arg; NumericVar result; int res_dscale; *ex = No_Error; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); /* * Same procedure like for sqrt() */ init_var(&arg); init_var(&result); set_var_from_num(num, &arg); res_dscale = MAX(arg.dscale, NUMERIC_MIN_DISPLAY_SCALE); res_dscale = MIN(res_dscale, NUMERIC_MAX_DISPLAY_SCALE); *global_rscale = MAX(arg.rscale, NUMERIC_MIN_RESULT_SCALE); *global_rscale = MAX(*global_rscale, res_dscale + 4); *global_rscale = MIN(*global_rscale, NUMERIC_MAX_RESULT_SCALE); ln_var(&arg, &result, global_rscale, ex); if ( *ex == No_Error ) result.dscale = res_dscale; res = make_result(&result); free_var(&result); free_var(&arg); return res; } /* ---------- * numeric_log() - * * Compute the logarithm of x in a given base * ---------- */ Numeric numeric_log(Numeric num1, Numeric num2, int *global_rscale, Decimal_Exception *ex) { Numeric res; NumericVar arg1; NumericVar arg2; NumericVar result; int res_dscale; *ex = No_Error; /* * Handle NaN */ if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); /* * Initialize things and calculate scales */ init_var(&arg1); init_var(&arg2); init_var(&result); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); res_dscale = MAX(arg1.dscale + arg2.dscale, NUMERIC_MIN_DISPLAY_SCALE); res_dscale = MIN(res_dscale, NUMERIC_MAX_DISPLAY_SCALE); *global_rscale = MAX(arg1.rscale + arg2.rscale, NUMERIC_MIN_RESULT_SCALE); *global_rscale = MAX(*global_rscale, res_dscale + 4); *global_rscale = MIN(*global_rscale, NUMERIC_MAX_RESULT_SCALE); /* * Call log_var() to compute and return the result */ log_var(&arg1, &arg2, &result, global_rscale, ex); if ( *ex == No_Error ) result.dscale = res_dscale; res = make_result(&result); free_var(&result); free_var(&arg2); free_var(&arg1); return res; } /* ---------- * numeric_power() - * * Raise m to the power of x * ---------- */ Numeric numeric_power(Numeric num1, Numeric num2, int *global_rscale, Decimal_Exception *ex) { Numeric res; NumericVar arg1; NumericVar arg2; NumericVar result; int res_dscale; *ex = No_Error; /* * Handle NaN */ if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); /* * Initialize things and calculate scales */ init_var(&arg1); init_var(&arg2); init_var(&result); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); res_dscale = MAX(arg1.dscale + arg2.dscale, NUMERIC_MIN_DISPLAY_SCALE); res_dscale = MIN(res_dscale, NUMERIC_MAX_DISPLAY_SCALE); *global_rscale = MAX(arg1.rscale + arg2.rscale, NUMERIC_MIN_RESULT_SCALE); *global_rscale = MAX(*global_rscale, res_dscale + 4); *global_rscale = MIN(*global_rscale, NUMERIC_MAX_RESULT_SCALE); /* * Call log_var() to compute and return the result */ power_var(&arg1, &arg2, &result, global_rscale, ex); if ( *ex == No_Error ) result.dscale = res_dscale; res = make_result(&result); free_var(&result); free_var(&arg2); free_var(&arg1); return res; } /* ---------------------------------------------------------------------- * * Local functions follow * * ---------------------------------------------------------------------- */ #ifdef NUMERIC_DEBUG /* ---------- * dump_numeric() - Dump a value in the db storage format for debugging * ---------- */ static void dump_numeric(char *str, Numeric num) { int i; printf("%s: NUMERIC w=%d r=%d d=%d ", str, num->n_weight, num->n_rscale, NUMERIC_DSCALE(num)); switch (NUMERIC_SIGN(num)) { case NUMERIC_POS: printf("POS"); break; case NUMERIC_NEG: printf("NEG"); break; case NUMERIC_NAN: printf("NaN"); break; default: printf("SIGN=0x%x", NUMERIC_SIGN(num)); break; } for (i = 0; i < num->varlen - NUMERIC_HDRSZ; i++) printf(" %d %d", (num->n_data[i] >> 4) & 0x0f, num->n_data[i] & 0x0f); printf("\n"); } /* ---------- * dump_var() - Dump a value in the variable format for debugging * ---------- */ static void dump_var(char *str, NumericVar *var) { int i; printf("%s: VAR w=%d r=%d d=%d ", str, var->weight, var->rscale, var->dscale); switch (var->sign) { case NUMERIC_POS: printf("POS"); break; case NUMERIC_NEG: printf("NEG"); break; case NUMERIC_NAN: printf("NaN"); break; default: printf("SIGN=0x%x", var->sign); break; } for (i = 0; i < var->ndigits; i++) printf(" %d", var->digits[i]); printf("\n"); } #endif /* NUMERIC_DEBUG */ /* ---------- * alloc_var() - * * Allocate a digit buffer of ndigits digits (plus a spare digit for rounding) * ---------- */ static void alloc_var(NumericVar *var, int ndigits) { digitbuf_free(var->buf); var->buf = digitbuf_alloc(ndigits + 1); var->buf[0] = 0; var->digits = var->buf + 1; var->ndigits = ndigits; } /* ---------- * free_var() - * * Return the digit buffer of a variable to the free pool * ---------- */ static void free_var(NumericVar *var) { digitbuf_free(var->buf); var->buf = NULL; var->digits = NULL; var->sign = NUMERIC_NAN; } /* ---------- * zero_var() - * * Set a variable to ZERO. * Note: rscale and dscale are not touched. * ---------- */ static void zero_var(NumericVar *var) { digitbuf_free(var->buf); var->buf = NULL; var->digits = NULL; var->ndigits = 0; var->weight = 0; /* by convention; doesn't really matter */ var->sign = NUMERIC_POS; /* anything but NAN... */ } /* ---------- * set_var_from_str() * * Parse a string and put the number into a variable * ---------- */ static void set_var_from_str(const char *str, NumericVar *dest, Decimal_Exception *ex) { char *cp = (char *) str; bool have_dp = FALSE; int i = 0; bool bad_format = FALSE; while (*cp) { if (!isspace((unsigned char) *cp)) break; cp++; } alloc_var(dest, strlen(cp)); dest->weight = -1; dest->dscale = 0; dest->sign = NUMERIC_POS; switch (*cp) { case '+': dest->sign = NUMERIC_POS; cp++; break; case '-': dest->sign = NUMERIC_NEG; cp++; break; } if (*cp == '.') { have_dp = TRUE; cp++; } if (!isdigit((unsigned char) *cp)) bad_format = TRUE; /* Bad format exception */ while (*cp) { if (isdigit((unsigned char) *cp)) { dest->digits[i++] = *cp++ - '0'; if (!have_dp) dest->weight++; else dest->dscale++; } else if (*cp == '.') { if (have_dp) bad_format = TRUE; have_dp = TRUE; cp++; } else break; } dest->ndigits = i; /* Handle exponent, if any */ if (*cp == 'e' || *cp == 'E') { long exponent; char *endptr; cp++; exponent = strtol(cp, &endptr, 10); if (endptr == cp) bad_format = TRUE; cp = endptr; if (exponent > NUMERIC_MAX_PRECISION || exponent < -NUMERIC_MAX_PRECISION) bad_format = TRUE; dest->weight += (int) exponent; dest->dscale -= (int) exponent; if (dest->dscale < 0) dest->dscale = 0; } /* Should be nothing left but spaces */ while (*cp) { if (!isspace((unsigned char) *cp)) bad_format = TRUE; cp++; } /* Strip any leading zeroes */ while (dest->ndigits > 0 && *(dest->digits) == 0) { (dest->digits)++; (dest->weight)--; (dest->ndigits)--; } if (dest->ndigits == 0) dest->weight = 0; dest->rscale = dest->dscale; if ( bad_format ) *ex = Numeric_Format; /* Bad format exception */ } /* * set_var_from_num() - * * Parse back the packed db format into a variable * */ static void set_var_from_num(Numeric num, NumericVar *dest) { NumericDigit *digit; int i; int n; n = num->varlen - NUMERIC_HDRSZ; /* number of digit-pairs in packed * fmt */ alloc_var(dest, n * 2); dest->weight = num->n_weight; dest->rscale = num->n_rscale; dest->dscale = NUMERIC_DSCALE(num); dest->sign = NUMERIC_SIGN(num); digit = dest->digits; for (i = 0; i < n; i++) { unsigned char digitpair = num->n_data[i]; *digit++ = (digitpair >> 4) & 0x0f; *digit++ = digitpair & 0x0f; } } /* ---------- * set_var_from_var() - * * Copy one variable into another * ---------- */ static void set_var_from_var(NumericVar *value, NumericVar *dest) { NumericDigit *newbuf; newbuf = digitbuf_alloc(value->ndigits + 1); newbuf[0] = 0; /* spare digit for rounding */ memcpy(newbuf + 1, value->digits, value->ndigits); digitbuf_free(dest->buf); memcpy(dest, value, sizeof(NumericVar)); dest->buf = newbuf; dest->digits = newbuf + 1; } /* ---------- * get_str_from_var() - * * Convert a var to text representation (guts of numeric_out). * CAUTION: var's contents may be modified by rounding! * Caller must have checked for NaN case. * Returns a palloc'd string. * ---------- */ static char * get_str_from_var(NumericVar *var, int dscale) { char *str; char *cp; int i; int d; /* * Check if we must round up before printing the value and do so. */ i = dscale + var->weight + 1; if (i >= 0 && var->ndigits > i) { int carry = (var->digits[i] > 4) ? 1 : 0; var->ndigits = i; while (carry) { carry += var->digits[--i]; var->digits[i] = carry % 10; carry /= 10; } if (i < 0) { Assert(i == -1); /* better not have added more than 1 digit */ Assert(var->digits > var->buf); var->digits--; var->ndigits++; var->weight++; } } else var->ndigits = MAX(0, MIN(i, var->ndigits)); /* * Allocate space for the result */ str = palloc(MAX(0, dscale) + MAX(0, var->weight) + 4); cp = str; /* * Output a dash for negative values */ if (var->sign == NUMERIC_NEG) *cp++ = '-'; /* * Output all digits before the decimal point */ i = MAX(var->weight, 0); d = 0; while (i >= 0) { if (i <= var->weight && d < var->ndigits) *cp++ = var->digits[d++] + '0'; else *cp++ = '0'; i--; } /* * If requested, output a decimal point and all the digits that follow * it. */ if (dscale > 0) { *cp++ = '.'; while (i >= -dscale) { if (i <= var->weight && d < var->ndigits) *cp++ = var->digits[d++] + '0'; else *cp++ = '0'; i--; } } /* * terminate the string and return it */ *cp = '\0'; return str; } Numeric numeric_nan(void) { Numeric num = (Numeric) palloc(NUMERIC_HDRSZ); num->varlen = NUMERIC_HDRSZ; num->n_weight = 0; num->n_rscale = 0; num->n_sign_dscale = NUMERIC_NAN; return num; } /* ---------- * make_result() - * * Create the packed db numeric format in palloc()'d memory from * a variable. The var's rscale determines the number of digits kept. * ---------- */ static Numeric make_result(NumericVar *var) { Numeric result; NumericDigit *digit = var->digits; int weight = var->weight; int sign = var->sign; int n; int i, j; if (sign == NUMERIC_NAN) { return numeric_nan(); return result; } n = MAX(0, MIN(var->ndigits, var->weight + var->rscale + 1)); /* truncate leading zeroes */ while (n > 0 && *digit == 0) { digit++; weight--; n--; } /* truncate trailing zeroes */ while (n > 0 && digit[n - 1] == 0) n--; /* If zero result, force to weight=0 and positive sign */ if (n == 0) { weight = 0; sign = NUMERIC_POS; } result = (Numeric) palloc(NUMERIC_HDRSZ + (n + 1) / 2); result->varlen = NUMERIC_HDRSZ + (n + 1) / 2; result->n_weight = weight; result->n_rscale = var->rscale; result->n_sign_dscale = sign | ((uint16) var->dscale & NUMERIC_DSCALE_MASK); i = 0; j = 0; while (j < n) { unsigned char digitpair = digit[j++] << 4; if (j < n) digitpair |= digit[j++]; result->n_data[i++] = digitpair; } dump_numeric("make_result()", result); return result; } /* ---------- * apply_typmod() - * * Do bounds checking and rounding according to the attributes * typmod field. * ---------- */ static void apply_typmod(NumericVar *var, int precision, int scale, Decimal_Exception *ex) { int maxweight; int i; maxweight = precision - scale; /* Round to target scale */ i = scale + var->weight + 1; if (i >= 0 && var->ndigits > i) { int carry = (var->digits[i] > 4) ? 1 : 0; var->ndigits = i; while (carry) { carry += var->digits[--i]; var->digits[i] = carry % 10; carry /= 10; } if (i < 0) { Assert(i == -1); /* better not have added more than 1 digit */ Assert(var->digits > var->buf); var->digits--; var->ndigits++; var->weight++; } } else var->ndigits = MAX(0, MIN(i, var->ndigits)); /* * Check for overflow - note we can't do this before rounding, because * rounding could raise the weight. Also note that the var's weight * could be inflated by leading zeroes, which will be stripped before * storage but perhaps might not have been yet. In any case, we must * recognize a true zero, whose weight doesn't mean anything. */ if (var->weight >= maxweight) { /* Determine true weight; and check for all-zero result */ int tweight = var->weight; for (i = 0; i < var->ndigits; i++) { if (var->digits[i]) break; tweight--; } if ( tweight >= maxweight && i < var->ndigits ) *ex = Numeric_Overflow; /* Overflow exception */ } if ( *ex == No_Error ) { var->rscale = scale; var->dscale = scale; } else nan_var(var); } /* ---------- * cmp_var() - * * Compare two values on variable level * ---------- */ static int cmp_var(NumericVar *var1, NumericVar *var2) { if (var1->ndigits == 0) { if (var2->ndigits == 0) return 0; if (var2->sign == NUMERIC_NEG) return 1; return -1; } if (var2->ndigits == 0) { if (var1->sign == NUMERIC_POS) return 1; return -1; } if (var1->sign == NUMERIC_POS) { if (var2->sign == NUMERIC_NEG) return 1; return cmp_abs(var1, var2); } if (var2->sign == NUMERIC_POS) return -1; return cmp_abs(var2, var1); } /* ---------- * add_var() - * * Full version of add functionality on variable level (handling signs). * result might point to one of the operands too without danger. * ---------- */ static void add_var(NumericVar *var1, NumericVar *var2, NumericVar *result) { /* * Decide on the signs of the two variables what to do */ if (var1->sign == NUMERIC_POS) { if (var2->sign == NUMERIC_POS) { /* * Both are positive result = +(ABS(var1) + ABS(var2)) */ add_abs(var1, var2, result); result->sign = NUMERIC_POS; } else { /* * var1 is positive, var2 is negative Must compare absolute * values */ switch (cmp_abs(var1, var2)) { case 0: /* ---------- * ABS(var1) == ABS(var2) * result = ZERO * ---------- */ zero_var(result); result->rscale = MAX(var1->rscale, var2->rscale); result->dscale = MAX(var1->dscale, var2->dscale); break; case 1: /* ---------- * ABS(var1) > ABS(var2) * result = +(ABS(var1) - ABS(var2)) * ---------- */ sub_abs(var1, var2, result); result->sign = NUMERIC_POS; break; case -1: /* ---------- * ABS(var1) < ABS(var2) * result = -(ABS(var2) - ABS(var1)) * ---------- */ sub_abs(var2, var1, result); result->sign = NUMERIC_NEG; break; } } } else { if (var2->sign == NUMERIC_POS) { /* ---------- * var1 is negative, var2 is positive * Must compare absolute values * ---------- */ switch (cmp_abs(var1, var2)) { case 0: /* ---------- * ABS(var1) == ABS(var2) * result = ZERO * ---------- */ zero_var(result); result->rscale = MAX(var1->rscale, var2->rscale); result->dscale = MAX(var1->dscale, var2->dscale); break; case 1: /* ---------- * ABS(var1) > ABS(var2) * result = -(ABS(var1) - ABS(var2)) * ---------- */ sub_abs(var1, var2, result); result->sign = NUMERIC_NEG; break; case -1: /* ---------- * ABS(var1) < ABS(var2) * result = +(ABS(var2) - ABS(var1)) * ---------- */ sub_abs(var2, var1, result); result->sign = NUMERIC_POS; break; } } else { /* ---------- * Both are negative * result = -(ABS(var1) + ABS(var2)) * ---------- */ add_abs(var1, var2, result); result->sign = NUMERIC_NEG; } } } /* ---------- * sub_var() - * * Full version of sub functionality on variable level (handling signs). * result might point to one of the operands too without danger. * ---------- */ static void sub_var(NumericVar *var1, NumericVar *var2, NumericVar *result) { /* * Decide on the signs of the two variables what to do */ if (var1->sign == NUMERIC_POS) { if (var2->sign == NUMERIC_NEG) { /* ---------- * var1 is positive, var2 is negative * result = +(ABS(var1) + ABS(var2)) * ---------- */ add_abs(var1, var2, result); result->sign = NUMERIC_POS; } else { /* ---------- * Both are positive * Must compare absolute values * ---------- */ switch (cmp_abs(var1, var2)) { case 0: /* ---------- * ABS(var1) == ABS(var2) * result = ZERO * ---------- */ zero_var(result); result->rscale = MAX(var1->rscale, var2->rscale); result->dscale = MAX(var1->dscale, var2->dscale); break; case 1: /* ---------- * ABS(var1) > ABS(var2) * result = +(ABS(var1) - ABS(var2)) * ---------- */ sub_abs(var1, var2, result); result->sign = NUMERIC_POS; break; case -1: /* ---------- * ABS(var1) < ABS(var2) * result = -(ABS(var2) - ABS(var1)) * ---------- */ sub_abs(var2, var1, result); result->sign = NUMERIC_NEG; break; } } } else { if (var2->sign == NUMERIC_NEG) { /* ---------- * Both are negative * Must compare absolute values * ---------- */ switch (cmp_abs(var1, var2)) { case 0: /* ---------- * ABS(var1) == ABS(var2) * result = ZERO * ---------- */ zero_var(result); result->rscale = MAX(var1->rscale, var2->rscale); result->dscale = MAX(var1->dscale, var2->dscale); break; case 1: /* ---------- * ABS(var1) > ABS(var2) * result = -(ABS(var1) - ABS(var2)) * ---------- */ sub_abs(var1, var2, result); result->sign = NUMERIC_NEG; break; case -1: /* ---------- * ABS(var1) < ABS(var2) * result = +(ABS(var2) - ABS(var1)) * ---------- */ sub_abs(var2, var1, result); result->sign = NUMERIC_POS; break; } } else { /* ---------- * var1 is negative, var2 is positive * result = -(ABS(var1) + ABS(var2)) * ---------- */ add_abs(var1, var2, result); result->sign = NUMERIC_NEG; } } } /* ---------- * mul_var() - * * Multiplication on variable level. Product of var1 * var2 is stored * in result. * ---------- */ static void mul_var(NumericVar *var1, NumericVar *var2, NumericVar *result, int *global_rscale) { NumericDigit *res_buf; NumericDigit *res_digits; int res_ndigits; int res_weight; int res_sign; int i, ri, i1, i2; long sum = 0; res_weight = var1->weight + var2->weight + 2; res_ndigits = var1->ndigits + var2->ndigits + 1; if (var1->sign == var2->sign) res_sign = NUMERIC_POS; else res_sign = NUMERIC_NEG; res_buf = digitbuf_alloc(res_ndigits); res_digits = res_buf; memset(res_digits, 0, res_ndigits); ri = res_ndigits; for (i1 = var1->ndigits - 1; i1 >= 0; i1--) { sum = 0; i = --ri; for (i2 = var2->ndigits - 1; i2 >= 0; i2--) { sum += res_digits[i] + var1->digits[i1] * var2->digits[i2]; res_digits[i--] = sum % 10; sum /= 10; } res_digits[i] = sum; } i = res_weight + *global_rscale + 2; if (i >= 0 && i < res_ndigits) { sum = (res_digits[i] > 4) ? 1 : 0; res_ndigits = i; i--; while (sum) { sum += res_digits[i]; res_digits[i--] = sum % 10; sum /= 10; } } while (res_ndigits > 0 && *res_digits == 0) { res_digits++; res_weight--; res_ndigits--; } while (res_ndigits > 0 && res_digits[res_ndigits - 1] == 0) res_ndigits--; if (res_ndigits == 0) { res_sign = NUMERIC_POS; res_weight = 0; } digitbuf_free(result->buf); result->buf = res_buf; result->digits = res_digits; result->ndigits = res_ndigits; result->weight = res_weight; result->rscale = *global_rscale; result->sign = res_sign; } /* ---------- * div_var() - * * Division on variable level. * ---------- */ static void div_var(NumericVar *var1, NumericVar *var2, NumericVar *result, int *global_rscale, Decimal_Exception *ex) { NumericDigit *res_digits; int res_ndigits; int res_sign; int res_weight; NumericVar dividend; NumericVar divisor[10]; int ndigits_tmp; int weight_tmp; int rscale_tmp; int ri; int i; long guess; long first_have; long first_div; int first_nextdigit; int stat = 0; /* * First of all division by zero check */ ndigits_tmp = var2->ndigits + 1; if (ndigits_tmp == 1) { *ex = Divide_By_Zero; nan_var(result); return; } /* * Determine the result sign, weight and number of digits to calculate */ if (var1->sign == var2->sign) res_sign = NUMERIC_POS; else res_sign = NUMERIC_NEG; res_weight = var1->weight - var2->weight + 1; res_ndigits = *global_rscale + res_weight; if (res_ndigits <= 0) res_ndigits = 1; /* * Now result zero check */ if (var1->ndigits == 0) { zero_var(result); result->rscale = *global_rscale; return; } /* * Initialize local variables */ init_var(÷nd); for (i = 1; i < 10; i++) init_var(&divisor[i]); /* * Make a copy of the divisor which has one leading zero digit */ divisor[1].ndigits = ndigits_tmp; divisor[1].rscale = var2->ndigits; divisor[1].sign = NUMERIC_POS; divisor[1].buf = digitbuf_alloc(ndigits_tmp); divisor[1].digits = divisor[1].buf; divisor[1].digits[0] = 0; memcpy(&(divisor[1].digits[1]), var2->digits, ndigits_tmp - 1); /* * Make a copy of the dividend */ dividend.ndigits = var1->ndigits; dividend.weight = 0; dividend.rscale = var1->ndigits; dividend.sign = NUMERIC_POS; dividend.buf = digitbuf_alloc(var1->ndigits); dividend.digits = dividend.buf; memcpy(dividend.digits, var1->digits, var1->ndigits); /* * Setup the result */ digitbuf_free(result->buf); result->buf = digitbuf_alloc(res_ndigits + 2); res_digits = result->buf; result->digits = res_digits; result->ndigits = res_ndigits; result->weight = res_weight; result->rscale = *global_rscale; result->sign = res_sign; res_digits[0] = 0; first_div = divisor[1].digits[1] * 10; if (ndigits_tmp > 2) first_div += divisor[1].digits[2]; first_have = 0; first_nextdigit = 0; weight_tmp = 1; rscale_tmp = divisor[1].rscale; for (ri = 0; ri <= res_ndigits; ri++) { first_have = first_have * 10; if (first_nextdigit >= 0 && first_nextdigit < dividend.ndigits) first_have += dividend.digits[first_nextdigit]; first_nextdigit++; guess = (first_have * 10) / first_div + 1; if (guess > 9) guess = 9; while (guess > 0) { if (divisor[guess].buf == NULL) { int i; long sum = 0; memcpy(&divisor[guess], &divisor[1], sizeof(NumericVar)); divisor[guess].buf = digitbuf_alloc(divisor[guess].ndigits); divisor[guess].digits = divisor[guess].buf; for (i = divisor[1].ndigits - 1; i >= 0; i--) { sum += divisor[1].digits[i] * guess; divisor[guess].digits[i] = sum % 10; sum /= 10; } } divisor[guess].weight = weight_tmp; divisor[guess].rscale = rscale_tmp; stat = cmp_abs(÷nd, &divisor[guess]); if (stat >= 0) break; guess--; } res_digits[ri + 1] = guess; if (stat == 0) { ri++; break; } weight_tmp--; rscale_tmp++; if (guess == 0) continue; sub_abs(÷nd, &divisor[guess], ÷nd); first_nextdigit = dividend.weight - weight_tmp; first_have = 0; if (first_nextdigit >= 0 && first_nextdigit < dividend.ndigits) first_have = dividend.digits[first_nextdigit]; first_nextdigit++; } result->ndigits = ri + 1; if (ri == res_ndigits + 1) { int carry = (res_digits[ri] > 4) ? 1 : 0; result->ndigits = ri; res_digits[ri] = 0; while (carry && ri > 0) { carry += res_digits[--ri]; res_digits[ri] = carry % 10; carry /= 10; } } while (result->ndigits > 0 && *(result->digits) == 0) { (result->digits)++; (result->weight)--; (result->ndigits)--; } while (result->ndigits > 0 && result->digits[result->ndigits - 1] == 0) (result->ndigits)--; if (result->ndigits == 0) result->sign = NUMERIC_POS; /* * Tidy up */ digitbuf_free(dividend.buf); for (i = 1; i < 10; i++) digitbuf_free(divisor[i].buf); } /* * Default scale selection for division * * Returns the appropriate display scale for the division result, * and sets global_rscale to the result scale to use during div_var. * * Note that this must be called before div_var. */ static int select_div_scale(NumericVar *var1, NumericVar *var2, int *global_rscale) { int res_dscale; int res_rscale; /* ---------- * The result scale of a division isn't specified in any * SQL standard. For Postgres it is the following (where * SR, DR are the result- and display-scales of the returned * value, S1, D1, S2 and D2 are the scales of the two arguments, * The minimum and maximum scales are compile time options from * numeric.h): * * DR = MIN(MAX(D1 + D2, MIN_DISPLAY_SCALE), MAX_DISPLAY_SCALE) * SR = MIN(MAX(MAX(S1 + S2, DR + 4), MIN_RESULT_SCALE), MAX_RESULT_SCALE) * * By default, any result is computed with a minimum of 34 digits * after the decimal point or at least with 4 digits more than * displayed. * ---------- */ res_dscale = var1->dscale + var2->dscale; res_dscale = MAX(res_dscale, NUMERIC_MIN_DISPLAY_SCALE); res_dscale = MIN(res_dscale, NUMERIC_MAX_DISPLAY_SCALE); res_rscale = var1->rscale + var2->rscale; res_rscale = MAX(res_rscale, res_dscale + 4); res_rscale = MAX(res_rscale, NUMERIC_MIN_RESULT_SCALE); res_rscale = MIN(res_rscale, NUMERIC_MAX_RESULT_SCALE); *global_rscale = res_rscale; return res_dscale; } /* ---------- * mod_var() - * * Calculate the modulo of two numerics at variable level * ---------- */ static void mod_var(NumericVar *var1, NumericVar *var2, NumericVar *result, int *global_rscale, Decimal_Exception *ex) { NumericVar tmp; int save_global_rscale; int div_dscale; *ex = No_Error; init_var(&tmp); /* --------- * We do this using the equation * mod(x,y) = x - trunc(x/y)*y * We set global_rscale the same way numeric_div and numeric_mul do * to get the right answer from the equation. The final result, * however, need not be displayed to more precision than the inputs. * ---------- */ save_global_rscale = *global_rscale; div_dscale = select_div_scale(var1, var2, global_rscale); div_var(var1, var2, &tmp, global_rscale, ex); if ( *ex == No_Error ) { tmp.dscale = div_dscale; /* do trunc() by forgetting digits to the right of the decimal point */ tmp.ndigits = MAX(0, MIN(tmp.ndigits, tmp.weight + 1)); *global_rscale = var2->rscale + tmp.rscale; mul_var(var2, &tmp, &tmp, global_rscale); sub_var(var1, &tmp, result); result->dscale = MAX(var1->dscale, var2->dscale); *global_rscale = save_global_rscale; } free_var(&tmp); } /* ---------- * ceil_var() - * * Return the smallest integer greater than or equal to the argument * on variable level * ---------- */ static void ceil_var(NumericVar *var, NumericVar *result) { NumericVar tmp; init_var(&tmp); set_var_from_var(var, &tmp); tmp.rscale = 0; tmp.ndigits = MIN(tmp.ndigits, MAX(0, tmp.weight + 1)); if (tmp.sign == NUMERIC_POS && cmp_var(var, &tmp) != 0) add_var(&tmp, &const_one, &tmp); set_var_from_var(&tmp, result); free_var(&tmp); } /* ---------- * floor_var() - * * Return the largest integer equal to or less than the argument * on variable level * ---------- */ static void floor_var(NumericVar *var, NumericVar *result) { NumericVar tmp; init_var(&tmp); set_var_from_var(var, &tmp); tmp.rscale = 0; tmp.ndigits = MIN(tmp.ndigits, MAX(0, tmp.weight + 1)); if (tmp.sign == NUMERIC_NEG && cmp_var(var, &tmp) != 0) sub_var(&tmp, &const_one, &tmp); set_var_from_var(&tmp, result); free_var(&tmp); } /* ---------- * sqrt_var() - * * Compute the square root of x using Newtons algorithm * ---------- */ static void sqrt_var(NumericVar *arg, NumericVar *result, int *global_rscale, Decimal_Exception *ex) { NumericVar tmp_arg; NumericVar tmp_val; NumericVar last_val; int res_rscale; int save_global_rscale; int stat; save_global_rscale = *global_rscale; *global_rscale += 8; res_rscale = *global_rscale; stat = cmp_var(arg, &const_zero); if (stat == 0) { set_var_from_var(&const_zero, result); result->rscale = res_rscale; result->sign = NUMERIC_POS; return; } if (stat < 0) { *ex = Undefined_Result; nan_var(result); return; } init_var(&tmp_arg); init_var(&tmp_val); init_var(&last_val); set_var_from_var(arg, &tmp_arg); set_var_from_var(result, &last_val); /* * Initialize the result to the first guess */ digitbuf_free(result->buf); result->buf = digitbuf_alloc(1); result->digits = result->buf; result->digits[0] = tmp_arg.digits[0] / 2; if (result->digits[0] == 0) result->digits[0] = 1; result->ndigits = 1; result->weight = tmp_arg.weight / 2; result->rscale = res_rscale; result->sign = NUMERIC_POS; for (;;) { div_var(&tmp_arg, result, &tmp_val, global_rscale, ex); if ( *ex != No_Error ) break; add_var(result, &tmp_val, result); div_var(result, &const_two, result, global_rscale, ex); if ( *ex != No_Error ) break; if (cmp_var(&last_val, result) == 0) break; set_var_from_var(result, &last_val); } free_var(&last_val); free_var(&tmp_val); free_var(&tmp_arg); if ( *ex == No_Error ) { *global_rscale = save_global_rscale; div_var(result, &const_one, result, global_rscale, ex); } if ( *ex != No_Error ) nan_var(result); /* Set NAN if any exception occurred */ } /* ---------- * exp_var() - * * Raise e to the power of x * ---------- */ static void exp_var(NumericVar *arg, NumericVar *result,int *global_rscale, Decimal_Exception *ex) { NumericVar x; NumericVar xpow; NumericVar ifac; NumericVar elem; NumericVar ni; int d; int i; int ndiv2 = 0; bool xneg = FALSE; int save_global_rscale; init_var(&x); init_var(&xpow); init_var(&ifac); init_var(&elem); init_var(&ni); set_var_from_var(arg, &x); if (x.sign == NUMERIC_NEG) { xneg = TRUE; x.sign = NUMERIC_POS; } save_global_rscale = *global_rscale; *global_rscale = 0; for (i = x.weight, d = 0; i >= 0; i--, d++) { *global_rscale *= 10; if (d < x.ndigits) *global_rscale += x.digits[d]; if (*global_rscale >= 1000) { *ex = Numeric_Overflow; /* argument for EXP() too big */ nan_var(result); return; } } *global_rscale = *global_rscale / 2 + save_global_rscale + 8; while (cmp_var(&x, &const_one) > 0) { ndiv2++; (*global_rscale)++; div_var(&x, &const_two, &x, global_rscale, ex); if ( *ex != No_Error ) break; } if ( *ex == No_Error ) { add_var(&const_one, &x, result); set_var_from_var(&x, &xpow); set_var_from_var(&const_one, &ifac); set_var_from_var(&const_one, &ni); for (i = 2;; i++) { add_var(&ni, &const_one, &ni); mul_var(&xpow, &x, &xpow, global_rscale); mul_var(&ifac, &ni, &ifac, global_rscale); div_var(&xpow, &ifac, &elem, global_rscale, ex); if ( *ex != No_Error ) break; if (elem.ndigits == 0) break; add_var(result, &elem, result); } } if ( *ex == No_Error ) { while (ndiv2-- > 0) mul_var(result, result, result, global_rscale); *global_rscale = save_global_rscale; if (xneg) div_var(&const_one, result, result, global_rscale, ex); else div_var(result, &const_one, result, global_rscale, ex); if ( *ex == No_Error ) result->sign = NUMERIC_POS; } free_var(&x); free_var(&xpow); free_var(&ifac); free_var(&elem); free_var(&ni); if ( *ex != No_Error ) nan_var(result); } /* ---------- * ln_var() - * * Compute the natural log of x * ---------- */ static void ln_var(NumericVar *arg, NumericVar *result, int *global_rscale, Decimal_Exception *ex) { NumericVar x; NumericVar xx; NumericVar ni; NumericVar elem; NumericVar fact; int i; int save_global_rscale; if (cmp_var(arg, &const_zero) <= 0) { /* math error on numeric - cannot compute LN of value <= zero */ *ex = Numeric_Overflow; nan_var(result); return; } save_global_rscale = *global_rscale; *global_rscale += 8; init_var(&x); init_var(&xx); init_var(&ni); init_var(&elem); init_var(&fact); set_var_from_var(&const_two, &fact); set_var_from_var(arg, &x); while (cmp_var(&x, &const_two) >= 0) { sqrt_var(&x, &x, global_rscale, ex); if ( *ex != No_Error ) break; mul_var(&fact, &const_two, &fact, global_rscale); } if ( *ex == No_Error ) { set_var_from_str("0.5", &elem, ex); /* This won't raise exception */ while (cmp_var(&x, &elem) <= 0) { sqrt_var(&x, &x, global_rscale, ex); if ( *ex != No_Error ) break; mul_var(&fact, &const_two, &fact, global_rscale); } } if ( *ex == No_Error ) { sub_var(&x, &const_one, result); add_var(&x, &const_one, &elem); div_var(result, &elem, result, global_rscale, ex); } if ( *ex == No_Error ) { set_var_from_var(result, &xx); mul_var(result, result, &x, global_rscale); set_var_from_var(&const_one, &ni); for (i = 2;; i++) { add_var(&ni, &const_two, &ni); mul_var(&xx, &x, &xx, global_rscale); div_var(&xx, &ni, &elem, global_rscale, ex); if ( *ex != No_Error ) break; if (cmp_var(&elem, &const_zero) == 0) break; add_var(result, &elem, result); } } if ( *ex == No_Error ) { *global_rscale = save_global_rscale; mul_var(result, &fact, result, global_rscale); } free_var(&x); free_var(&xx); free_var(&ni); free_var(&elem); free_var(&fact); if ( *ex != No_Error ) nan_var(result); } /* ---------- * log_var() - * * Compute the logarithm of x in a given base * ---------- */ static void log_var(NumericVar *base, NumericVar *num, NumericVar *result, int *global_rscale, Decimal_Exception *ex) { NumericVar ln_base; NumericVar ln_num; *global_rscale += 8; init_var(&ln_base); init_var(&ln_num); ln_var(base, &ln_base, global_rscale, ex); if ( *ex == No_Error ) ln_var(num, &ln_num, global_rscale, ex); if ( *ex == No_Error ) { *global_rscale -= 8; div_var(&ln_num, &ln_base, result, global_rscale, ex); } free_var(&ln_num); free_var(&ln_base); if ( *ex != No_Error ) nan_var(result); } /* ---------- * power_var() - * * Raise base to the power of exp * ---------- */ static void power_var(NumericVar *base, NumericVar *exp, NumericVar *result, int *global_rscale, Decimal_Exception *ex) { NumericVar ln_base; NumericVar ln_num; int save_global_rscale; save_global_rscale = *global_rscale; *global_rscale += *global_rscale / 3 + 8; init_var(&ln_base); init_var(&ln_num); ln_var(base, &ln_base, global_rscale, ex); if ( *ex == No_Error ) { mul_var(&ln_base, exp, &ln_num, global_rscale); *global_rscale = save_global_rscale; exp_var(&ln_num, result, global_rscale, ex); } free_var(&ln_num); free_var(&ln_base); if ( *ex != No_Error ) nan_var(result); } /* ---------------------------------------------------------------------- * * Following are the lowest level functions that operate unsigned * on the variable level * * ---------------------------------------------------------------------- */ /* ---------- * cmp_abs() - * * Compare the absolute values of var1 and var2 * Returns: -1 for ABS(var1) < ABS(var2) * 0 for ABS(var1) == ABS(var2) * 1 for ABS(var1) > ABS(var2) * ---------- */ static int cmp_abs(NumericVar *var1, NumericVar *var2) { int i1 = 0; int i2 = 0; int w1 = var1->weight; int w2 = var2->weight; int stat; while (w1 > w2 && i1 < var1->ndigits) { if (var1->digits[i1++] != 0) return 1; w1--; } while (w2 > w1 && i2 < var2->ndigits) { if (var2->digits[i2++] != 0) return -1; w2--; } if (w1 == w2) { while (i1 < var1->ndigits && i2 < var2->ndigits) { stat = var1->digits[i1++] - var2->digits[i2++]; if (stat) { if (stat > 0) return 1; return -1; } } } while (i1 < var1->ndigits) { if (var1->digits[i1++] != 0) return 1; } while (i2 < var2->ndigits) { if (var2->digits[i2++] != 0) return -1; } return 0; } /* ---------- * add_abs() - * * Add the absolute values of two variables into result. * result might point to one of the operands without danger. * ---------- */ static void add_abs(NumericVar *var1, NumericVar *var2, NumericVar *result) { NumericDigit *res_buf; NumericDigit *res_digits; int res_ndigits; int res_weight; int res_rscale; int res_dscale; int i, i1, i2; int carry = 0; /* copy these values into local vars for speed in inner loop */ int var1ndigits = var1->ndigits; int var2ndigits = var2->ndigits; NumericDigit *var1digits = var1->digits; NumericDigit *var2digits = var2->digits; res_weight = MAX(var1->weight, var2->weight) + 1; res_rscale = MAX(var1->rscale, var2->rscale); res_dscale = MAX(var1->dscale, var2->dscale); res_ndigits = res_rscale + res_weight + 1; if (res_ndigits <= 0) res_ndigits = 1; res_buf = digitbuf_alloc(res_ndigits); res_digits = res_buf; i1 = res_rscale + var1->weight + 1; i2 = res_rscale + var2->weight + 1; for (i = res_ndigits - 1; i >= 0; i--) { i1--; i2--; if (i1 >= 0 && i1 < var1ndigits) carry += var1digits[i1]; if (i2 >= 0 && i2 < var2ndigits) carry += var2digits[i2]; if (carry >= 10) { res_digits[i] = carry - 10; carry = 1; } else { res_digits[i] = carry; carry = 0; } } Assert(carry == 0); /* else we failed to allow for carry out */ while (res_ndigits > 0 && *res_digits == 0) { res_digits++; res_weight--; res_ndigits--; } while (res_ndigits > 0 && res_digits[res_ndigits - 1] == 0) res_ndigits--; if (res_ndigits == 0) res_weight = 0; digitbuf_free(result->buf); result->ndigits = res_ndigits; result->buf = res_buf; result->digits = res_digits; result->weight = res_weight; result->rscale = res_rscale; result->dscale = res_dscale; } /* ---------- * sub_abs() - * * Subtract the absolute value of var2 from the absolute value of var1 * and store in result. result might point to one of the operands * without danger. * * ABS(var1) MUST BE GREATER OR EQUAL ABS(var2) !!! * ---------- */ static void sub_abs(NumericVar *var1, NumericVar *var2, NumericVar *result) { NumericDigit *res_buf; NumericDigit *res_digits; int res_ndigits; int res_weight; int res_rscale; int res_dscale; int i, i1, i2; int borrow = 0; /* copy these values into local vars for speed in inner loop */ int var1ndigits = var1->ndigits; int var2ndigits = var2->ndigits; NumericDigit *var1digits = var1->digits; NumericDigit *var2digits = var2->digits; res_weight = var1->weight; res_rscale = MAX(var1->rscale, var2->rscale); res_dscale = MAX(var1->dscale, var2->dscale); res_ndigits = res_rscale + res_weight + 1; if (res_ndigits <= 0) res_ndigits = 1; res_buf = digitbuf_alloc(res_ndigits); res_digits = res_buf; i1 = res_rscale + var1->weight + 1; i2 = res_rscale + var2->weight + 1; for (i = res_ndigits - 1; i >= 0; i--) { i1--; i2--; if (i1 >= 0 && i1 < var1ndigits) borrow += var1digits[i1]; if (i2 >= 0 && i2 < var2ndigits) borrow -= var2digits[i2]; if (borrow < 0) { res_digits[i] = borrow + 10; borrow = -1; } else { res_digits[i] = borrow; borrow = 0; } } Assert(borrow == 0); /* else caller gave us var1 < var2 */ while (res_ndigits > 0 && *res_digits == 0) { res_digits++; res_weight--; res_ndigits--; } while (res_ndigits > 0 && res_digits[res_ndigits - 1] == 0) res_ndigits--; if (res_ndigits == 0) res_weight = 0; digitbuf_free(result->buf); result->ndigits = res_ndigits; result->buf = res_buf; result->digits = res_digits; result->weight = res_weight; result->rscale = res_rscale; result->dscale = res_dscale; } apq-postgresql-3.2.0/src/numeric.h000066400000000000000000000101331172102510600170710ustar00rootroot00000000000000/****************************************************************************/ /* APQ DATABASE BINDINGS */ /* */ /* A P Q - POSTGRESQL */ /* */ /* S p e c */ /* */ /* Copyright (C) 2002-2007, Warren W. Gay VE3WWG */ /* Copyright (C) 2007-2009, Ada Works Project */ /* */ /* */ /* APQ is free software; you can redistribute it and/or modify it under */ /* terms of the GNU General Public License as published by the Free Soft- */ /* ware Foundation; either version 2, or (at your option) any later ver- */ /* sion. APQ is distributed in the hope that it will be useful, but WITH- */ /* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY */ /* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License */ /* for more details. You should have received a copy of the GNU General */ /* Public License distributed with APQ; see file COPYING. If not, write */ /* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, */ /* MA 02111-1307, USA. */ /* */ /* As a special exception, if other files instantiate generics from this */ /* unit, or you link this unit with other files to produce an executable, */ /* this unit does not by itself cause the resulting executable to be */ /* covered by the GNU General Public License. This exception does not */ /* however invalidate any other reasons why the executable file might be */ /* covered by the GNU Public License. */ /****************************************************************************/ #ifndef _PG_NUMERIC_H_ #define _PG_NUMERIC_H_ /* ---------- * The hardcoded limits and defaults of the numeric data type * ---------- */ #define NUMERIC_MAX_PRECISION 1000 #define NUMERIC_DEFAULT_PRECISION 30 #define NUMERIC_DEFAULT_SCALE 6 /* ---------- * Internal limits on the scales chosen for calculation results * ---------- */ #define NUMERIC_MAX_DISPLAY_SCALE NUMERIC_MAX_PRECISION #define NUMERIC_MIN_DISPLAY_SCALE (NUMERIC_DEFAULT_SCALE + 4) #define NUMERIC_MAX_RESULT_SCALE (NUMERIC_MAX_PRECISION * 2) #define NUMERIC_MIN_RESULT_SCALE (NUMERIC_DEFAULT_PRECISION + 4) /* ---------- * Sign values and macros to deal with packing/unpacking n_sign_dscale * ---------- */ #define NUMERIC_SIGN_MASK 0xC000 #define NUMERIC_POS 0x0000 #define NUMERIC_NEG 0x4000 #define NUMERIC_NAN 0xC000 #define NUMERIC_DSCALE_MASK 0x3FFF #define NUMERIC_SIGN(n) ((n)->n_sign_dscale & NUMERIC_SIGN_MASK) #define NUMERIC_DSCALE(n) ((n)->n_sign_dscale & NUMERIC_DSCALE_MASK) #define NUMERIC_IS_NAN(n) (NUMERIC_SIGN(n) != NUMERIC_POS && \ NUMERIC_SIGN(n) != NUMERIC_NEG) /* ---------- * The Numeric data type stored in the database * * NOTE: by convention, values in the packed form have been stripped of * all leading and trailing zeroes (except there will be a trailing zero * in the last byte, if the number of digits is odd). In particular, * if the value is zero, there will be no digits at all! The weight is * arbitrary in that case, but we normally set it to zero. * ---------- */ typedef struct NumericData { int32 varlen; /* Variable size */ int16 n_weight; /* Weight of 1st digit */ uint16 n_rscale; /* Result scale */ uint16 n_sign_dscale; /* Sign + display scale */ unsigned char n_data[1]; /* Digit data (2 decimal digits/byte) */ } NumericData; typedef NumericData *Numeric; #define NUMERIC_HDRSZ (sizeof(int32) + sizeof(uint16) * 3) #endif /* _PG_NUMERIC_H_ */ apq-postgresql-3.2.0/src/pgtypes.h000066400000000000000000000141751172102510600171340ustar00rootroot00000000000000/****************************************************************************/ /* APQ DATABASE BINDINGS */ /* */ /* A P Q - POSTGRESQL */ /* */ /* S p e c */ /* */ /* Copyright (C) 2002-2007, Warren W. Gay VE3WWG */ /* Copyright (C) 2007-2009, Ada Works Project */ /* */ /* */ /* APQ is free software; you can redistribute it and/or modify it under */ /* terms of the GNU General Public License as published by the Free Soft- */ /* ware Foundation; either version 2, or (at your option) any later ver- */ /* sion. APQ is distributed in the hope that it will be useful, but WITH- */ /* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY */ /* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License */ /* for more details. You should have received a copy of the GNU General */ /* Public License distributed with APQ; see file COPYING. If not, write */ /* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, */ /* MA 02111-1307, USA. */ /* */ /* As a special exception, if other files instantiate generics from this */ /* unit, or you link this unit with other files to produce an executable, */ /* this unit does not by itself cause the resulting executable to be */ /* covered by the GNU General Public License. This exception does not */ /* however invalidate any other reasons why the executable file might be */ /* covered by the GNU Public License. */ /****************************************************************************/ #include #ifndef _PGTYPES_H_ #define _PGTYPES_H_ #include #define palloc malloc #define prealloc realloc #define pfree free #define pstrdup strdup #define Assert assert #define VARHDRSZ ((int32) sizeof(int32)) /* * NULL * Null pointer. */ #ifndef NULL #define NULL ((void *) 0) #endif typedef int bool; #define FALSE 0 #define TRUE 1 /* ---------------------------------------------------------------- * Section 3: standard system types * ---------------------------------------------------------------- */ /* * Pointer * Variable holding address of any memory resident object. * * XXX Pointer arithmetic is done with this, so it can't be void * * under "true" ANSI compilers. */ typedef char *Pointer; /* * intN * Signed integer, EXACTLY N BITS IN SIZE, * used for numerical computations and the * frontend/backend protocol. */ #ifndef HAVE_INT8 typedef signed char int8; /* == 8 bits */ typedef signed short int16; /* == 16 bits */ typedef signed int int32; /* == 32 bits */ #endif /* not HAVE_INT8 */ /* * uintN * Unsigned integer, EXACTLY N BITS IN SIZE, * used for numerical computations and the * frontend/backend protocol. */ /* Also defined in interfaces/odbc/md5.h */ #ifndef HAVE_UINT8 typedef unsigned char uint8; /* == 8 bits */ typedef unsigned short uint16; /* == 16 bits */ typedef unsigned int uint32; /* == 32 bits */ #endif /* not HAVE_UINT8 */ /* * boolN * Boolean value, AT LEAST N BITS IN SIZE. */ typedef uint8 bool8; /* >= 8 bits */ typedef uint16 bool16; /* >= 16 bits */ typedef uint32 bool32; /* >= 32 bits */ /* * bitsN * Unit of bitwise operation, AT LEAST N BITS IN SIZE. */ typedef uint8 bits8; /* >= 8 bits */ typedef uint16 bits16; /* >= 16 bits */ typedef uint32 bits32; /* >= 32 bits */ /* * wordN * Unit of storage, AT LEAST N BITS IN SIZE, * used to fetch/store data. */ typedef uint8 word8; /* >= 8 bits */ typedef uint16 word16; /* >= 16 bits */ typedef uint32 word32; /* >= 32 bits */ /* * floatN * Floating point number, AT LEAST N BITS IN SIZE, * used for numerical computations. * * Since sizeof(floatN) may be > sizeof(char *), always pass * floatN by reference. * * XXX: these typedefs are now deprecated in favor of float4 and float8. * They will eventually go away. */ typedef float float32data; typedef double float64data; typedef float *float32; typedef double *float64; /* * 64-bit integers */ #ifdef HAVE_LONG_INT_64 /* Plain "long int" fits, use it */ #ifndef HAVE_INT64 typedef long int int64; #endif #ifndef HAVE_UINT64 typedef unsigned long int uint64; #endif #elif defined(HAVE_LONG_LONG_INT_64) /* We have working support for "long long int", use that */ #ifndef HAVE_INT64 typedef long long int int64; #endif #ifndef HAVE_UINT64 typedef unsigned long long int uint64; #endif #else /* not HAVE_LONG_INT_64 and not HAVE_LONG_LONG_INT_64 */ /* Won't actually work, but fall back to long int so that code compiles */ #ifndef HAVE_INT64 typedef long int int64; #endif #ifndef HAVE_UINT64 typedef unsigned long int uint64; #endif #define INT64_IS_BUSTED #endif /* not HAVE_LONG_INT_64 and not HAVE_LONG_LONG_INT_64 */ /* sig_atomic_t is required by ANSI C, but may be missing on old platforms */ #ifndef HAVE_SIG_ATOMIC_T typedef int sig_atomic_t; #endif /* * Size * Size of any memory resident object, as returned by sizeof. */ typedef size_t Size; /* * Index * Index into any memory resident array. * * Note: * Indices are non negative. */ typedef unsigned int Index; /* * Offset * Offset into any memory resident array. * * Note: * This differs from an Index in that an Index is always * non negative, whereas Offset may be negative. */ typedef signed int Offset; /* * Common Postgres datatype names (as used in the catalogs) */ typedef int16 int2; typedef int32 int4; typedef float float4; typedef double float8; #endif /* End $Source: /cvsroot/apq/apq/pgtypes.h,v $ */ apq-postgresql-3.2.0/ssl/000077500000000000000000000000001172102510600152725ustar00rootroot00000000000000apq-postgresql-3.2.0/ssl/src-in/000077500000000000000000000000001172102510600164655ustar00rootroot00000000000000apq-postgresql-3.2.0/ssl/src-in/apq-postgresql.ads.in000066400000000000000000000121131172102510600225430ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- APQ DATABASE BINDINGS -- -- -- -- A P Q -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Warren W. Gay VE3WWG -- -- Copyright (C) 2007-2011, KOW Framework Project -- -- -- -- -- -- APQ is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. APQ is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with APQ; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ------------------------------------------------------------------------------ ------------------------------------------------------------------------------- -- This is the base package for the PostreSQL driver for APQ. -- ------------------------------------------------------------------------------- with ada.Strings.Unbounded; package APQ.PostgreSQL is pragma linker_options("-lpq"); type Result_Type is ( Empty_Query, Command_OK, Tuples_OK, Copy_Out, Copy_In, Bad_Response, Nonfatal_Error, Fatal_Error ); for Result_Type use ( Empty_Query => 0, Command_OK => 1, Tuples_OK => 2, Copy_Out => 3, Copy_In => 4, Bad_Response => 5, Nonfatal_Error => 6, Fatal_Error => 7 ); subtype PG_Smallint is APQ_Smallint; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Integer is APQ_Integer; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Bigint is APQ_Bigint; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Real is APQ_Real; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Double is APQ_Double; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Serial is APQ_Serial; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Bigserial is APQ_Bigserial; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Oid is APQ.Row_ID_Type; -- For compatibility only (use APQ.Row_ID_Type instead) subtype PG_Boolean is Boolean; -- For compatibility only (use APQ_Boolean or Boolean instead) subtype PG_Date is APQ_Date; -- For compatibility only (use APQ_Date instead) subtype PG_Time is APQ_Time; -- For compatibility only (use APQ_Time instead) subtype PG_Timestamp is APQ_Timestamp; -- For compatibility only (use APQ_Timestamp instead) -- subtype PG_Timezone is APQ_Timezone; -- For compatibility only (use APQ_Timestamp instead) subtype PG_Bitstring is APQ_Bitstring; -- For compatibility only (use APQ_Timestamp instead) type Mode_Type is ( Write, Read, Read_Write ); for Mode_Type use ( Write => 16#00020000#, -- Write access Read => 16#00040000#, -- Read access Read_Write => 16#00060000# -- Read/Write access ); for Mode_Type'Size use 32; type root_option_record2 is private; private type root_option_record2 is tagged record is_valid : boolean := false; key_u : ada.Strings.Unbounded.Unbounded_String := ada.Strings.Unbounded.To_Unbounded_String(""); value_u : ada.Strings.Unbounded.Unbounded_String := ada.Strings.Unbounded.To_Unbounded_String(""); end record; type PQOid_Type is mod 2 ** 32; -- Currently PostgreSQL uses unsigned int for Oid Null_Row_ID : constant Row_ID_Type := 0; -- Value representing no OID end APQ.PostgreSQL; apq-postgresql-3.2.0/ssl/src/000077500000000000000000000000001172102510600160615ustar00rootroot00000000000000apq-postgresql-3.2.0/ssl/src/apq-postgresql-client.adb000066400000000000000000001640001172102510600227700ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- APQ DATABASE BINDINGS -- -- -- -- A P Q - POSTGRESQL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Warren W. Gay VE3WWG -- -- Copyright (C) 2007-2011, KOW Framework Project -- -- -- -- -- -- APQ is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. APQ is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with APQ; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Calendar; with Ada.Unchecked_Deallocation; with Ada.Unchecked_Conversion; with Ada.Characters.Latin_1; with Ada.Characters.Handling; with Ada.Strings.Fixed; with ada.strings.maps; with Ada.IO_Exceptions; with System; with System.Address_To_Access_Conversions; with Interfaces.C.Strings; with GNAT.OS_Lib; use Interfaces.C; use Ada.Exceptions; package body APQ.PostgreSQL.Client is Seek_Set : constant Interfaces.C.int := 0; Seek_Cur : constant Interfaces.C.int := 1; Seek_End : constant Interfaces.C.int := 2; No_Date : Ada.Calendar.Time; type PQ_Status_Type is ( Connection_OK, Connection_Bad, Connection_Started, -- Waiting for connection to be made. Connection_Made, -- Connection OK; waiting to send. Connection_Awaiting_Response, -- Waiting for a response Connection_Auth_OK, -- Received authentication Connection_Setenv, -- Negotiating environment. Connection_ssl_startup, Connection_needed ); for PQ_Status_Type use ( 0, -- CONNECTION_OK 1, -- CONNECTION_BAD 2, -- CONNECTION_STARTED 3, -- CONNECTION_MADE 4, -- CONNECTION_AWAITING_RESPONSE 5, -- CONNECTION_AUTH_OK 6, -- CONNECTION_SETENV 7, -- Connection_ssl_startup 8 -- Connection_needed ); pragma convention(C,PQ_Status_Type); ------------------------------ -- DATABASE CONNECTION : ------------------------------ function Engine_Of(C : Connection_Type) return Database_Type is begin return Engine_PostgreSQL; end Engine_Of; function New_Query(C : Connection_Type) return Root_Query_Type'Class is Q : Query_Type; begin return Q; end New_Query; procedure Notify_on_Standard_Error(C : in out Connection_Type; Message : String) is use Ada.Text_IO; begin Put(Standard_Error,"*** NOTICE : "); Put_Line(Standard_Error,Message); end Notify_on_Standard_Error; procedure Set_Instance(C : in out Connection_Type; Instance : String) is begin Raise_Exception(Not_Supported'Identity, "PG01: PostgreSQL has no Instance ID. (Set_Instance)"); end Set_Instance; function Host_Name(C : Connection_Type) return String is begin if not Is_Connected(C) then return Host_Name(Root_Connection_Type(C)); else declare use Interfaces.C.Strings; function PQhost(PGconn : PG_Conn) return chars_ptr; pragma Import(C,PQhost,"PQhost"); The_Host : chars_ptr := PQhost(C.Connection); begin if The_Host = Null_Ptr then return "localhost"; end if; return Value_Of(The_Host); end; end if; end Host_Name; function Port(C : Connection_Type) return Integer is begin if not Is_Connected(C) then return Port(Root_Connection_Type(C)); else declare use Interfaces.C.Strings; function PQport(PGconn : PG_Conn) return chars_ptr; pragma Import(C,PQport,"PQport"); The_Port : String := Value_Of(PQport(C.Connection)); begin return Integer'Value(The_Port); exception when others => Raise_Exception(Invalid_Format'Identity, "PG02: Invalid port number or is a UNIX socket reference (Port)."); end; end if; return 0; end Port; function Port(C : Connection_Type) return String is begin if not Is_Connected(C) then return Port(Root_Connection_Type(C)); else declare use Interfaces.C.Strings; function PQport(PGconn : PG_Conn) return chars_ptr; pragma Import(C,PQport,"PQport"); begin return Value_Of(PQport(C.Connection)); end; end if; end Port; function DB_Name(C : Connection_Type) return String is begin if not Is_Connected(C) then return To_Case(DB_Name(Root_Connection_Type(C)),C.SQL_Case); else declare use Interfaces.C.Strings; function PQdb(PGconn : PG_Conn) return chars_ptr; pragma Import(C,PQdb,"PQdb"); begin return Value_Of(PQdb(C.Connection)); end; end if; end DB_Name; function User(C : Connection_Type) return String is begin if not Is_Connected(C) then return User(Root_Connection_Type(C)); else declare use Interfaces.C.Strings; function PQuser(PGconn : PG_Conn) return chars_ptr; pragma Import(C,PQuser,"PQuser"); begin return Value_Of(PQuser(C.Connection)); end; end if; end User; function Password(C : Connection_Type) return String is begin if not Is_Connected(C) then return Password(Root_Connection_Type(C)); else declare use Interfaces.C.Strings; function PQpass(PGconn : PG_Conn) return chars_ptr; pragma Import(C,PQpass,"PQpass"); begin return Value_Of(PQpass(C.Connection)); end; end if; end Password; procedure Set_DB_Name(C : in out Connection_Type; DB_Name : String) is procedure Use_Database(C : in out Connection_Type; DB_Name : String) is Q : Query_Type; begin begin Prepare(Q,To_Case("USE " & DB_Name,C.SQL_Case)); Execute(Q,C); exception when SQL_Error => Raise_Exception(APQ.Use_Error'Identity, "PG03: Unable to select database " & DB_Name & ". (Use_Database)"); end; end Use_Database; begin if not Is_Connected(C) then -- Modify context to connect to this database when we connect Set_DB_Name(Root_Connection_Type(C),DB_Name); else -- Use this database now Use_Database(C,DB_Name); -- Update context info if no exception thrown above Set_DB_Name(Root_Connection_Type(C),DB_Name); end if; C.keyname_val_cache_uptodate := false; end Set_DB_Name; procedure Set_Options(C : in out Connection_Type; Options : String) is begin Replace_String(C.Options,Set_Options.Options); C.keyname_val_cache_uptodate := false; end Set_Options; function Options(C : Connection_Type) return String is begin if not Is_Connected(C) then if C.Options /= null then return C.Options.all; end if; else declare use Interfaces.C.Strings; function PQoptions(PGconn : PG_Conn) return chars_ptr; pragma Import(C,PQoptions,"PQoptions"); begin return Value_Of(PQoptions(C.Connection)); end; end if; return ""; end Options; procedure Set_Notify_Proc(C : in out Connection_Type; Notify_Proc : Notify_Proc_Type) is begin C.Notify_Proc := Set_Notify_Proc.Notify_Proc; end Set_Notify_Proc; function Notify_Proc(C : Connection_Type) return Notify_Proc_Type is begin return C.Notify_Proc; end Notify_Proc; -------------------------------------------------- -- Connection_Notify is called by notices.c as -- a callback from the libpq interface. -------------------------------------------------- -- procedure Connection_Notify(C_Addr : System.Address; Msg_Ptr : Interfaces.C.Strings.chars_ptr); -- pragma Export(C,Connection_Notify,"Connection_Notify"); procedure Connection_Notify(C_Addr : System.Address; Msg_Ptr : Interfaces.C.Strings.chars_ptr) is use Interfaces.C.Strings; package Addr is new System.Address_To_Access_Conversions(Connection_Type); function Strip_Prefix(S : String) return String is use Ada.Strings.Fixed, Ada.Strings; begin if S(S'First..S'First+6) = "NOTICE:" then return Trim(S(S'First+7..S'Last),Left); end if; return S; end Strip_Prefix; Abrt_Notice : constant String := "current transaction is aborted, queries ignored until end of transaction block"; Conn : Addr.Object_Pointer := Addr.To_Pointer(C_Addr); Msg : String := Strip_Prefix(Strip_NL(To_Ada_String(Msg_Ptr))); begin if Conn.Notice /= null then Free(Conn.Notice); -- Free last notice end if; -- Store new notice Conn.Notice := new String(1..Msg'Length); Conn.Notice.all := Msg; if Conn.Notice.all = Abrt_Notice then Conn.Abort_State := True; end if; if Conn.Notify_Proc /= Null then Conn.Notify_Proc(Conn.all,Conn.Notice.all); end if; end Connection_Notify; function PQ_Status(C : Connection_Type) return PQ_Status_Type is function PQstatus(C : PG_Conn) return PQ_Status_Type; pragma Import(C,PQstatus,"PQstatus"); begin if C.Connection = Null_Connection then return Connection_Bad; else return PQstatus(C.Connection); end if; end PQ_Status; procedure Disconnect(C : in out Connection_Type) is procedure Notice_Uninstall(C : PG_Conn); pragma Import(C,notice_uninstall,"notice_uninstall"); procedure PQfinish(C : PG_Conn); pragma Import(C,PQfinish,"PQfinish"); begin if not Is_Connected(C) then Raise_Exception(Not_Connected'Identity, "PG09: Not connected. (Disconnect)"); end if; Notice_Uninstall(C.Connection); -- Disconnect callback notices PQfinish(C.Connection); -- Now release the connection C.Connection := Null_Connection; C.Abort_State := False; -- Clear abort state C.Notify_Proc := null; -- De-register the notify procedure if C.Trace_Mode = Trace_APQ or else C.Trace_Mode = Trace_Full then Ada.Text_IO.Put_Line(C.Trace_Ada,"-- DISCONNECT"); end if; Reset(C); end Disconnect; function Is_Connected(C : Connection_Type) return Boolean is begin return PQ_Status(C) = Connection_OK; end Is_Connected; procedure Internal_Reset(C : in out Connection_Type; In_Finalize : Boolean := False) is begin Free_Ptr(C.Error_Message); if C.Connection /= Null_Connection then declare Q : Query_Type; begin Clear_Abort_State(C); if C.Rollback_Finalize or In_Abort_State(C) then if C.Trace_On and then C.Trace_Filename /= null and then In_Finalize = True then Ada.Text_IO.Put_Line(C.Trace_Ada,"-- ROLLBACK ON FINALIZE"); end if; Rollback_Work(Q,C); else if C.Trace_On and then C.Trace_Filename /= null and then In_Finalize = True then Ada.Text_IO.Put_Line(C.Trace_Ada,"-- COMMIT ON FINALIZE"); end if; Commit_Work(Q,C); end if; exception when others => null; -- Ignore if the Rollback/commit fails end; Clear_Abort_State(C); Disconnect(C); if C.Trace_Filename /= null then Close_DB_Trace(C); end if; end if; if C.Connection = Null_Connection then Free_Ptr(C.Host_Name); Free_Ptr(C.Host_Address); Free_Ptr(C.DB_Name); Free_Ptr(C.User_Name); Free_Ptr(C.User_Password); Free_Ptr(C.Options); Free_Ptr(C.Error_Message); Free_Ptr(C.Notice); -- clear_all_key_nameval(c); end if; end Internal_Reset; procedure Reset(C : in out Connection_Type) is begin Internal_Reset(C,In_Finalize => False); end Reset; function Error_Message(C : Connection_Type) return String is function PQerrorMessage(C : PG_Conn) return Interfaces.C.Strings.chars_ptr; pragma Import(C,PQerrorMessage,"PQerrorMessage"); begin if C.Connection = Null_Connection then if C.Error_Message /= null then return C.Error_Message.all; else return ""; end if; else return To_Ada_String(PQerrorMessage(C.Connection)); end if; end Error_Message; function Notice_Message(C : Connection_Type) return String is begin if C.Notice /= null then return C.Notice.all; end if; return ""; end Notice_Message; -- -- function "="( Left :root_option_record2; right : root_option_record2) return boolean is pragma Optimize(time); lkey_s : string := ada.Strings.fixed.Trim( ada.Characters.Handling.To_Lower( ada.Strings.Unbounded.To_String( left.key_u)) , ada.Strings.Both ); rkey_s : string := ada.Strings.fixed.Trim( ada.Characters.Handling.To_Lower( ada.Strings.Unbounded.To_String( right.key_u)) , ada.Strings.Both ); begin if lkey_s = rkey_s then return true; end if; return false; end "="; function quote_string( qkv : string ) return String is use ada.Strings; use ada.Strings.Fixed; function PQescapeString(to, from : System.Address; length : size_t) return size_t; pragma Import(C,PQescapeString,"PQescapeString"); src : string := trim ( qkv , both ); C_Length : size_t := src'Length * 2 + 1; C_From : char_array := To_C(src); C_To : char_array(0..C_Length-1); R_Length : size_t := PQescapeString(C_To'Address,C_From'Address,C_Length); -- viva!!! :-) begin return To_Ada(C_To); end quote_string; ---- function quote_string( qkv : string ) return ada.Strings.Unbounded.Unbounded_String is begin return ada.Strings.Unbounded.To_Unbounded_String(String'(quote_string(qkv))); end quote_string; -- function cache_key_nameval_uptodate( C : Connection_Type) -- return boolean is begin return c.keyname_val_cache_uptodate; end cache_key_nameval_uptodate; -- procedure cache_key_nameval_create( C : in out Connection_Type; force : boolean := false)-- is pragma optimize(time); use ada.strings.Unbounded; use ada.strings.Fixed; use ada.Strings; use Ada.Characters.Handling; use apq.postgresql.client.options_list2; -- tmp_ub_cache : Unbounded_String := To_Unbounded_String(160); -- pre-allocate :-) tmp_eq : Unbounded_String := to_Unbounded_String(" = '"); tmp_ap : Unbounded_String := to_Unbounded_String("' "); -- procedure process(position : cursor) is val_tmp : root_option_record2 := element(position); begin if val_tmp.is_valid = false then return; end if; --bahiii! :-) tmp_ub_cache := tmp_ub_cache & val_tmp.key_u & tmp_eq & trim(Unbounded_String'(quote_string(string'(To_String(val_tmp.value_u)))),ada.Strings.Both) & tmp_ap ; end process; begin if cache_key_nameval_uptodate( C ) and force = false then return; end if; -- bahiii :-) c.keyname_val_cache := To_Unbounded_String(""); if c.Port_Format = UNIX_Port then tmp_ub_cache := to_Unbounded_String("host") & tmp_eq & trim(Unbounded_String'(quote_string(string'(To_String(C.Host_Name)))),ada.Strings.both) & tmp_ap & to_Unbounded_String("port") & tmp_eq & trim(Unbounded_String'(quote_string(string'(To_String(C.Port_Name)))),ada.Strings.both) & tmp_ap ; elsif c.Port_Format = IP_Port then tmp_ub_cache := to_Unbounded_String("hostaddr") & tmp_eq & trim(Unbounded_String'(quote_string(string'(To_String(C.Host_Address)))),ada.Strings.both) & tmp_ap & to_Unbounded_String("port") & tmp_eq & trim(to_Unbounded_String(string'(Port_Integer'image(c.Port_Number))),ada.Strings.both) & tmp_ap; else raise program_error; end if; tmp_ub_cache := tmp_ub_cache & to_Unbounded_String("dbname") & tmp_eq & trim(Unbounded_String'(quote_string(string'(To_String(C.DB_Name)))),ada.Strings.both) & tmp_ap & to_Unbounded_String("user") & tmp_eq & trim(Unbounded_String'(quote_string(string'(To_String(C.User_Name)))),ada.Strings.both) & tmp_ap & to_Unbounded_String("password") & tmp_eq & trim(Unbounded_String'(quote_string(string'(To_String(C.User_Password)))),ada.Strings.both) & tmp_ap; if trim(string'(To_String(C.Options)), ada.Strings.Both) /= "" then tmp_ub_cache := tmp_ub_cache & to_Unbounded_String("options") & tmp_eq & trim(Unbounded_String'(quote_string(string'(To_String(C.Options)))), both) & tmp_ap ; end if; if not (c.key_name_list.Is_Empty ) then c.key_name_list.Iterate(process'Access); end if; c.keyname_val_cache := tmp_ub_cache; tmp_ub_cache := To_Unbounded_String(""); end cache_key_nameval_create;-- -- procedure clear_all_key_nameval(C : in out Connection_Type ) is pragma optimize(time); begin if not ( c.key_name_list.is_empty ) then c.key_name_list.clear; end if; c.keyname_val_cache := ada.Strings.Unbounded.To_Unbounded_String(""); c.keyname_val_cache_uptodate := false; end clear_all_key_nameval; procedure key_nameval( L : in out options_list2.list ; val : root_option_record2; clear : boolean := false ) is use options_list2; mi_cursor : options_list2.cursor := no_element; begin if clear then if not ( L.is_empty ) then L.clear; end if; end if; if L.is_empty then L.append(val); return; end if; mi_cursor := L.find(val); if mi_cursor = No_Element then L.append(val); return; end if; L.replace_element(mi_cursor, val); end key_nameval; procedure add_key_nameval( C : in out Connection_Type; kname, kval : string := ""; clear : boolean := false ) is pragma optimize(time); use ada.strings; use ada.Strings.Fixed; tmp_kname : string := string'(trim(kname,both)); tmp_kval : string := string'(trim(kval,both)); begin if tmp_kname = "" then return; end if; -- bahiii :-) declare val_tmp : root_option_record2 := root_option_record2'(is_valid => true, key_u => ada.Strings.Unbounded.To_Unbounded_String(tmp_kname), value_u => ada.Strings.Unbounded.To_Unbounded_String(tmp_kval) ); begin key_nameval(L => c.key_name_list, val => val_tmp , clear => clear); end; C.keyname_val_cache_uptodate := false; end add_key_nameval; -- procedure clone_clone_pg(To : in out Connection_Type; From : Connection_Type ) is pragma optimize(time); use apq.postgresql.client.options_list2; -- procedure add(position : cursor) is begin to.key_name_list.append(element(position)); end add; begin clear_all_key_nameval(to); if not ( from.key_name_list.is_empty ) then from.key_name_list.iterate(add'Access); end if; to.keyname_val_cache_uptodate := false; end clone_clone_pg; -- procedure connect(C : in out Connection_Type; Check_Connection : Boolean := True) is pragma optimize(time); use Interfaces.C.Strings; begin if Check_Connection and then Is_Connected(C) then Raise_Exception(Already_Connected'Identity, "PG07: Already connected (Connect)."); end if; cache_key_nameval_create(C); -- don't worry :-) "re-create" accours only if not uptodate :-) -- This procedure can be executed manually if you desire :-) -- "for example": the "Connection_type" var was created and configured -- much before the connection with the DataBase server :-) take place -- then the "Connection_type" already uptodate -- ( well... uptodate if really uptodate ;-) -- this will speedy up the things a little :-) declare procedure Notice_Install(Conn : PG_Conn; ada_obj_ptr : System.Address); pragma import(C,Notice_Install,"notice_install"); function PQconnectdb(coni : chars_ptr ) return PG_Conn; pragma import(C,PQconnectdb,"PQconnectdb"); coni_str : string := ada.Strings.Unbounded.To_String(C.keyname_val_cache); C_conni : chars_ptr := New_String(Str => coni_str ); begin C.Connection := PQconnectdb( C_conni); -- blocking call :-) Free_Ptr(C.Error_Message); if PQ_Status(C) /= Connection_OK then -- if the connecting in a non-blocking fashion, -- there are more option of status needing verification :-) -- it Don't the case here declare procedure PQfinish(C : PG_Conn); pragma Import(C,PQfinish,"PQfinish"); Msg : String := Strip_NL(Error_Message(C)); begin PQfinish(C.Connection); C.Connection := Null_Connection; C.Error_Message := new String(1..Msg'Length); C.Error_Message.all := Msg; Raise_Exception(Not_Connected'Identity, "PG08: Failed to connect to database server (Connect). error was: " & msg ); -- more descriptive about 'what failed' :-) end; end if; Notice_Install(C.Connection,C'Address); -- Install Connection_Notify handler ------------------------------ -- SET PGDATESTYLE TO ISO; -- -- This is necessary for all of the -- APQ date handling routines to -- function correctly. This implies -- that all APQ applications programs -- should use the ISO date format. ------------------------------ declare SQL : Query_Type; begin Prepare(SQL,"SET DATESTYLE TO ISO"); Execute(SQL,C); exception when Ex : others => Disconnect(C); Reraise_Occurrence(Ex); end; end; end connect; procedure connect(C : in out Connection_Type; Same_As : Root_Connection_Type'Class) is pragma optimize(time); type Info_Func is access function(C : Connection_Type) return String; procedure Clone(S : in out String_Ptr; Get_Info : Info_Func) is Info : String := Get_Info(Connection_Type(Same_As)); begin if Info'Length > 0 then S := new String(1..Info'Length); S.all := Info; else null; pragma assert(S = null); end if; end Clone; blo : boolean := true; tmpex : natural := 2; begin Reset(C); Clone(C.Host_Name,Host_Name'Access); C.Port_Format := Same_As.Port_Format; if C.Port_Format = IP_Port then C.Port_Number := Port(Same_As); -- IP_Port else Clone(C.Port_Name,Port'Access); -- UNIX_Port end if; Clone(C.DB_Name,DB_Name'Access); Clone(C.User_Name,User'Access); Clone(C.User_Password,Password'Access); Clone(C.Options,Options'Access); C.Rollback_Finalize := Same_As.Rollback_Finalize; C.Notify_Proc := Connection_Type(Same_As).Notify_Proc; -- I believe if "Same_As" var is defacto a "Connection_Type" as "C" var, -- there are need for copy key's name and val from "Same_As" , -- because in this keys and vals -- maybe are key's how sslmode , gsspi etc, that are defacto needs for connecting "C" if Same_As.Engine_Of = Engine_PostgreSQL then clone_clone_pg(C , Connection_Type(Same_as)); end if; connect(C); -- Connect to database before worrying about trace facilities -- TRACE FILE & TRACE SETTINGS ARE NOT CLONED end connect; function verifica_conninfo_cache( C : Connection_Type) return string -- for debug purpose :-P -- in the spirit there are an get_password(c) yet... is begin return ada.Strings.Unbounded.To_String(c.keyname_val_cache); end verifica_conninfo_cache; procedure Open_DB_Trace(C : in out Connection_Type; Filename : String; Mode : Trace_Mode_Type := Trace_APQ) is begin if C.Trace_Filename /= null then Raise_Exception(Tracing_State'Identity, "PG04: Already in a tracing state (Open_DB_Trace)."); end if; if not Is_Connected(C) then Raise_Exception(Not_Connected'Identity, "PG05: Not connected (Open_DB_Trace)."); end if; if Mode = Trace_None then pragma assert(C.Trace_Mode = Trace_None); return; -- No trace required end if; declare use CStr, System, Ada.Text_IO, Ada.Text_IO.C_Streams; procedure PQtrace(PGconn : PG_Conn; debug_port : CStr.FILEs); pragma Import(C,PQtrace,"PQtrace"); C_Filename : char_array := To_C(Filename); File_Mode : char_array := To_C("a"); begin C.Trace_File := fopen(C_Filename'Address,File_Mode'Address); if C.Trace_File = Null_Stream then Raise_Exception(Ada.IO_Exceptions.Name_Error'Identity, "PG06: Unable to open trace file " & Filename & " (Open_DB_Trace)."); end if; Open(C.Trace_Ada,Append_File,C.Trace_File,Form => "shared=yes"); Ada.Text_IO.Put_Line(C.Trace_Ada,"-- Start of Trace, Mode = " & Trace_Mode_Type'Image(Mode)); if Mode = Trace_DB or Mode = Trace_Full then PQtrace(C.Connection,C.Trace_File); end if; end; C.Trace_Filename := new String(1..Filename'Length); C.Trace_Filename.all := Filename; C.Trace_Mode := Mode; C.Trace_On := True; -- Enabled by default until Set_Trace disables this end Open_DB_Trace; procedure Close_DB_Trace(C : in out Connection_Type) is begin if C.Trace_Mode = Trace_None then return; -- No tracing in progress end if; pragma assert(C.Trace_Filename /= null); declare use CStr; procedure PQuntrace(PGconn : PG_Conn); pragma Import(C,PQuntrace,"PQuntrace"); begin if C.Trace_Mode = Trace_DB or C.Trace_Mode = Trace_Full then PQuntrace(C.Connection); end if; Free(C.Trace_Filename); Ada.Text_IO.Put_Line(C.Trace_Ada,"-- End of Trace."); Ada.Text_IO.Close(C.Trace_Ada); -- This closes C.Trace_File too C.Trace_Mode := Trace_None; C.Trace_On := True; -- Restore default end; end Close_DB_Trace; procedure Set_Trace(C : in out Connection_Type; Trace_On : Boolean := True) is procedure PQtrace(PGconn : PG_Conn; debug_port : CStr.FILEs); procedure PQuntrace(PGconn : PG_Conn); pragma Import(C,PQtrace,"PQtrace"); pragma Import(C,PQuntrace,"PQuntrace"); Orig_Trace : Boolean := C.Trace_On; begin C.Trace_On := Set_Trace.Trace_On; if Orig_Trace = C.Trace_On then return; -- No change end if; if C.Trace_On then if C.Trace_Mode = Trace_DB or C.Trace_Mode = Trace_Full then PQtrace(C.Connection,C.Trace_File); -- Enable libpq tracing end if; else if C.Trace_Mode = Trace_DB or C.Trace_Mode = Trace_Full then PQuntrace(C.Connection); -- Disable libpq tracing end if; end if; end Set_Trace; function Is_Trace(C : Connection_Type) return Boolean is begin return C.Trace_On; end Is_Trace; function In_Abort_State(C : Connection_Type) return Boolean is begin if C.Connection = Null_Connection then return False; end if; return C.Abort_State; end In_Abort_State; ------------------------------ -- SQL QUERY API : ------------------------------ procedure Free(R : in out PQ_Result) is procedure PQclear(R : PQ_Result); pragma Import(C,PQclear,"PQclear"); begin if R /= Null_Result then PQclear(R); R := Null_Result; end if; end Free; procedure Clear(Q : in out Query_Type) is begin Free(Q.Result); Clear(Root_Query_Type(Q)); end Clear; procedure Append_Quoted(Q : in out Query_Type; Connection : Root_Connection_Type'Class; SQL : String; After : String := "") is function PQescapeString(to, from : System.Address; length : size_t) return size_t; pragma Import(C,PQescapeString,"PQescapeString"); C_Length : size_t := SQL'Length * 2 + 1; C_From : char_array := To_C(SQL); C_To : char_array(0..C_Length-1); R_Length : size_t := PQescapeString(C_To'Address,C_From'Address,C_Length); begin Append(Q,"'" & To_Ada(C_To) & "'",After); Q.Caseless(Q.Count) := False; -- Preserve case for this one end Append_Quoted; procedure Execute(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class) is function PQexec(C : PG_Conn; Q : System.Address) return PQ_Result; pragma Import(C,PQexec,"PQexec"); R : Result_Type; begin Query.SQL_Case := Connection.SQL_Case; if not Is_Connected(Connection) then Raise_Exception(Not_Connected'Identity, "PG14: The Connection_Type object supplied is not connected (Execute)."); end if; if In_Abort_State(Connection) then Raise_Exception(Abort_State'Identity, "PG15: The PostgreSQL connection is in the Abort state (Execute)."); end if; if Query.Result /= Null_Result then Free(Query.Result); end if; declare A_Query : String := To_String(Query); C_Query : char_array := To_C(A_Query); begin if Connection.Trace_On then if Connection.Trace_Mode = Trace_APQ or Connection.Trace_Mode = Trace_Full then Ada.Text_IO.Put_Line(Connection.Trace_Ada,"-- SQL QUERY:"); Ada.Text_IO.Put_Line(Connection.Trace_Ada,A_Query); Ada.Text_IO.Put_Line(Connection.Trace_Ada,";"); end if; end if; Query.Result := PQexec(Internal_Connection(Connection_Type(Connection)),C_Query'Address); if Connection.Trace_On then if Connection.Trace_Mode = Trace_APQ or Connection.Trace_Mode = Trace_Full then Ada.Text_IO.Put_Line(Connection.Trace_Ada,"-- Result: '" & Command_Status(Query) & "'"); Ada.Text_IO.New_Line(Connection.Trace_Ada); end if; end if; end; if Query.Result /= Null_Result then Query.Tuple_Index := First_Tuple_Index; R := Result(Query); if R /= Command_OK and R /= Tuples_OK then -- if Connection.Trace_On then -- Ada.Text_IO.Put_Line(Connection.Trace_Ada,"-- Error " & -- Result_Type'Image(Query.Error_Code) & " : " & Error_Message(Query)); -- end if; Raise_Exception(SQL_Error'Identity, "PG16: The query failed (Execute)."); end if; else -- if Connection.Trace_On then -- Ada.Text_IO.Put_Line(Connection.Trace_Ada,"-- Error " & -- Result_Type'Image(Query.Error_Code) & " : " & Error_Message(Query)); -- end if; Raise_Exception(SQL_Error'Identity, "PG17: The query failed (Execute)."); end if; end Execute; procedure Execute_Checked(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class; Msg : String := "") is use Ada.Text_IO; begin begin Execute(Query,Connection); exception when Ex : SQL_Error => if Msg'Length > 0 then Put(Standard_Error,"*** SQL ERROR: "); Put_Line(Standard_Error,Msg); else Put(Standard_Error,"*** SQL ERROR IN QUERY:"); New_Line(Standard_Error); Put(Standard_Error,To_String(Query)); if Col(Standard_Error) > 1 then New_Line(Standard_Error); end if; end if; Put(Standard_Error,"["); Put(Standard_Error,Result_Type'Image(Result(Query))); Put(Standard_Error,": "); Put(Standard_Error,Error_Message(Query)); Put_Line(Standard_Error,"]"); Reraise_Occurrence(Ex); when Ex : others => Reraise_Occurrence(Ex); end; end Execute_Checked; procedure Begin_Work(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class) is begin if In_Abort_State(Connection) then Raise_Exception(Abort_State'Identity, "PG36: PostgreSQL connection is in the abort state (Begin_Work)."); end if; Clear(Query); Prepare(Query,"BEGIN WORK"); Execute(Query,Connection); Clear(Query); end Begin_Work; procedure Commit_Work(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class) is begin if In_Abort_State(Connection) then Raise_Exception(Abort_State'Identity, "PG37: PostgreSQL connection is in the abort state (Commit_Work)."); end if; Clear(Query); Prepare(Query,"COMMIT WORK"); Execute(Query,Connection); Clear(Query); end Commit_Work; procedure Rollback_Work(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class) is begin Clear(Query); Prepare(Query,"ROLLBACK WORK"); Execute(Query,Connection); Clear_Abort_State(Connection); Clear(Query); end Rollback_Work; procedure Rewind(Q : in out Query_Type) is begin Q.Rewound := True; Q.Tuple_Index := First_Tuple_Index; end Rewind; procedure Fetch(Q : in out Query_Type) is begin if not Q.Rewound then Q.Tuple_Index := Q.Tuple_Index + 1; else Q.Rewound := False; end if; Fetch(Q,Q.Tuple_Index); end Fetch; procedure Fetch(Q : in out Query_Type; TX : Tuple_Index_Type) is NT : Tuple_Count_Type := Tuples(Q); -- May raise No_Result begin if NT < 1 then Raise_Exception(No_Tuple'Identity, "PG33: There is no row" & Tuple_Index_Type'Image(TX) & " (Fetch)."); end if; Q.Tuple_Index := TX; Q.Rewound := False; if TX > NT then Raise_Exception(No_Tuple'Identity, "PG34: There is no row" & Tuple_Index_Type'Image(TX) & " (Fetch)."); end if; end Fetch; function End_of_Query(Q : Query_Type) return Boolean is NT : Tuple_Count_Type := Tuples(Q); -- May raise No_Result begin if NT < 1 then return True; -- There are no tuples to return end if; if Q.Rewound then return False; -- There is at least 1 tuple to return yet end if; return Tuple_Count_Type(Q.Tuple_Index) >= NT; -- We've fetched them all end End_of_Query; function Tuple(Q : Query_Type) return Tuple_Index_Type is NT : Tuple_Count_Type := Tuples(Q); -- May raise No_Result begin if NT < 1 or else Q.Rewound then Raise_Exception(No_Tuple'Identity, "PG35: There are no tuples to return (Tuple)."); end if; return Q.Tuple_Index; end Tuple; function Tuples(Q : Query_Type) return Tuple_Count_Type is use Interfaces.C; function PQntuples(R : PQ_Result) return int; pragma Import(C,PQntuples,"PQntuples"); begin if Q.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG19: There are no query results (Tuples)."); end if; return Tuple_Count_Type(PQntuples(Q.Result)); end Tuples; function Columns(Q : Query_Type) return Natural is use Interfaces.C; function PQnfields(R : PQ_Result) return int; pragma Import(C,PQnfields,"PQnfields"); begin if Q.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG20: There are no query results (Columns)."); end if; return Natural(PQnfields(Q.Result)); end Columns; function Column_Name(Q : Query_Type; CX : Column_Index_Type) return String is use Interfaces.C.Strings; function PQfname(R : PQ_Result; CBX : int) return chars_ptr; pragma Import(C,PQfname,"PQfname"); CBX : int := int(CX) - 1; -- Make zero based begin if Q.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG21: There are no query results (Column_Name)."); end if; declare use Interfaces.C.Strings; CP : chars_ptr := PQfname(Q.Result,CBX); begin if CP = Null_Ptr then Raise_Exception(No_Column'Identity, "PG22: There is no column CX=" & Column_Index_Type'Image(CX) & "."); end if; return To_Case(Value_Of(CP),Q.SQL_Case); end; end Column_Name; function Column_Index(Q : Query_Type; Name : String) return Column_Index_Type is use Interfaces.C.Strings; function PQfnumber(R : PQ_Result; CBX : System.Address) return int; pragma Import(C,PQfnumber,"PQfnumber"); C_Name : char_array := To_C(Name); CBX : int := -1; begin if Q.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG23: There are no query results (Column_Index)."); end if; CBX := PQfnumber(Q.Result,C_Name'Address); if CBX < 0 then Raise_Exception(No_Column'Identity, "PG24: There is no column named '" & Name & " (Column_Index)."); end if; return Column_Index_Type(CBX+1); end Column_Index; function Is_Column(Q : Query_Type; CX : Column_Index_Type) return Boolean is begin if Q.Result = Null_Result then return False; end if; return Natural(CX) <= Columns(Q); end Is_Column; function Column_Type(Q : Query_Type; CX : Column_Index_Type) return Row_ID_Type is function PQftype(R : PQ_Result; Field_Index : int) return PQOid_Type; pragma Import(C,PQftype,"PQftype"); CBX : int := int(CX) - 1; begin if Q.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG25: There are no query results (Column_Type)."); end if; if not Is_Column(Q,CX) then Raise_Exception(No_Column'Identity, "PG26: There is no column CX=" & Column_Index_Type'Image(CX) & " (Column_Type)."); end if; return Row_ID_Type(PQftype(Q.Result,CBX)); end Column_Type; function Is_Null(Q : Query_Type; CX : Column_Index_Type) return Boolean is use Interfaces.C.Strings; function PQgetisnull(R : PQ_Result; tup_num, field_num : int) return int; pragma Import(C,PQgetisnull,"PQgetisnull"); C_TX : int := int(Q.Tuple_Index) - 1; -- Make zero based tuple # C_CX : int := int(CX) - 1; -- Field index begin if Q.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG31: There are no query results (Is_Null)."); end if; if not Is_Column(Q,CX) then Raise_Exception(No_Column'Identity, "PG32: There is now column" & Column_Index_Type'Image(CX) & " (Is_Null)."); end if; return PQgetisnull(Q.Result,C_TX,C_CX) /= 0; end Is_Null; function Value(Query : Query_Type; CX : Column_Index_Type) return String is use Interfaces.C.Strings; function PQgetvalue(R : PQ_Result; tup_num, field_num : int) return chars_ptr; pragma Import(C,PQgetvalue,"PQgetvalue"); function PQgetisnull(R : PQ_Result; tup_num, field_num : int) return int; pragma Import(C,PQgetisnull,"PQgetisnull"); C_TX : int := int(Query.Tuple_Index) - 1; -- Make zero based tuple # C_CX : int := int(CX) - 1; -- Field index begin if Query.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG27: There are no query results (Value)."); end if; if not Is_Column(Query,CX) then Raise_Exception(No_Column'Identity, "PG28: There is no column CX=" & Column_Index_Type'Image(CX) & " (Value)."); end if; declare use Ada.Strings, Ada.Strings.Fixed; C_Val : chars_ptr := PQgetvalue(Query.Result,C_TX,C_CX); begin if C_Val = Null_Ptr then Raise_Exception(No_Tuple'Identity, "PG29: There is no row" & Tuple_Index_Type'Image(Query.Tuple_Index) & " (Value)."); elsif PQgetisnull(Query.Result,C_TX,C_CX) /= 0 then Raise_Exception(Null_Value'Identity, "PG30: Value for column" & Column_Index_Type'Image(CX) & " is NULL (Value)."); else return Trim(Value_Of(C_Val),Right); end if; end; end Value; function Result(Query : Query_Type) return Natural is begin return Result_Type'Pos(Result(Query)); end Result; function Result(Query : Query_Type) return Result_Type is function PQresultStatus(R : PQ_Result) return Result_Type; pragma Import(C,PQresultStatus,"PQresultStatus"); begin if Query.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG13: There are no query results (function Result)."); end if; return PQresultStatus(Query.Result); end Result; function Command_Oid(Query : Query_Type) return Row_ID_Type is function PQoidValue(R : PQ_Result) return PQOid_Type; pragma Import(C,PQoidValue,"PQoidValue"); begin if Query.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG12: There are no query results (Command_Oid)."); end if; return Row_ID_Type(PQoidValue(Query.Result)); end Command_Oid; function Null_Oid(Query : Query_Type) return Row_ID_Type is begin return APQ.PostgreSQL.Null_Row_ID; end Null_Oid; function Command_Status(Query : Query_Type) return String is use Interfaces.C.Strings; function PQcmdStatus(R : PQ_Result) return chars_ptr; pragma Import(C,PQcmdStatus,"PQcmdStatus"); begin if Query.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG11: There are no query results (Command_Status)."); end if; declare use Interfaces.C.Strings; Msg_Ptr : chars_ptr := PQcmdStatus(Query.Result); begin if Msg_Ptr = Null_Ptr then return ""; else return Strip_NL(Value_Of(Msg_Ptr)); end if; end; end Command_Status; function Error_Message(Query : Query_Type) return String is use Interfaces.C.Strings; function PQresultErrorMessage(R : PQ_Result) return chars_ptr; pragma Import(C,PQresultErrorMessage,"PQresultErrorMessage"); begin if Query.Result = Null_Result then Raise_Exception(No_Result'Identity, "PG10: There are no query results (Error_Message)."); end if; declare use Interfaces.C.Strings; Msg_Ptr : chars_ptr := PQresultErrorMessage(Query.Result); begin if Msg_Ptr = Null_Ptr then return ""; else return Strip_NL(Value_Of(Msg_Ptr)); end if; end; end Error_Message; function Is_Duplicate_Key(Query : Query_Type) return Boolean is Msg : String := Error_Message(Query); Dup : constant String := "ERROR: Cannot insert a duplicate key"; begin if Msg'Length < Dup'Length then return False; end if; return Msg(Msg'First..Msg'First+Dup'Length-1) = Dup; end Is_Duplicate_Key; function Engine_Of(Q : Query_Type) return Database_Type is begin return Engine_PostgreSQL; end Engine_Of; -------------------------------------------------- -- BLOB SUPPORT : -------------------------------------------------- function lo_creat(conn : PG_Conn; Mode : Mode_Type) return PQOid_Type; pragma Import(C,lo_creat,"lo_creat"); function lo_open(conn : PG_Conn; Oid : PQOid_Type; Mode : Mode_Type) return Blob_Fd; pragma Import(C,lo_open,"lo_open"); function lo_close(conn : PG_Conn; fd : Blob_Fd) return int; pragma Import(C,lo_close,"lo_close"); function lo_read(conn : PG_Conn; fd : Blob_Fd; buf : System.Address; len : size_t) return int; pragma Import(C,lo_read,"lo_read"); function lo_write(conn : PG_Conn; fd : Blob_Fd; buf : System.Address; len : size_t) return int; pragma Import(C,lo_write,"lo_write"); function lo_unlink(conn : PG_Conn; Oid : PQOid_Type) return int; pragma Import(C,lo_unlink,"lo_unlink"); function lo_lseek(conn : PG_Conn; fd : Blob_Fd; offset, whence : int) return int; pragma Import(C,lo_lseek,"lo_lseek"); procedure Free is new Ada.Unchecked_Deallocation(Blob_Object,Blob_Type); -- internal function Raw_Index(Blob : Blob_Type) return Str.Stream_Element_Offset is use Ada.Streams; Offset : int; begin loop -- In loop form in case EINTR processing should be required someday Offset := lo_lseek(Blob.Conn.Connection,Blob.Fd,0,Seek_Cur); exit when Offset >= 0; Raise_Exception(Blob_Error'Identity, "PG38: Server blob error occurred."); end loop; return Stream_Element_Offset(Offset + 1); end Raw_Index; procedure Raw_Set_Index(Blob : Blob_Object; To : Str.Stream_Element_Offset) is Offset : int := int(To) - 1; Z : int; begin loop -- In loop form in case EINTR processing should be required someday Z := lo_lseek(Blob.Conn.Connection,Blob.Fd,Offset,Seek_Set); exit when Z >= 0; Raise_Exception(Blob_Error'Identity, "PG39: Server blob error occurred."); end loop; end Raw_Set_Index; function Internal_Size(Blob : Blob_Type) return Str.Stream_Element_Offset is use Ada.Streams; Saved_Pos : Stream_Element_Offset := Raw_Index(Blob); End_Offset : int := lo_lseek(Blob.Conn.Connection,Blob.Fd,0,Seek_End); begin if End_Offset < 0 then Raise_Exception(Blob_Error'Identity, "PG40: Server blob error occurred."); end if; Raw_Set_Index(Blob.all,Saved_Pos); return Stream_Element_Offset(End_Offset); end Internal_Size; procedure Internal_Write( Stream: in out Blob_Object; Item: in Ada.Streams.Stream_Element_Array ) is use Ada.Streams; Total : size_t := 0; Len : size_t; IX : Stream_Element_Offset := Item'First; N : int; begin while IX < Item'Last loop Len := size_t(Item'Last - IX + 1); N := lo_write(Stream.Conn.Connection,Stream.Fd,Item(IX)'Address,Len); if N < 0 then Raise_Exception(Blob_Error'Identity, "PG43: Server blob write error occurred."); elsif N > 0 then IX := IX + Stream_Element_Offset(N); Stream.Phy_Offset := Stream.Phy_Offset + Stream_Element_Offset(N); if Stream.Phy_Offset - 1 > Stream.The_Size then Stream.The_Size := Stream.Phy_Offset - 1; end if; end if; if N = 0 then Raise_Exception(Ada.IO_Exceptions.End_Error'Identity, "PG44: End_Error raised while server was writing blob."); end if; end loop; end Internal_Write; procedure Internal_Read( Stream: in out Blob_Object; Item: out Ada.Streams.Stream_Element_Array; Last: out Ada.Streams.Stream_Element_Offset ) is use Ada.Streams; Len : size_t := size_t(Item'Length); N : int; begin loop -- In loop form in case EINTR processing should be required someday N := lo_read(Stream.Conn.Connection,Stream.Fd,Item(Item'First)'Address,Len); exit when N >= 0; Raise_Exception(Blob_Error'Identity, "PG41: Server blob error occurred while reading the blob."); end loop; if N = 0 then Raise_Exception(Ada.IO_Exceptions.End_Error'Identity, "PG42: Reached the end of blob while reading."); end if; Last := Item'First + Stream_Element_Offset(N) - 1; Stream.Phy_Offset := Stream.Phy_Offset + Stream_Element_Offset(N); end Internal_Read; procedure Internal_Blob_Open(Blob : in out Blob_Type; Mode : Mode_Type; Buf_Size : Natural := Buf_Size_Default) is use Ada.Streams; begin Blob.Mode := Internal_Blob_Open.Mode; Blob.Fd := lo_open(Blob.Conn.Connection,PQOid_Type(Blob.Oid),Blob.Mode); if Blob.Fd = -1 then Free(Blob); Raise_Exception(Blob_Error'Identity, "PG45: Unable to open blob on server (OID=" & Row_ID_Type'Image(Blob.Oid) & ")."); end if; if Buf_Size > 0 then Blob.Buffer := new Stream_Element_Array(1..Stream_Element_Offset(Buf_Size)); Blob.Buf_Empty := True; Blob.Buf_Dirty := False; Blob.Buf_Offset := 0; Blob.Log_Offset := 1; Blob.Phy_Offset := 1; Blob.The_Size := Stream_Element_Offset(Internal_Size(Blob)); else null; -- unbuffered blob operations will be used end if; end Internal_Blob_Open; procedure Internal_Set_Index(Blob : in out Blob_Object; To : Str.Stream_Element_Offset) is use Ada.Streams; begin if Blob.Phy_Offset /= Stream_Element_Offset(To) then Raw_Set_Index(Blob,To); Blob.Phy_Offset := Stream_Element_Offset(To); end if; end Internal_Set_Index; -- end internal function Blob_Create(DB : access Connection_Type; Buf_Size : Natural := Buf_Size_Default) return Blob_Type is Blob : Blob_Type; begin Blob := new Blob_Object(DB); Blob.Oid := Row_ID_Type(lo_creat(Blob.Conn.Connection,Read_Write)); if Blob.Oid = -1 then free(Blob); Raise_Exception(Blob_Error'Identity, "PG46: Unable to create blob on server."); end if; begin Internal_Blob_Open(Blob,Write,Buf_Size); exception when Ex : others => Blob_Unlink(DB.all,Blob.Oid); -- Release what will result in an unused blob! Reraise_Occurrence(Ex); -- HINT: Internal_Blob_Open() FAILS IF IT IS NOT IN A TRANSACTION! end; return Blob; end Blob_Create; function Blob_Open(DB : access Connection_Type; Oid : Row_ID_Type; Mode : Mode_Type; Buf_Size : Natural := Buf_Size_Default) return Blob_Type is Blob : Blob_Type; begin Blob := new Blob_Object(DB); Blob.Oid := Blob_Open.Oid; Internal_Blob_Open(Blob,Mode,Buf_Size); return Blob; end Blob_Open; procedure Blob_Flush(Blob : in out Blob_Object) is begin if Blob.Buffer /= null then if ( not Blob.Buf_Empty ) and Blob.Buf_Dirty then Internal_Set_Index(Blob,Blob.Buf_Offset); Internal_Write(Blob,Blob.Buffer(1..Blob.Buf_Size)); end if; Blob.Buf_Dirty := False; else null; -- Ignore flush calls in the unbuffered case end if; end Blob_Flush; procedure Blob_Flush(Blob : Blob_Type) is begin Blob_Flush(Blob.all); end Blob_Flush; procedure Internal_Blob_Close(Blob : in out Blob_Object) is Z : int; begin if Blob.Buffer /= null then if Blob.Buf_Dirty then Blob_Flush(Blob); end if; Free(Blob.Buffer); end if; Z := lo_close(Blob.Conn.Connection,Blob.Fd); if Z /= 0 then Raise_Exception(Blob_Error'Identity, "PG47: Server error when closing blob."); end if; Blob.Fd := -1; end Internal_Blob_Close; procedure Blob_Close(Blob : in out Blob_Type) is begin Internal_Blob_Close(Blob.all); Free(Blob); end Blob_Close; procedure Blob_Set_Index(Blob : Blob_Type; To : Blob_Offset) is use Ada.Streams; begin if Blob.Buffer /= null then Blob.Log_Offset := Stream_Element_Offset(To); else Internal_Set_Index(Blob.all,Stream_Element_Offset(To)); end if; end Blob_Set_Index; function Internal_Index(Blob : Blob_Type) return Str.Stream_Element_Offset is begin return Blob.Phy_Offset; end Internal_Index; function Blob_Index(Blob : Blob_Type) return Blob_Offset is begin if Blob.Buffer /= null then return Blob_Offset(Blob.Log_Offset); else return Blob_Offset(Internal_Index(Blob)); end if; end Blob_Index; function End_of_Blob(Blob : Blob_Type) return Boolean is use Ada.Streams; begin if Blob.Buffer /= null then return Blob.Log_Offset > Blob.The_Size; else return Blob_Index(Blob) > Blob_Size(Blob); end if; end End_of_Blob; function Blob_Oid(Blob : Blob_Type) return Row_ID_Type is begin return Blob.Oid; end Blob_Oid; function Blob_Size(Blob : Blob_Type) return Blob_Count is begin if Blob.Buffer /= null then return Blob_Count(Blob.The_Size); else return Blob_Count(Internal_Size(Blob)); end if; end Blob_Size; function Blob_Stream(Blob : Blob_Type) return Root_Stream_Access is begin if Blob = Null then Raise_Exception(Blob_Error'Identity, "PG49: No blob to create a stream from (Blob_Stream)."); end if; return Root_Stream_Access(Blob); end Blob_Stream; procedure Blob_Unlink(DB : Connection_Type; Oid : Row_ID_Type) is Z : int; begin Z := lo_unlink(DB.Connection,PQOid_Type(Oid)); if Z = -1 then Raise_Exception(Blob_Error'Identity, "PG50: Unable to unlink blob OID=" & Row_ID_Type'Image(Oid) & " (Blob_Unlink)."); end if; end Blob_Unlink; function lo_import(conn : PG_Conn; filename : System.Address) return int; pragma Import(C,lo_import,"lo_import"); function lo_export(conn : PG_Conn; Oid : PQOid_Type; filename : System.Address) return int; pragma Import(C,lo_export,"lo_export"); procedure Blob_Import(DB : Connection_Type; Pathname : String; Oid : out Row_ID_Type) is use Interfaces.C; P : char_array := To_C(Pathname); Z : int; begin Oid := Row_ID_Type'Last; Z := lo_import(DB.Connection,P'Address); if Z <= -1 then Raise_Exception(Blob_Error'Identity, "PG51: Unable to import blob from " & Pathname & " (Blob_Import)."); end if; Oid := Row_ID_Type(Z); end Blob_Import; procedure Blob_Export(DB : Connection_Type; Oid : Row_ID_Type; Pathname : String) is P : char_array := To_C(Pathname); Z : int; begin Z := lo_export(DB.Connection,PQOid_Type(Oid),P'Address); if Z <= -1 then Raise_Exception(Blob_Error'Identity, "PG52: Unable to export blob to " & Pathname & " (Blob_Export)."); end if; end Blob_Export; function Generic_Blob_Open(DB : access Connection_Type; Oid : Oid_Type; Mode : Mode_Type; Buf_Size : Natural := Buf_Size_Default) return Blob_Type is begin return Blob_Open(DB,Row_ID_Type(Oid),Mode,Buf_Size); end Generic_Blob_Open; function Generic_Blob_Oid(Blob : Blob_Type) return Oid_Type is begin return Oid_Type(Blob_Oid(Blob)); end Generic_Blob_Oid; procedure Generic_Blob_Unlink(DB : Connection_Type; Oid : Oid_Type) is begin Blob_Unlink(DB,Row_ID_Type(Oid)); end Generic_Blob_Unlink; procedure Generic_Blob_Import(DB : Connection_Type; Pathname : String; Oid : out Oid_Type) is Local_Oid : Row_ID_Type; begin Blob_Import(DB,Pathname,Local_Oid); Oid := Oid_Type(Local_Oid); end Generic_Blob_Import; procedure Generic_Blob_Export(DB : Connection_Type; Oid : Oid_Type; Pathname : String) is begin Blob_Export(DB,Row_ID_Type(Oid),Pathname); end Generic_Blob_Export; -- private --------------------- -- CONNECTION_TYPE -- --------------------- procedure Initialize(C : in out Connection_Type) is begin C.Port_Format := IP_Port; C.Port_Number := 5432; C.keyname_val_cache_uptodate := false; end Initialize; procedure Finalize(C : in out Connection_Type) is begin Internal_Reset(C,In_Finalize => True); end Finalize; function Internal_Connection(C : Connection_Type) return PG_Conn is begin return C.Connection; end Internal_Connection; function Query_Factory( C: in Connection_Type ) return Root_Query_Type'Class is q: Query_Type; begin return q; end query_factory; ---------------- -- QUERY_TYPE -- ---------------- procedure Adjust(Q : in out Query_Type) is begin Q.Result := Null_Result; Adjust(Root_Query_Type(Q)); end Adjust; procedure Finalize(Q : in out Query_Type) is begin Clear(Q); end Finalize; function SQL_Code(Query : Query_Type) return SQL_Code_Type is begin return 0; end SQL_Code; --------------- -- BLOB_TYPE -- --------------- procedure Finalize(Blob : in out Blob_Object) is begin if Blob.Fd /= -1 then Internal_Blob_Close(Blob); end if; end Finalize; procedure Read( Stream: in out Blob_Object; Item: out Ada.Streams.Stream_Element_Array; Last: out Ada.Streams.Stream_Element_Offset ) is use Ada.Streams; IX : Stream_Element_Offset := Item'First; BX : Stream_Element_Offset; begin if Stream.Buffer /= null then while IX <= Item'Last and Stream.Log_Offset <= Stream.The_Size loop if ( not Stream.Buf_Empty ) and then Stream.Buf_Dirty then -- if not empty and is dirty if Stream.Log_Offset < Stream.Buf_Offset -- if offset too low or else Stream.Log_Offset >= Stream.Buf_Offset + Stream.Buf_Size then -- or offset too high Blob_Flush(Stream); Stream.Buf_Empty := True; end if; end if; if Stream.Buf_Empty then -- If we have an empty buffer then.. if Stream.Log_Offset > Stream.The_Size + 1 then Raise_Exception(Ada.IO_Exceptions.End_Error'Identity, "PG47: End reached while reading blob."); end if; Stream.Buf_Offset := Stream.Log_Offset; -- Start with our convenient offset Stream.Buf_Size := Stream.Buffer.all'Length; -- Try to read entire buffer in if Stream.Buf_Offset + Stream.Buf_Size - 1 > Stream.The_Size then Stream.Buf_Size := Stream.The_Size + 1 - Stream.Buf_Offset; -- read somewhat less in end if; Internal_Set_Index(Stream,Stream.Buf_Offset); Internal_Read(Stream,Stream.Buffer(1..Stream.Buf_Size),Last); if Last /= Stream.Buf_Size then -- Check that all was read Raise_Exception(Blob_Error'Identity, "PG48: Error while reading from blob."); end if; Stream.Buf_Empty := False; -- Buffer is not empty pragma assert(Stream.Buf_Dirty = False); -- Should not be dirty at this point BX := Stream.Buffer.all'First; -- Start reading from buffer here else BX := Stream.Log_Offset - Stream.Buf_Offset + Stream.Buffer.all'First; end if; Item(IX) := Stream.Buffer.all(BX); -- Read item byte IX := IX + 1; -- Advance item index Stream.Log_Offset := Stream.Log_Offset + 1; -- Advance logical offset end loop; Last := IX - 1; else Internal_Read(Stream,Item,Last); end if; end Read; procedure Write( Stream: in out Blob_Object; Item: in Ada.Streams.Stream_Element_Array ) is use Ada.Streams; IX : Stream_Element_Offset := Item'First; BX : Stream_Element_Offset := -1; begin if Stream.Buffer /= null then while IX <= Item'Last loop if ( not Stream.Buf_Empty ) and then Stream.Buf_Dirty then -- Buffer is not empty and is dirty if Stream.Log_Offset < Stream.Buf_Offset -- if offset too low or else Stream.Log_Offset > Stream.Buf_Offset + Stream.Buf_Size -- or offset too high or else Stream.Buf_Size >= Stream.Buffer.all'Length then -- or buffer is full then.. Blob_Flush(Stream); -- Flush out dirty data Stream.Buf_Empty := True; -- Now mark buffer as empty else BX := Stream.Log_Offset - Stream.Buf_Offset + Stream.Buffer.all'First; end if; else BX := Stream.Log_Offset - Stream.Buf_Offset + Stream.Buffer.all'First; end if; if Stream.Buf_Empty then -- if buf was empty or was just made empty then.. Stream.Buf_Offset := Stream.Log_Offset; -- Set to our convenient offset Stream.Buf_Size := 0; -- No data in this buffer yet Stream.Buf_Dirty := False; -- Make sure it's not marked dirty yet BX := Stream.Buffer.all'First; -- Point to start of buffer end if; Stream.Buffer.all(BX) := Item(IX); -- Write the byte IX := IX + 1; -- Advance Item Index Stream.Log_Offset := Stream.Log_Offset + 1; -- Advance the logical blob offset Stream.Buf_Empty := False; -- Buffer is no longer empty Stream.Buf_Dirty := True; -- Buffer has been modified if BX > Stream.Buf_Size then -- Did the buffer contents grow? Stream.Buf_Size := Stream.Buf_Size + 1; -- Buffer size has grown end if; end loop; else Internal_Write(Stream,Item); end if; end Write; begin declare use Ada.Calendar; begin No_Date := Time_Of(Year_Number'First,Month_Number'First,Day_Number'First); end; end APQ.PostgreSQL.Client; -- End $Source: /cvsroot/apq/apq/apq-postgresql-client.adb,v $ apq-postgresql-3.2.0/ssl/src/apq-postgresql-client.ads000066400000000000000000000354731172102510600230240ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- APQ DATABASE BINDINGS -- -- -- -- A P Q - POSTGRESQL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Warren W. Gay VE3WWG -- -- Copyright (C) 2007-2011, KOW Framework Project -- -- -- -- -- -- APQ is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. APQ is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with APQ; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ------------------------------------------------------------------------------ ------------------------------------------------------------------------------- -- This is the base package for the PostreSQL driver for APQ. -- ------------------------------------------------------------------------------- with System; with Interfaces; with Ada.Text_IO.C_Streams; with Ada.Finalization; with Ada.Streams.Stream_IO; with Ada.Calendar; with Ada.Strings.Bounded; with Ada.Strings.Unbounded; with Interfaces.C_Streams; with Ada.Containers.Doubly_Linked_Lists; package APQ.PostgreSQL.Client is package Str renames Ada.Streams; package CStr renames Interfaces.C_Streams; -------------------------------------------------- -- Connection_Notify is called by notices.c as -- a callback from the libpq interface. -------------------------------------------------- procedure Connection_Notify(C_Addr : System.Address; Msg_Ptr : Interfaces.C.Strings.chars_ptr); pragma Export(C,Connection_Notify,"Connection_Notify"); ------------------------------ -- CLIENT DATA TYPES ------------------------------ type Connection_Type is new APQ.Root_Connection_Type with private; type Notify_Proc_Type is access procedure(C : in out Connection_Type; Message : String); type Query_Type is new Root_Query_Type with private; type Blob_Type is private; type Root_Stream_Access is access all Str.Root_Stream_Type'Class; ------------------------------ -- DATABASE CONNECTION : ------------------------------ function Engine_Of(C : Connection_Type) return Database_Type; function New_Query(C : Connection_Type) return Root_Query_Type'Class; procedure Notify_on_Standard_Error(C : in out Connection_Type; Message : String); procedure Set_Instance(C : in out Connection_Type; Instance : String); function Host_Name(C : Connection_Type) return String; function Port(C : Connection_Type) return Integer; function Port(C : Connection_Type) return String; function DB_Name(C : Connection_Type) return String; function User(C : Connection_Type) return String; function Password(C : Connection_Type) return String; procedure Set_DB_Name(C : in out Connection_Type; DB_Name : String); procedure Set_Options(C : in out Connection_Type; Options : String); function Options(C : Connection_Type) return String; procedure Set_Notify_Proc(C : in out Connection_Type; Notify_Proc : Notify_Proc_Type); function Notify_Proc(C : Connection_Type) return Notify_Proc_Type; procedure Disconnect(C : in out Connection_Type); function Is_Connected(C : Connection_Type) return Boolean; procedure Reset(C : in out Connection_Type); function Error_Message(C : Connection_Type) return String; function Notice_Message(C : Connection_Type) return String; -- function "="( Left :root_option_record2; right : root_option_record2) return boolean; package options_list2 is new Ada.Containers.Doubly_Linked_Lists( root_option_record2 , "=" ); function quote_string( qkv : string ) return ada.Strings.Unbounded.Unbounded_String; function quote_string( qkv : string ) return String; function cache_key_nameval_uptodate( C : Connection_Type) return boolean;-- pragma inline(cache_key_nameval_uptodate); -- if force = true, re-create it even if already uptodate; -- if force = false,(automatic,normal daily use) re-create only if necessary/not-uptodate procedure cache_key_nameval_create( C : in out Connection_Type; force : boolean := false); -- add keyword and his respective value for the connection string. -- if clear = false, just append keyword and value to list of keywords and values -- if clear = true, remove all values in list before add keyword and value to list -- see http://www.postgresql.org/docs/8.4/static/libpq-connect.html or -- see http://www.postgresql.org/docs/9.0/static/libpq-connect.html to a list of kewords and his values -- -- example sslmode, sslcert, ..., sslkey, gsspi ,etc :-) -- -- if in the list of keywords have keywords equals the value used is the last value in list. -- remember to include the libs was needed procedure add_key_nameval( C : in out Connection_Type; kname,kval : string := ""; clear : boolean := false); procedure clear_all_key_nameval(C : in out Connection_Type ); procedure Connect(C : in out Connection_Type; Check_Connection : Boolean := True); procedure Connect(C : in out Connection_Type; Same_As : Root_Connection_Type'Class); function verifica_conninfo_cache( C : Connection_Type) return string; -- Open trace output file procedure Open_DB_Trace(C : in out Connection_Type; Filename : String; Mode : Trace_Mode_Type := Trace_APQ); procedure Close_DB_Trace(C : in out Connection_Type); -- Close trace output file procedure Set_Trace(C : in out Connection_Type; Trace_On : Boolean := True); -- Enable/Disable tracing function Is_Trace(C : Connection_Type) return Boolean; -- Test trace enabled/disabled function In_Abort_State(C : Connection_Type) return Boolean; No_Notify : constant Notify_Proc_Type := null; -- Null disables notification Standard_Error_Notify : constant Notify_Proc_Type; ------------------------------ -- SQL QUERY API : ------------------------------ procedure Clear(Q : in out Query_Type); procedure Append_Quoted(Q : in out Query_Type; Connection : Root_Connection_Type'Class; SQL : String; After : String := ""); procedure Execute(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class); procedure Execute_Checked(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class; Msg : String := ""); procedure Begin_Work(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class); procedure Commit_Work(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class); procedure Rollback_Work(Query : in out Query_Type; Connection : in out Root_Connection_Type'Class); procedure Rewind(Q : in out Query_Type); procedure Fetch(Q : in out Query_Type); procedure Fetch(Q : in out Query_Type; TX : Tuple_Index_Type); function End_of_Query(Q : Query_Type) return Boolean; -- Avoid use (catch exception instead) function Tuple(Q : Query_Type) return Tuple_Index_Type; function Tuples(Q : Query_Type) return Tuple_Count_Type; function Columns(Q : Query_Type) return Natural; function Column_Name(Q : Query_Type; CX : Column_Index_Type) return String; function Column_Index(Q : Query_Type; Name : String) return Column_Index_Type; function Column_Type(Q : Query_Type; CX : Column_Index_Type) return Row_ID_Type; function Is_Null(Q : Query_Type; CX : Column_Index_Type) return Boolean; function Value(Query : Query_Type; CX : Column_Index_Type) return String; function Result(Query : Query_Type) return Natural; -- Returns Result_Type'Pos() function Result(Query : Query_Type) return Result_Type; function Command_Oid(Query : Query_Type) return Row_ID_Type; function Null_Oid(Query : Query_Type) return Row_ID_Type; function Command_Status(Query : Query_Type) return String; -- PostgreSQL only function Error_Message(Query : Query_Type) return String; function Is_Duplicate_Key(Query : Query_Type) return Boolean; function Engine_Of(Q : Query_Type) return Database_Type; ------------------------------ -- BLOB API : ------------------------------ Buf_Size_Default : constant Natural; type Blob_Count is new Ada.Streams.Stream_Element_Offset range 0..Ada.Streams.Stream_Element_Offset'Last; subtype Blob_Offset is Blob_Count range 1..Blob_Count'Last; function Blob_Create(DB : access Connection_Type; Buf_Size : Natural := Buf_Size_Default) return Blob_Type; function Blob_Open(DB : access Connection_Type; Oid : Row_ID_Type; Mode : Mode_Type; Buf_Size : Natural := Buf_Size_Default) return Blob_Type; procedure Blob_Flush(Blob : Blob_Type); procedure Blob_Close(Blob : in out Blob_Type); procedure Blob_Set_Index (Blob : Blob_Type; To : Blob_Offset); function Blob_Index(Blob : Blob_Type) return Blob_Offset; function End_of_Blob(Blob : Blob_Type) return Boolean; function Blob_Oid(Blob : Blob_Type) return Row_ID_Type; function Blob_Size(Blob : Blob_Type) return Blob_Count; function Blob_Stream(Blob : Blob_Type) return Root_Stream_Access; procedure Blob_Unlink(DB : Connection_Type; Oid : Row_ID_Type); procedure Blob_Import(DB : Connection_Type; Pathname : String; Oid : out Row_ID_Type); procedure Blob_Export(DB : Connection_Type; Oid : Row_ID_Type; Pathname : String); generic type Oid_Type is new Row_ID_Type; function Generic_Blob_Open(DB : access Connection_Type; Oid : Oid_Type; Mode : Mode_Type; Buf_Size : Natural := Buf_Size_Default) return Blob_Type; generic type Oid_Type is new Row_ID_Type; function Generic_Blob_Oid(Blob : Blob_Type) return Oid_Type; generic type Oid_Type is new Row_ID_Type; procedure Generic_Blob_Unlink(DB : Connection_Type; Oid : Oid_Type); generic type Oid_Type is new Row_ID_Type; procedure Generic_Blob_Import(DB : Connection_Type; Pathname : String; Oid : out Oid_Type); generic type Oid_Type is new Row_ID_Type; procedure Generic_Blob_Export(DB : Connection_Type; Oid : Oid_Type; Pathname : String); private type PG_Conn is new System.Address; Null_Connection : PG_Conn := PG_Conn(System.Null_Address); --------------------- -- CONNECTION_TYPE -- --------------------- type Connection_Type is new APQ.Root_Connection_Type with record Options : String_Ptr; -- Debug and trace options, if any Connection : PG_Conn := Null_Connection; Error_Message : String_Ptr; -- Error message after failed to connect (only) Notice : String_Ptr; -- Last notice message if any Notify_Proc : Notify_Proc_Type; -- Notify procedure or NULL ---- -- see http://www.postgresql.org/docs/8.4/interactive/libpq-connect.html -- or see http://www.postgresql.org/docs/9.0/static/libpq-connect.html -- or yet more uptodate url,for example of keyname(s) e theirs possible keyvals :-) key_name_list : options_list2.List; keyname_val_cache : ada.Strings.Unbounded.Unbounded_String := ada.Strings.Unbounded.To_Unbounded_String(""); -- for bypass "the recreate it" , keyname_val_cache_uptodate : boolean := false; -- if keyname_val_cache_uptodate = true (True) end record; procedure Initialize(C : in out Connection_Type); procedure Finalize(C : in out Connection_Type); function Internal_Connection(C : Connection_Type) return PG_Conn; function Query_Factory( C: in Connection_Type ) return Root_Query_Type'Class; type PQ_Result is new System.Address; Null_Result : PQ_Result := PQ_Result(System.Null_Address); type Query_Type is new Root_Query_Type with record Result : PQ_Result := Null_Result; -- Result from a command end record; procedure Adjust(Q : in out Query_Type); procedure Finalize(Q : in out Query_Type); function SQL_Code(Query : Query_Type) return SQL_Code_Type; type Blob_Fd is range -2 ** 31 .. 2 ** 31 - 1; type Blob_Object(Conn : access Connection_Type) is new Ada.Streams.Root_Stream_Type with record Oid : Row_ID_Type := Row_ID_Type'First; -- Oid of this blob Mode : Mode_Type := Read; -- I/O mode of blob Fd : Blob_Fd := -1; -- Blob file descriptor Buffer : Stream_Element_Array_Ptr; -- The stream buffer, if any Buf_Empty : Boolean := True; -- True when buffer is empty Buf_Dirty : Boolean := False; -- True when the buffer needs writing out Buf_Size : Str.Stream_Element_Offset := 0; -- The logical size of the buffer Buf_Offset : Str.Stream_Element_Offset := 0; -- The physical offset of the buffer Log_Offset : Str.Stream_Element_Offset := 0; -- The current logical offset within the blob Phy_Offset : Str.Stream_Element_Offset := 0; -- Physical blob offset The_Size : Str.Stream_Element_Offset := 0; -- The blob's size in bytes end record; type Blob_Type is access all Blob_Object; procedure Finalize(Blob : in out Blob_Object); procedure Read( Stream: in out Blob_Object; Item: out Ada.Streams.Stream_Element_Array; Last: out Ada.Streams.Stream_Element_Offset ); procedure Write( Stream: in out Blob_Object; Item: in Ada.Streams.Stream_Element_Array ); Buf_Size_Default : constant Natural := 5 * 1024; Standard_Error_Notify : constant Notify_Proc_Type := Notify_on_Standard_Error'Access; pragma Inline(Is_Connected); pragma Inline(In_Abort_State); pragma Inline(Clear_Abort_State); pragma Inline(Raise_Exceptions); pragma Inline(Report_Errors); pragma Inline(Rewind); pragma Inline(End_Of_Query); pragma Inline(Blob_Oid); pragma Inline(End_Of_Blob); end APQ.PostgreSQL.Client; apq-postgresql-3.2.0/ssl/src/apq-postgresql-decimal.adb000066400000000000000000000410621172102510600231120ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- APQ DATABASE BINDINGS -- -- -- -- A P Q - POSTGRESQL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Warren W. Gay VE3WWG -- -- Copyright (C) 2007-2011, KOW Framework Project -- -- -- -- -- -- APQ is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. APQ is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with APQ; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- ------------------------------------------------------------------------------ with Interfaces.C, Interfaces.C.Strings; use Interfaces.C, Interfaces.C.Strings; package body APQ.PostgreSQL.Decimal is type numeric_ex is ( C_No_Error, C_Numeric_Format, C_Numeric_Overflow, C_Undefined_Result, C_Divide_By_Zero ); for numeric_ex use ( 0, -- No_Error 1, -- Numeric_Format 2, -- Numeric_Overflow 3, -- Undefined_Result 4 -- Divide_By_Zero ); for numeric_ex'Size use 32; function numeric_global_rscale return Rscale_Type; pragma Import(C,numeric_global_rscale,"numeric_global_rscale"); procedure numeric_free(num : Numeric_Type); pragma Import(C,numeric_free,"numeric_free"); procedure free_cstring(ptr : chars_ptr); pragma Import(C,free_cstring,"numeric_free"); function numeric_isnan(num : Numeric_Type) return int; pragma Import(C,numeric_isnan,"numeric_isnan"); function numeric_in(str : System.Address; precision, scale : int; ex : System.Address) return Numeric_Type; pragma Import(C,numeric_in,"numeric_in"); function numeric_out(num : Numeric_Type) return chars_ptr; pragma Import(C,numeric_out,"numeric_out"); function numeric(num : Numeric_Type; precision, scale : int; ex : System.Address) return Numeric_Type; pragma Import(C,numeric,"numeric"); function numeric_uplus(num : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_uplus,"numeric_uplus"); function numeric_add(num1, num2 : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_add,"numeric_add"); function numeric_sub(num1, num2 : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_sub,"numeric_sub"); function numeric_mul(num1, num2 : Numeric_Type; global_rscale : System.Address) return Numeric_Type; pragma Import(C,numeric_mul,"numeric_mul"); function numeric_div(num1, num2 : Numeric_Type; global_rscale, ex : System.Address) return Numeric_Type; pragma Import(C,numeric_div,"numeric_div"); function numeric_abs(num : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_abs,"numeric_abs"); function numeric_uminus(num : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_uminus,"numeric_uminus"); function numeric_sign(num : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_sign,"numeric_sign"); function numeric_round(num : Numeric_Type; Scale : int) return Numeric_Type; pragma Import(C,numeric_round,"numeric_round"); function numeric_trunc(num : Numeric_Type; Scale : int) return Numeric_Type; pragma Import(C,numeric_trunc,"numeric_trunc"); function numeric_ceil(num : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_ceil,"numeric_ceil"); function numeric_floor(num : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_floor,"numeric_floor"); function numeric_eq(num1, num2 : Numeric_Type) return int; pragma Import(C,numeric_eq,"numeric_eq"); function numeric_ne(num1, num2 : Numeric_Type) return int; pragma Import(C,numeric_ne,"numeric_ne"); function numeric_gt(num1, num2 : Numeric_Type) return int; pragma Import(C,numeric_gt,"numeric_gt"); function numeric_ge(num1, num2 : Numeric_Type) return int; pragma Import(C,numeric_ge,"numeric_ge"); function numeric_lt(num1, num2 : Numeric_Type) return int; pragma Import(C,numeric_lt,"numeric_lt"); function numeric_le(num1, num2 : Numeric_Type) return int; pragma Import(C,numeric_le,"numeric_le"); function numeric_smaller(num1, num2 : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_smaller,"numeric_smaller"); function numeric_larger(num1, num2 : Numeric_Type) return Numeric_Type; pragma Import(C,numeric_larger,"numeric_larger"); function numeric_sqrt(num : Numeric_Type; global_rscale, ex : System.Address) return Numeric_Type; pragma Import(C,numeric_sqrt,"numeric_sqrt"); function numeric_exp(num : Numeric_Type; global_rscale, ex : System.Address) return Numeric_Type; pragma Import(C,numeric_exp,"numeric_exp"); function numeric_ln(num : Numeric_Type; global_rscale, ex : System.Address) return Numeric_Type; pragma Import(C,numeric_ln,"numeric_ln"); function numeric_log(num, base : Numeric_Type; global_rscale, ex : System.Address) return Numeric_Type; pragma Import(C,numeric_log,"numeric_log"); function numeric_power(x, y : Numeric_Type; global_rscale, ex : System.Address) return Numeric_Type; pragma Import(C,numeric_power,"numeric_power"); procedure Free(Num : in out Numeric_Type) is begin if Num /= Null_Numeric then numeric_free(Num); Num := Null_Numeric; end if; end Free; procedure Raise_Exception(Ex : numeric_ex) is begin case Ex is when C_No_Error => return; when C_Numeric_Format => raise Decimal_Format; when C_Numeric_Overflow => raise Decimal_Overflow; when C_Undefined_Result => raise Undefined_Result; when C_Divide_By_Zero => raise Divide_By_Zero; end case; end Raise_Exception; -- private procedure Initialize(DT : in out Decimal_Type) is begin DT.Global_Rscale := numeric_global_rscale; end Initialize; procedure Finalize(DT : in out Decimal_Type) is begin Free(DT.Numeric); end Finalize; procedure Adjust(DT : in out Decimal_Type) is Num : Numeric_Type := DT.Numeric; begin if DT.Numeric = Null_Numeric or else Is_NaN(DT) then return; -- Nothing further to adjust end if; DT.Numeric := numeric_uplus(DT.Numeric); end Adjust; -- public function Is_Nan(DT : Decimal_Type) return Boolean is begin return DT.Numeric = Null_Numeric or else numeric_isnan(DT.Numeric) /= 0; end Is_Nan; procedure Convert(DT : in out Decimal_Type; S : String; Precision : Precision_Type := 0; Scale : Scale_Type := 2) is C_String : char_array := To_C(S); P : int := int(Precision); Sc : int := int(Scale); Ex : numeric_ex; begin if DT.Numeric /= Null_Numeric then Free(DT.Numeric); end if; DT.Numeric := numeric_in(C_String'Address,P,Sc,Ex'Address); if Ex /= C_No_Error then Raise_Exception(Ex); end if; end Convert; function To_String(DT : Decimal_Type) return String is begin if Is_Nan(DT) then raise Decimal_NaN; end if; declare C_Ptr : chars_ptr := numeric_out(DT.Numeric); begin if C_Ptr = Null_Ptr then return "NULL"; else declare S : String := To_Ada(Value(C_Ptr)); begin free_cstring(C_Ptr); return S; end; end if; end; end To_String; function Constrain(DT : Decimal_Type; Precision : Precision_Type; Scale : Scale_Type) return Decimal_Type is R : Decimal_Type; P : int := int(Precision); S : int := int(Scale); E : numeric_ex; begin if Is_Nan(DT) then raise Decimal_NaN; else if Precision /= 0 then R.Numeric := numeric(DT.Numeric,P,S,E'Address); -- Set precision and scale if E /= C_No_Error then Raise_Exception(E); end if; else R.Numeric := numeric_uplus(DT.Numeric); -- Just copy end if; end if; return R; end Constrain; function Abs_Value(DT : Decimal_Type) return Decimal_Type is begin if Is_NaN(DT) then raise Decimal_NaN; end if; declare R : Decimal_Type; begin R.Numeric := numeric_abs(DT.Numeric); return R; end; end Abs_Value; function Sign(DT : Decimal_Type) return Decimal_Type is begin if Is_NaN(DT) then raise Decimal_NaN; end if; declare R : Decimal_Type; begin R.Numeric := numeric_sign(DT.Numeric); return R; end; end Sign; function Ceil(DT : Decimal_Type) return Decimal_Type is begin if Is_NaN(DT) then raise Decimal_NaN; end if; declare R : Decimal_Type; begin R.Numeric := numeric_ceil(DT.Numeric); return R; end; end Ceil; function Floor(DT : Decimal_Type) return Decimal_Type is begin if Is_NaN(DT) then raise Decimal_NaN; end if; declare R : Decimal_Type; begin R.Numeric := numeric_floor(DT.Numeric); return R; end; end Floor; function Round(DT : Decimal_Type; Scale : Scale_Type) return Decimal_Type is begin if Is_NaN(DT) then raise Decimal_NaN; end if; declare R : Decimal_Type; begin R.Numeric := numeric_round(DT.Numeric,int(Scale)); return R; end; end Round; function Trunc(DT : Decimal_Type; Scale : Scale_Type) return Decimal_Type is begin if Is_NaN(DT) then raise Decimal_NaN; end if; declare R : Decimal_Type; begin R.Numeric := numeric_trunc(DT.Numeric,int(Scale)); return R; end; end Trunc; function Min_Value(Left, Right : Decimal_Type) return Decimal_Type is begin if Is_NaN(Left) or else Is_Nan(Right) then raise Decimal_NaN; end if; declare R : Decimal_Type; begin R.Numeric := numeric_smaller(Left.Numeric,Right.Numeric); return R; end; end Min_Value; function Max_Value(Left, Right : Decimal_Type) return Decimal_Type is begin if Is_NaN(Left) or else Is_Nan(Right) then raise Decimal_NaN; end if; declare R : Decimal_Type; begin R.Numeric := numeric_larger(Left.Numeric,Right.Numeric); return R; end; end Max_Value; function Sqrt(X : Decimal_Type) return Decimal_Type is begin if Is_NaN(X) then raise Decimal_NaN; end if; declare R : Decimal_Type; E : numeric_ex; begin R.Numeric := numeric_sqrt(X.Numeric,R.Global_Rscale'Address,E'Address); if E /= C_No_Error then Raise_Exception(E); end if; return R; end; end Sqrt; function Exp(X : Decimal_Type) return Decimal_Type is begin if Is_NaN(X) then raise Decimal_NaN; end if; declare R : Decimal_Type; E : numeric_ex; begin R.Numeric := numeric_exp(X.Numeric,R.Global_Rscale'Address,E'Address); if E /= C_No_Error then Raise_Exception(E); end if; return R; end; end Exp; function Ln(X : Decimal_Type) return Decimal_Type is begin if Is_NaN(X) then raise Decimal_NaN; end if; declare R : Decimal_Type; E : numeric_ex; begin R.Numeric := numeric_ln(X.Numeric,R.Global_Rscale'Address,E'Address); if E /= C_No_Error then Raise_Exception(E); end if; return R; end; end Ln; function Log10(X : Decimal_Type) return Decimal_Type is begin if Is_NaN(X) then raise Decimal_NaN; end if; declare R : Decimal_Type; E : numeric_ex; begin R.Numeric := numeric_log(Ten.Numeric,X.Numeric,R.Global_Rscale'Address,E'Address); if E /= C_No_Error then Raise_Exception(E); end if; return R; end; end Log10; function Log(X, Base : Decimal_Type) return Decimal_Type is begin if Is_NaN(X) or else Is_Nan(Base) then raise Decimal_NaN; end if; declare R : Decimal_Type; E : numeric_ex; begin R.Numeric := numeric_log(Base.Numeric,X.Numeric,R.Global_Rscale'Address,E'Address); if E /= C_No_Error then Raise_Exception(E); end if; return R; end; end Log; function Power(X, Y : Decimal_Type) return Decimal_Type is begin if Is_NaN(X) or else Is_Nan(Y) then raise Decimal_NaN; end if; declare R : Decimal_Type; E : numeric_ex; begin R.Numeric := numeric_power(X.Numeric,Y.Numeric,R.Global_Rscale'Address,E'Address); if E /= C_No_Error then Raise_Exception(E); end if; return R; end; end Power; function "+"(Left, Right : Decimal_Type) return Decimal_Type is R : Decimal_Type; begin R.Numeric := numeric_add(Left.Numeric,Right.Numeric); if Is_Nan(R) then raise Decimal_NaN; end if; return R; end "+"; function "-"(Left, Right : Decimal_Type) return Decimal_Type is R : Decimal_Type; begin R.Numeric := numeric_sub(Left.Numeric,Right.Numeric); if Is_Nan(R) then raise Decimal_NaN; end if; return R; end "-"; function "-"(DT : Decimal_Type) return Decimal_Type is R : Decimal_Type; begin if Is_NaN(DT) then raise Decimal_NaN; end if; R.Numeric := numeric_uminus(DT.Numeric); return R; end "-"; function "*"(Left, Right : Decimal_Type) return Decimal_Type is R : Decimal_Type; begin R.Numeric := numeric_mul(Left.Numeric,Right.Numeric,R.Global_Rscale'Address); if Is_Nan(R) then raise Decimal_NaN; end if; return R; end "*"; function "/"(Left, Right : Decimal_Type) return Decimal_Type is R : Decimal_Type; E : numeric_ex; begin R.Numeric := numeric_div(Left.Numeric,Right.Numeric,R.Global_Rscale'Address,E'Address); if E /= C_No_Error then Raise_Exception(E); end if; if Is_Nan(R) then raise Decimal_NaN; end if; return R; end "/"; function "="(Left, Right : Decimal_Type) return Boolean is begin if Is_NaN(Left) or else Is_Nan(Right) then raise Decimal_NaN; end if; return numeric_eq(Left.Numeric,Right.Numeric) /= 0; end "="; function ">"(Left, Right : Decimal_Type) return Boolean is begin if Is_NaN(Left) or else Is_Nan(Right) then raise Decimal_NaN; end if; return numeric_gt(Left.Numeric,Right.Numeric) /= 0; end ">"; function ">="(Left, Right : Decimal_Type) return Boolean is begin if Is_NaN(Left) or else Is_Nan(Right) then raise Decimal_NaN; end if; return numeric_ge(Left.Numeric,Right.Numeric) /= 0; end ">="; function "<"(Left, Right : Decimal_Type) return Boolean is begin if Is_NaN(Left) or else Is_Nan(Right) then raise Decimal_NaN; end if; return numeric_lt(Left.Numeric,Right.Numeric) /= 0; end "<"; function "<="(Left, Right : Decimal_Type) return Boolean is begin if Is_NaN(Left) or else Is_Nan(Right) then raise Decimal_NaN; end if; return numeric_le(Left.Numeric,Right.Numeric) /= 0; end "<="; Const_Nan : Decimal_Type; Const_Zero, Const_One, Const_Two, Const_Ten : Decimal_Type; -- Constants after elaboration function NaN return Decimal_Type is begin return Const_NaN; end Nan; function Zero return Decimal_Type is begin return Const_Zero; end Zero; function One return Decimal_Type is begin return Const_One; end One; function Two return Decimal_Type is begin return Const_Two; end Two; function Ten return Decimal_Type is begin return Const_Ten; end Ten; procedure Append(Query : in out PostgreSQL.Client.Query_Type; DT : Decimal_Type'Class; After : String := "") is use PostgreSQL.Client; begin Append(Query,To_String(DT),After); end Append; function Value(Query : PostgreSQL.Client.Query_Type; CX : Column_Index_Type) return Decimal_Type is use PostgreSQL.Client; begin if Is_Null(Query,CX) then return NaN; else declare S : String := Value(Query,CX); R : Decimal_Type; begin Convert(R,S); return R; end; end if; end Value; begin Convert(Const_Zero,"0"); Convert(Const_One,"1"); Convert(Const_Two,"2"); Convert(Const_Ten,"10"); end APQ.PostgreSQL.Decimal; -- End $Source: /cvsroot/apq/apq/apq-postgresql-decimal.adb,v $ apq-postgresql-3.2.0/ssl/src/apq-postgresql-decimal.ads000066400000000000000000000130141172102510600231270ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- APQ DATABASE BINDINGS -- -- -- -- A P Q - POSTGRESQL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Warren W. Gay VE3WWG -- -- Copyright (C) 2007-2011, KOW Framework Project -- -- -- -- -- -- APQ is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. APQ is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with APQ; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- ------------------------------------------------------------------------------ with System; with Interfaces; with Ada.Finalization; with APQ.PostgreSQL.Client; package APQ.PostgreSQL.Decimal is Decimal_NaN : exception; Decimal_Format : exception; Decimal_Overflow : exception; Undefined_Result : exception; Divide_By_Zero : exception; type Decimal_Type is new Ada.Finalization.Controlled with private; type Precision_Type is range 0..32767; -- Implementation may not actually live up to these limits type Scale_Type is range 0..32767; -- Ditto. function Is_Nan(DT : Decimal_Type) return Boolean; procedure Convert(DT : in out Decimal_Type; S : String; Precision : Precision_Type := 0; Scale : Scale_Type := 2); function To_String(DT : Decimal_Type) return String; function Constrain(DT : Decimal_Type; Precision : Precision_Type; Scale : Scale_Type) return Decimal_Type; function Abs_Value(DT : Decimal_Type) return Decimal_Type; function Sign(DT : Decimal_Type) return Decimal_Type; function Ceil(DT : Decimal_Type) return Decimal_Type; function Floor(DT : Decimal_Type) return Decimal_Type; function Round(DT : Decimal_Type; Scale : Scale_Type) return Decimal_Type; function Trunc(DT : Decimal_Type; Scale : Scale_Type) return Decimal_Type; function Min_Value(Left, Right : Decimal_Type) return Decimal_Type; function Max_Value(Left, Right : Decimal_Type) return Decimal_Type; function Sqrt(X : Decimal_Type) return Decimal_Type; function Exp(X : Decimal_Type) return Decimal_Type; function Ln(X : Decimal_Type) return Decimal_Type; function Log10(X : Decimal_Type) return Decimal_Type; function Log(X, Base : Decimal_Type) return Decimal_Type; function Power(X, Y : Decimal_Type) return Decimal_Type; function "+"(Left, Right : Decimal_Type) return Decimal_Type; function "-"(Left, Right : Decimal_Type) return Decimal_Type; function "-"(DT : Decimal_Type) return Decimal_Type; function "*"(Left, Right : Decimal_Type) return Decimal_Type; function "/"(Left, Right : Decimal_Type) return Decimal_Type; function "="(Left, Right : Decimal_Type) return Boolean; function ">"(Left, Right : Decimal_Type) return Boolean; function ">="(Left, Right : Decimal_Type) return Boolean; function "<"(Left, Right : Decimal_Type) return Boolean; function "<="(Left, Right : Decimal_Type) return Boolean; function NaN return Decimal_Type; function Zero return Decimal_Type; function One return Decimal_Type; function Two return Decimal_Type; function Ten return Decimal_Type; procedure Append(Query : in out PostgreSQL.Client.Query_Type; DT : Decimal_Type'Class; After : String := ""); function Value(Query : PostgreSQL.Client.Query_Type; CX : Column_Index_Type) return Decimal_Type; private type Rscale_Type is range -2 ** 31 .. 2 ** 31 - 1; type Numeric_Type is new System.Address; Null_Numeric : constant Numeric_Type := Numeric_Type(System.Null_Address); type Decimal_Type is new Ada.Finalization.Controlled with record Global_Rscale : Rscale_Type; Precision : Precision_Type := 0; Scale : Scale_Type := 0; Numeric : Numeric_Type := Null_Numeric; end record; procedure Initialize(DT : in out Decimal_Type); procedure Finalize(DT : in out Decimal_Type); procedure Adjust(DT : in out Decimal_Type); end APQ.PostgreSQL.Decimal; -- End $Source: /cvsroot/apq/apq/apq-postgresql-decimal.ads,v $ apq-postgresql-3.2.0/ssl/src/decimal.h000066400000000000000000000120451172102510600176320ustar00rootroot00000000000000/****************************************************************************/ /* APQ DATABASE BINDINGS */ /* */ /* A P Q - POSTGRESQL */ /* */ /* S p e c */ /* */ /* Copyright (C) 2002-2007, Warren W. Gay VE3WWG */ /* Copyright (C) 2007-2009, Ada Works Project */ /* */ /* */ /* APQ is free software; you can redistribute it and/or modify it under */ /* terms of the GNU General Public License as published by the Free Soft- */ /* ware Foundation; either version 2, or (at your option) any later ver- */ /* sion. APQ is distributed in the hope that it will be useful, but WITH- */ /* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY */ /* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License */ /* for more details. You should have received a copy of the GNU General */ /* Public License distributed with APQ; see file COPYING. If not, write */ /* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, */ /* MA 02111-1307, USA. */ /* */ /* As a special exception, if other files instantiate generics from this */ /* unit, or you link this unit with other files to produce an executable, */ /* this unit does not by itself cause the resulting executable to be */ /* covered by the GNU General Public License. This exception does not */ /* however invalidate any other reasons why the executable file might be */ /* covered by the GNU Public License. */ /****************************************************************************/ #ifndef _DECIMAL_H_ #define _DECIMAL_H_ 1 #include "pgtypes.h" #include "numeric.h" enum Num_Exception { No_Error = 0, Numeric_Format, Numeric_Overflow, Undefined_Result, Divide_By_Zero }; typedef enum Num_Exception Decimal_Exception; extern int numeric_global_rscale(void); /* Initial value for global_rscale */ extern void numeric_free(Numeric num); /* Free storage used by Numeric */ extern int numeric_isnan(Numeric num); /* Test for NaN */ extern Numeric numeric_nan(void); /* Create a NaN */ extern Numeric numeric_in(const char *str,int precision,int scale,Decimal_Exception *ex); extern char * numeric_out(Numeric num); /* Numeric to String */ extern Numeric numeric(Numeric num, int precision, int scale, Decimal_Exception *ex); extern Numeric numeric_abs(Numeric num); /* Absolute value */ extern Numeric numeric_uminus(Numeric num); /* Unary minus */ extern Numeric numeric_uplus(Numeric num); /* Copy value */ extern Numeric numeric_sign(Numeric num); /* Determine sign */ extern Numeric numeric_round(Numeric num,int scale); /* Round */ extern Numeric numeric_trunc(Numeric num,int scale); /* Truncate */ extern Numeric numeric_ceil(Numeric num); /* Ceiling */ extern Numeric numeric_floor(Numeric num); /* Floor */ extern int numeric_cmp(Numeric num1, Numeric num2); /* Compare */ extern int numeric_eq(Numeric num1, Numeric num2); /* = */ extern int numeric_ne(Numeric num1, Numeric num2); /* != */ extern int numeric_gt(Numeric num1, Numeric num2); /* > */ extern int numeric_ge(Numeric num1, Numeric num2); /* >= */ extern int numeric_lt(Numeric num1, Numeric num2); /* < */ extern int numeric_le(Numeric num1, Numeric num2); /* <= */ extern Numeric numeric_add(Numeric num1, Numeric num2); /* + */ extern Numeric numeric_sub(Numeric num1, Numeric num2); /* - */ extern Numeric numeric_mul(Numeric num1, Numeric num2, int *global_rscale); /* * */ extern Numeric numeric_div(Numeric num1, Numeric num2, int *global_rscale, Decimal_Exception *ex); /* / */ extern Numeric numeric_mod(Numeric num1, Numeric num2, int *global_rscale, Decimal_Exception *ex); /* % */ extern Numeric numeric_smaller(Numeric num1, Numeric num2); /* min(a,b) */ extern Numeric numeric_larger(Numeric num1, Numeric num2); /* max(a,b) */ extern Numeric numeric_sqrt(Numeric num, int *global_rscale,Decimal_Exception *ex); /* Square root */ extern Numeric numeric_exp(Numeric num, int *global_rscale, Decimal_Exception *ex); /* Exponent */ extern Numeric numeric_ln(Numeric num, int *global_rscale, Decimal_Exception *ex); /* Ln */ extern Numeric numeric_log(Numeric num1, Numeric num2, int *global_rscale, Decimal_Exception *ex); /* Log */ extern Numeric numeric_power(Numeric num1, Numeric num2, int *global_rscale, Decimal_Exception *ex); /* Power */ #endif /* _DECIMAL_H_ */ /* End $Source: /cvsroot/apq/apq/decimal.h,v $ */ apq-postgresql-3.2.0/ssl/src/notices.c000066400000000000000000000055451172102510600177020ustar00rootroot00000000000000/****************************************************************************/ /* APQ DATABASE BINDINGS */ /* */ /* A P Q - POSTGRESQL */ /* */ /* B o d y */ /* */ /* Copyright (C) 2002-2007, Warren W. Gay VE3WWG */ /* Copyright (C) 2007-2009, Ada Works Project */ /* */ /* */ /* APQ is free software; you can redistribute it and/or modify it under */ /* terms of the GNU General Public License as published by the Free Soft- */ /* ware Foundation; either version 2, or (at your option) any later ver- */ /* sion. APQ is distributed in the hope that it will be useful, but WITH- */ /* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY */ /* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License */ /* for more details. You should have received a copy of the GNU General */ /* Public License distributed with APQ; see file COPYING. If not, write */ /* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, */ /* MA 02111-1307, USA. */ /* */ /* As a special exception, if other files instantiate generics from this */ /* unit, or you link this unit with other files to produce an executable, */ /* this unit does not by itself cause the resulting executable to be */ /* covered by the GNU General Public License. This exception does not */ /* however invalidate any other reasons why the executable file might be */ /* covered by the GNU Public License. */ /****************************************************************************/ #include #include /* * Connection_Notify is an Ada procedure using C calling convention : */ extern void Connection_Notify(void *arg,const char *message); /* * A do-nothing notices callback : */ static void notices_dud(void *arg,const char *message) { return; } /* * Install a new notices callback : */ void notice_install(PGconn *conn,void *ada_obj_ptr) { PQsetNoticeProcessor(conn,Connection_Notify,ada_obj_ptr); } /* * Disable callbacks to the Connection_Notify Ada procedure : */ void notice_uninstall(PGconn *conn) { PQsetNoticeProcessor(conn,notices_dud,NULL); } /* End $Source: /cvsroot/apq/apq/notices.c,v $ */ apq-postgresql-3.2.0/ssl/src/numeric.c000066400000000000000000002017621172102510600176770ustar00rootroot00000000000000/****************************************************************************/ /* APQ DATABASE BINDINGS */ /* */ /* A P Q - POSTGRESQL */ /* */ /* B o d y */ /* */ /* Copyright (C) 2002-2007, Warren W. Gay VE3WWG */ /* Copyright (C) 2007-2009, Ada Works Project */ /* */ /* */ /* APQ is free software; you can redistribute it and/or modify it under */ /* terms of the GNU General Public License as published by the Free Soft- */ /* ware Foundation; either version 2, or (at your option) any later ver- */ /* sion. APQ is distributed in the hope that it will be useful, but WITH- */ /* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY */ /* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License */ /* for more details. You should have received a copy of the GNU General */ /* Public License distributed with APQ; see file COPYING. If not, write */ /* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, */ /* MA 02111-1307, USA. */ /* */ /* As a special exception, if other files instantiate generics from this */ /* unit, or you link this unit with other files to produce an executable, */ /* this unit does not by itself cause the resulting executable to be */ /* covered by the GNU General Public License. This exception does not */ /* however invalidate any other reasons why the executable file might be */ /* covered by the GNU Public License. */ /****************************************************************************/ #include #include #include "decimal.h" /* ---------- * Uncomment the following to enable compilation of dump_numeric() * and dump_var() and to get a dump of any result produced by make_result(). * ---------- #define NUMERIC_DEBUG */ /* ---------- * Local definitions * ---------- */ #ifndef MIN #define MIN(a,b) (((a)<(b)) ? (a) : (b)) #endif #ifndef MAX #define MAX(a,b) (((a)>(b)) ? (a) : (b)) #endif #ifndef NAN #define NAN (0.0/0.0) #endif #define nan_var(v) free_var(v) /* ---------- * Local data types * * Note: the first digit of a NumericVar's value is assumed to be multiplied * by 10 ** weight. Another way to say it is that there are weight+1 digits * before the decimal point. It is possible to have weight < 0. * * The value represented by a NumericVar is determined by the sign, weight, * ndigits, and digits[] array. The rscale and dscale are carried along, * but they are just auxiliary information until rounding is done before * final storage or display. (Scales are the number of digits wanted * *after* the decimal point. Scales are always >= 0.) * * buf points at the physical start of the palloc'd digit buffer for the * NumericVar. digits points at the first digit in actual use (the one * with the specified weight). We normally leave an unused byte or two * (preset to zeroes) between buf and digits, so that there is room to store * a carry out of the top digit without special pushups. We just need to * decrement digits (and increment weight) to make room for the carry digit. * * If buf is NULL then the digit buffer isn't actually palloc'd and should * not be freed --- see the constants below for an example. * * NB: All the variable-level functions are written in a style that makes it * possible to give one and the same variable as argument and destination. * This is feasible because the digit buffer is separate from the variable. * ---------- */ typedef unsigned char NumericDigit; typedef struct NumericVar { int ndigits; /* number of digits in digits[] - can be * 0! */ int weight; /* weight of first digit */ int rscale; /* result scale */ int dscale; /* display scale */ int sign; /* NUMERIC_POS, NUMERIC_NEG, or * NUMERIC_NAN */ NumericDigit *buf; /* start of palloc'd space for digits[] */ NumericDigit *digits; /* decimal digits */ } NumericVar; /* ---------- * Some preinitialized variables we need often * ---------- */ static NumericDigit const_zero_data[1] = {0}; static NumericVar const_zero = {0, 0, 0, 0, NUMERIC_POS, NULL, const_zero_data}; static NumericDigit const_one_data[1] = {1}; static NumericVar const_one = {1, 0, 0, 0, NUMERIC_POS, NULL, const_one_data}; static NumericDigit const_two_data[1] = {2}; static NumericVar const_two = {1, 0, 0, 0, NUMERIC_POS, NULL, const_two_data}; static NumericVar const_nan = {0, 0, 0, 0, NUMERIC_NAN, NULL, NULL}; /* ---------- * Local functions * ---------- */ #ifdef NUMERIC_DEBUG static void dump_numeric(char *str, Numeric num); static void dump_var(char *str, NumericVar *var); #else #define dump_numeric(s,n) #define dump_var(s,v) #endif #define digitbuf_alloc(size) ((NumericDigit *) palloc(size)) #define digitbuf_free(buf) \ do { \ if ((buf) != NULL) \ pfree(buf); \ } while (0) #define init_var(v) memset(v,0,sizeof(NumericVar)) static void alloc_var(NumericVar *var, int ndigits); static void free_var(NumericVar *var); static void zero_var(NumericVar *var); static void set_var_from_str(const char *str, NumericVar *dest, Decimal_Exception *ex); static void set_var_from_num(Numeric value, NumericVar *dest); static void set_var_from_var(NumericVar *value, NumericVar *dest); static char *get_str_from_var(NumericVar *var, int dscale); static Numeric make_result(NumericVar *var); static void apply_typmod(NumericVar *var, int precision, int scale, Decimal_Exception *ex); static int cmp_numerics(Numeric num1, Numeric num2); static int cmp_var(NumericVar *var1, NumericVar *var2); static void add_var(NumericVar *var1, NumericVar *var2, NumericVar *result); static void sub_var(NumericVar *var1, NumericVar *var2, NumericVar *result); static void mul_var(NumericVar *var1, NumericVar *var2, NumericVar *result, int *global_rscale); static void div_var(NumericVar *var1, NumericVar *var2, NumericVar *result, int *global_rscale, Decimal_Exception *ex); static int select_div_scale(NumericVar *var1, NumericVar *var2, int *global_rscale); static void mod_var(NumericVar *var1, NumericVar *var2, NumericVar *result, int *global_rscale, Decimal_Exception *ex); static void ceil_var(NumericVar *var, NumericVar *result); static void floor_var(NumericVar *var, NumericVar *result); static void sqrt_var(NumericVar *arg, NumericVar *result, int *global_rscale, Decimal_Exception *ex); static void exp_var(NumericVar *arg, NumericVar *result, int *global_rscale, Decimal_Exception *ex); static void ln_var(NumericVar *arg, NumericVar *result, int *global_rscale, Decimal_Exception *ex); static void log_var(NumericVar *base, NumericVar *num, NumericVar *result, int *global_rscale, Decimal_Exception *ex); static void power_var(NumericVar *base, NumericVar *exp, NumericVar *result, int *global_rscale, Decimal_Exception *ex); static int cmp_abs(NumericVar *var1, NumericVar *var2); static void add_abs(NumericVar *var1, NumericVar *var2, NumericVar *result); static void sub_abs(NumericVar *var1, NumericVar *var2, NumericVar *result); /* * Provide an initialization value for global_rscale : */ int numeric_global_rscale(void) { return NUMERIC_MIN_RESULT_SCALE; } /* ---------------------------------------------------------------------- * * Input-, output- and rounding-functions * * ---------------------------------------------------------------------- * numeric_in() - * * Input function for numeric data type : * NOTES: * When precision is zero, the precision and scale arguments are * ignored. Otherwise the converted value is made to fit the * parameters supplied, else Numeric_Overflow exception. * ---------- */ Numeric numeric_in(const char *str, int precision, int scale, Decimal_Exception *ex) { NumericVar value; Numeric res; *ex = No_Error; /* * Check for NaN */ if (strcmp(str, "NaN") == 0) return make_result(&const_nan); /* * Use set_var_from_str() to parse the input string and return it in * the packed DB storage format */ init_var(&value); set_var_from_str(str, &value, ex); if ( *ex != No_Error ) { res = make_result(&const_nan); } else { if ( precision != 0 ) apply_typmod(&value, precision, scale, ex); res = make_result(&value); } free_var(&value); return res; } /* ---------- * numeric_out() - * * Output function for numeric data type * ---------- */ char * numeric_out(Numeric num) { NumericVar x; char *str; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return pstrdup("NaN"); /* * Get the number in the variable format. * * Even if we didn't need to change format, we'd still need to copy the * value to have a modifiable copy for rounding. set_var_from_num() * also guarantees there is extra digit space in case we produce a * carry out from rounding. */ init_var(&x); set_var_from_num(num, &x); str = get_str_from_var(&x, x.dscale); free_var(&x); return str; } /* * Return TRUE if the value is NaN : */ int numeric_isnan(Numeric num) { return NUMERIC_IS_NAN(num); } /* ---------- * numeric() - * * This is a special function called by the Postgres database system * before a value is stored in a tuples attribute. The precision and * scale of the attribute have to be applied on the value. * ---------- */ Numeric numeric(Numeric num, int precision, int scale, Decimal_Exception *ex) { Numeric new; int maxweight; NumericVar var; *ex = No_Error; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); maxweight = precision - scale; /* * If the number is in bounds and due to the present result scale no * rounding could be necessary, just make a copy of the input and * modify its scale fields. */ if (num->n_weight < maxweight && scale >= num->n_rscale) { new = (Numeric) palloc(num->varlen); memcpy(new, num, num->varlen); new->n_rscale = scale; new->n_sign_dscale = NUMERIC_SIGN(new) | ((uint16) scale & NUMERIC_DSCALE_MASK); return new; } /* * We really need to fiddle with things - unpack the number into a * variable and let apply_typmod() do it. */ init_var(&var); set_var_from_num(num, &var); apply_typmod(&var, precision, scale, ex); new = make_result(&var); free_var(&var); return new; } /* * Release the storage occupied by this Numeric : * (designed to be called by Ada95) */ void numeric_free(Numeric num) { free(num); } /* ---------------------------------------------------------------------- * * Sign manipulation, rounding and the like * * ---------------------------------------------------------------------- */ Numeric numeric_abs(Numeric num) { Numeric res; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); /* * Do it the easy way directly on the packed format */ res = (Numeric) palloc(num->varlen); memcpy(res, num, num->varlen); res->n_sign_dscale = NUMERIC_POS | NUMERIC_DSCALE(num); return res; } Numeric numeric_uminus(Numeric num) { Numeric res; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); /* * Do it the easy way directly on the packed format */ res = (Numeric) palloc(num->varlen); memcpy(res, num, num->varlen); /* * The packed format is known to be totally zero digit trimmed always. * So we can identify a ZERO by the fact that there are no digits at * all. Do nothing to a zero. */ if (num->varlen != NUMERIC_HDRSZ) { /* Else, flip the sign */ if (NUMERIC_SIGN(num) == NUMERIC_POS) res->n_sign_dscale = NUMERIC_NEG | NUMERIC_DSCALE(num); else res->n_sign_dscale = NUMERIC_POS | NUMERIC_DSCALE(num); } return res; } /* * This effectively just copies the value : */ Numeric numeric_uplus(Numeric num) { Numeric res; res = (Numeric) palloc(num->varlen); memcpy(res, num, num->varlen); return res; } /* * Return the sign of the value : */ Numeric numeric_sign(Numeric num) { Numeric res; NumericVar result; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); init_var(&result); /* * The packed format is known to be totally zero digit trimmed always. * So we can identify a ZERO by the fact that there are no digits at * all. */ if (num->varlen == NUMERIC_HDRSZ) set_var_from_var(&const_zero, &result); else { /* * And if there are some, we return a copy of ONE with the sign of * our argument */ set_var_from_var(&const_one, &result); result.sign = NUMERIC_SIGN(num); } res = make_result(&result); free_var(&result); return res; } /* ---------- * numeric_round() - * * Round a value to have 'scale' digits after the decimal point. * We allow negative 'scale', implying rounding before the decimal * point --- Oracle interprets rounding that way. * ---------- */ Numeric numeric_round(Numeric num,int scale) { Numeric res; NumericVar arg; int i; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); /* * Limit the scale value to avoid possible overflow in calculations * below. */ scale = MIN(NUMERIC_MAX_RESULT_SCALE, MAX(-NUMERIC_MAX_RESULT_SCALE, scale)); /* * Unpack the argument and round it at the proper digit position */ init_var(&arg); set_var_from_num(num, &arg); i = arg.weight + scale + 1; if (i < arg.ndigits) { /* * If i = 0, the value loses all digits, but could round up if its * first digit is more than 4. If i < 0 the result must be 0. */ if (i < 0) arg.ndigits = 0; else { int carry = (arg.digits[i] > 4) ? 1 : 0; arg.ndigits = i; while (carry) { carry += arg.digits[--i]; arg.digits[i] = carry % 10; carry /= 10; } if (i < 0) { Assert(i == -1); /* better not have added more than 1 digit */ Assert(arg.digits > arg.buf); arg.digits--; arg.ndigits++; arg.weight++; } } } /* * Set result's scale to something reasonable. */ scale = MIN(NUMERIC_MAX_DISPLAY_SCALE, MAX(0, scale)); arg.rscale = scale; arg.dscale = scale; /* * Return the rounded result */ res = make_result(&arg); free_var(&arg); return res; } /* ---------- * numeric_trunc() - * * Truncate a value to have 'scale' digits after the decimal point. * We allow negative 'scale', implying a truncation before the decimal * point --- Oracle interprets truncation that way. * ---------- */ Numeric numeric_trunc(Numeric num,int scale) { Numeric res; NumericVar arg; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); /* * Limit the scale value to avoid possible overflow in calculations * below. */ scale = MIN(NUMERIC_MAX_RESULT_SCALE, MAX(-NUMERIC_MAX_RESULT_SCALE, scale)); /* * Unpack the argument and truncate it at the proper digit position */ init_var(&arg); set_var_from_num(num, &arg); arg.ndigits = MIN(arg.ndigits, MAX(0, arg.weight + scale + 1)); /* * Set result's scale to something reasonable. */ scale = MIN(NUMERIC_MAX_DISPLAY_SCALE, MAX(0, scale)); arg.rscale = scale; arg.dscale = scale; /* * Return the truncated result */ res = make_result(&arg); free_var(&arg); return res; } /* ---------- * numeric_ceil() - * * Return the smallest integer greater than or equal to the argument * ---------- */ Numeric numeric_ceil(Numeric num) { Numeric res; NumericVar result; if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); init_var(&result); set_var_from_num(num, &result); ceil_var(&result, &result); result.dscale = 0; res = make_result(&result); free_var(&result); return res; } /* ---------- * numeric_floor() - * * Return the largest integer equal to or less than the argument * ---------- */ Numeric numeric_floor(Numeric num) { Numeric res; NumericVar result; if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); init_var(&result); set_var_from_num(num, &result); floor_var(&result, &result); result.dscale = 0; res = make_result(&result); free_var(&result); return res; } /* ---------------------------------------------------------------------- * * Comparison functions * * Note: btree indexes need these routines not to leak memory; therefore, * be careful to free working copies of toasted datums. Most places don't * need to be so careful. * ---------------------------------------------------------------------- */ int numeric_cmp(Numeric num1, Numeric num2) { Numeric orig1 = num1, orig2 = num2; int result; result = cmp_numerics(num1, num2); if ( num1 != orig1 ) free(num1); if ( num2 != orig2 ) free(num2); return result; } int numeric_eq(Numeric num1, Numeric num2) { return numeric_cmp(num1,num2) == 0; } int numeric_ne(Numeric num1, Numeric num2) { return numeric_cmp(num1,num2) != 0; } int numeric_gt(Numeric num1, Numeric num2) { return numeric_cmp(num1,num2) > 0; } int numeric_ge(Numeric num1, Numeric num2) { return numeric_cmp(num1,num2) >= 0; } int numeric_lt(Numeric num1, Numeric num2) { return numeric_cmp(num1,num2) < 0; } int numeric_le(Numeric num1, Numeric num2) { return numeric_cmp(num1,num2) <= 0; } static int cmp_numerics(Numeric num1, Numeric num2) { int result; /* * We consider all NANs to be equal and larger than any non-NAN. This * is somewhat arbitrary; the important thing is to have a consistent * sort order. */ if (NUMERIC_IS_NAN(num1)) { if (NUMERIC_IS_NAN(num2)) result = 0; /* NAN = NAN */ else result = 1; /* NAN > non-NAN */ } else if (NUMERIC_IS_NAN(num2)) { result = -1; /* non-NAN < NAN */ } else { NumericVar arg1; NumericVar arg2; init_var(&arg1); init_var(&arg2); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); result = cmp_var(&arg1, &arg2); free_var(&arg1); free_var(&arg2); } return result; } /* ---------------------------------------------------------------------- * * Arithmetic base functions * * ---------------------------------------------------------------------- * numeric_add() - * * Add two numerics * ---------- */ Numeric numeric_add(Numeric num1, Numeric num2) { NumericVar arg1; NumericVar arg2; NumericVar result; Numeric res; /* * Handle NaN */ if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); /* * Unpack the values, let add_var() compute the result and return it. * The internals of add_var() will automatically set the correct * result and display scales in the result. */ init_var(&arg1); init_var(&arg2); init_var(&result); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); add_var(&arg1, &arg2, &result); res = make_result(&result); free_var(&arg1); free_var(&arg2); free_var(&result); return res; } /* ---------- * numeric_sub() - * * Subtract one numeric from another * ---------- */ Numeric numeric_sub(Numeric num1, Numeric num2) { NumericVar arg1; NumericVar arg2; NumericVar result; Numeric res; /* * Handle NaN */ if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); /* * Unpack the two arguments, let sub_var() compute the result and * return it. */ init_var(&arg1); init_var(&arg2); init_var(&result); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); sub_var(&arg1, &arg2, &result); res = make_result(&result); free_var(&arg1); free_var(&arg2); free_var(&result); return res; } /* ---------- * numeric_mul() - * * Calculate the product of two numerics * ---------- */ Numeric numeric_mul(Numeric num1, Numeric num2, int *global_rscale) { NumericVar arg1; NumericVar arg2; NumericVar result; Numeric res; /* * Handle NaN */ if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); /* * Unpack the arguments, let mul_var() compute the result and return * it. Unlike add_var() and sub_var(), mul_var() will round the result * to the scale stored in global_rscale. In the case of numeric_mul(), * which is invoked for the * operator on numerics, we set it to the * exact representation for the product (rscale = sum(rscale of arg1, * rscale of arg2) and the same for the dscale). */ init_var(&arg1); init_var(&arg2); init_var(&result); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); *global_rscale = arg1.rscale + arg2.rscale; mul_var(&arg1, &arg2, &result, global_rscale); result.dscale = arg1.dscale + arg2.dscale; res = make_result(&result); free_var(&arg1); free_var(&arg2); free_var(&result); return res; } /* ---------- * numeric_div() - * * Divide one numeric into another * ---------- */ Numeric numeric_div(Numeric num1, Numeric num2, int *global_rscale, Decimal_Exception *ex) { NumericVar arg1; NumericVar arg2; NumericVar result; Numeric res; int res_dscale; *ex = No_Error; /* * Handle NaN */ if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); /* * Unpack the arguments */ init_var(&arg1); init_var(&arg2); init_var(&result); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); res_dscale = select_div_scale(&arg1, &arg2, global_rscale); /* * Do the divide, set the display scale and return the result */ div_var(&arg1, &arg2, &result, global_rscale, ex); if ( *ex != No_Error ) { res = make_result(&const_nan); } else { result.dscale = res_dscale; res = make_result(&result); } free_var(&arg1); free_var(&arg2); free_var(&result); return res; } /* ---------- * numeric_mod() - * * Calculate the modulo of two numerics * ---------- */ Numeric numeric_mod(Numeric num1, Numeric num2, int *global_rscale, Decimal_Exception *ex) { Numeric res; NumericVar arg1; NumericVar arg2; NumericVar result; *ex = No_Error; if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); init_var(&arg1); init_var(&arg2); init_var(&result); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); mod_var(&arg1, &arg2, &result, global_rscale, ex); res = make_result(&result); free_var(&result); free_var(&arg2); free_var(&arg1); return res; } /* ---------- * numeric_smaller() - * * Return the smaller of two numbers * ---------- */ Numeric numeric_smaller(Numeric num1, Numeric num2) { NumericVar arg1; NumericVar arg2; Numeric res; /* * Handle NaN */ if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); /* * Unpack the values, and decide which is the smaller one */ init_var(&arg1); init_var(&arg2); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); if (cmp_var(&arg1, &arg2) <= 0) res = make_result(&arg1); else res = make_result(&arg2); free_var(&arg1); free_var(&arg2); return res; } /* ---------- * numeric_larger() - * * Return the larger of two numbers * ---------- */ Numeric numeric_larger(Numeric num1, Numeric num2) { NumericVar arg1; NumericVar arg2; Numeric res; /* * Handle NaN */ if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); /* * Unpack the values, and decide which is the larger one */ init_var(&arg1); init_var(&arg2); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); if (cmp_var(&arg1, &arg2) >= 0) res = make_result(&arg1); else res = make_result(&arg2); free_var(&arg1); free_var(&arg2); return res; } /* ---------------------------------------------------------------------- * * Complex math functions * * ---------------------------------------------------------------------- * numeric_sqrt() - * * Compute the square root of a numeric. * ---------- */ Numeric numeric_sqrt(Numeric num, int *global_rscale, Decimal_Exception *ex) { Numeric res; NumericVar arg; NumericVar result; int res_dscale; *ex = No_Error; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); /* * Unpack the argument, determine the scales like for divide, let * sqrt_var() do the calculation and return the result. */ init_var(&arg); init_var(&result); set_var_from_num(num, &arg); res_dscale = MAX(arg.dscale, NUMERIC_MIN_DISPLAY_SCALE); res_dscale = MIN(res_dscale, NUMERIC_MAX_DISPLAY_SCALE); *global_rscale = MAX(arg.rscale, NUMERIC_MIN_RESULT_SCALE); *global_rscale = MAX(*global_rscale, res_dscale + 4); *global_rscale = MIN(*global_rscale, NUMERIC_MAX_RESULT_SCALE); sqrt_var(&arg, &result, global_rscale, ex); result.dscale = res_dscale; res = make_result(&result); free_var(&result); free_var(&arg); return res; } /* ---------- * numeric_exp() - * * Raise e to the power of x * ---------- */ Numeric numeric_exp(Numeric num, int *global_rscale, Decimal_Exception *ex) { Numeric res; NumericVar arg; NumericVar result; int res_dscale; *ex = No_Error; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); /* * Same procedure like for sqrt(). */ init_var(&arg); init_var(&result); set_var_from_num(num, &arg); res_dscale = MAX(arg.dscale, NUMERIC_MIN_DISPLAY_SCALE); res_dscale = MIN(res_dscale, NUMERIC_MAX_DISPLAY_SCALE); *global_rscale = MAX(arg.rscale, NUMERIC_MIN_RESULT_SCALE); *global_rscale = MAX(*global_rscale, res_dscale + 4); *global_rscale = MIN(*global_rscale, NUMERIC_MAX_RESULT_SCALE); exp_var(&arg, &result, global_rscale, ex); result.dscale = res_dscale; res = make_result(&result); free_var(&result); free_var(&arg); return res; } /* ---------- * numeric_ln() - * * Compute the natural logarithm of x * ---------- */ Numeric numeric_ln(Numeric num, int *global_rscale, Decimal_Exception *ex) { Numeric res; NumericVar arg; NumericVar result; int res_dscale; *ex = No_Error; /* * Handle NaN */ if (NUMERIC_IS_NAN(num)) return make_result(&const_nan); /* * Same procedure like for sqrt() */ init_var(&arg); init_var(&result); set_var_from_num(num, &arg); res_dscale = MAX(arg.dscale, NUMERIC_MIN_DISPLAY_SCALE); res_dscale = MIN(res_dscale, NUMERIC_MAX_DISPLAY_SCALE); *global_rscale = MAX(arg.rscale, NUMERIC_MIN_RESULT_SCALE); *global_rscale = MAX(*global_rscale, res_dscale + 4); *global_rscale = MIN(*global_rscale, NUMERIC_MAX_RESULT_SCALE); ln_var(&arg, &result, global_rscale, ex); if ( *ex == No_Error ) result.dscale = res_dscale; res = make_result(&result); free_var(&result); free_var(&arg); return res; } /* ---------- * numeric_log() - * * Compute the logarithm of x in a given base * ---------- */ Numeric numeric_log(Numeric num1, Numeric num2, int *global_rscale, Decimal_Exception *ex) { Numeric res; NumericVar arg1; NumericVar arg2; NumericVar result; int res_dscale; *ex = No_Error; /* * Handle NaN */ if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); /* * Initialize things and calculate scales */ init_var(&arg1); init_var(&arg2); init_var(&result); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); res_dscale = MAX(arg1.dscale + arg2.dscale, NUMERIC_MIN_DISPLAY_SCALE); res_dscale = MIN(res_dscale, NUMERIC_MAX_DISPLAY_SCALE); *global_rscale = MAX(arg1.rscale + arg2.rscale, NUMERIC_MIN_RESULT_SCALE); *global_rscale = MAX(*global_rscale, res_dscale + 4); *global_rscale = MIN(*global_rscale, NUMERIC_MAX_RESULT_SCALE); /* * Call log_var() to compute and return the result */ log_var(&arg1, &arg2, &result, global_rscale, ex); if ( *ex == No_Error ) result.dscale = res_dscale; res = make_result(&result); free_var(&result); free_var(&arg2); free_var(&arg1); return res; } /* ---------- * numeric_power() - * * Raise m to the power of x * ---------- */ Numeric numeric_power(Numeric num1, Numeric num2, int *global_rscale, Decimal_Exception *ex) { Numeric res; NumericVar arg1; NumericVar arg2; NumericVar result; int res_dscale; *ex = No_Error; /* * Handle NaN */ if (NUMERIC_IS_NAN(num1) || NUMERIC_IS_NAN(num2)) return make_result(&const_nan); /* * Initialize things and calculate scales */ init_var(&arg1); init_var(&arg2); init_var(&result); set_var_from_num(num1, &arg1); set_var_from_num(num2, &arg2); res_dscale = MAX(arg1.dscale + arg2.dscale, NUMERIC_MIN_DISPLAY_SCALE); res_dscale = MIN(res_dscale, NUMERIC_MAX_DISPLAY_SCALE); *global_rscale = MAX(arg1.rscale + arg2.rscale, NUMERIC_MIN_RESULT_SCALE); *global_rscale = MAX(*global_rscale, res_dscale + 4); *global_rscale = MIN(*global_rscale, NUMERIC_MAX_RESULT_SCALE); /* * Call log_var() to compute and return the result */ power_var(&arg1, &arg2, &result, global_rscale, ex); if ( *ex == No_Error ) result.dscale = res_dscale; res = make_result(&result); free_var(&result); free_var(&arg2); free_var(&arg1); return res; } /* ---------------------------------------------------------------------- * * Local functions follow * * ---------------------------------------------------------------------- */ #ifdef NUMERIC_DEBUG /* ---------- * dump_numeric() - Dump a value in the db storage format for debugging * ---------- */ static void dump_numeric(char *str, Numeric num) { int i; printf("%s: NUMERIC w=%d r=%d d=%d ", str, num->n_weight, num->n_rscale, NUMERIC_DSCALE(num)); switch (NUMERIC_SIGN(num)) { case NUMERIC_POS: printf("POS"); break; case NUMERIC_NEG: printf("NEG"); break; case NUMERIC_NAN: printf("NaN"); break; default: printf("SIGN=0x%x", NUMERIC_SIGN(num)); break; } for (i = 0; i < num->varlen - NUMERIC_HDRSZ; i++) printf(" %d %d", (num->n_data[i] >> 4) & 0x0f, num->n_data[i] & 0x0f); printf("\n"); } /* ---------- * dump_var() - Dump a value in the variable format for debugging * ---------- */ static void dump_var(char *str, NumericVar *var) { int i; printf("%s: VAR w=%d r=%d d=%d ", str, var->weight, var->rscale, var->dscale); switch (var->sign) { case NUMERIC_POS: printf("POS"); break; case NUMERIC_NEG: printf("NEG"); break; case NUMERIC_NAN: printf("NaN"); break; default: printf("SIGN=0x%x", var->sign); break; } for (i = 0; i < var->ndigits; i++) printf(" %d", var->digits[i]); printf("\n"); } #endif /* NUMERIC_DEBUG */ /* ---------- * alloc_var() - * * Allocate a digit buffer of ndigits digits (plus a spare digit for rounding) * ---------- */ static void alloc_var(NumericVar *var, int ndigits) { digitbuf_free(var->buf); var->buf = digitbuf_alloc(ndigits + 1); var->buf[0] = 0; var->digits = var->buf + 1; var->ndigits = ndigits; } /* ---------- * free_var() - * * Return the digit buffer of a variable to the free pool * ---------- */ static void free_var(NumericVar *var) { digitbuf_free(var->buf); var->buf = NULL; var->digits = NULL; var->sign = NUMERIC_NAN; } /* ---------- * zero_var() - * * Set a variable to ZERO. * Note: rscale and dscale are not touched. * ---------- */ static void zero_var(NumericVar *var) { digitbuf_free(var->buf); var->buf = NULL; var->digits = NULL; var->ndigits = 0; var->weight = 0; /* by convention; doesn't really matter */ var->sign = NUMERIC_POS; /* anything but NAN... */ } /* ---------- * set_var_from_str() * * Parse a string and put the number into a variable * ---------- */ static void set_var_from_str(const char *str, NumericVar *dest, Decimal_Exception *ex) { char *cp = (char *) str; bool have_dp = FALSE; int i = 0; bool bad_format = FALSE; while (*cp) { if (!isspace((unsigned char) *cp)) break; cp++; } alloc_var(dest, strlen(cp)); dest->weight = -1; dest->dscale = 0; dest->sign = NUMERIC_POS; switch (*cp) { case '+': dest->sign = NUMERIC_POS; cp++; break; case '-': dest->sign = NUMERIC_NEG; cp++; break; } if (*cp == '.') { have_dp = TRUE; cp++; } if (!isdigit((unsigned char) *cp)) bad_format = TRUE; /* Bad format exception */ while (*cp) { if (isdigit((unsigned char) *cp)) { dest->digits[i++] = *cp++ - '0'; if (!have_dp) dest->weight++; else dest->dscale++; } else if (*cp == '.') { if (have_dp) bad_format = TRUE; have_dp = TRUE; cp++; } else break; } dest->ndigits = i; /* Handle exponent, if any */ if (*cp == 'e' || *cp == 'E') { long exponent; char *endptr; cp++; exponent = strtol(cp, &endptr, 10); if (endptr == cp) bad_format = TRUE; cp = endptr; if (exponent > NUMERIC_MAX_PRECISION || exponent < -NUMERIC_MAX_PRECISION) bad_format = TRUE; dest->weight += (int) exponent; dest->dscale -= (int) exponent; if (dest->dscale < 0) dest->dscale = 0; } /* Should be nothing left but spaces */ while (*cp) { if (!isspace((unsigned char) *cp)) bad_format = TRUE; cp++; } /* Strip any leading zeroes */ while (dest->ndigits > 0 && *(dest->digits) == 0) { (dest->digits)++; (dest->weight)--; (dest->ndigits)--; } if (dest->ndigits == 0) dest->weight = 0; dest->rscale = dest->dscale; if ( bad_format ) *ex = Numeric_Format; /* Bad format exception */ } /* * set_var_from_num() - * * Parse back the packed db format into a variable * */ static void set_var_from_num(Numeric num, NumericVar *dest) { NumericDigit *digit; int i; int n; n = num->varlen - NUMERIC_HDRSZ; /* number of digit-pairs in packed * fmt */ alloc_var(dest, n * 2); dest->weight = num->n_weight; dest->rscale = num->n_rscale; dest->dscale = NUMERIC_DSCALE(num); dest->sign = NUMERIC_SIGN(num); digit = dest->digits; for (i = 0; i < n; i++) { unsigned char digitpair = num->n_data[i]; *digit++ = (digitpair >> 4) & 0x0f; *digit++ = digitpair & 0x0f; } } /* ---------- * set_var_from_var() - * * Copy one variable into another * ---------- */ static void set_var_from_var(NumericVar *value, NumericVar *dest) { NumericDigit *newbuf; newbuf = digitbuf_alloc(value->ndigits + 1); newbuf[0] = 0; /* spare digit for rounding */ memcpy(newbuf + 1, value->digits, value->ndigits); digitbuf_free(dest->buf); memcpy(dest, value, sizeof(NumericVar)); dest->buf = newbuf; dest->digits = newbuf + 1; } /* ---------- * get_str_from_var() - * * Convert a var to text representation (guts of numeric_out). * CAUTION: var's contents may be modified by rounding! * Caller must have checked for NaN case. * Returns a palloc'd string. * ---------- */ static char * get_str_from_var(NumericVar *var, int dscale) { char *str; char *cp; int i; int d; /* * Check if we must round up before printing the value and do so. */ i = dscale + var->weight + 1; if (i >= 0 && var->ndigits > i) { int carry = (var->digits[i] > 4) ? 1 : 0; var->ndigits = i; while (carry) { carry += var->digits[--i]; var->digits[i] = carry % 10; carry /= 10; } if (i < 0) { Assert(i == -1); /* better not have added more than 1 digit */ Assert(var->digits > var->buf); var->digits--; var->ndigits++; var->weight++; } } else var->ndigits = MAX(0, MIN(i, var->ndigits)); /* * Allocate space for the result */ str = palloc(MAX(0, dscale) + MAX(0, var->weight) + 4); cp = str; /* * Output a dash for negative values */ if (var->sign == NUMERIC_NEG) *cp++ = '-'; /* * Output all digits before the decimal point */ i = MAX(var->weight, 0); d = 0; while (i >= 0) { if (i <= var->weight && d < var->ndigits) *cp++ = var->digits[d++] + '0'; else *cp++ = '0'; i--; } /* * If requested, output a decimal point and all the digits that follow * it. */ if (dscale > 0) { *cp++ = '.'; while (i >= -dscale) { if (i <= var->weight && d < var->ndigits) *cp++ = var->digits[d++] + '0'; else *cp++ = '0'; i--; } } /* * terminate the string and return it */ *cp = '\0'; return str; } Numeric numeric_nan(void) { Numeric num = (Numeric) palloc(NUMERIC_HDRSZ); num->varlen = NUMERIC_HDRSZ; num->n_weight = 0; num->n_rscale = 0; num->n_sign_dscale = NUMERIC_NAN; return num; } /* ---------- * make_result() - * * Create the packed db numeric format in palloc()'d memory from * a variable. The var's rscale determines the number of digits kept. * ---------- */ static Numeric make_result(NumericVar *var) { Numeric result; NumericDigit *digit = var->digits; int weight = var->weight; int sign = var->sign; int n; int i, j; if (sign == NUMERIC_NAN) { return numeric_nan(); return result; } n = MAX(0, MIN(var->ndigits, var->weight + var->rscale + 1)); /* truncate leading zeroes */ while (n > 0 && *digit == 0) { digit++; weight--; n--; } /* truncate trailing zeroes */ while (n > 0 && digit[n - 1] == 0) n--; /* If zero result, force to weight=0 and positive sign */ if (n == 0) { weight = 0; sign = NUMERIC_POS; } result = (Numeric) palloc(NUMERIC_HDRSZ + (n + 1) / 2); result->varlen = NUMERIC_HDRSZ + (n + 1) / 2; result->n_weight = weight; result->n_rscale = var->rscale; result->n_sign_dscale = sign | ((uint16) var->dscale & NUMERIC_DSCALE_MASK); i = 0; j = 0; while (j < n) { unsigned char digitpair = digit[j++] << 4; if (j < n) digitpair |= digit[j++]; result->n_data[i++] = digitpair; } dump_numeric("make_result()", result); return result; } /* ---------- * apply_typmod() - * * Do bounds checking and rounding according to the attributes * typmod field. * ---------- */ static void apply_typmod(NumericVar *var, int precision, int scale, Decimal_Exception *ex) { int maxweight; int i; maxweight = precision - scale; /* Round to target scale */ i = scale + var->weight + 1; if (i >= 0 && var->ndigits > i) { int carry = (var->digits[i] > 4) ? 1 : 0; var->ndigits = i; while (carry) { carry += var->digits[--i]; var->digits[i] = carry % 10; carry /= 10; } if (i < 0) { Assert(i == -1); /* better not have added more than 1 digit */ Assert(var->digits > var->buf); var->digits--; var->ndigits++; var->weight++; } } else var->ndigits = MAX(0, MIN(i, var->ndigits)); /* * Check for overflow - note we can't do this before rounding, because * rounding could raise the weight. Also note that the var's weight * could be inflated by leading zeroes, which will be stripped before * storage but perhaps might not have been yet. In any case, we must * recognize a true zero, whose weight doesn't mean anything. */ if (var->weight >= maxweight) { /* Determine true weight; and check for all-zero result */ int tweight = var->weight; for (i = 0; i < var->ndigits; i++) { if (var->digits[i]) break; tweight--; } if ( tweight >= maxweight && i < var->ndigits ) *ex = Numeric_Overflow; /* Overflow exception */ } if ( *ex == No_Error ) { var->rscale = scale; var->dscale = scale; } else nan_var(var); } /* ---------- * cmp_var() - * * Compare two values on variable level * ---------- */ static int cmp_var(NumericVar *var1, NumericVar *var2) { if (var1->ndigits == 0) { if (var2->ndigits == 0) return 0; if (var2->sign == NUMERIC_NEG) return 1; return -1; } if (var2->ndigits == 0) { if (var1->sign == NUMERIC_POS) return 1; return -1; } if (var1->sign == NUMERIC_POS) { if (var2->sign == NUMERIC_NEG) return 1; return cmp_abs(var1, var2); } if (var2->sign == NUMERIC_POS) return -1; return cmp_abs(var2, var1); } /* ---------- * add_var() - * * Full version of add functionality on variable level (handling signs). * result might point to one of the operands too without danger. * ---------- */ static void add_var(NumericVar *var1, NumericVar *var2, NumericVar *result) { /* * Decide on the signs of the two variables what to do */ if (var1->sign == NUMERIC_POS) { if (var2->sign == NUMERIC_POS) { /* * Both are positive result = +(ABS(var1) + ABS(var2)) */ add_abs(var1, var2, result); result->sign = NUMERIC_POS; } else { /* * var1 is positive, var2 is negative Must compare absolute * values */ switch (cmp_abs(var1, var2)) { case 0: /* ---------- * ABS(var1) == ABS(var2) * result = ZERO * ---------- */ zero_var(result); result->rscale = MAX(var1->rscale, var2->rscale); result->dscale = MAX(var1->dscale, var2->dscale); break; case 1: /* ---------- * ABS(var1) > ABS(var2) * result = +(ABS(var1) - ABS(var2)) * ---------- */ sub_abs(var1, var2, result); result->sign = NUMERIC_POS; break; case -1: /* ---------- * ABS(var1) < ABS(var2) * result = -(ABS(var2) - ABS(var1)) * ---------- */ sub_abs(var2, var1, result); result->sign = NUMERIC_NEG; break; } } } else { if (var2->sign == NUMERIC_POS) { /* ---------- * var1 is negative, var2 is positive * Must compare absolute values * ---------- */ switch (cmp_abs(var1, var2)) { case 0: /* ---------- * ABS(var1) == ABS(var2) * result = ZERO * ---------- */ zero_var(result); result->rscale = MAX(var1->rscale, var2->rscale); result->dscale = MAX(var1->dscale, var2->dscale); break; case 1: /* ---------- * ABS(var1) > ABS(var2) * result = -(ABS(var1) - ABS(var2)) * ---------- */ sub_abs(var1, var2, result); result->sign = NUMERIC_NEG; break; case -1: /* ---------- * ABS(var1) < ABS(var2) * result = +(ABS(var2) - ABS(var1)) * ---------- */ sub_abs(var2, var1, result); result->sign = NUMERIC_POS; break; } } else { /* ---------- * Both are negative * result = -(ABS(var1) + ABS(var2)) * ---------- */ add_abs(var1, var2, result); result->sign = NUMERIC_NEG; } } } /* ---------- * sub_var() - * * Full version of sub functionality on variable level (handling signs). * result might point to one of the operands too without danger. * ---------- */ static void sub_var(NumericVar *var1, NumericVar *var2, NumericVar *result) { /* * Decide on the signs of the two variables what to do */ if (var1->sign == NUMERIC_POS) { if (var2->sign == NUMERIC_NEG) { /* ---------- * var1 is positive, var2 is negative * result = +(ABS(var1) + ABS(var2)) * ---------- */ add_abs(var1, var2, result); result->sign = NUMERIC_POS; } else { /* ---------- * Both are positive * Must compare absolute values * ---------- */ switch (cmp_abs(var1, var2)) { case 0: /* ---------- * ABS(var1) == ABS(var2) * result = ZERO * ---------- */ zero_var(result); result->rscale = MAX(var1->rscale, var2->rscale); result->dscale = MAX(var1->dscale, var2->dscale); break; case 1: /* ---------- * ABS(var1) > ABS(var2) * result = +(ABS(var1) - ABS(var2)) * ---------- */ sub_abs(var1, var2, result); result->sign = NUMERIC_POS; break; case -1: /* ---------- * ABS(var1) < ABS(var2) * result = -(ABS(var2) - ABS(var1)) * ---------- */ sub_abs(var2, var1, result); result->sign = NUMERIC_NEG; break; } } } else { if (var2->sign == NUMERIC_NEG) { /* ---------- * Both are negative * Must compare absolute values * ---------- */ switch (cmp_abs(var1, var2)) { case 0: /* ---------- * ABS(var1) == ABS(var2) * result = ZERO * ---------- */ zero_var(result); result->rscale = MAX(var1->rscale, var2->rscale); result->dscale = MAX(var1->dscale, var2->dscale); break; case 1: /* ---------- * ABS(var1) > ABS(var2) * result = -(ABS(var1) - ABS(var2)) * ---------- */ sub_abs(var1, var2, result); result->sign = NUMERIC_NEG; break; case -1: /* ---------- * ABS(var1) < ABS(var2) * result = +(ABS(var2) - ABS(var1)) * ---------- */ sub_abs(var2, var1, result); result->sign = NUMERIC_POS; break; } } else { /* ---------- * var1 is negative, var2 is positive * result = -(ABS(var1) + ABS(var2)) * ---------- */ add_abs(var1, var2, result); result->sign = NUMERIC_NEG; } } } /* ---------- * mul_var() - * * Multiplication on variable level. Product of var1 * var2 is stored * in result. * ---------- */ static void mul_var(NumericVar *var1, NumericVar *var2, NumericVar *result, int *global_rscale) { NumericDigit *res_buf; NumericDigit *res_digits; int res_ndigits; int res_weight; int res_sign; int i, ri, i1, i2; long sum = 0; res_weight = var1->weight + var2->weight + 2; res_ndigits = var1->ndigits + var2->ndigits + 1; if (var1->sign == var2->sign) res_sign = NUMERIC_POS; else res_sign = NUMERIC_NEG; res_buf = digitbuf_alloc(res_ndigits); res_digits = res_buf; memset(res_digits, 0, res_ndigits); ri = res_ndigits; for (i1 = var1->ndigits - 1; i1 >= 0; i1--) { sum = 0; i = --ri; for (i2 = var2->ndigits - 1; i2 >= 0; i2--) { sum += res_digits[i] + var1->digits[i1] * var2->digits[i2]; res_digits[i--] = sum % 10; sum /= 10; } res_digits[i] = sum; } i = res_weight + *global_rscale + 2; if (i >= 0 && i < res_ndigits) { sum = (res_digits[i] > 4) ? 1 : 0; res_ndigits = i; i--; while (sum) { sum += res_digits[i]; res_digits[i--] = sum % 10; sum /= 10; } } while (res_ndigits > 0 && *res_digits == 0) { res_digits++; res_weight--; res_ndigits--; } while (res_ndigits > 0 && res_digits[res_ndigits - 1] == 0) res_ndigits--; if (res_ndigits == 0) { res_sign = NUMERIC_POS; res_weight = 0; } digitbuf_free(result->buf); result->buf = res_buf; result->digits = res_digits; result->ndigits = res_ndigits; result->weight = res_weight; result->rscale = *global_rscale; result->sign = res_sign; } /* ---------- * div_var() - * * Division on variable level. * ---------- */ static void div_var(NumericVar *var1, NumericVar *var2, NumericVar *result, int *global_rscale, Decimal_Exception *ex) { NumericDigit *res_digits; int res_ndigits; int res_sign; int res_weight; NumericVar dividend; NumericVar divisor[10]; int ndigits_tmp; int weight_tmp; int rscale_tmp; int ri; int i; long guess; long first_have; long first_div; int first_nextdigit; int stat = 0; /* * First of all division by zero check */ ndigits_tmp = var2->ndigits + 1; if (ndigits_tmp == 1) { *ex = Divide_By_Zero; nan_var(result); return; } /* * Determine the result sign, weight and number of digits to calculate */ if (var1->sign == var2->sign) res_sign = NUMERIC_POS; else res_sign = NUMERIC_NEG; res_weight = var1->weight - var2->weight + 1; res_ndigits = *global_rscale + res_weight; if (res_ndigits <= 0) res_ndigits = 1; /* * Now result zero check */ if (var1->ndigits == 0) { zero_var(result); result->rscale = *global_rscale; return; } /* * Initialize local variables */ init_var(÷nd); for (i = 1; i < 10; i++) init_var(&divisor[i]); /* * Make a copy of the divisor which has one leading zero digit */ divisor[1].ndigits = ndigits_tmp; divisor[1].rscale = var2->ndigits; divisor[1].sign = NUMERIC_POS; divisor[1].buf = digitbuf_alloc(ndigits_tmp); divisor[1].digits = divisor[1].buf; divisor[1].digits[0] = 0; memcpy(&(divisor[1].digits[1]), var2->digits, ndigits_tmp - 1); /* * Make a copy of the dividend */ dividend.ndigits = var1->ndigits; dividend.weight = 0; dividend.rscale = var1->ndigits; dividend.sign = NUMERIC_POS; dividend.buf = digitbuf_alloc(var1->ndigits); dividend.digits = dividend.buf; memcpy(dividend.digits, var1->digits, var1->ndigits); /* * Setup the result */ digitbuf_free(result->buf); result->buf = digitbuf_alloc(res_ndigits + 2); res_digits = result->buf; result->digits = res_digits; result->ndigits = res_ndigits; result->weight = res_weight; result->rscale = *global_rscale; result->sign = res_sign; res_digits[0] = 0; first_div = divisor[1].digits[1] * 10; if (ndigits_tmp > 2) first_div += divisor[1].digits[2]; first_have = 0; first_nextdigit = 0; weight_tmp = 1; rscale_tmp = divisor[1].rscale; for (ri = 0; ri <= res_ndigits; ri++) { first_have = first_have * 10; if (first_nextdigit >= 0 && first_nextdigit < dividend.ndigits) first_have += dividend.digits[first_nextdigit]; first_nextdigit++; guess = (first_have * 10) / first_div + 1; if (guess > 9) guess = 9; while (guess > 0) { if (divisor[guess].buf == NULL) { int i; long sum = 0; memcpy(&divisor[guess], &divisor[1], sizeof(NumericVar)); divisor[guess].buf = digitbuf_alloc(divisor[guess].ndigits); divisor[guess].digits = divisor[guess].buf; for (i = divisor[1].ndigits - 1; i >= 0; i--) { sum += divisor[1].digits[i] * guess; divisor[guess].digits[i] = sum % 10; sum /= 10; } } divisor[guess].weight = weight_tmp; divisor[guess].rscale = rscale_tmp; stat = cmp_abs(÷nd, &divisor[guess]); if (stat >= 0) break; guess--; } res_digits[ri + 1] = guess; if (stat == 0) { ri++; break; } weight_tmp--; rscale_tmp++; if (guess == 0) continue; sub_abs(÷nd, &divisor[guess], ÷nd); first_nextdigit = dividend.weight - weight_tmp; first_have = 0; if (first_nextdigit >= 0 && first_nextdigit < dividend.ndigits) first_have = dividend.digits[first_nextdigit]; first_nextdigit++; } result->ndigits = ri + 1; if (ri == res_ndigits + 1) { int carry = (res_digits[ri] > 4) ? 1 : 0; result->ndigits = ri; res_digits[ri] = 0; while (carry && ri > 0) { carry += res_digits[--ri]; res_digits[ri] = carry % 10; carry /= 10; } } while (result->ndigits > 0 && *(result->digits) == 0) { (result->digits)++; (result->weight)--; (result->ndigits)--; } while (result->ndigits > 0 && result->digits[result->ndigits - 1] == 0) (result->ndigits)--; if (result->ndigits == 0) result->sign = NUMERIC_POS; /* * Tidy up */ digitbuf_free(dividend.buf); for (i = 1; i < 10; i++) digitbuf_free(divisor[i].buf); } /* * Default scale selection for division * * Returns the appropriate display scale for the division result, * and sets global_rscale to the result scale to use during div_var. * * Note that this must be called before div_var. */ static int select_div_scale(NumericVar *var1, NumericVar *var2, int *global_rscale) { int res_dscale; int res_rscale; /* ---------- * The result scale of a division isn't specified in any * SQL standard. For Postgres it is the following (where * SR, DR are the result- and display-scales of the returned * value, S1, D1, S2 and D2 are the scales of the two arguments, * The minimum and maximum scales are compile time options from * numeric.h): * * DR = MIN(MAX(D1 + D2, MIN_DISPLAY_SCALE), MAX_DISPLAY_SCALE) * SR = MIN(MAX(MAX(S1 + S2, DR + 4), MIN_RESULT_SCALE), MAX_RESULT_SCALE) * * By default, any result is computed with a minimum of 34 digits * after the decimal point or at least with 4 digits more than * displayed. * ---------- */ res_dscale = var1->dscale + var2->dscale; res_dscale = MAX(res_dscale, NUMERIC_MIN_DISPLAY_SCALE); res_dscale = MIN(res_dscale, NUMERIC_MAX_DISPLAY_SCALE); res_rscale = var1->rscale + var2->rscale; res_rscale = MAX(res_rscale, res_dscale + 4); res_rscale = MAX(res_rscale, NUMERIC_MIN_RESULT_SCALE); res_rscale = MIN(res_rscale, NUMERIC_MAX_RESULT_SCALE); *global_rscale = res_rscale; return res_dscale; } /* ---------- * mod_var() - * * Calculate the modulo of two numerics at variable level * ---------- */ static void mod_var(NumericVar *var1, NumericVar *var2, NumericVar *result, int *global_rscale, Decimal_Exception *ex) { NumericVar tmp; int save_global_rscale; int div_dscale; *ex = No_Error; init_var(&tmp); /* --------- * We do this using the equation * mod(x,y) = x - trunc(x/y)*y * We set global_rscale the same way numeric_div and numeric_mul do * to get the right answer from the equation. The final result, * however, need not be displayed to more precision than the inputs. * ---------- */ save_global_rscale = *global_rscale; div_dscale = select_div_scale(var1, var2, global_rscale); div_var(var1, var2, &tmp, global_rscale, ex); if ( *ex == No_Error ) { tmp.dscale = div_dscale; /* do trunc() by forgetting digits to the right of the decimal point */ tmp.ndigits = MAX(0, MIN(tmp.ndigits, tmp.weight + 1)); *global_rscale = var2->rscale + tmp.rscale; mul_var(var2, &tmp, &tmp, global_rscale); sub_var(var1, &tmp, result); result->dscale = MAX(var1->dscale, var2->dscale); *global_rscale = save_global_rscale; } free_var(&tmp); } /* ---------- * ceil_var() - * * Return the smallest integer greater than or equal to the argument * on variable level * ---------- */ static void ceil_var(NumericVar *var, NumericVar *result) { NumericVar tmp; init_var(&tmp); set_var_from_var(var, &tmp); tmp.rscale = 0; tmp.ndigits = MIN(tmp.ndigits, MAX(0, tmp.weight + 1)); if (tmp.sign == NUMERIC_POS && cmp_var(var, &tmp) != 0) add_var(&tmp, &const_one, &tmp); set_var_from_var(&tmp, result); free_var(&tmp); } /* ---------- * floor_var() - * * Return the largest integer equal to or less than the argument * on variable level * ---------- */ static void floor_var(NumericVar *var, NumericVar *result) { NumericVar tmp; init_var(&tmp); set_var_from_var(var, &tmp); tmp.rscale = 0; tmp.ndigits = MIN(tmp.ndigits, MAX(0, tmp.weight + 1)); if (tmp.sign == NUMERIC_NEG && cmp_var(var, &tmp) != 0) sub_var(&tmp, &const_one, &tmp); set_var_from_var(&tmp, result); free_var(&tmp); } /* ---------- * sqrt_var() - * * Compute the square root of x using Newtons algorithm * ---------- */ static void sqrt_var(NumericVar *arg, NumericVar *result, int *global_rscale, Decimal_Exception *ex) { NumericVar tmp_arg; NumericVar tmp_val; NumericVar last_val; int res_rscale; int save_global_rscale; int stat; save_global_rscale = *global_rscale; *global_rscale += 8; res_rscale = *global_rscale; stat = cmp_var(arg, &const_zero); if (stat == 0) { set_var_from_var(&const_zero, result); result->rscale = res_rscale; result->sign = NUMERIC_POS; return; } if (stat < 0) { *ex = Undefined_Result; nan_var(result); return; } init_var(&tmp_arg); init_var(&tmp_val); init_var(&last_val); set_var_from_var(arg, &tmp_arg); set_var_from_var(result, &last_val); /* * Initialize the result to the first guess */ digitbuf_free(result->buf); result->buf = digitbuf_alloc(1); result->digits = result->buf; result->digits[0] = tmp_arg.digits[0] / 2; if (result->digits[0] == 0) result->digits[0] = 1; result->ndigits = 1; result->weight = tmp_arg.weight / 2; result->rscale = res_rscale; result->sign = NUMERIC_POS; for (;;) { div_var(&tmp_arg, result, &tmp_val, global_rscale, ex); if ( *ex != No_Error ) break; add_var(result, &tmp_val, result); div_var(result, &const_two, result, global_rscale, ex); if ( *ex != No_Error ) break; if (cmp_var(&last_val, result) == 0) break; set_var_from_var(result, &last_val); } free_var(&last_val); free_var(&tmp_val); free_var(&tmp_arg); if ( *ex == No_Error ) { *global_rscale = save_global_rscale; div_var(result, &const_one, result, global_rscale, ex); } if ( *ex != No_Error ) nan_var(result); /* Set NAN if any exception occurred */ } /* ---------- * exp_var() - * * Raise e to the power of x * ---------- */ static void exp_var(NumericVar *arg, NumericVar *result,int *global_rscale, Decimal_Exception *ex) { NumericVar x; NumericVar xpow; NumericVar ifac; NumericVar elem; NumericVar ni; int d; int i; int ndiv2 = 0; bool xneg = FALSE; int save_global_rscale; init_var(&x); init_var(&xpow); init_var(&ifac); init_var(&elem); init_var(&ni); set_var_from_var(arg, &x); if (x.sign == NUMERIC_NEG) { xneg = TRUE; x.sign = NUMERIC_POS; } save_global_rscale = *global_rscale; *global_rscale = 0; for (i = x.weight, d = 0; i >= 0; i--, d++) { *global_rscale *= 10; if (d < x.ndigits) *global_rscale += x.digits[d]; if (*global_rscale >= 1000) { *ex = Numeric_Overflow; /* argument for EXP() too big */ nan_var(result); return; } } *global_rscale = *global_rscale / 2 + save_global_rscale + 8; while (cmp_var(&x, &const_one) > 0) { ndiv2++; (*global_rscale)++; div_var(&x, &const_two, &x, global_rscale, ex); if ( *ex != No_Error ) break; } if ( *ex == No_Error ) { add_var(&const_one, &x, result); set_var_from_var(&x, &xpow); set_var_from_var(&const_one, &ifac); set_var_from_var(&const_one, &ni); for (i = 2;; i++) { add_var(&ni, &const_one, &ni); mul_var(&xpow, &x, &xpow, global_rscale); mul_var(&ifac, &ni, &ifac, global_rscale); div_var(&xpow, &ifac, &elem, global_rscale, ex); if ( *ex != No_Error ) break; if (elem.ndigits == 0) break; add_var(result, &elem, result); } } if ( *ex == No_Error ) { while (ndiv2-- > 0) mul_var(result, result, result, global_rscale); *global_rscale = save_global_rscale; if (xneg) div_var(&const_one, result, result, global_rscale, ex); else div_var(result, &const_one, result, global_rscale, ex); if ( *ex == No_Error ) result->sign = NUMERIC_POS; } free_var(&x); free_var(&xpow); free_var(&ifac); free_var(&elem); free_var(&ni); if ( *ex != No_Error ) nan_var(result); } /* ---------- * ln_var() - * * Compute the natural log of x * ---------- */ static void ln_var(NumericVar *arg, NumericVar *result, int *global_rscale, Decimal_Exception *ex) { NumericVar x; NumericVar xx; NumericVar ni; NumericVar elem; NumericVar fact; int i; int save_global_rscale; if (cmp_var(arg, &const_zero) <= 0) { /* math error on numeric - cannot compute LN of value <= zero */ *ex = Numeric_Overflow; nan_var(result); return; } save_global_rscale = *global_rscale; *global_rscale += 8; init_var(&x); init_var(&xx); init_var(&ni); init_var(&elem); init_var(&fact); set_var_from_var(&const_two, &fact); set_var_from_var(arg, &x); while (cmp_var(&x, &const_two) >= 0) { sqrt_var(&x, &x, global_rscale, ex); if ( *ex != No_Error ) break; mul_var(&fact, &const_two, &fact, global_rscale); } if ( *ex == No_Error ) { set_var_from_str("0.5", &elem, ex); /* This won't raise exception */ while (cmp_var(&x, &elem) <= 0) { sqrt_var(&x, &x, global_rscale, ex); if ( *ex != No_Error ) break; mul_var(&fact, &const_two, &fact, global_rscale); } } if ( *ex == No_Error ) { sub_var(&x, &const_one, result); add_var(&x, &const_one, &elem); div_var(result, &elem, result, global_rscale, ex); } if ( *ex == No_Error ) { set_var_from_var(result, &xx); mul_var(result, result, &x, global_rscale); set_var_from_var(&const_one, &ni); for (i = 2;; i++) { add_var(&ni, &const_two, &ni); mul_var(&xx, &x, &xx, global_rscale); div_var(&xx, &ni, &elem, global_rscale, ex); if ( *ex != No_Error ) break; if (cmp_var(&elem, &const_zero) == 0) break; add_var(result, &elem, result); } } if ( *ex == No_Error ) { *global_rscale = save_global_rscale; mul_var(result, &fact, result, global_rscale); } free_var(&x); free_var(&xx); free_var(&ni); free_var(&elem); free_var(&fact); if ( *ex != No_Error ) nan_var(result); } /* ---------- * log_var() - * * Compute the logarithm of x in a given base * ---------- */ static void log_var(NumericVar *base, NumericVar *num, NumericVar *result, int *global_rscale, Decimal_Exception *ex) { NumericVar ln_base; NumericVar ln_num; *global_rscale += 8; init_var(&ln_base); init_var(&ln_num); ln_var(base, &ln_base, global_rscale, ex); if ( *ex == No_Error ) ln_var(num, &ln_num, global_rscale, ex); if ( *ex == No_Error ) { *global_rscale -= 8; div_var(&ln_num, &ln_base, result, global_rscale, ex); } free_var(&ln_num); free_var(&ln_base); if ( *ex != No_Error ) nan_var(result); } /* ---------- * power_var() - * * Raise base to the power of exp * ---------- */ static void power_var(NumericVar *base, NumericVar *exp, NumericVar *result, int *global_rscale, Decimal_Exception *ex) { NumericVar ln_base; NumericVar ln_num; int save_global_rscale; save_global_rscale = *global_rscale; *global_rscale += *global_rscale / 3 + 8; init_var(&ln_base); init_var(&ln_num); ln_var(base, &ln_base, global_rscale, ex); if ( *ex == No_Error ) { mul_var(&ln_base, exp, &ln_num, global_rscale); *global_rscale = save_global_rscale; exp_var(&ln_num, result, global_rscale, ex); } free_var(&ln_num); free_var(&ln_base); if ( *ex != No_Error ) nan_var(result); } /* ---------------------------------------------------------------------- * * Following are the lowest level functions that operate unsigned * on the variable level * * ---------------------------------------------------------------------- */ /* ---------- * cmp_abs() - * * Compare the absolute values of var1 and var2 * Returns: -1 for ABS(var1) < ABS(var2) * 0 for ABS(var1) == ABS(var2) * 1 for ABS(var1) > ABS(var2) * ---------- */ static int cmp_abs(NumericVar *var1, NumericVar *var2) { int i1 = 0; int i2 = 0; int w1 = var1->weight; int w2 = var2->weight; int stat; while (w1 > w2 && i1 < var1->ndigits) { if (var1->digits[i1++] != 0) return 1; w1--; } while (w2 > w1 && i2 < var2->ndigits) { if (var2->digits[i2++] != 0) return -1; w2--; } if (w1 == w2) { while (i1 < var1->ndigits && i2 < var2->ndigits) { stat = var1->digits[i1++] - var2->digits[i2++]; if (stat) { if (stat > 0) return 1; return -1; } } } while (i1 < var1->ndigits) { if (var1->digits[i1++] != 0) return 1; } while (i2 < var2->ndigits) { if (var2->digits[i2++] != 0) return -1; } return 0; } /* ---------- * add_abs() - * * Add the absolute values of two variables into result. * result might point to one of the operands without danger. * ---------- */ static void add_abs(NumericVar *var1, NumericVar *var2, NumericVar *result) { NumericDigit *res_buf; NumericDigit *res_digits; int res_ndigits; int res_weight; int res_rscale; int res_dscale; int i, i1, i2; int carry = 0; /* copy these values into local vars for speed in inner loop */ int var1ndigits = var1->ndigits; int var2ndigits = var2->ndigits; NumericDigit *var1digits = var1->digits; NumericDigit *var2digits = var2->digits; res_weight = MAX(var1->weight, var2->weight) + 1; res_rscale = MAX(var1->rscale, var2->rscale); res_dscale = MAX(var1->dscale, var2->dscale); res_ndigits = res_rscale + res_weight + 1; if (res_ndigits <= 0) res_ndigits = 1; res_buf = digitbuf_alloc(res_ndigits); res_digits = res_buf; i1 = res_rscale + var1->weight + 1; i2 = res_rscale + var2->weight + 1; for (i = res_ndigits - 1; i >= 0; i--) { i1--; i2--; if (i1 >= 0 && i1 < var1ndigits) carry += var1digits[i1]; if (i2 >= 0 && i2 < var2ndigits) carry += var2digits[i2]; if (carry >= 10) { res_digits[i] = carry - 10; carry = 1; } else { res_digits[i] = carry; carry = 0; } } Assert(carry == 0); /* else we failed to allow for carry out */ while (res_ndigits > 0 && *res_digits == 0) { res_digits++; res_weight--; res_ndigits--; } while (res_ndigits > 0 && res_digits[res_ndigits - 1] == 0) res_ndigits--; if (res_ndigits == 0) res_weight = 0; digitbuf_free(result->buf); result->ndigits = res_ndigits; result->buf = res_buf; result->digits = res_digits; result->weight = res_weight; result->rscale = res_rscale; result->dscale = res_dscale; } /* ---------- * sub_abs() - * * Subtract the absolute value of var2 from the absolute value of var1 * and store in result. result might point to one of the operands * without danger. * * ABS(var1) MUST BE GREATER OR EQUAL ABS(var2) !!! * ---------- */ static void sub_abs(NumericVar *var1, NumericVar *var2, NumericVar *result) { NumericDigit *res_buf; NumericDigit *res_digits; int res_ndigits; int res_weight; int res_rscale; int res_dscale; int i, i1, i2; int borrow = 0; /* copy these values into local vars for speed in inner loop */ int var1ndigits = var1->ndigits; int var2ndigits = var2->ndigits; NumericDigit *var1digits = var1->digits; NumericDigit *var2digits = var2->digits; res_weight = var1->weight; res_rscale = MAX(var1->rscale, var2->rscale); res_dscale = MAX(var1->dscale, var2->dscale); res_ndigits = res_rscale + res_weight + 1; if (res_ndigits <= 0) res_ndigits = 1; res_buf = digitbuf_alloc(res_ndigits); res_digits = res_buf; i1 = res_rscale + var1->weight + 1; i2 = res_rscale + var2->weight + 1; for (i = res_ndigits - 1; i >= 0; i--) { i1--; i2--; if (i1 >= 0 && i1 < var1ndigits) borrow += var1digits[i1]; if (i2 >= 0 && i2 < var2ndigits) borrow -= var2digits[i2]; if (borrow < 0) { res_digits[i] = borrow + 10; borrow = -1; } else { res_digits[i] = borrow; borrow = 0; } } Assert(borrow == 0); /* else caller gave us var1 < var2 */ while (res_ndigits > 0 && *res_digits == 0) { res_digits++; res_weight--; res_ndigits--; } while (res_ndigits > 0 && res_digits[res_ndigits - 1] == 0) res_ndigits--; if (res_ndigits == 0) res_weight = 0; digitbuf_free(result->buf); result->ndigits = res_ndigits; result->buf = res_buf; result->digits = res_digits; result->weight = res_weight; result->rscale = res_rscale; result->dscale = res_dscale; } apq-postgresql-3.2.0/ssl/src/numeric.h000066400000000000000000000101331172102510600176720ustar00rootroot00000000000000/****************************************************************************/ /* APQ DATABASE BINDINGS */ /* */ /* A P Q - POSTGRESQL */ /* */ /* S p e c */ /* */ /* Copyright (C) 2002-2007, Warren W. Gay VE3WWG */ /* Copyright (C) 2007-2009, Ada Works Project */ /* */ /* */ /* APQ is free software; you can redistribute it and/or modify it under */ /* terms of the GNU General Public License as published by the Free Soft- */ /* ware Foundation; either version 2, or (at your option) any later ver- */ /* sion. APQ is distributed in the hope that it will be useful, but WITH- */ /* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY */ /* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License */ /* for more details. You should have received a copy of the GNU General */ /* Public License distributed with APQ; see file COPYING. If not, write */ /* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, */ /* MA 02111-1307, USA. */ /* */ /* As a special exception, if other files instantiate generics from this */ /* unit, or you link this unit with other files to produce an executable, */ /* this unit does not by itself cause the resulting executable to be */ /* covered by the GNU General Public License. This exception does not */ /* however invalidate any other reasons why the executable file might be */ /* covered by the GNU Public License. */ /****************************************************************************/ #ifndef _PG_NUMERIC_H_ #define _PG_NUMERIC_H_ /* ---------- * The hardcoded limits and defaults of the numeric data type * ---------- */ #define NUMERIC_MAX_PRECISION 1000 #define NUMERIC_DEFAULT_PRECISION 30 #define NUMERIC_DEFAULT_SCALE 6 /* ---------- * Internal limits on the scales chosen for calculation results * ---------- */ #define NUMERIC_MAX_DISPLAY_SCALE NUMERIC_MAX_PRECISION #define NUMERIC_MIN_DISPLAY_SCALE (NUMERIC_DEFAULT_SCALE + 4) #define NUMERIC_MAX_RESULT_SCALE (NUMERIC_MAX_PRECISION * 2) #define NUMERIC_MIN_RESULT_SCALE (NUMERIC_DEFAULT_PRECISION + 4) /* ---------- * Sign values and macros to deal with packing/unpacking n_sign_dscale * ---------- */ #define NUMERIC_SIGN_MASK 0xC000 #define NUMERIC_POS 0x0000 #define NUMERIC_NEG 0x4000 #define NUMERIC_NAN 0xC000 #define NUMERIC_DSCALE_MASK 0x3FFF #define NUMERIC_SIGN(n) ((n)->n_sign_dscale & NUMERIC_SIGN_MASK) #define NUMERIC_DSCALE(n) ((n)->n_sign_dscale & NUMERIC_DSCALE_MASK) #define NUMERIC_IS_NAN(n) (NUMERIC_SIGN(n) != NUMERIC_POS && \ NUMERIC_SIGN(n) != NUMERIC_NEG) /* ---------- * The Numeric data type stored in the database * * NOTE: by convention, values in the packed form have been stripped of * all leading and trailing zeroes (except there will be a trailing zero * in the last byte, if the number of digits is odd). In particular, * if the value is zero, there will be no digits at all! The weight is * arbitrary in that case, but we normally set it to zero. * ---------- */ typedef struct NumericData { int32 varlen; /* Variable size */ int16 n_weight; /* Weight of 1st digit */ uint16 n_rscale; /* Result scale */ uint16 n_sign_dscale; /* Sign + display scale */ unsigned char n_data[1]; /* Digit data (2 decimal digits/byte) */ } NumericData; typedef NumericData *Numeric; #define NUMERIC_HDRSZ (sizeof(int32) + sizeof(uint16) * 3) #endif /* _PG_NUMERIC_H_ */ apq-postgresql-3.2.0/ssl/src/pgtypes.h000066400000000000000000000141751172102510600177350ustar00rootroot00000000000000/****************************************************************************/ /* APQ DATABASE BINDINGS */ /* */ /* A P Q - POSTGRESQL */ /* */ /* S p e c */ /* */ /* Copyright (C) 2002-2007, Warren W. Gay VE3WWG */ /* Copyright (C) 2007-2009, Ada Works Project */ /* */ /* */ /* APQ is free software; you can redistribute it and/or modify it under */ /* terms of the GNU General Public License as published by the Free Soft- */ /* ware Foundation; either version 2, or (at your option) any later ver- */ /* sion. APQ is distributed in the hope that it will be useful, but WITH- */ /* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY */ /* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License */ /* for more details. You should have received a copy of the GNU General */ /* Public License distributed with APQ; see file COPYING. If not, write */ /* to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, */ /* MA 02111-1307, USA. */ /* */ /* As a special exception, if other files instantiate generics from this */ /* unit, or you link this unit with other files to produce an executable, */ /* this unit does not by itself cause the resulting executable to be */ /* covered by the GNU General Public License. This exception does not */ /* however invalidate any other reasons why the executable file might be */ /* covered by the GNU Public License. */ /****************************************************************************/ #include #ifndef _PGTYPES_H_ #define _PGTYPES_H_ #include #define palloc malloc #define prealloc realloc #define pfree free #define pstrdup strdup #define Assert assert #define VARHDRSZ ((int32) sizeof(int32)) /* * NULL * Null pointer. */ #ifndef NULL #define NULL ((void *) 0) #endif typedef int bool; #define FALSE 0 #define TRUE 1 /* ---------------------------------------------------------------- * Section 3: standard system types * ---------------------------------------------------------------- */ /* * Pointer * Variable holding address of any memory resident object. * * XXX Pointer arithmetic is done with this, so it can't be void * * under "true" ANSI compilers. */ typedef char *Pointer; /* * intN * Signed integer, EXACTLY N BITS IN SIZE, * used for numerical computations and the * frontend/backend protocol. */ #ifndef HAVE_INT8 typedef signed char int8; /* == 8 bits */ typedef signed short int16; /* == 16 bits */ typedef signed int int32; /* == 32 bits */ #endif /* not HAVE_INT8 */ /* * uintN * Unsigned integer, EXACTLY N BITS IN SIZE, * used for numerical computations and the * frontend/backend protocol. */ /* Also defined in interfaces/odbc/md5.h */ #ifndef HAVE_UINT8 typedef unsigned char uint8; /* == 8 bits */ typedef unsigned short uint16; /* == 16 bits */ typedef unsigned int uint32; /* == 32 bits */ #endif /* not HAVE_UINT8 */ /* * boolN * Boolean value, AT LEAST N BITS IN SIZE. */ typedef uint8 bool8; /* >= 8 bits */ typedef uint16 bool16; /* >= 16 bits */ typedef uint32 bool32; /* >= 32 bits */ /* * bitsN * Unit of bitwise operation, AT LEAST N BITS IN SIZE. */ typedef uint8 bits8; /* >= 8 bits */ typedef uint16 bits16; /* >= 16 bits */ typedef uint32 bits32; /* >= 32 bits */ /* * wordN * Unit of storage, AT LEAST N BITS IN SIZE, * used to fetch/store data. */ typedef uint8 word8; /* >= 8 bits */ typedef uint16 word16; /* >= 16 bits */ typedef uint32 word32; /* >= 32 bits */ /* * floatN * Floating point number, AT LEAST N BITS IN SIZE, * used for numerical computations. * * Since sizeof(floatN) may be > sizeof(char *), always pass * floatN by reference. * * XXX: these typedefs are now deprecated in favor of float4 and float8. * They will eventually go away. */ typedef float float32data; typedef double float64data; typedef float *float32; typedef double *float64; /* * 64-bit integers */ #ifdef HAVE_LONG_INT_64 /* Plain "long int" fits, use it */ #ifndef HAVE_INT64 typedef long int int64; #endif #ifndef HAVE_UINT64 typedef unsigned long int uint64; #endif #elif defined(HAVE_LONG_LONG_INT_64) /* We have working support for "long long int", use that */ #ifndef HAVE_INT64 typedef long long int int64; #endif #ifndef HAVE_UINT64 typedef unsigned long long int uint64; #endif #else /* not HAVE_LONG_INT_64 and not HAVE_LONG_LONG_INT_64 */ /* Won't actually work, but fall back to long int so that code compiles */ #ifndef HAVE_INT64 typedef long int int64; #endif #ifndef HAVE_UINT64 typedef unsigned long int uint64; #endif #define INT64_IS_BUSTED #endif /* not HAVE_LONG_INT_64 and not HAVE_LONG_LONG_INT_64 */ /* sig_atomic_t is required by ANSI C, but may be missing on old platforms */ #ifndef HAVE_SIG_ATOMIC_T typedef int sig_atomic_t; #endif /* * Size * Size of any memory resident object, as returned by sizeof. */ typedef size_t Size; /* * Index * Index into any memory resident array. * * Note: * Indices are non negative. */ typedef unsigned int Index; /* * Offset * Offset into any memory resident array. * * Note: * This differs from an Index in that an Index is always * non negative, whereas Offset may be negative. */ typedef signed int Offset; /* * Common Postgres datatype names (as used in the catalogs) */ typedef int16 int2; typedef int32 int4; typedef float float4; typedef double float8; #endif /* End $Source: /cvsroot/apq/apq/pgtypes.h,v $ */ apq-postgresql-3.2.0/version000066400000000000000000000000061172102510600160750ustar00rootroot000000000000003.2.0